Selecting folder with msoFileDialogFolderPicker

[Indigenous]

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?



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

[gmayor]

msoFileDialogFolderPicker is not supported in Outlook VBA

[skatonni]

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.


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

[gmayor]

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.

[Indigenous]

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?

[skatonni]

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.


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

[Indigenous]

@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.

[gmayor]

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


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

[Indigenous]

@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?

[gmayor]

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


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

[Indigenous]

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:


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

[gmayor]

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


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


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

[Indigenous]

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

[gmayor]

Yes - it works here (Office 2016).

See if https://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-msoffice_custom/8002801d-automation-error-library-not-registered/5717123b-4c0b-4a3d-8bb5-7d0fe84e6ac9?page=2 helps

[Indigenous]

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

[gmayor]

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 (http://www.microsoft.com/en-us/download/details.aspx?id=36852). will uncover the reason why it is not working for you.