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.