Folder Picker for MS Word

Question

Я работаю над функцией экспорта слияния. Я хотел бы добавить диалоговое окно «Выбрать папку».

Я нашел это в своем походе (browse button in input box to find file Excel2007 Vba), но я хочу выбрать папку, а не файл. Имя и тип файла автоматически генерируются через экспорт.

Sub Export_Docs() 
    'Used to set criteria for moving through the document by section. 
    Application.Browser.Target = wdBrowseSection 

    'A mailmerge document ends with a section break next page. 
    'Subtracting one from the section count stop error message. 
    For i = 1 To ((ActiveDocument.Sections.Count) - 1) 

     'Select and copy the section text to the clipboard 
     ActiveDocument.Bookmarks("\Section").Range.Copy 

     'Create a new document to paste text from clipboard. 
     Documents.Add 
     'To save your document with the original formatting' 
     Selection.PasteAndFormat (wdFormatOriginalFormatting) 

     'Removes the break that is copied at the end of the section, if any. 
     Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend 
     Selection.Delete Unit:=wdCharacter, Count:=1 
     'Sets Save Location and Document Name Parameters' 

     ChangeFileOpenDirectory "C:\Users\tveinot\Documents\Asset Management\Buildings\" 
     MyString = ActiveDocument.Tables(1).Cell(6, 3).Range.Text 
     Filename = Left(MyString, 13) 
     DocNum = DocNum + 1 
     ActiveDocument.SaveAs Filename:=Filename & ".doc" 
     ActiveDocument.Close 
     'Move the selection to the next section in the document 
     Application.Browser.Next 
    Next i 
    ActiveDocument.Close savechanges:=wdDoNotSaveChanges 
End Sub 

Answer 1

Первый Google match дал мне this:

Function GetFolder(strPath As String) As String 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
     .Title = "Select a Folder" 
     .AllowMultiSelect = False 
     .InitialFileName = strPath 
     If .Show <> -1 Then GoTo NextCode 
     sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function 

Испытано: отлично работает. В приведенном выше коде вы также можете увидеть, как они устанавливают начальный путь.