VBA to extract Outlook attachment and save to specified folder with subject line and convert to CSV

[Holley]

Hello all! Once again many many thanks for all the help I've received!! Hoping you can chime in again to assist this newbie.

I have numerous emails that are saved to the hard drive. Each email contains attachments with the same names as the other emails. I have a working macro 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_1234 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

 

[Holley]

Would anyone be able to able to push me in the correct direction with this? Thanks again in advance!

 

[John_w]

Try this macro:

Option Explicit

Public Sub Extract_Emails_Save_XLSX_Attachments_As_CSV()
    
    Dim FSO As Object 'Scripting.FileSystemObject
    Dim FSfolder As Object 'Scripting.Folder
    Dim FSfile As Object 'Scripting.File
    Dim oApp As Object 'Outlook.Application
    Dim oMail As Object 'Outlook.MailItem
    Dim oAttachment As Object 'Outlook.Attachment
    Dim re As Object 'VBScript_RegExp_55.RegExp
    Dim reMatches As Object 'VBScript_RegExp_55.MatchCollection
    Dim OutlookFilesFolder As String, SaveInFolder As String
    Dim csvFileNamePrefix As String
    Dim AttachmentFileName As String
    Dim csvFileName As String
    Dim n As Long
    
    OutlookFilesFolder = ActiveWorkbook.Path & "\" & csOutlookIn
    SaveInFolder = ActiveWorkbook.Path & "\" & csOutlookOut & "\"
    
    If Right(SaveInFolder, 1) <> "\" Then SaveInFolder = SaveInFolder & "\"
    
    'Regular expression to match numbers followed by 4 alphanumeric characters within parentheses in email subject and capture them
    
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d+)\s*\((\w{4})\)"
    
    Set oApp = CreateObject("Outlook.Application")
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set FSfolder = FSO.GetFolder(OutlookFilesFolder)
    
    Application.ScreenUpdating = False
    
    For Each FSfile In FSfolder.Files
        
        Select Case Left(oApp.Version, InStr(oApp.Version, ".") - 1)
            Case Is = 11
                'Open .msg file in Outlook 2003
                Set oMail = oApp.CreateItemFromTemplate(FSfile.Path)
            Case Is >= 12
                'Open .msg file in Outlook 2007+
                Set oMail = oApp.Session.OpenSharedItem(FSfile.Path)
        End Select
        
        'Extract 123456789 and 123A parts from email subject and build csv file name prefix
        
        csvFileNamePrefix = ""
        Set reMatches = re.Execute(oMail.Subject)
        If reMatches.Count = 1 Then
            If reMatches(0).SubMatches.Count = 2 Then
                csvFileNamePrefix = reMatches(0).SubMatches(0) & "_" & reMatches(0).SubMatches(1)
            End If
        End If
        
        If csvFileNamePrefix <> "" Then
        
            n = 0
            
            For Each oAttachment In oMail.Attachments
            
                If LCase(Mid(oAttachment.Filename, InStrRev(oAttachment.Filename, "."))) = ".xlsx" Then
                
                    n = n + 1
                    AttachmentFileName = SaveInFolder & oAttachment.Filename
                    csvFileName = SaveInFolder & csvFileNamePrefix & "_" & n & ".csv"
                    oAttachment.SaveAsFile AttachmentFileName
                    
                    Application.DisplayAlerts = False
                    Application.AskToUpdateLinks = False
                    Workbooks.Open AttachmentFileName
                    ActiveWorkbook.SaveAs Filename:=csvFileName, FileFormat:=xlCSV, CreateBackup:=False
                    ActiveWorkbook.Close False
                    Application.AskToUpdateLinks = True
                    Application.DisplayAlerts = True
                    
                    Kill AttachmentFileName
                
                End If
                
            Next
        
        End If
        
    Next
    
    Application.ScreenUpdating = True

    MsgBox "Finished Extracting Files"
    
End Sub

 

[Holley]

Try this macro:

Option Explicit

Public Sub Extract_Emails_Save_XLSX_Attachments_As_CSV()
   
    Dim FSO As Object 'Scripting.FileSystemObject
    Dim FSfolder As Object 'Scripting.Folder
    Dim FSfile As Object 'Scripting.File
    Dim oApp As Object 'Outlook.Application
    Dim oMail As Object 'Outlook.MailItem
    Dim oAttachment As Object 'Outlook.Attachment
    Dim re As Object 'VBScript_RegExp_55.RegExp
    Dim reMatches As Object 'VBScript_RegExp_55.MatchCollection
    Dim OutlookFilesFolder As String, SaveInFolder As String
    Dim csvFileNamePrefix As String
    Dim AttachmentFileName As String
    Dim csvFileName As String
    Dim n As Long
   
    OutlookFilesFolder = ActiveWorkbook.Path & "\" & csOutlookIn
    SaveInFolder = ActiveWorkbook.Path & "\" & csOutlookOut & "\"
   
    If Right(SaveInFolder, 1) <> "\" Then SaveInFolder = SaveInFolder & "\"
   
    'Regular expression to match numbers followed by 4 alphanumeric characters within parentheses in email subject and capture them
   
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d+)\s*\((\w{4})\)"
   
    Set oApp = CreateObject("Outlook.Application")
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    Set FSfolder = FSO.GetFolder(OutlookFilesFolder)
   
    Application.ScreenUpdating = False
   
    For Each FSfile In FSfolder.Files
       
        Select Case Left(oApp.Version, InStr(oApp.Version, ".") - 1)
            Case Is = 11
                'Open .msg file in Outlook 2003
                Set oMail = oApp.CreateItemFromTemplate(FSfile.Path)
            Case Is >= 12
                'Open .msg file in Outlook 2007+
                Set oMail = oApp.Session.OpenSharedItem(FSfile.Path)
        End Select
       
        'Extract 123456789 and 123A parts from email subject and build csv file name prefix
       
        csvFileNamePrefix = ""
        Set reMatches = re.Execute(oMail.Subject)
        If reMatches.Count = 1 Then
            If reMatches(0).SubMatches.Count = 2 Then
                csvFileNamePrefix = reMatches(0).SubMatches(0) & "_" & reMatches(0).SubMatches(1)
            End If
        End If
       
        If csvFileNamePrefix <> "" Then
       
            n = 0
           
            For Each oAttachment In oMail.Attachments
           
                If LCase(Mid(oAttachment.Filename, InStrRev(oAttachment.Filename, "."))) = ".xlsx" Then
               
                    n = n + 1
                    AttachmentFileName = SaveInFolder & oAttachment.Filename
                    csvFileName = SaveInFolder & csvFileNamePrefix & "_" & n & ".csv"
                    oAttachment.SaveAsFile AttachmentFileName
                   
                    Application.DisplayAlerts = False
                    Application.AskToUpdateLinks = False
                    Workbooks.Open AttachmentFileName
                    ActiveWorkbook.SaveAs Filename:=csvFileName, FileFormat:=xlCSV, CreateBackup:=False
                    ActiveWorkbook.Close False
                    Application.AskToUpdateLinks = True
                    Application.DisplayAlerts = True
                   
                    Kill AttachmentFileName
               
                End If
               
            Next
       
        End If
       
    Next
   
    Application.ScreenUpdating = True

    MsgBox "Finished Extracting Files"
   
End Sub

Just realized I never thanked you for your help! Sorry about that!!!