Enregistrement de l'email Outlook en PDF + Pièces jointes

Question

J'utilise donc une macro pour enregistrer le courrier entrant (avec une règle de boîte de réception et un code VBA). Le problème que j'ai est que quand il y a plusieurs emails avec le même nom (et aussi si les attachements ont le même nom) ils ne sauveront pas. (Ils se remplacent). J'ai besoin à la fois de l'e-mail et des pièces jointes pour boucler 1-10 (il peut y avoir jusqu'à dix e-mails et pièces jointes avec les mêmes noms). Voici le code:

Sub SaveAsMsg(MyMail As MailItem) 
' requires reference to Microsoft Scripting Runtime 
' \Windows\System32\Scrrun.dll 
' Also requires reference to Microsoft Word Object Library 
Dim fso As FileSystemObject 
Dim strSubject As String 
Dim strSaveName As String 
Dim blnOverwrite As Boolean 
Dim strFolderPath As String 
Dim looper As Integer 
Dim strID As String 
Dim olNS As Outlook.NameSpace 
Dim oMail As Outlook.MailItem 

strID = MyMail.EntryID 
Set olNS = Application.GetNamespace("MAPI") 
Set oMail = olNS.GetItemFromID(strID) 

'Get Sender email domain 
sendEmailAddr = oMail.SenderEmailAddress 
companyDomain = Right(sendEmailAddr, Len(sendEmailAddr) - InStr(sendEmailAddr, "@")) 

' ### USER OPTIONS ### 
blnOverwrite = False ' False = don't overwrite, True = do overwrite 

'### THIS IS WHERE SAVE LOCATIONS ARE SET ### 
'Currently only saves to yPath. Change the yPath variable to mPath in other areas of the script to enable the month folder. 
bPath = "C:\email\" 'Defines the base path to save the email 
cPath = bPath & companyDomain & "\" 'Adds company domain to base path 
yPath = cPath & Format(Now(), "yyyy") & "\" 'Add year subfolder 
mPath = yPath & Format(Now(), "MMMM") & "\" 'Add month subfolder 

'### Path Validity ### 
'Make sure base path exists 
If Dir(bPath, vbDirectory) = vbNullString Then 
    MkDir bPath 
End If 
'Make sure company domain path exists 
'If Dir(cPath, vbDirectory) = vbNullString Then 
    'MkDir cPath 
'End If 
'Make sure year path exists 
'If Dir(yPath, vbDirectory) = vbNullString Then 
    'MkDir yPath 
'End If 
'Make sure month path exists (uncomment below lines to enable) 
'If Dir(mPath, vbDirectory) = vbNullString Then 
'MkDir mPath 
'End If 

'### Get Email subject & set name to be saved as ### 
emailSubject = CleanFileName(oMail.Subject) 
saveName = Format(oMail.ReceivedTime, "yyyymmdd") & "_" & emailSubject & ".txt" 
Set fso = CreateObject("Scripting.FileSystemObject") 

'### If don't overwrite is on then ### 
If blnOverwrite = False Then 
    looper = 0 
    Do While fso.FileExists(yPath & saveName) 
     looper = looper + 1 
     saveName = Format(oMail.ReceivedTime, "yyyymmdd") & "_" & emailSubject & "_" & looper & ".txt" 
    Loop 
Else '### If don't overwrite is off, delete the file ### 
    If fso.FileExists(yPath & saveName) Then 
     fso.DeleteFile yPath & saveName 
    End If 
End If 

'### Save MSG File ### 
oMail.SaveAs bPath & saveName, olTXT 

'### If Mail Attachments: clean file name, save into path ### 
If oMail.Attachments.Count > 0 Then 
    For Each atmt In oMail.Attachments 
     atmtName = CleanFileName(atmt.FileName) 
     atmtSave = bPath & Format(oMail.ReceivedTime, "yyyymmdd") & "_" & atmtName 
     atmt.SaveAsFile atmtSave 
    Next 
End If 

Set oMail = Nothing 
Set olNS = Nothing 
Set fso = Nothing 
End Sub 

Function CleanFileName(strText As String) As String 
Dim strStripChars As String 
Dim intLen As Integer 
Dim i As Integer 
strStripChars = "/\[]:=," & Chr(34) 
intLen = Len(strStripChars) 
strText = Trim(strText) 
For i = 1 To intLen 
strText = Replace(strText, Mid(strStripChars, i, 1), "") 
Next 
CleanFileName = strText 
End Function 



Sub SaveAsPDF(MyMail As MailItem) 
' requires reference to Microsoft Scripting Runtime 
' \Windows\System32\Scrrun.dll 
' Also requires reference to Microsoft Word Object Library 
Dim fso As FileSystemObject 
Dim strSubject As String 
Dim strSaveName As String 
Dim blnOverwrite As Boolean 
Dim strFolderPath As String 
Dim looper As Integer 
Dim strID As String 
Dim olNS As Outlook.NameSpace 
Dim oMail As Outlook.MailItem 

strID = MyMail.EntryID 
Set olNS = Application.GetNamespace("MAPI") 
Set oMail = olNS.GetItemFromID(strID) 

'Get Sender email domain 
sendEmailAddr = oMail.SenderEmailAddress 
companyDomain = Right(sendEmailAddr, Len(sendEmailAddr) - InStr(sendEmailAddr, "@")) 

' ### USER OPTIONS ### 
blnOverwrite = False ' False = don't overwrite, True = do overwrite 

'### THIS IS WHERE SAVE LOCATIONS ARE SET ### 
bPath = "C:\email\" 'Defines the base path to save the email 
cPath = bPath & companyDomain & "\" 'Adds company domain to base path 
yPath = cPath & Format(Now(), "yyyy") & "\" 'Add year subfolder 
mPath = yPath & Format(Now(), "MMMM") & "\" 'Add month subfolder 

'### Path Validity ### 
If Dir(bPath, vbDirectory) = vbNullString Then 
    MkDir bPath 
End If 
'If Dir(cPath, vbDirectory) = vbNullString Then 
    ' MkDir cPath 
'End If 
'If Dir(yPath, vbDirectory) = vbNullString Then 
    ' MkDir yPath 
'End If 

'### Get Email subject & set name to be saved as ### 
emailSubject = CleanFileName(oMail.Subject) 
saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".mht" 
Set fso = CreateObject("Scripting.FileSystemObject") 

'### If don't overwrite is on then ### 
If blnOverwrite = False Then 
    looper = 0 
    Do While fso.FileExists(bPath & saveName) 
     looper = looper + 1 
     saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & "_" & looper & ".mht" 
     pdfSave = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & "_" & looper & ".pdf" 
     Loop 
Else '### If don't overwrite is off, delete the file ### 
    If fso.FileExists(bPath & saveName) Then 
     fso.DeleteFile bPath & saveName 
    End If 
End If 
oMail.SaveAs bPath & saveName, olMHTML 
pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".pdf" 

'### Open Word to convert file to PDF ### 
Dim wrdApp As Word.Application 
Dim wrdDoc As Word.Document 
Set wrdApp = CreateObject("Word.Application") 

Set wrdDoc = wrdApp.Documents.Open(FileName:=bPath & saveName, Visible:=True) 
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _ 
      pdfSave, ExportFormat:= _ 
      wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _ 
      wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _ 
      Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _ 
      CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _ 
      BitmapMissingFonts:=True, UseISO19005_1:=False 

wrdDoc.Close 
wrdApp.Quit 

'### Clean up files ### 
With New FileSystemObject 
    If .FileExists(bPath & saveName) Then 
     .DeleteFile bPath & saveName 
    End If 
End With 

'### If Mail Attachments: clean file name, save into path ### 
If oMail.Attachments.Count > 0 Then 
    For Each atmt In oMail.Attachments 
     atmtName = CleanFileName(atmt.FileName) 
     atmtSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & atmtName 
     atmt.SaveAsFile atmtSave 
    Next 
End If 

Set oMail = Nothing 
Set olNS = Nothing 
Set fso = Nothing 
End Sub 

Si quelqu'un a une idée, une aide serait grandement appréciée.

Answer 1

J'ai remarqué les lignes de code suivantes:

strID = MyMail.EntryID 
Set olNS = Application.GetNamespace("MAPI") 
Set oMail = olNS.GetItemFromID(strID) 

Il n'y a pas besoin d'obtenir une nouvelle instance de la classe MailItem. Vous pouvez utiliser l'instance passée en paramètre.

If fso.FileExists(bPath & saveName) Then 
    fso.DeleteFile bPath & saveName 

Il semble que vous supprimiez des fichiers existants au lieu d'en enregistrer un nouveau avec des noms différents.

Vous pouvez utiliser le marqueur datetime (pas seulement la date) lors de la sauvegarde des emails/pièces jointes. Ou vous pouvez vérifier si un tel fichier existe déjà sur le disque.

Answer 2

Cela fonctionne très bien une fois que vous supprimez les instructions if qui suppriment le fichier. Merci pour la fondation.

J'ai modifié la partie PDF de votre code (pour le meilleur, j'espère) et corrigé un problème que le nom de fichier pdf n'augmenterait pas s'il existait déjà. J'ai dû écrire une boucle séparée pour le PDF parce que vous avez essentiellement arrêté la boucle avec cette ligne: pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".pdf" mais je n'arrive pas à me débarrasser de cette ligne sans produire d'erreur, donc j'ai fait une nouvelle boucle. Peut-être que quelqu'un peut simplifier cette partie pour moi.

J'ai aussi ajouté une ligne pour supprimer le fichier .mht utilisé uniquement pour créer le PDF et modifié les noms de fichiers un peu:

Function CleanFileName(strText As String) As String 
Dim strStripChars As String 
Dim intLen As Integer 
Dim i As Integer 
strStripChars = "/\[]:=," & Chr(34) 
intLen = Len(strStripChars) 
strText = Trim(strText) 
For i = 1 To intLen 
strText = Replace(strText, Mid(strStripChars, i, 1), "") 
Next 
CleanFileName = strText 
End Function 



Sub SaveAsPDF(MyMail As MailItem) 
' ### Requires reference to Microsoft Scripting Runtime ### 
' ### Requires reference to Microsoft Word Object Library ### 
' --- In VBE click TOOLS > REFERENCES and check the boxes for both of the above --- 
Dim fso As FileSystemObject 
Dim strSubject As String 
Dim strSaveName As String 
Dim blnOverwrite As Boolean 
Dim strFolderPath As String 
Dim sendEmailAddr As String 
Dim senderName As String 
Dim looper As Integer 
Dim plooper As Integer 
Dim strID As String 
Dim olNS As Outlook.NameSpace 
Dim oMail As Outlook.MailItem 

strID = MyMail.EntryID 
Set olNS = Application.GetNamespace("MAPI") 
Set oMail = olNS.GetItemFromID(strID) 

' ### Get username portion of sender email address ### 
sendEmailAddr = oMail.SenderEmailAddress 
senderName = Left(sendEmailAddr, InStr(sendEmailAddr, "@") - 1) 

' ### USER OPTIONS ### 
blnOverwrite = False ' False = don't overwrite, True = do overwrite 

' ### Path to save directory ### 
bPath = "Z:\email\" 

' ### Create Directory if it doesnt exist ### 
If Dir(bPath, vbDirectory) = vbNullString Then 
    MkDir bPath 
End If 

' ### Get Email subject & set name to be saved as ### 
emailSubject = CleanFileName(oMail.Subject) 
saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".mht" 
Set fso = CreateObject("Scripting.FileSystemObject") 

' ### Increment filename if it already exists ### 
If blnOverwrite = False Then 
    looper = 0 
    Do While fso.FileExists(bPath & saveName) 
     looper = looper + 1 
     saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & "_" & looper & ".mht" 
     Loop 
Else 
End If 

' ### Save .mht file to create pdf from Word ### 
oMail.SaveAs bPath & saveName, olMHTML 
pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & ".pdf" 

If fso.FileExists(pdfSave) Then 
    plooper = 0 
    Do While fso.FileExists(pdfSave) 
    plooper = plooper + 1 
    pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & "_" & plooper & ".pdf" 
    Loop 
Else 
End If 


' ### Open Word to convert .mht file to PDF ### 
Dim wrdApp As Word.Application 
Dim wrdDoc As Word.Document 
Set wrdApp = CreateObject("Word.Application") 

' ### Open .mht file we just saved and export as PDF ### 
Set wrdDoc = wrdApp.Documents.Open(FileName:=bPath & saveName, Visible:=True) 
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _ 
      pdfSave, ExportFormat:= _ 
      wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _ 
      wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _ 
      Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _ 
      CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _ 
      BitmapMissingFonts:=True, UseISO19005_1:=False 

wrdDoc.Close 
wrdApp.Quit 

' ### Delete .mht file ### 
Kill bPath & saveName 

' ### Uncomment this section to save attachments ### 
'If oMail.Attachments.Count > 0 Then 
' For Each atmt In oMail.Attachments 
'  atmtName = CleanFileName(atmt.FileName) 
'  atmtSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & atmtName 
'  atmt.SaveAsFile atmtSave 
' Next 
'End If 

Set oMail = Nothing 
Set olNS = Nothing 
Set fso = Nothing 
End Sub