How to Save Outlook Message useing `OpenFileDialog` to select a folder - vba

Question

I am using the below Code to Save email in specific folder.
By Default it should save in Specific folder however sometimes if i want to save in other folders I need to type the location manually.
How do I use OpenFileDialog to select a folder.
Option Explicit
Sub SaveMessage()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
If Not TypeName(olMsg) = "MailItem" Then
MsgBox "Select a mail item!"
GoTo lbl_Exit
End If
SaveItem olMsg
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub
Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim fPath As String
Dim JVvalue As Variant
fPath = "C:\GUIC\JV Approval Backup"
CreateFolders fPath
If olItem.Sender Like "*#gmayor.com" & olItem.Subject Like "*RE" Then 'Your domain
fname = JVvalue & " " & Chr(32) & olItem.SenderName & " " & Format(olItem.SentOn, "mmmm" & " " & "YYYY-MM-DD") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & " " & " " & Chr(32) & olItem.Subject
Else
fname = JVvalue & " " & Chr(32) & olItem.SenderName & " " & Format(olItem.ReceivedTime, "mmmm" & " " & "YYYY-MM-DD") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & " " & " " & Chr(32) & olItem.Subject
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, fPath, fname
lbl_Exit:
Exit Sub
End Sub**
Private Function CreateFolders(strPath As String)
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function FolderExists(fldr As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Answer 1

Work with Shell.Application MSDN to browse for local folder
Try the following Example
Option Explicit
Dim fPath As String
Sub SaveMessage()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
If Not TypeName(olMsg) = "MailItem" Then
MsgBox "Select a mail item!"
GoTo lbl_Exit
End If
SaveItem olMsg
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub
Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim JVvalue As Variant
Dim Result As Integer
Result = MsgBox("Save it to default folder?", vbQuestion + vbYesNo)
If Result = vbYes Then
fPath = "C:\GUIC\JV Approval Backup"
CreateFolders fPath
Else
BrowseForFolder fPath
End If
If olItem.Sender Like "*gmayor.com" & olItem.Subject Like "*RE" Then
fname = JVvalue & " " & Chr(32) & _
olItem.SenderName & " " & _
Format(olItem.SentOn, "mmmm" & " " _
& "YYYY-MM-DD") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & " " & _
" " & Chr(32) & olItem.Subject
Else
fname = JVvalue & " " & Chr(32) & olItem.SenderName & _
" " & Format(olItem.ReceivedTime, "mmmm" & _
" " & "YYYY-MM-DD") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & " " & _
" " & Chr(32) & olItem.Subject
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, fPath, fname
lbl_Exit:
Exit Sub
End Sub
Private Function CreateFolders(strPath As String)
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
Debug.Print strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function FolderExists(fldr As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function
Function BrowseForFolder(fPath As String, _
Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder ' As Folder
Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", _
0, enviro & "C:\Temp\Folders")
fPath = objFolder.self.Path
fPath = fPath & "\"
Debug.Print fPath
On Error Resume Next
On Error GoTo 0
ExitFunction:
Set objShell = Nothing
End Function