將Outlook電子郵件另存爲PDF +附件

Question

因此，我使用宏來保存傳入郵件（使用收件箱規則和VBA代碼）。我遇到的問題是，如果有多個具有相同名稱的電子郵件（並且附件具有相同的名稱），則不會保存。 （他們相互覆蓋）。我需要電子郵件和附件才能循環顯示1-10（最多可以有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