title: Saving Outlook email as PDF + Attachments
body: <p>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). </p>
  
  <p>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:</p>
  
  <pre><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 &amp; companyDomain &amp; "\" 'Adds company domain to base path
  yPath = cPath &amp; Format(Now(), "yyyy") &amp; "\" 'Add year subfolder
  mPath = yPath &amp; Format(Now(), "MMMM") &amp; "\" '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 &amp; set name to be saved as ###
  emailSubject = CleanFileName(oMail.Subject)
  saveName = Format(oMail.ReceivedTime, "yyyymmdd") &amp; "_" &amp; emailSubject &amp; ".txt"
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  '### If don't overwrite is on then ###
  If blnOverwrite = False Then
     looper = 0
     Do While fso.FileExists(yPath &amp; saveName)
        looper = looper + 1
        saveName = Format(oMail.ReceivedTime, "yyyymmdd") &amp; "_" &amp; emailSubject &amp; "_" &amp; looper &amp; ".txt"
     Loop
  Else '### If don't overwrite is off, delete the file ###
     If fso.FileExists(yPath &amp; saveName) Then
        fso.DeleteFile yPath &amp; saveName
     End If
  End If
  
  '### Save MSG File ###
  oMail.SaveAs bPath &amp; saveName, olTXT
  
  '### If Mail Attachments: clean file name, save into path ###
  If oMail.Attachments.Count &gt; 0 Then
     For Each atmt In oMail.Attachments
        atmtName = CleanFileName(atmt.FileName)
        atmtSave = bPath &amp; Format(oMail.ReceivedTime, "yyyymmdd") &amp; "_" &amp; 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 = "/\[]:=," &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
  ' \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 &amp; companyDomain &amp; "\" 'Adds company domain to base path
  yPath = cPath &amp; Format(Now(), "yyyy") &amp; "\" 'Add year subfolder
  mPath = yPath &amp; Format(Now(), "MMMM") &amp; "\" '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 &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")
  
  '### If don't overwrite is on then ###
  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; emailSubject &amp; "_" &amp; looper &amp; ".mht"
          pdfSave = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") &amp; "_" &amp; emailSubject &amp; "_" &amp; looper &amp; ".pdf"
          Loop
  Else '### If don't overwrite is off, delete the file ###
      If fso.FileExists(bPath &amp; saveName) Then
          fso.DeleteFile bPath &amp; saveName
      End If
  End If
  oMail.SaveAs bPath &amp; saveName, olMHTML
  pdfSave = bPath &amp; Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") &amp; "_" &amp; emailSubject &amp; ".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 &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
  
  '### Clean up files ###
  With New FileSystemObject
      If .FileExists(bPath &amp; saveName) Then
          .DeleteFile bPath &amp; saveName
      End If
  End With
  
  '### If Mail Attachments: clean file name, save into path ###
  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>
  
  <p>If anyone has any idea, help would be greatly appreciated.</p>