将Outlook电子邮件另存为PDF +附件 [英] Saving Outlook email as PDF + Attachments

问题描述

因此，我正在使用宏来保存传入的邮件(带有收件箱规则和VBA代码).我遇到的问题是，当有多个具有相同名称的电子邮件(以及附件具有相同名称)时，它们将不会保存. (它们彼此覆盖).

So I am using a macro to save incoming mail (with an inbox rule and VBA code). The problem I am having is that when there are multiple emails with the same name (and also if the attachments have the same name) they will not save. (they overwrite each other).

我需要电子邮件和附件都循环到1到10(最多可以有十个具有相同名称的电子邮件和附件).这是代码:

I need both the email and the attachments to loop through 1-10 (there can be up to ten emails and attachments with the same names). Here is the 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

如果有人有任何想法，将不胜感激.

If anyone has any idea, help would be greatly appreciated.

推荐答案

我注意到以下代码行:

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

不需要获取MailItem类的新实例.您可以使用作为参数传递的实例.

There is no need to get a new instance of the MailItem class. You can use the instance passed as a parameter.

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

您似乎删除了现有文件，而不是使用其他名称保存新文件.

It looks like you delete existing files instead of saving a new ones with different names.

在保存电子邮件/附件时，您可以考虑使用datetime(不仅是日期)标记.或者，您可以检查磁盘上是否已经存在此类文件.

You may consider using the datetime (not only the date) marker when saving emails/attachments. Or you may check out whether such file exists on the disk already.

这篇关于将Outlook电子邮件另存为PDF +附件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！