Save and Rename Attachment

[ebrown00]

Hello,

Using VBA in Outlook, I am trying to save attachments from a handful of daily emails and rename the files using the SAME name each day, essentially replacing the set of files each day. I have the code to save the attachments, but I'm stumped when it comes to renaming the files. The email subject lines and the files have the date in them, and I would like to save the files without the date (Example, if the email subject line reads "Weekly Dashboard 3/25/12 - 3/31/12", the file is "Weekly Dashboard 3/25/12 - 3/31/12.xlsx". I need the file to be renamed "Weekly Dashboard.xlsx".

Here is the code I have so far (I also attached it for easier viewing). Can someone help me out?

Sub GetAttachments()
On Error GoTo SaveAttachmentsToFolder_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Reports")
Dim objAtt As Outlook.Attachment
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Reports folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 4) = "xlsx" Then
FileName = "\\AD\MyND_RO\Profile\HomeDrive\LDP DSS\TV DISPLAY\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into \\AD\MyND_RO\Profile\HomeDrive\LDP DSS\TV DISPLAY." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
If varResponse = vbYes Then
Shell "Explorer.exe /e,\\AD\MyND_RO\Profile\HomeDrive\LDP DSS\TV DISPLAY\", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub

[Crocus Crow]

Replace:
FileName = "\\AD\MyND_RO\Profile\HomeDrive\LDP DSS\TV DISPLAY\" & Atmt.FileName
with:
Dim p As Integer
p = InStr(Atmt.fileName, "/")
p = InStrRev(Atmt.fileName, " ", p)
fileName = "\\AD\MyND_RO\Profile\HomeDrive\LDP (file://\\AD\MyND_RO\Profile\HomeDrive\LDP) DSS\TV DISPLAY\" & Left(Atmt.fileName, p - 1) & ".xlsx"

[ebrown00]

I replaced the code and got this error message:

"An unexpected error has occurred.
Please note and report the following information.
Macro Name: GetAttachments
Error Number: 5
Error Description: Invalid procedure call or argument"

Is this because some of the files have a date and some do not?

[Crocus Crow]

Is this because some of the files have a date and some do not?Yes, probably, though it's difficult to know for certain without seeing the actual file name with which it fails.

Try this instead (entirely replaces my previous code):
Dim p As Integer
fileName = Atmt.fileName
p = InStr(fileName, "/")
If p > 0 Then
p = InStrRev(fileName, " ", p)
If p > 0 Then
fileName = Left(fileName, p - 1) & ".xlsx"
End If
End If
fileName = "\\AD\MyND_RO\Profile\HomeDrive\LDP (file://\\AD\MyND_RO\Profile\HomeDrive\LDP) DSS\TV DISPLAY\" & fileName
The code is just a simple string parser based on your described file name format - look at the functions used in the VB help to understand how it works.

If it still doesn't work, set a breakpoint on a suitable line and debug it in the VB editor.

[ebrown00]

Thanks for the help! It didn't quite work, so I'll try to debug it.