将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