excel - 将 Outlook "Run as Script"规则集成到发送电子邮件的 Excel VBA 代码中

Question

我有一个创建 的 Excel VBA 脚本。 pdf 事件工作表，然后发送一封带有 的 Outlook 电子邮件pdf 随附的。

然后我在 Outlook 中有一个规则，它根据主题中的关键字对到达已发送文件夹的电子邮件运行脚本，该主题中保存了 。 pdf 该电子邮件和/或其附件的副本。

我宁愿让 Excel VBA 脚本保存 pdf 刚刚由 excel vba 脚本发送的电子邮件的副本。否则，我需要在我们系统中的每台计算机上实现 Outlook“作为脚本运行”规则。

如何将 Outlook 脚本与 Excel 脚本结合起来？

发送电子邮件的 Excel 代码(工作正常):

Sub AttachActiveSheetPDF_01()
  Dim IsCreated As Boolean
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object

   ' Define PDF filename
  Title = Range("C218").Value
  PdfFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Title & ".pdf"


  ' Exportactivesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, FileName:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)

    ' Prepare e-mail
    .Subject = Title
    .To = "" ' <-- Put email of the recipient here
    .CC = "" ' <-- Put email of 'copy to' recipient here
    .Body = "Hello," & vbLf & vbLf _
          & "Please find attached a completed case review." & vbLf & vbLf _
          & "Thank you," & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile

    ' Try to send
    Application.Visible = True
    .Display
  End With

  ' Quit Outlook if it was not already open
  If IsCreated Then OutlApp.Quit

  ' Release the memory of object variable
  Set OutlApp = Nothing

End Sub

Outlook 脚本保存电子邮件的 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

Answer 1

更改您的 outlook-vba 应该不难至excel-vba ，只需将您的 Outlook 脚本移动到 Excel 模块并修改以下行。

Set App = CreateObject("Outlook.Application") '<- add
Set olNS = App.GetNamespace("MAPI") '<- change

现在创建新模块并添加以下代码

Option Explicit
Sub Outlook()
    Dim olNameSpace As Outlook.Namespace
    Dim olApp As Outlook.Application
    Dim olFolder As Outlook.MAPIFolder
    Dim olItem As Object

    Set olApp = CreateObject("Outlook.Application")
    Set olNameSpace = olApp.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderSentMail)
    Set olItem = olApp.CreateItem(olMailItem)

    For Each olItem In olFolder.Items
        If olItem.Class = olMail Then
            If olItem.Subject = [A1] Then '< - update cell range
                Debug.Print olItem
                SaveAsPDF olItem '< - Call SaveAsPDF code
            End If
        End If
    Next

End Sub

该代码将通过 [Subject] 搜索 Outlook 发送的文件夹所以更新一下你的 Excel 代码 [Subject Title range]

If olItem.Subject = [A1] Then ' Update cell [C218]

如果找到主题，则调用 Outlook 脚本

SaveAsPDF olItem

请记住添加 - 在 VBE 中单击工具 > 引用并选中复选框
Microsoft Outlook Object Library & Microsoft Scripting Runtime