将Outlook“以脚本运行”规则集成到发送电子邮件的Excel VBA代码中
我有一个Excel VBA脚本，用于创build活动工作表的pdf ，然后用附带的pdf发送带有Outlook的电子邮件。
然后我在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
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
将outlook-vba更改为excel-vba并不难，只需将您的outlook脚本移至Excel模块并修改以下行即可。
Set App = CreateObject("Outlook.Application") '<- add Set olNS = App.GetNamespace("MAPI") '<- change
现在创build新模块并添加下面的代码
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]searchOutlook发送的文件夹，以便更新以encryption您的Excel代码[Subject Title range]
If olItem.Subject = [A1] Then ' Update cell [C218]
如果主题发现，然后调用Outlook脚本
SaveAsPDF olItem
请记住，在VBE中单击“工具”>“参考”，然后选中框
Microsoft Outlook Object Library和Microsoft Scripting Runtime
如果有人感兴趣，这是我最后的组合工作代码（全部在1个模块中）
所有的代码组合的道具都去了Om3r，他有一个冷漠的科罗拉多州的小老虎在等着他！
此代码将：
- 创build活动工作表的PDF，附加到电子邮件
- 用户发送电子邮件后，search该邮件的“已发送邮件”文件夹
- 保存发送的电子邮件的PDF副本（如果需要，附件）
对不起，关于'前'格式，但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