Selecting folder with msoFileDialogFolderPicker

This macro saves selected emails into a folder chosen by function "BrowseForFolder".
The problem is that the default start folder is always the same and I have a lot of navigation to do each time I call up the macro.
I want to use "msoFileDialogFolderPicker" such as used in Excel/Word because this is able to remember the last folder chosen.
Is this possible?

Code:

---

Option Explicit

Public Sub Save_Messages_Select_Ask2()

Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String

enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection

If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem

sName = oMail.Subject

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy mm dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, " hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

sPath = BrowseForFolder(enviro & "\Documents\")
Debug.Print sPath & "\" & sName
oMail.SaveAs sPath & "\" & sName, olMSG

End If
Next

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

---

msoFileDialogFolderPicker is not supported in Outlook VBA

I suggest you try to save the last folder somewhere and retrieve it when needed. Maybe a text file, an Outlook item.

If you cannot make that work with BrowseForFolder then you could try the same idea with msoFileDialogFolderPicker.

This demonstrates how you could get msoFileDialogFolderPicker in Outlook. I haven't worked out saving and retrieving the path there is no guarantee it can be done.

Code:

---

Option Explicit

Private Sub msoFileDialogFolderPicker_test()
   
    Dim strPath As String
    Dim fldr As FileDialog
   
    Dim exApp As excel.Application
    On Error Resume Next
    Set exApp = GetObject(, "Excel.Application")
    On Error GoTo 0
   
    If exApp Is Nothing Then
        Set exApp = CreateObject("Excel.Application")
    End If
   
    exApp.Visible = True
   
    ' Read the strPath from where it is stored
    '  somewhere in Outlook, or a text file, or an Excel Workbook, ...
   
    strPath = "" ' the saved path
   
    Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
   
    With fldr
        .title = "Select a Folder"
        .AllowMultiSelect = False
       
        If strPath <> "" Then .InitialFileName = strPath
        If .Show <> -1 Then GoTo ExitRoutine
        strPath = .selectedItems(1)
    End With
   
    If strPath <> "" Then
        Debug.Print strPath
        ' Save strPath somewhere
    End If
   
ExitRoutine:
    Set fldr = Nothing
    Set exApp = Nothing
   
End Sub

---

You can of course use msoFileDialogFolderPicker from another Office application that has it, but it's a sledgehammer to crack a nut and if you don't have an SSD C drive with the applications, it can also be quite slow. You could store the folder in the registry with SaveSetting/GetSetting.

Quote:

---

Originally Posted by skatonni

I suggest you try to save the last folder somewhere and retrieve it when needed. Maybe a text file, an Outlook item.

---

How could I store to a text file if using BrowseForFolder?

In BrowseForFolder, at least in my installation, OpenAt becomes the root folder so navigation is impossible. This demonstrates how to save the folder for msoFileDialogFolderPicker.

Code:

---

Private Sub msoFileDialogFolderPicker_test()
   
    Dim strPath As String
    Dim fldr As FileDialog
   
    Dim savedFldrPath As String
    Dim txtFileName As String
    Dim OpenAt
    Dim nextOpenAt As String
    txtFileName = "C:\test\fldrPathFile.txt"
    Dim exApp As excel.Application

    On Error Resume Next
    Set exApp = GetObject(, "Excel.Application")
    On Error GoTo 0
   
    If exApp Is Nothing Then
        Set exApp = CreateObject("Excel.Application")
    End If
   
    exApp.Visible = True
   
    ' Read the strPath from where it is stored
    '  somewhere in Outlook, or a text file, or an Excel Workbook, ...
   
    readTextFile strPath, txtFileName
   
    Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
   
    With fldr
        .title = "Select a Folder"
        .AllowMultiSelect = False
       
        If strPath <> "" Then .InitialFileName = strPath
        If .Show <> -1 Then GoTo ExitRoutine
        strPath = .SelectedItems(1)
    End With
   
    Debug.Print strPath
    ' Save strPath somewhere
    writeToATextFile strPath, txtFileName
   
ExitRoutine:
    Set fldr = Nothing
    Set exApp = Nothing
   
End Sub


Private Sub writeToATextFile(savedFldrPath, txtFileName)
  Dim objFSO
  Dim objTextFile
 
  Set objFSO = CreateObject("Scripting.FileSystemObject")
 
  ' 8 = append
  'Set objTextFile = objFSO.OpenTextFile(txtFileName, 8, True)
 
  ' 2 = overwrite
  Set objTextFile = objFSO.OpenTextFile(txtFileName, 2, True)
 
  objTextFile.WriteLine (savedFldrPath)
  Debug.Print "New savedFldrPath is " & savedFldrPath
  objTextFile.Close
 
ExitRoutine:
  Set objFSO = Nothing
  Set objTextFile = Nothing
 
End Sub

Private Sub readTextFile(savedFldrPath, txtFileName)
    Open txtFileName For Input As #1
    Do Until EOF(1)
        ' One iteration if overwriting the saved path
        Line Input #1, savedFldrPath
        'Debug.Print "savedFldrPath: " & savedFldrPath
    Loop
   
    Debug.Print "Last savedFldrPath: " & savedFldrPath
    Close #1
End Sub

---

@skattoni
A bit confused.
- Is your Private Sub msoFileDialogFolderPicker_test() in #6 analogous to Function BrowseForFolder in #1? Is it the supposed to be called up from sub in #1? I inserted Call msoFileDialogFolderPicker_test into sub at #1 but get an error message "Method FileDialog of object Application failed".
- Is strPath in #6 equivalent to sPath in #1? I changed this but still have issues.

I also have the text file in C:\test.

If you want to use that method to duplicate the Function BrowseForFolder then the following will replace that function

Code:

---

Option Explicit

Function BrowseForFolder() As String
Dim exApp As Object
Dim strPath As String: strPath = ""
Dim fldr As FileDialog
    On Error Resume Next
    Set exApp = GetObject(, "Excel.Application")
    On Error GoTo 0
    If exApp Is Nothing Then
        Set exApp = CreateObject("Excel.Application")
    End If
    Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo lbl_Exit
        strPath = .SelectedItems(1) & Chr(92)
    End With
lbl_Exit:
    BrowseForFolder = strPath
    exApp.Quit
    Set exApp = Nothing
    Exit Function
End Function

---

@gmayor
Combining suggestion at #8 with #1:
"Run time error -2147319779 (8002801d) Automaton error Library not registered".
I assume "strPath" in #8 is equivalent to "sPath" in #8.
Line sPath = BrowseForFolder(enviro & "\Documents\") in #1 is changed to sPath = BrowseForFolder() otherwise it would not run.
If I press debug the line highlighted in yellow is Set fldr = exApp.FileDialog(msoFileDialogFolderPicker).
Is there a Reference that may be missing?

The version I posted last does not include an initial folder option. If you want that then

Code:

---

Function BrowseForFolder(Optional sFolder As String) As String
    Dim exApp As Object
    Dim strPath As String: strPath = ""
    Dim fldr As FileDialog
    On Error Resume Next
    Set exApp = GetObject(, "Excel.Application")
    On Error GoTo 0
    If exApp Is Nothing Then
        Set exApp = CreateObject("Excel.Application")
    End If
    Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .InitialFileName = sFolder
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo lbl_Exit
        strPath = .SelectedItems(1) & Chr(92)
    End With
lbl_Exit:
    BrowseForFolder = strPath
    exApp.Quit
    Set exApp = Nothing
    Exit Function
End Function

---

Still not working.
Run time error -2147319779 (8002801d) Automaton error Library not registered.
Yellow line at Set fldr = exApp.FileDialog(msoFileDialogFolderPicker).
Issues with opening file dialog via Excel?
My code:

Code:

---

Option Explicit
Public Sub Save_Messages_Select_Ask2()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim strPath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))
    For Each objItem In ActiveExplorer.Selection

        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem

            sName = oMail.Subject

            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyy mm dd", vbUseSystemDayOfWeek, _
            vbUseSystem) & Format(dtDate, " hhnn", _
            vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

            strPath = BrowseForFolder()
            Debug.Print strPath & "\" & sName
            oMail.SaveAs strPath & "\" & sName, olMSG
        End If
    Next
End Sub
Function BrowseForFolder(Optional sFolder As String) As String
    Dim exApp As Object
    Dim strPath As String: strPath = ""
    Dim fldr As FileDialog
    On Error Resume Next
    Set exApp = GetObject(, "Excel.Application")
    On Error GoTo 0
    If exApp Is Nothing Then
        Set exApp = CreateObject("Excel.Application")
    End If
    Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .InitialFileName = sFolder
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo lbl_Exit
        strPath = .SelectedItems(1) & Chr(92)
    End With
lbl_Exit:
    BrowseForFolder = strPath
    exApp.Quit
    Set exApp = Nothing
    Exit Function
End

---

Press CTRL+SHIFT+ESC and make sure there is no unwanted Excel application running from your crashes. Better still reboot and try again.

You don't need the backslashes here as the BrowseforFolder function includes them

Code:

---

strPath = BrowseForFolder()
Debug.Print strPath & "\" & sName
oMail.SaveAs strPath & "\" & sName, olMSG

---

Code:

---

strPath = BrowseForFolder()
If strPath = "" then Exit Sub
Debug.Print strPath & sName
oMail.SaveAs strPath & sName, olMSG

---

The last line of the Function is End Function - not End

No, still the same issue as in #11.
Does it work on your machine?

Yes - it works here (Office 2016).

See if https://answers.microsoft.com/en-us/...84e6ac9?page=2 helps

OK thank-you.
It's still not working on my machine even when deleting the registry folder.
Not much else you can do.
Cheers.

While I said at the outset that I don't like this method, it should still work. See if the Microsoft Office Configuration Analyzer Tool (OffCAT) 2.2. will uncover the reason why it is not working for you.