To rename outlook mail attachment to sender's email address

[sriramus]

Hi All,

I want to rename my email attachment received to attachment name same
as the sender address.

In more detail: If my email is received from the address say
(e-mail address removed) and the attachment name is skills.doc i want to
extract the attachment and rename it from skill.doc to
(e-mail address removed)

Below is my code to save the attachment with the attached file name.
and i want this attachement to renamed to what ever the variable
strReport contains each time the loop runs.

The below code that works fine:

Sub SendersInFolder()

Dim ns As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Outlook.MailItem
Dim strReport As String
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer

' Get the current Folder
Set ns = GetNamespace("MAPI")
Set Inbox = ActiveExplorer.CurrentFolder
' Check for messages in Folder
If Inbox.Items.Count = 0 Then
strReport = "No Mail Items in current Folder"
Else
For Each Item In Inbox.Items
' Get the Sender's name and Email address
strReport = strReport & Item.SenderName & vbCrLf
MsgBox strReport


i = 0

For Each Atmt In Item.Attachments
FileName = "D:\HR\Email Attachments\" & Atmt.FileName '#1
MsgBox FileName

Atmt.SaveAsFile FileName
'#2
i = i + 1

Next Atmt
Next Item
End If

If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the D:\HR\Email Attachments
folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation,
"Finished!"
Else
MsgBox "I didn't find any attached files in your mail.",
vbInformation, _
"Finished!"
End If

'GetAttachments_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 GetAttachments_exit


GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing

' Clean Up
Set Inbox = Nothing
Set ns = Nothing
Set Item = Nothing
MsgBox "done"
End Sub

I tried modifying the above code in #1 as below line and tried
FileName = "D:\HR\Email Attachments\" & strReport

#2
Atmt.SaveAsFile strReport

I am getting error which says Automation error


Can anyone help me with this please

Thanks in advance

 

[Dave Kane [MVP - Outlook]]

For each item you append the SenderName plus a CRLF to your strReport
variable. So you are trying to save the file with a name that contains or
more CRLF, and keeps growing and growing. That's the first problem. The
second problem is that, no matter how many attachments there are on a
message you are trying to save them all to the same directory using the same
name (you set strReport once for each item, and then use that value for all
the attachments)

This might work better if you create a sub-folder for each sender (or locate
the existing sub-folder since you probably get more than one message from
some senders) and then save the attachments to that folder using the
original filename.