I have a very similar requirement and have cobbled together this:
Public Sub SaveAttachmentsToDisk(MItem As Outlook.mailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
Dim jobID As String
Dim Dest As String
Dest = "Y:\!!1-Uplift\DBYD\" ' folder to save all DBYD attachments
Debug.Print "Attachment Count=" & MItem.Attachments.Count
If MItem.Attachments.Count = 0 Then Exit Sub
On Error GoTo extSub
' Get job ID from Email subject (ND0000XXXX)
If InStr(MItem.Subject, "ND") <> 0 Then
jobID = Mid(MItem.Subject, InStr(MItem.Subject, "ND"), 11)
ElseIf InStr(MItem.Subject, "Job No") <> 0 Then ' likely Jemina response
jobID = Mid(MItem.Subject, InStr(MItem.Subject, "Job No "), 16)
jobID = Replace(jobID, ",", "")
Else
jobID = "Unknown"
End If
strFolderExists = Dir(Dest & jobID & "\", vbDirectory) ' check if folder already exists
If strFolderExists = "" Then
MkDir Dest & jobID & "\" ' create job ID folder if it doesn't already exist
End If
fldr = MItem.SenderName ' set folder as senders name (not email address)
If fldr = "" Then fldr = MItem.SenderEmailAddress ' if no sender name, fail over to email address
Debug.Print "fldr=" & fldr
strFolderExists = Dir(Dest & jobID & "\" & fldr & "\", vbDirectory) ' check if responder folder already exists
If strFolderExists = "" Then
MkDir Dest & jobID & "\" & fldr & "\" ' create responder folder if it doesn't already exist
End If
sSaveFolder = Dest & jobID & "\" & fldr & "\" ' set save destination
For Each oAttachment In MItem.Attachments
If oAttachment.DisplayName like "*PDF*" Then ' check if attachment is PDF if so, save to destination sSaveFolder
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
End If
Next
MItem.UnRead = False
Exit Sub
extSub:
msgbox "Something went wrong"
End Sub
This code is triggered by a rule for any emails received from a specific email address.
It can also be triggered manually by highlighting the email(s) in question and running this:
Sub saveAttach()
Dim x, mailItem As Outlook.mailItem
For Each x In Application.ActiveExplorer.Selection
If TypeName(x) = "MailItem" Then
Set mailItem = x
Call SaveAttachmentsToDisk(mailItem)
End If
Next
End Sub
It should be straightforward enough to change the fixed save location to a prompt.
Cheers