MS Word Document Batch Convert

batch_convert.bas

' MS Word Document Batch Convert
' Inspiration: http://windowssecrets.com/forums/showthread.php/70355-Batch-convert-files-from-rtf-to-doc-%28Word-2003%29

Sub BatchConvert()

' Configuration
    Const strSourcePath = "C:\Path\To\Source\Dir\" ' Keep final backslash
    Const strTargetPath = "C:\Path\To\Target\Dir\" ' Keep final backslash
    Const sourceExtension = "docx"
    Const targetFormat = wdFormatDocument97 ' Available file formats: https://msdn.microsoft.com/fr-fr/library/microsoft.office.interop.word.wdsaveformat.aspx
    Const targetExtension = "doc" ' Must match with specified targetFormat
    

' Execution
    Dim strFile As String
    Dim newFileName As String
    Dim doc As Document

    On Error GoTo ErrHandler
    
    strFile = Dir(strSourcePath & "*." & sourceExtension)
    Do While Not strFile = ""
        newFileName = Left(strFile, InStrRev(strFile, ".") - 1) & "." & targetExtension
        Set doc = Documents.Open(FileName:=strSourcePath & strFile, AddToRecentFiles:=False)
        doc.SaveAs FileName:=strTargetPath & newFileName, FileFormat:=targetFormat
        
        
        ' Embed images
        For Each objField In doc.Fields
            If Not objField.LinkFormat Is Nothing Then
                objField.LinkFormat.Update
                objField.LinkFormat.BreakLink
                doc.UndoClear
            End If
        Next
        
        doc.Save
        doc.Close savechanges:=wdDoNotSaveChanges
        strFile = Dir
    Loop


ExitHandler:
    Set doc = Nothing
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler

End Sub

batch_convert_function.bas

' MS Word Document Batch Convert
' Inspiration: http://windowssecrets.com/forums/showthread.php/70355-Batch-convert-files-from-rtf-to-doc-%28Word-2003%29

Function BatchConvert(strSourcePath As String, strTargetPath As String, sourceExtension As String, targetFormat As Integer, targetExtension As String)

' Configuration
'    Const strSourcePath = "C:\Users\Thomas\Desktop\Conversions\doc\" ' Keep final backslash
'    Const strTargetPath = "C:\Users\Thomas\Desktop\Conversions\html\" ' Keep final backslash
'    Const sourceExtension = "docx"
'    Const targetFormat = wdFormatDocument97 ' Available file formats: https://msdn.microsoft.com/fr-fr/library/microsoft.office.interop.word.wdsaveformat.aspx
'    Const targetExtension = "doc" ' Must match with specified targetFormat
    

' Execution
    Dim strFile As String
    Dim newFileName As String
    Dim doc As Document

    On Error GoTo ErrHandler
    
    strFile = Dir(strSourcePath & "*." & sourceExtension)
    Do While Not strFile = ""
        newFileName = Left(strFile, InStrRev(strFile, ".") - 1) & "." & targetExtension
        Set doc = Documents.Open(FileName:=strSourcePath & strFile, AddToRecentFiles:=False)
        doc.SaveAs FileName:=strTargetPath & newFileName, FileFormat:=targetFormat
        
        
        ' Embed images
        For Each objField In doc.Fields
            If Not objField.LinkFormat Is Nothing Then
                objField.LinkFormat.Update
                objField.LinkFormat.BreakLink
                doc.UndoClear
            End If
        Next
        
        doc.Save
        doc.Close savechanges:=wdDoNotSaveChanges
        strFile = Dir
    Loop


ExitHandler:
    Set doc = Nothing
    Exit Function

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler

End Function

Sub ConvertDoc2Html()
    BatchConvert "C:\Users\Thomas\Desktop\Conversions\doc\", "C:\Users\Thomas\Desktop\Conversions\html\", "doc", wdFormatHTML, "html"
End Sub

Sub ConvertHtml2Doc()
    BatchConvert "C:\Users\Thomas\Desktop\Conversions\html\", "C:\Users\Thomas\Desktop\Conversions\doc\", "html", wdFormatDocument97, "doc"
End Sub

Sub ConvertRtf2Doc()
    BatchConvert "C:\Users\Thomas\Desktop\Conversions\rtf\", "C:\Users\Thomas\Desktop\Conversions\doc\", "rtf", wdFormatDocument97, "doc"
End Sub