Convert templates to documents

[timf]

Originally Posted by macropod

You can convert a whole folder of documents with a simple macro:

Sub ConvertFiles()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If InStrRev(strFile, ".docx") = 0 Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _
      AddToRecentFiles:=False, Visible:=False)
    wdDoc.SaveAs2 FileName:=strFolder & "\" & Left(strFile, InStrRev(strFile, ".doc")) & "docx", _
      Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
    wdDoc.Close SaveChanges:=False
  End If
  strFile = Dir()
Wend
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 a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

This code works great but I'm trying to make it a little more precise. I'm trying to allow the user to pick several files from a certain folder, convert them from *.dotx to *.docx, then send them to another folder. The macro runs as far as selecting multiple files then goes straight to ending the sub, skipping over the actual conversion coding. Is what I'm trying to do possible?

Sub ConvertFile()
Application.ScreenUpdating = False
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim strfolder As String, strFile As String
Dim sDocName As String, fnlfolder As String


MsgBox "Select the Destination Folder", vbInformation
fnlfolder = GetFolder

MsgBox "Select the Folder Containing the .dotx Files You Need to Convert", vbInformation
If strfolder = "" Then
    With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
      If .Show = -1 Then
        Set wdDocSrc = ActiveDocument
      Else
        MsgBox "No Source document chosen. Exiting", vbExclamation
        Exit Sub
      End If
    End With
strFile = Dir(strfolder & "\*.dotx", vbNormal)
wdApp.DisplayAlerts = False
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(FileName:=strfolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
    With wdDoc
    sDocName = Left(strFile, Len(strFile) - 5)
    sDocName = sDocName & ".docx"
    wdDoc.SaveAs2 FileName:=fnlfolder & "\" & sDocName, FileFormat:=wdFormatDocumentDefault, AddToRecentFiles:=False
    wdDoc.Close savechanges:=False
    strFile = Dir()
    End With
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
MsgBox ("Operation Complete")
End If
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function