Outlook Save attachment and rename file with Subject

[aaronz07]

Hi All,

please help with code below as I've scattered it around and found.

What I am trying to do is: select emails with attachment in Outlook and then extract the attached files then rename the files with the subject line.

this is what I have but its not 100% working yet. Sample() extracts the file GetValidName() function checks if the subject line had invalid characters.




Sub Sample()
Dim selectedEmail As Outlook.Attachment
Dim emailsub As String


Dim itm As Outlook.MailItem
Dim currentExplorer As Explorer
Dim Selection As Selection

Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim fso As Object
Dim oldName

Dim file As String
Dim DateFormat As String
Dim newName As String

Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
'saveFolder = enviro & "\Documents\Attachments\"
saveFolder = "C:\Temp"

Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection


Set selectedEmail = ActiveExplorer.Selection.Item(1)

emailsub = GetValidName(objAtt.Subject)

'Debug.Print emailsub

With selectedEmail
.SaveAs "C:\Temp" & emailsub & ".pdf", OlSaveAsType.olMSG
End With
End Sub

Function GetValidName(sSub As String) As String
'~~> File Name cannot have these \ / : * ? " < > |
Dim sTemp As String

sTemp = sSub

sTemp = Replace(sTemp, "\", "")
sTemp = Replace(sTemp, "/", "")
sTemp = Replace(sTemp, ":", "")
sTemp = Replace(sTemp, "*", "")
sTemp = Replace(sTemp, """", "")
sTemp = Replace(sTemp, "<", "")
sTemp = Replace(sTemp, ">", "")
sTemp = Replace(sTemp, "|", "")

GetValidName = sTemp
End Function

[gmayor]

See the thread - http://www.vbaexpress.com/forum/show...-Message-Macro which is very similar to your requirement, and has a more useful naming structure. It also includes code for ensuring duplicated filenames are not overwritten.