Save Outlook Emails with Attachment name - vba

Question

I need to copy a whole lot of e-mails to a folder, but instead of saving them using the subject line I want the file name of the saved e-mail to be that of the attachment in the e-mail.
All I currently have is the code to save the e-mail using the subject line:
Sub Sample()
Dim selectedEmail As MailItem
Dim emailsub As String
Set selectedEmail = ActiveExplorer.Selection.Item(1)
attach = GetValidName(selectedEmail.subject)
'Debug.Print emailsub
With selectedEmail
.SaveAs "C:\direcotry\folder\" & attach & ".msg", 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
How can I determine the name of an attachment in the e-mail?

Answer 1

Work with DisplayName Property
Option Explicit
Public Sub SaveAsAttchmentName()
'// Declare variables-
Dim olMail As Outlook.MailItem
Dim olItem As Object
Dim sPath As String
Dim sName As String
Dim olAtt As Outlook.Attachment
For Each olItem In ActiveExplorer.Selection
If olItem.MessageClass = "IPM.Note" Then
Set olMail = olItem
For Each olAtt In olMail.Attachments
'// SaveAs Attachment Name-
sName = olAtt.DisplayName
'// Call Function-
ReplaceCharsForFileName sName, "-"
sName = sName & ".msg"
'// SaveAs Path-
sPath = "C:\temp\"
olMail.SaveAs sPath & sName, olMsg
Next
End If
Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
Best place to start is - Getting Started with VBA in Outlook 2010
Code Tested on Outlook 2010