Problem with Application.FileDialog(msoFileDialogFolderPicker) in Outlook

[Hermac]

Hi!,

I use this code (within my Outlook) to drop my e-mails in a folder “MAILTRANSIT”. It works fine, but I’d like to expand it with some additional features.
For the moment, MAILTRANSIT has 2 subfolders to which BrowserForFolder leads me automatically to make my pick for the drop. But I’d like to have it work more flexible like the Application.FileDialog(msoFileDialogFolderPicker) which I’m familiar with in Excel but his seems not to work within Outlook.
It would also be handy if , when the need arises, a new subfolder could be created while browsing, and entering a name by means of e.g. an InputBox.
I’ve written quite a lot of code in Excel but in Outlook, this is a long shot for me. Can anyone help me to get this thing on track? I’ll be very grateful.

Herman Van Noten

Public Sub SaveIncMesAsMsg()
Dim oMail As Outlook.MailItem, objItem As Object, sPath As String, dtDate As Date, sSubj As String, sSendr As String, sRecip As String, enviro As String, strFolderpath As String

enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder(enviro & "\documents\MAILTRANSIT")

For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
     Set oMail = objItem
     sSubj = oMail.Subject: sSendr = oMail.SenderName: sRecip = oMail.To
    ReplacementsInSubj sSubj, "-": ReplacementsInSendr sSendr, "HVN": ReplacementsInRecip sRecip, "HVN"
    dtDate = oMail.ReceivedTime
    sSubj = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dtDate, "-hhnnss", _ vbUseSystemDayOfWeek, vbUseSystem) & "-" & sSendr & " TO " & sRecip & " " & sSubj & " Atms" &                   oMail.Attachments.Count & ".msg"
    sPath = strFolderpath & "\"
    Debug.Print sPath & sSubj
    oMail.SaveAs sPath & sSubj, olMSG
End If
Next
End Sub

Private Sub ReplacementsInSubj(sSubj As String, sChr As String)
sSubj = Replace(sSubj, "'", sChr) : sSubj = Replace(sSubj, "*", sChr) : sSubj = Replace(sSubj, "/", sChr): sSubj = Replace(sSubj, "\", sChr): sSubj = Replace(sSubj, ":", sChr)
sSubj = Replace(sSubj, "?", sChr) : sSubj = Replace(sSubj, Chr(34), sChr) : sSubj = Replace(sSubj, "<", sChr) : sSubj = Replace(sSubj, ">", sChr) : sSubj = Replace(sSubj, "|", sChr)
End Sub

Private Sub ReplacementsInSendr(sSendr As String, sChr As String)
sSendr = Replace(sSendr, "Herman Van Noten [MAWS]", sChr) : sSendr = Replace(sSendr, "Herman Van Noten", sChr) : sSendr = Replace(sSendr, "[EMAIL]herman@maws.be[/EMAIL]", sChr)
sSendr = Replace(sSendr, "[EMAIL]herman@telenet.be[/EMAIL]", sChr) : sSendr = Replace(sSendr, "[EMAIL]herman@hvn.be[/EMAIL]:", sChr) : sSendr = Replace(sSendr, "HermanOutlook", sChr)
sSendr = Replace(sSendr, "MAWS [mailto:[EMAIL]info@maws.be[/EMAIL]]", sChr) : sSendr = Replace(sSendr, "MawsInfo <[EMAIL]info@maws.be[/EMAIL]>", sChr) : sSendr = Replace(sSendr, "herman", sChr)
sSendr = Replace(sSendr, "/", sChr)
End Sub

Private Sub ReplacementsInRecip(sRecip As String, sChr As String)
sRecip = Replace(sRecip, "Herman Van Noten [MAWS]", sChr) : sRecip = Replace(sRecip, "Herman Van Noten", sChr) : sRecip = Replace(sRecip, "[EMAIL]herman@maws.be[/EMAIL]", sChr)
sRecip = Replace(sRecip, "[EMAIL]herman@telenet.be[/EMAIL]", sChr) : sRecip = Replace(sRecip, "[EMAIL]herman@hvn.be[/EMAIL]:", sChr) : sRecip = Replace(sRecip, "HermanOutlook", sChr)
sRecip = Replace(sRecip, "MAWS [mailto:[EMAIL]info@maws.be[/EMAIL]]", sChr) : sRecip = Replace(sRecip, "MawsInfo <[EMAIL]info@maws.be[/EMAIL]>", sChr) : sRecip = Replace(sRecip, "herman", sChr)
End Sub

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

 

[Anthony47]

You might set a reference to the "Microsoft Excel XX.Y Object Library", via Menu /Tools /Reference, and then you will be able to use, for example:

With Excel.Application.FileDialog(msoFileDialogFolderPicker)
   .Show
    If .SelectedItems.Count = 0 Then
        MsgBox ("Nothing selecte, process is aborted")
        Exit Sub
    End If
    myPath = .SelectedItems.Item(1)             'myPath will contain the selected path
End With

 

[Hermac]

Got it! I can take it from here. Thank you veeeeery much Anthony! You made my day.
Herman