Solved: Save Email attachments with Email subject as file name

[rhxiong]

Hello,

I get a lot of emails with .xls attachments and they all have the same file name. I want to save these with the subject of the email as the file name as the subject is a better description and has a unique identifier. I know there are codes that save the attachments, but I need to automate it as I had described. Can anyone help:help

[Charlize]

Try this as a warm-up. Select a bunch of e-mails and let the macro do the hard work (saving). You need to specify the directory in the coding where the files need to be saved to. Doc and Xls will be processed. Rest will be ignored.Sub SaveAttachmentsSelectedMails()
Dim myAttachment As Outlook.Attachment
Dim avDate() As String
Dim avTime() As String
Dim vDate As String
Dim i As Long
Dim No_Mails As Long
Dim vSubject As String

Const myPath As String = "C:\Data\Bijlagen\"

ReDim Preserve avDate(3)
ReDim Preserve avTime(2)

i = CountFiles(myPath)

With Outlook.ActiveExplorer.Selection
For No_Mails = 1 To .Count
avDate = Split(CStr(.Item(No_Mails).ReceivedTime), "/")
avTime = Split(CStr(.Item(No_Mails).ReceivedTime), " ")
'constructing date to be yyyy-m(m)-d(d)
'3rd value of array avDate is the year (for me). It could be
'different for you. Check it in vbe with debug.print avDate(0),
'avDate(1) and avDate(2)
vDate = Mid(avDate(2), 1, 4) & "-" & avDate(1) & "-" & avDate(0)
vSubject = StripIllegalChar(.Item(No_Mails).Subject)
If .Item(No_Mails).Attachments.Count <> 0 Then
For Each myAttachment In .Item(No_Mails).Attachments
If UCase(Right(myAttachment, 3)) = "DOC" Or _
UCase(Right(myAttachment, 3)) = "XLS" Then
i = i + 1
myAttachment.SaveAsFile (myPath & Left(i & " - " & vSubject & _
" - " & vDate & " - " & myAttachment.FileName, 256))
End If
Next myAttachment
End If
Next
End With
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "-")
ExitFunction:
Set RegX = Nothing
End Function
Function CountFiles(strPath As String) As Integer
Dim FSO As Object
Dim fldr As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fldr = FSO.GetFolder(strPath)
CountFiles = fldr.Files.Count
Set fldr = Nothing
Set FSO = Nothing
End FunctionCharlize