We need a macro for saving attachments with name of that file and one more thing from the body

Tom Skowyrski
Tom Skowyrski used Ask the Experts™
on
We receive emails with pdf invoices and need to save them to the folder. As mentioned we need to save it with current filename and add from the message body the invoice ID. It looks like this in the message: "The invoice number is: 7489. The invoice ID is: 5088." So we need that file to be named like this: 'current filename - invoice ID.pdf'. We use a macro to save those files and we'd like to ask how to modify it to get what we want. This is the macro we've been currently using:

Sub SaveAttachmentsFromSelectedMailItems()
Dim individualItem As Object
Dim att As Attachment
Dim strPath As String
Dim strFileName As String
Dim strExt As String
Dim dicFileNames As Object

    strPath = "C:\Test\"
   
    Set dicFileNames = CreateObject("Scripting.Dictionary")
   
    For Each individualItem In Application.ActiveExplorer.Selection
        If TypeName(individualItem) = "MailItem" Then
            For Each att In individualItem.Attachments
               
                If Not dicFileNames.exists(att.FileName) Then
                    dicFileNames.Add att.FileName, 1
                Else
                              If LCase(Right(strFile, 4)) <> ".pdf"
                    dicFileNames(att.FileName) = dicFileNames(att.FileName) + 1
                End If
               
                strFileName = Split(att.FileName, ".")(0)
                strExt = Split(att.FileName, ".")(1)
               
                att.SaveAsFile strPath & strFileName & "-" & dicFileNames(att.FileName) & "." & strExt
               
            Next att
        End If
    Next individualItem
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
End-user support
Commented:
This works. In Outlook, you'll need to add the Microsoft VBScript Regular Expressions 5.5 library in Tools, References.:

Function GetValueUsingRegEx(sStr As String)
 ' Set reference to VB Script library
 ' Microsoft VBScript Regular Expressions 5.5
 
    sMain = sStr
    
    Dim olMail As Outlook.MailItem
    Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
        
    Set olMail = Application.ActiveExplorer().Selection(1)
   ' Debug.Print olMail.Body
    
    Set Reg1 = New RegExp
    
    ' \s* = invisible spaces
    ' \d* = match digits
    ' \w* = match alphanumeric
    
    With Reg1
        '.Pattern = "The invoice ID is\s*[:]+\s*(\w*)\s*"
        .Pattern = sMain & "\s*[:]+\s*(\w*)\s*"
        .Global = True
    End With
    If Reg1.test(olMail.Body) Then
    
        Set M1 = Reg1.Execute(olMail.Body)
        For Each M In M1
            ' M.SubMatches(1) is the (\w*) in the pattern
            ' use M.SubMatches(2) for the second one if you have two (\w*)
            Debug.Print M
            sRtnVal = M
        Next
    Else
      Debug.Print sMain & " not found"
    End If
    GetValueUsingRegEx = sRtnVal
End Function

Open in new window


Sub SaveAttachmentsFromSelectedMailItems()

Dim individualItem As Object
Dim att As Attachment
Dim strPath As String
Dim strFileName As String
Dim strExt As String
Dim dicFileNames As Object

strPath = "c:\test\"

Set dicFileNames = CreateObject("Scripting.Dictionary")

strInvNo = GetValueUsingRegEx("invoice ID is")

If strInvNo <> "" Then
  strInvNo = Split(strInvNo, ":")
  strInvNo = Trim(strInvNo(1))
  strChrA = Mid(strInvNo, Len(strInvNo), 1)
  ' Remove CrLf
  If Asc(strChrA) < 13 Then
    strInvNo = Replace(strInvNo, vbNewLine, "")
  End If
  
  For Each individualItem In Application.ActiveExplorer.Selection
      If TypeName(individualItem) = "MailItem" Then
        For Each att In individualItem.Attachments
          If Not dicFileNames.Exists(att.FileName) Then
            dicFileNames.Add att.FileName, 1
          ElseIf LCase(Right(strFile, 4)) <> ".pdf" Then
            dicFileNames(att.FileName) = dicFileNames(att.FileName) + 1
          End If
          If strInvNo <> "" Then
            strFileName = Split(att.FileName, ".")(0)
            strExt = Split(att.FileName, ".")(1)
            strFull = strPath & strFileName & "-" & strInvNo & "-" & dicFileNames(att.FileName) & "." & strExt
            att.SaveAsFile (strFull)
          End If
        Next att
      End If
  Next individualItem
End If
End Sub

Open in new window

Author

Commented:
Hello NVIT,
Sorry for the delayed answer. The macro is working. Thank you very much for your help.
Kind regards,
Tom
NVITEnd-user support

Commented:
No worries 👍. Thanks for the update

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial