When you use a VBA macro to save messages or files you can hard code the file path, use the user account's My Documents folder, or select a folder on the hard drive. The first two methods are fairly short and sweet.
Note: this function will work in any Office application, it is not specific to Outlook. (Actually, it's not specific to Office either, it's a general VB function.)
Dim strFolderpath as String strFolderpath = "C:\OLAttachments\"
Or use this to save to a folder using the user's profile in the path (example, C:\Users\Diane\)
Dim enviro As String enviro = CStr(Environ("USERPROFILE")) strFolderpath = enviro & "\OLAttachments\"
For more examples, see Using Windows environment variables in Outlook macros
If you want to bring up a folder picker dialog, you need to use a function, such as the one below.
Add the function to your project and call the folderpath using the following format. You can use any valid file path, either a drive letter or network path (\\). If the path is not valid, the folder picker will show all folders (desktop level), as seen in the screenshot.
strFolderpath = BrowseForFolder("C:\Users\username\documents\")
Use this to save the file:
strFile = strFolderpath & "\" & strFile
(The lines above can be used in Save Attachments to the hard drive)
Function BrowseForFolder(Optional OpenAt As Variant) As Variant Dim ShellApp As Object Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 Set ShellApp = Nothing Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: BrowseForFolder = False End Function
Save attachments macro using BrowseForFolder
This macro uses BrowseForFolder function when saving email attachments on the selected message. When you use this function, you can browse to or create subfolders but cannot "browse up" to a folder above the preselected root.
Public Sub SaveAttachmentstoFolder() Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem 'Object Dim objAttachments As Outlook.Attachments Dim i As Long Dim lngCount As Long Dim StrFile As String Dim strPath As String Dim StrFolderPath As String Dim strDeletedFiles As String Dim sFileType As String On Error Resume Next Set objOL = CreateObject("Outlook.Application") Set objMsg = objOL.ActiveExplorer.Selection.Item(1) ' Get the BrowseForFolder function http://slipstick.me/u1a2d StrFolderPath = BrowseForFolder("D:\My Stuff\Email Attachments\") Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then For i = lngCount To 1 Step -1 StrFile = objAttachments.Item(i).FileName StrFile = StrFolderPath & "\" & StrFile objAttachments.Item(i).SaveAsFile StrFile Next i End If ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub
To make this macro portable when you use a folder under the user's directory, replace StrFolderPath = BrowseForFolder("D:\My Stuff\Email Attachments\") with the following:
Dim StrUserPath as string Dim enviro As String enviro = CStr(Environ("USERPROFILE")) StrUserPath = enviro & "\Documents\Email Attachments\" StrFolderPath = BrowseForFolder(StrUserPath)