Try:
Code:
Sub ExportDocs()
Application.ScreenUpdating = False
Dim strFolder As String, wdDoc As Document, i As Long
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
.Title = "Select the source document containing the Find/Replace Table"
.AllowMultiSelect = True
If .Show = -1 Then
strFolder = GetFolder
If strFolder = "" Then
MsgBox "No output folder selected. Exiting", vbCritical
Exit Sub
End If
For i = 1 To .SelectedItems.Count
Set wdDoc = Documents.Add(.SelectedItems(i))
With wdDoc
.SaveAs2 FileName:=strFolder & "\" & Split(.AttachedTemplate.Name, ".dot")(0) & ".docx", _
Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close False
End With
Next
Else
MsgBox "No source file selected. Exiting", vbExclamation
Exit Sub
End If
End With
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose an output folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function