Save the currently opened Outlook Message to a folder

[sspatriots]

I'm trying to use the code below to save an open Outlook message to a folder on our network. Right now, I've set it to my local drive. Anyway, it stops when it gets to the line in bold text below:

Sub SaveMessageAsMsg()
Dim olItem As Outlook.MailItem
Dim fName As String
Dim fPath As String
fPath = "C:\Documents\Outlook Work Help\"
For Each olItem In ActiveExplorer.Selection
fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & _
olItem.SenderName & " - " & olItem.Subject & ".msg"
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), "-")
olItem.SaveAs fPath & fName
Next olItem
Set olItem = Nothing
End Sub


Why would it hang up at that point in the code? I just want it to take the e-mail I'm looking at open a dialogue box where I can drill down into a few layers of network folders and save the e-mail there.

 

[sspatriots]

I've found a solution that does exactly what I needed. So sharing here:

Public Sub SaveMessageAsMsg()
'Update by Extendoffice 2018/3/5

Dim xMail As Outlook.MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xDtDate As Date
Dim xName, xFileName As String
On Error Resume Next
Set xShell = CreateObject("Shell.Application")

Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, "C:\Documents\")

If Not TypeName(xFolder) = "Nothing" Then
Set xFolderItem = xFolder.Self
xFileName = xFolderItem.Path & "\"

Else
xFileName = ""
Exit Sub
End If
For Each xObjItem In Outlook.ActiveExplorer.Selection
If xObjItem.Class = olMail Then
Set xMail = xObjItem
xName = xMail.Subject
xDtDate = xMail.ReceivedTime
xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(xDtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & xName & ".msg"
xPath = xFileName + xName
xMail.SaveAs xPath, olMSG
End If
Next
End Sub