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