title: Integrate Outlook "Run as Script" rule into Excel VBA code that sends email
body: <p>I have an Excel VBA script that creates a <strong><code>pdf</code></strong> of the active worksheet and then sends an email with Outlook with the <strong><code>pdf</code></strong> attached.  </p>
  
  <p>Then I have a rule in Outlook that runs a script on Emails that arrive in the Sent folder based on keywords in the subject that saves a <strong><code>pdf</code></strong> copy of that email and/or it's attachments.</p>
  
  <p>I would rather just have the Excel VBA script save that <strong><code>pdf</code></strong> copy of the email that was just sent by the excel vba script.  Otherwise, I would need to implement the Outlook "run as script" rule on every computer in our system.</p>
  
  <p><strong>How can I marry the Outlook script with the Excel script??</strong></p>
  
  <p><strong>Excel Code to send email (works fine):</strong></p>
  
  <pre><code>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") &amp; "\" &amp; Title &amp; ".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 = "" ' &lt;-- Put email of the recipient here
      .CC = "" ' &lt;-- Put email of 'copy to' recipient here
      .Body = "Hello," &amp; vbLf &amp; vbLf _
            &amp; "Please find attached a completed case review." &amp; vbLf &amp; vbLf _
            &amp; "Thank you," &amp; vbLf _
            &amp; Application.UserName &amp; vbLf &amp; 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
  </code></pre>
  
  <p><strong>Outlook script to save pdf copy of email (works fine):</strong></p>
  
  <pre><code>Function CleanFileName(strText As String) As String
  Dim strStripChars As String
  Dim intLen As Integer
  Dim i As Integer
  strStripChars = "/\[]:=," &amp; 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 &gt; 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 &amp; set name to be saved as ###
  emailSubject = CleanFileName(oMail.Subject)
  saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") &amp; "_" &amp; emailSubject &amp; ".mht"
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  ' ### Increment filename if it already exists ###
  If blnOverwrite = False Then
      looper = 0
      Do While fso.FileExists(bPath &amp; saveName)
          looper = looper + 1
          saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") &amp; "_" &amp; senderName &amp; "_" &amp; emailSubject &amp; "_" &amp; looper &amp; ".mht"
          Loop
  Else
  End If
  
  ' ### Save .mht file to create pdf from Word ###
  oMail.SaveAs bPath &amp; saveName, olMHTML
  pdfSave = bPath &amp; Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") &amp; "_" &amp; senderName &amp; "_" &amp; emailSubject &amp; ".pdf"
  If fso.FileExists(pdfSave) Then
      plooper = 0
      Do While fso.FileExists(pdfSave)
      plooper = plooper + 1
      pdfSave = bPath &amp; Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") &amp; "_" &amp; senderName &amp; "_" &amp; emailSubject &amp; "_" &amp; plooper &amp; 
  
  ".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 &amp; 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 &amp; saveName
  
  ' ### Uncomment this section to save attachments ###
  'If oMail.Attachments.Count &gt; 0 Then
  '    For Each atmt In oMail.Attachments
  '        atmtName = CleanFileName(atmt.FileName)
  '        atmtSave = bPath &amp; Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") &amp; "_" &amp; atmtName
  '        atmt.SaveAsFile atmtSave
  '    Next
  'End If
  
  Set oMail = Nothing
  Set olNS = Nothing
  Set fso = Nothing
  End Sub
  </code></pre>