将 Outlook 电子邮件另存为 PDF + 附件
Saving Outlook email as PDF + Attachments
所以我使用宏来保存收到的邮件（使用收件箱规则和 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
如果有人有任何想法，将不胜感激。
我注意到以下代码行：
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
无需获取 MailItem 的新实例 class。您可以使用作为参数传递的实例。
If fso.FileExists(bPath & saveName) Then
fso.DeleteFile bPath & saveName
您似乎删除了现有文件，而不是使用不同名称保存新文件。
您可以考虑在保存时使用日期时间（不仅仅是日期）标记 emails/attachments。或者你可以检查磁盘上是否已经存在这样的文件。
一旦您删除了删除文件的 if 语句，这就非常有效。谢谢你的基金会。
我已经修改了您代码的 PDF 部分（我希望更好）并解决了 pdf 文件名如果已经存在则不会递增的问题。我不得不为 PDF 编写一个单独的循环，因为您基本上用这一行停止了循环：pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".pdf" 但我似乎无法在不产生错误的情况下摆脱该行，因此创建了一个新循环。也许有人可以为我简化那部分。
我还添加了一行以删除仅用于创建 PDF 的 .mht 文件并稍微修改了文件名：
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
所以我使用宏来保存收到的邮件（使用收件箱规则和 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
如果有人有任何想法，将不胜感激。
我注意到以下代码行：
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
无需获取 MailItem 的新实例 class。您可以使用作为参数传递的实例。
If fso.FileExists(bPath & saveName) Then
fso.DeleteFile bPath & saveName
您似乎删除了现有文件，而不是使用不同名称保存新文件。
您可以考虑在保存时使用日期时间（不仅仅是日期）标记 emails/attachments。或者你可以检查磁盘上是否已经存在这样的文件。
一旦您删除了删除文件的 if 语句，这就非常有效。谢谢你的基金会。
我已经修改了您代码的 PDF 部分（我希望更好）并解决了 pdf 文件名如果已经存在则不会递增的问题。我不得不为 PDF 编写一个单独的循环，因为您基本上用这一行停止了循环：pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".pdf" 但我似乎无法在不产生错误的情况下摆脱该行，因此创建了一个新循环。也许有人可以为我简化那部分。
我还添加了一行以删除仅用于创建 PDF 的 .mht 文件并稍微修改了文件名：
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