J'ai un code VBA pour envoyer un courriel mais comment enregistrer une copie due-mail

[bouclesdor]

Bonjour,

J'ai besoin de votre aide, j'ai un fichier excel qui contient un bouton avec un code VBA pour envoyer automatiquement un courriel via excel mais je veux qu'une copie de ce courriel aille se concerver dans un dossier spécifique de mon outlook. Je ne veux pas qu'il soit dans les "sent items" mais bien dans un autre dossier qui se trouve dans mon outlook à cet endroit " Inbox/ADM/Fournisseurs/Envoie commande" .

Savez-vous comment écrire ce code car je ne trouve rien sur internet...

Merci à l'avance de votre aide!

Bouclesdor

 

[bouclesdor]

Re : J'ai un code VBA pour envoyer un courriel mais comment enregistrer une copie due

.... je pense à voix haute...

Est-ce qu'il y aurait une formule du genre

On Error Resume Next
With OutMail
............
............
**** .savesentitem = (avec le chemin pour se rendre au classeur désiré.... ça serait trop simple!! )

 

[bouclesdor]

Re : J'ai un code VBA pour envoyer un courriel mais comment enregistrer une copie due

J'ai trouvé un bout de code mais je n'arive pas à le faire fonctionner et l'adapter à mon fichier.... voici le code au cas ou quelqu'un pourrait m'aider:

Sub Folder()


Dim myNamespace As Namespace
Dim objFolder As MAPIFolder
Set objMail = Application.ActiveInspector.CurrentItem
Set myNamespace = Application.GetNamespace("MAPI")
Set objFolder = myNamespace.GetDefaultFolder(olFolderInbox).Parent.Folders("Envoie commande")
Set Item.SaveSentMessageFolder = objFolder
'Set objMail.SaveSentMessageFolder = objFolder

Set myNamespace = Nothing
Set objFolder = Nothing
End Sub

Merci beaucoup,

Bouclesdor

 

[bouclesdor]

Re : J'ai un code VBA pour envoyer un courriel mais comment enregistrer une copie due

un petit up pour cette discussion... je me remets sur le dossier car je n'ai pas encore trouvé comment sauvegarder une copie du courriel dans un fichier spécifique de mon outlook...

voici mon code qui fait le fichier un courriel à partir de mon fichiere excel mais je veux ajouter un code qui met une copie de ce courriel dans un dossier spécifique (save sent item) mon dossier est dans INBOX / ADM / Fournisseurs / Envoie commande.

Sub printPDFFournisseur()

Sheets("PO").CheckBox7 = True

'delete le formattage avant la copie PDF
With Range("A20:G35")
.FormatConditions.Delete
End With
' enleve le jaune du BE dans section interne
With Range("n57")
.FormatConditions.Delete
End With

'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Excel 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim PJ As String
Dim NumeroPO As String

Dim SigString As String
Dim signature As String


If ActiveWorkbook.Path <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


'défini le nom PO pour l'écrire dans le corps du message plus bas...

strbody = "<font size=""3"" face=""Calibri"">" & _
"Dear Madam / Sir,<br><br>" & _
"Please find attached our purchase order # <B>" & _
Range("p1") & " </B>(1 page).<BR>" & _
"<br>Please confirm receipt of this order to ...." & _
"<font color=""red""><br><br><B>NOTE: Please pay attention to the shipping address indicated on the purchase order.</font></B> " & _
"<br><br>Thank you!" & _
"<br><br>Kind Regards," & _
"<br><br></font>"


'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\bouclesdor.htm"

If Dir(SigString) <> "" Then
signature = GetBoiler(SigString)
Else
signature = ""
End If



On Error Resume Next
With OutMail
.To = Sheets("po").Range("c13")
.CC = "email..."


' fait un cutePDF de la feuille PO de la plage a1 à o60
Sheets("PO").Range("A160").ExportAsFixedFormat xlTypePDF, "C:\Documents and Settings\Desktop\PO Copie à envoyer fournisseur\" & "PO " & Range("K8") & " " & Range("a8") & ".pdf"
'''Pour enregistrer la copie du PO sur le bureau avec toujours le même nom et joindre ce fichier au e-mail
PJ = "C:\Documents and Settings\Desktop\PO Copie à envoyer fournisseur\" & "PO " & Range("K8") & " " & Range("a8") & ".pdf"
.Attachments.Add (PJ)

.Subject = ActiveWorkbook.Name
.HTMLBody = strbody & "<br>" & signature 'strbody
.ReadReceiptRequested = True
.display 'or use .Send ou .display


End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
Else
MsgBox "Ce fichier n'est pas enregistrer, vous devez enregistrer le fichier avant de pouvoir l'envoyer par e-mail."
End If

'applique la condition de formatage pour les Be avec un * dans al colonne O la ligne vient jaune et gras de A à G
Range("a20:g35").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$O20=""*"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Font.Bold = True

With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 11796479
End With
Selection.FormatConditions(1).StopIfTrue = False

'applique jaune dans section BE
Range("N57").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
Formula1:="=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Bold = True
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
Selection.FormatConditions(1).StopIfTrue = False



End Sub

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

Merci à l'avance de votre aide...