Сохранение электронной почты Outlook в формате PDF + Приложения

Question

Так что я использую макрос для сохранения входящей почты (с правилом входящей почты и кодом VBA). Проблема, с которой я столкнулась, заключается в том, что когда есть несколько писем с одинаковым именем (а также, если вложения имеют одно и то же имя), они не будут сохраняться. (они переписывают друг друга). Мне нужно как электронное письмо, так и вложения для перехода через 1-10 (может быть до десяти писем и вложений с одинаковыми именами). Вот код:

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 

Если у кого-то есть идеи, справка будет принята с благодарностью.

Answer 1

я заметил следующие строки кода:

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

Там нет необходимости, чтобы получить новый экземпляр класса MailItem. Вы можете использовать экземпляр, переданный как параметр.

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

Похоже, вы удаляете существующие файлы вместо сохранения новых с разными именами.

Вы можете использовать маркер даты и времени (не только даты) при сохранении электронных писем/вложений. Или вы можете проверить, существует ли такой файл на диске уже.

Answer 2

Это работает очень хорошо, как только вы удаляете операторы if, которые удаляют файл. Благодарю вас за фундамент.

Я изменил часть PDF вашего кода (к лучшему, надеюсь), и исправил проблему, когда имя файла pdf не увеличивалось, если оно уже существовало. Мне пришлось написать отдельный цикл для PDF, потому что вы в основном остановили цикл с помощью этой строки: pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".pdf", но я не могу избавиться от этой строки, не создавая ошибку, поэтому сделал новый цикл. Может быть, кто-то может упростить эту часть для меня.

Я также добавил строку для удаления файла .mht используется только для создания PDF и изменять имена файлов, немного:

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