将Outlook“作为脚本运行”规则集成到发送电子邮件的Excel VBA代码中

时间：2016-03-13 00:59:26

标签： excel vba outlook outlook-vba

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

然后我在Outlook中有一条规则，根据主题中保存 pdf 该电子邮件副本的关键字和/或主题中的关键字在电子邮件中运行脚本这是附件。

我宁愿让Excel VBA脚本保存excel vba脚本刚刚发送的电子邮件的 pdf 副本。否则，我需要在我们系统中的每台计算机上实现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

用于保存电子邮件的pdf副本的Outlook脚本（工作正常）： 

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

2 个答案:

答案 0 :(得分：1)

将更改为应该不难，只需将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中点击TOOLS＆gt;参考并选中

的复选框

Microsoft Outlook Object Library＆amp; Microsoft Scripting Runtime

答案 1 :(得分：1)

如果有人感兴趣（全部在1个模块中）

，这是我的最终组合工作代码

组合代码的所有道具都归Om3r所有，他们有一个冷酷的科罗拉多小啤酒等着他！

此代码将：

  • 创建活动工作表的PDF，将其附加到电子邮件
  • 用户发送电子邮件后，在“已发邮件”文件夹中搜索该电子邮件
  • 保存已发送电子邮件的PDF副本（如果需要，还可以保存附件）

对'pre'格式感到抱歉，但ctrl + K并没有削减它！抓住它，得到它

Sub AttachActiveSheetPDF()
  Dim IsCreated As Boolean
  Dim PdfFile As String, Esub As String
  Dim OutlApp As Object
  Dim sendTime As String

    sendTime = Now()
    sendTime = Format(sendTime, "yyyy-mm-dd-hhmmss")

  ' ### Define email subject and PDF path & filename ###
  Esub = sendTime & "_Completed Case Review"
  PdfFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Esub & ".pdf"


  ' ### Export ActiveSheet to PDF ###
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  ' ### Open Outlook ###
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")  '<-- If open, use it
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")  '<-- If not, open it
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

  ' ### Prepare email and attach pdf created above ###
  With OutlApp.CreateItem(0)

    .Subject = Esub
    .To = ""   ' <-- Put email of the recipient here
    .CC = ""
    .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 True '<-- True forces code to wait for user to send email. Or just automate what the user is doing and change this to .Send
  End With

  Application.Wait (Now + TimeValue("0:00:05"))  '<-- 5 second delay allows email to finish sending

' ### Search Sent Mail folder for emails with same timestamp in subject ###
    Dim olNameSpace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olItem As Object

    Set olNameSpace = OutlApp.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderSentMail)
    Set olItem = OutlApp.CreateItem(olMailItem)

    For Each olItem In olFolder.Items
        If olItem.Class = olMail Then
            If olItem.Subject = Esub Then  '<-- check for match
                SaveAsPDF olItem '< - Call SaveAsPDF code
            End If
        End If
    Next

    If IsCreated Then OutlApp.Quit  '<-- Quit Outlook if it was not already open
  Set OutlApp = Nothing  '<-- Release the memory of object variable

   ' ### Delete our temp pdf file if not needed anymore ###
  Kill PdfFile

End Sub


Sub SaveAsPDF(MyMail As MailItem)

' ### Requires reference to Microsoft Scripting Runtime ###
' ### Requires reference to Microsoft Outlook Object Library ###
' ### Requires reference to Microsoft Word Object Library ###
' --- In VBE click TOOLS > REFERENCES and check the boxes for all of the above ---

  Dim fso As FileSystemObject
  Dim emailSubject As String
  Dim saveName As String
  Dim blnOverwrite As Boolean
  Dim bPath As String
  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 App = CreateObject("Outlook.Application")
  Set olNS = App.GetNamespace("MAPI")
  Set oMail = olNS.GetItemFromID(strID)

  ' ### Get username portion of sender's email address ###
  sendEmailAddr = oMail.SenderEmailAddress
  senderName = Left(sendEmailAddr, InStr(sendEmailAddr, "@") - 1)

  ' ### USER OPTIONS ###
  blnOverwrite = False ' False = don't overwrite, True = do overwrite

  ' ### Path to directory for saving pdf copy of sent email ###
  bPath = "Z:\MyEmailFolder\"

  ' ### 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 = emailSubject & ".mht"
  Set fso = CreateObject("Scripting.FileSystemObject")

  ' ### Save .mht file to create pdf from within Word ###
  oMail.SaveAs bPath & saveName, olMHTML
  pdfSave = bPath & emailSubject & "_" & senderName & "_" & ".pdf"

  ' ### 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 our temp .mht file ###
  Kill bPath & saveName

  ' ### Uncomment this section to save attachments also ###
  '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


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
相关问题
最新问题