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!
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.