VBA to save attachments as subject field [closed]

Question

Hope someone can help with this... thanks in advance!

I have numerous emails that are saved to the hard drive. Each email contains attachments with the same name as in the other emails. I have a working macro (thanks go Google) that will extract the attachments, save to a specific folder with a prefix to keep from overwriting. But what I really need for it to do is to rename the file based on the subject field. Or.. to at least be able to read some of the information from the subject line. Each email will have a set of numbers, followed by four characters within parenthesis. For example the subject will read... Successfully processed for your customer 123456789 (123A) accounts payable. I would like for the file to be saved as 123456789_123A and to add a _1 or _2 depending on how many files are in the email and to convert from XLSX to CSV.

We run this process biweekly and opening each email and doing "save as" is very time consuming as we are working with approximately 70 emails that each contain two attachments.

Below is the code that I am using. Any help would be most appreciated!!

Option Explicit
Const csOutlookIn As String = "In"
Const csOutlookOut As String = "Out"
Const csFilePrefix As String = "file"
Sub Extract_Emails_Demo2()
Application.ScreenUpdating = False


Dim sCurrentFolder As String
sCurrentFolder = ActiveWorkbook.Path & "\"

Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject

Dim fldrOutlookIn As Scripting.Folder
Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

Dim oApp As Outlook.Application
Set oApp = New Outlook.Application

Dim oMail As Outlook.MailItem
Dim oAttach As Outlook.Attachment

Dim fileItem As Scripting.File
Dim sAttachName As String
Dim lcounter As Long
lcounter = 0
Dim scounter As String
For Each fileItem In fldrOutlookIn.Files
Set oMail = oApp.CreateItemFromTemplate(fileItem.Path)
For Each oAttach In oMail.Attachments
lcounter = lcounter + 1
scounter = Format(lcounter, "000")
sAttachName = oAttach.Filename
sAttachName = sCurrentFolder & csOutlookOut & "\" & scounter & "_" & sAttachName
oAttach.SaveAsFile sAttachName
Next oAttach
Set oMail = Nothing
Next fileItem

MsgBox "Finished Extrating Files"
Application.ScreenUpdating = True
End Sub

Thanks in advance!

Answer 1

Please, test the next adapted code. It will not take in consideration mails not having any attachment and will send a message containing the email subjects not containing two numbers. It uses two functions to build the necessary names to save the attachments, open them, save as csv and delete the xls* workbook:

Sub Extract_Emails_Demo2()
 Const csOutlookIn As String = "In", csOutlookOut As String = "Out"
 Const csFilePrefix As String = "file", prefixName As String = "abcdefg_"

 Dim sCurrentFolder As String
 sCurrentFolder = ActiveWorkbook.Path & "\"

 Dim FSO As Scripting.FileSystemObject
 Set FSO = New Scripting.FileSystemObject

 Dim fldrOutlookIn As Scripting.Folder
 Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

 Dim oApp As Outlook.Application
 Set oApp = New Outlook.Application

 Dim oMail As Outlook.MailItem
 Dim oAttach As Outlook.Attachment

 Dim fileItem As Scripting.file, sAttachName As String, scounter As String
 Dim lcounter As Long, strSubject As String, arr, strNoPattern As String, strExt As String

 For Each fileItem In fldrOutlookIn.files
    Set oMail = oApp.CreateItemFromTemplate(fileItem.path)
    strSubject = oMail.Subject: lcounter = 0
    For Each oAttach In oMail.Attachments
        'Debug.Print oAttach.DisplayName: Stop
        lcounter = lcounter + 1
        arr = extrAllNumb(strSubject)             'extract an array of found numbers in the subject text
        sAttachName = buildName(arr, strSubject) 'build the name of the attachment to be saved
        If sAttachName = "" Then 'if no any number found in the subject
            strNoPattern = strNoPattern & fileItem & vbCrLf 'build the string of non conform Pattern files
            GoTo LoopEnd                         'skip the following code iteration lines
        End If
        strExt = Split(oAttach.DisplayName, ".")(UBound(Split(oAttach.DisplayName, ".")))
        sAttachName = sAttachName & "_" & lcounter 'add the attachment number
        sAttachName = sCurrentFolder & csOutlookOut & "\" & prefixName & sAttachName & "." & strExt
        oAttach.SaveAsFile sAttachName 'save the attachment using the above built name
        If strExt Like "xls*" Then     'saving excluding extension as pdf, doc, txt etc.
            Dim wb As Workbook, CSVName As String
            Application.ScreenUpdating = False     'some optimization for opening wb and process it
             Set wb = Workbooks.Open(sAttachName)  'open the workbook
             CSVName = Replace(sAttachName, "." & strExt, ".csv") 'build the csv name
             wb.saveas CSVName, xlCSV              'save the wb as csv
             wb.Close False                        'close the wb without saving
            Application.ScreenUpdating = True
             Kill sAttachName                      'delete the original attachment xls* file
        End If
    Next oAttach
LoopEnd:
 Next fileItem
 MsgBox "Finished Extrating Files"
 If strNoPattern <> "" Then MsgBox "Wrong pattern files: " & vbCrLf & strNoPattern
End Sub

Function buildName(arr As Variant, strSubject As String) As String
  Dim lngStart As Long, strChar As String
  If Not IsArray(arr) Then buildName = "": Exit Function
  If UBound(arr) >= 1 Then
    lngStart = InStr(strSubject, arr(0)) + Len(CStr(arr(0)))
    strChar = Mid(strSubject, InStr(lngStart, strSubject, arr(1)) + Len(CStr(arr(1))), 1)
    'buildName = arr(0) & "_" & arr(1) & IIf(strChar = ")", "", strChar)
    buildName = arr(1) & IIf(strChar = ")", "", strChar) & "_" & arr(0)
  Else
    buildName = arr(0)
  End If
End Function

Private Function extrAllNumb(strVal As String) As Variant
    Dim res As Object, El, arr, i As Long
    With CreateObject("VBscript.RegExp")
        .Pattern = "(\d{3,10})"
        .Global = True
        If .Test(strVal) Then
            Set res = .Execute(strVal)
            ReDim arr(res.count - 1)
            For Each El In res
                arr(i) = El: i = i + 1
            Next
        End If
    End With
    extrAllNumb = arr
End Function

If something not clear enough, please do not hesitate to ask for clarifications.