Save Outlook .csv attachment as .xlsx in network folder

[xraytech81]

Every month I receive volume statistics for the previous month in several emails. The subject is always "Proc Stats by Proc Begin Date and Cost Ctr XXXXXX" where XXXXXX is a variable 6 digit number. Each email contains a single .xls attachment. I need to save the .xls attachment from each of those emails in a network location that changes based on the month that is reported in the file (effectively 'Month of received date - 1 month'). The preexisting folders are named 01 January, 02 February, 03 March, etc. The remainder of the path name is constant. The name of the file needs to be the last 6 characters of the email subject and must be saved in .xlsx format. Any help is greatly appreciated. Thanks.

[xraytech81]

Sorry, my subject should read "Save Outlook .xls attachment as .xlsx in network folder"

[gmayor]

I could have sworn I just replied to this, but I cannot find my reply :(

The process is easy enough, but in order to save as xlsx the file must be saved to the hard drive and opened in Excel. This can be done from a rule and a script as the messages arrive, but can you first clarify where the date comes from, that determines where the workbook is saved?

What is the attachment name?

Is there only one attachment per message?

As current and recent versions of Excel can open xls format, why is this even necessary?

[gmayor]

Forget my last, I think the following will do what you ask, with the possible proviso that the Month is not what you intended and you will need to change the value of strRootPath as appropriate. The macro will create the folders if missing. Run the SaveAsExcel macro as a script from a rule that identifies the incoming messages. You can process selected individual messages from your inbox with the ProcessAttachment macro.

The macro uses a few standard functions from my web site and will not overwrite existing files of the same name (process the same message twice and you will see what I mean)


Option Explicit

Sub ProcessAttachment()
'An Outlook macro by Graham Mayor
'www.gmayor.com
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAsExcel olMsg
lbl_Exit:
Exit Sub
End Sub

Sub SaveAsExcel(olItem As Outlook.MailItem)
'An Outlook macro by Graham Mayor
'www.gmayor.com
Dim olAtt As Attachment
Dim strExt As String
Dim strNewExt As String
Dim xlApp As Object
Dim xlWB As Object
Dim strName As String
Dim strAttName As String
Dim strPath As String
Dim strTempPath As String
Dim bAtt As Boolean
Dim bStarted As Boolean
Dim strSubject As String
Const strRootPath As String = "C:\Path\Forum\"
strExt = ".xls"
strNewExt = ".xlsx"
strTempPath = Environ("Temp") & Chr(92)

With olItem
strSubject = .Subject
If Not strSubject Like "Proc Stats by Proc Begin Date and Cost Ctr *" Then
GoTo lbl_Exit
Else
strSubject = Right(strSubject, 6) & ".xlsx"
End If
For Each olAtt In .Attachments
If Right(olAtt.FileName, 3) = "xls" Then
strName = olAtt.FileName
strAttName = strTempPath & strName
olAtt.SaveAsFile strAttName
bAtt = True
Exit For
End If
Next olAtt
If Not bAtt Then GoTo lbl_Exit

strPath = strRootPath & "01 " & Format(.SentOn, "MMMM")
CreateFolders strPath
End With

On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err Then
Err.Clear
Set xlApp = CreateObject("Excel.Application")
bStarted = True
End If
On Error GoTo 0
xlApp.Visible = True

Set xlWB = xlApp.Workbooks.Open(FileName:=strAttName, AddToMru:=False)
strName = Replace(strName, strExt, strNewExt)
xlApp.DisplayAlerts = False
strSubject = FileNameUnique(strPath, strSubject, "xlsx")
xlWB.SaveAs FileName:=strPath & strSubject, FileFormat:=51, AddToMru:=False
xlWB.Close
xlApp.DisplayAlerts = True
Kill strAttName
If bStarted Then xlApp.Quit
lbl_Exit:
strExt = vbNullString
strNewExt = vbNullString
Set xlApp = Nothing
Set xlWB = Nothing
strName = vbNullString
strPath = vbNullString
Set olAtt = Nothing
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
'www.gmayor.com
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
'www.gmayor.com
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
'www.gmayor.com
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
'www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

[xraytech81]

gmayor,
Again thank you for your help. To answer your questions:

The date should come from the date the email is received. The emails are always sent on the 2nd day of the month. The path that they will need to save to will always be the previous month. For example: I receive the emails on 3/2/2016. The path for the attachments should be "C:\Path\Forum\02 February"

The attachment name is a random system generated name, nothing uniform or constant.

There is only 1 attachment per email.

The necessity is that I have a separate workbook that runs a sumproduct on all of these workbooks. The sumproduct only works on closed network files if they are in .xlsx format.

Looking through your code I seem to be following everything for the most part. The only question I have is on the


strPath = strRootPath & "01 " & Format(.SentOn, "MMMM")

This appears to always name the path with a preceding "01 " and uses the current month versus the previous. The preceding "01 " needs to change relative to the month of the year. I could be misinterpreting. Thanks again for your assistance.

[gmayor]

As I said I was unsure about the month part and I set the line you queried to save the files in a folder dated the 1st of the month the messages were sent.
If you want the 2nd of the previous month then you could use

MonthName(Month(.SentOn) - 1)
Thus

strPath = strRootPath & "02 " & MonthName(Month(.SentOn) - 1)
If you want "02" to reflect the date the messages were sent then

strPath = strRootPath & Format(.SentOn, "DD ") & MonthName(Month(.SentOn) - 1)

[xraytech81]

gmayor,
This appears to be exactly what I need. I modified your code slightly to


strPath = strRootPath & Format(.SentOn - 5, "MM ") & MonthName(Month(.SentOn) - 1)

This works assuming my emails always come no later than the 5th of every month. Thank you again for your help.

[gmayor]

I am not convinced your modification provides the result you want. What EXACTLY is the number e.g. 01 January, 02 February, 03 March, etc supposed to represent?