Sub saveHtmlAsDocx()
    Dim d As Document
    Set d = Documents.Open("C:\scratch\test.html")
    
    Dim newfile As String
    newfile = Replace(d, ".html", ".docx")
    d.SaveAs2 newfile, FileFormat:=wdFormatDocumentDefault
End Sub

Sub ConvertHTMLtoDOC()
Dim file
Dim path As String

' Path to your folder. Make SURE you include the terminating "\"
'YOU MUST EDIT THIS.
path = "\\MYPATH"

'Change this file extension to the file you are opening. .htm is listed below.
'YOU MAY NEED TO EDIT THIS.
file = Dir(path & "*.htm*")
Do While file <> ""
Documents.Open FileName:=path & file

' This is the call to the macro you want to run on each file the folder
Call SaveAsDocx

ActiveDocument.Close

' set file to next in Dir
file = Dir()
Loop
End Sub

Sub SaveAsDoc(d As Document)
    Dim newfile As String
    If InStrRev(d.Name, ".html") > 0 Then
        newfile = Replace(d, ".html", ".doc")
    ElseIf InStrRev(d.Name, ".htm") > 0 Then
        newfile = Replace(d, ".htm", ".doc")
    End If
    d.SaveAs2 newfile, FileFormat:=wdFormatDocument97
End Sub
Sub ConvertHTMLtoDOC()
    Dim file
    Dim path As String
    path = "C:\scratch\"
    
    file = Dir(path & "*.htm*")
    Do While file <> ""
        Dim d As Document
        Set d = Documents.Open(file)
        
        Call SaveAsDoc(d)
        d.Close
        file = Dir()
    Loop
End Sub

Debug.Print path & "\" & file

Sub ConvertHTMLtoDOC()
Dim strFile As String
Dim strPath As String
Dim strDocName As String
Dim oDoc As Document
    strPath = "C:\scratch\"
    strFile = Dir(strPath & "*.htm*")
    Do While strFile <> ""
        Set oDoc = Documents.Open(strPath & strFile) 'This line needs to include the path
        strDocName = Left(oDoc.FullName, InStrRev(oDoc.FullName, ".") - 1) & ".docx"
        oDoc.SaveAs2 FileName:=strDocName, FileFormat:=wdFormatDocumentDefault
        oDoc.Close
        strFile = Dir()
    Loop
    Set oDoc = Nothing
End Sub

Sub ConvertHTMLtoDOC()
'Graham Mayor - https://www.gmayor.com - Last updated - 28 Sep 2019
Dim strFile As String
Dim strPath As String
Dim strDocName As String
Dim oDoc As Document
Dim oColl As Collection
Dim arr() As Variant
Dim i As Integer
    Set oColl = New Collection
    strPath = "C:\path\"
    strFile = Dir(strPath & "*.htm*")
    Do While strFile <> ""
        oColl.Add strPath & strFile
        strFile = Dir()
    Loop
    arr = toArray(oColl)
    For i = LBound(arr) To UBound(arr)
        Set oDoc = Documents.Open(arr(i))
        strDocName = Left(oDoc.FullName, InStrRev(oDoc.FullName, ".") - 1) & ".docx"
        oDoc.SaveAs2 FileName:=strDocName, FileFormat:=wdFormatDocumentDefault
        oDoc.Close
    Next i
    Set oDoc = Nothing
End Sub

Private Function toArray(ByVal Coll As Collection) As Variant
Dim arr() As Variant
Dim i As Long
    ReDim arr(1 To Coll.Count) As Variant
    For i = 1 To Coll.Count
        arr(i) = Coll(i)
    Next
    toArray = arr
    QuickSort arr
lbl_Exit:
    Exit Function
End Function

Private Sub QuickSort(vArray As Variant, _
                      Optional lng_Low As Long, _
                      Optional lng_High As Long)
Dim vPivot As Variant
Dim vTmp_Swap As Variant
Dim tmp_Low As Long
Dim tmp_High As Long

    If lng_High = 0 Then
        lng_Low = LBound(vArray)
        lng_High = UBound(vArray)
    End If

    tmp_Low = lng_Low
    tmp_High = lng_High
    vPivot = vArray((lng_Low + lng_High) \ 2)
    While (tmp_Low <= tmp_High)
        While (vArray(tmp_Low) < vPivot And tmp_Low < lng_High)
            tmp_Low = tmp_Low + 1
        Wend
        While (vPivot < vArray(tmp_High) And tmp_High > lng_Low)
            tmp_High = tmp_High - 1
        Wend
        If (tmp_Low <= tmp_High) Then
            vTmp_Swap = vArray(tmp_Low)
            vArray(tmp_Low) = vArray(tmp_High)
            vArray(tmp_High) = vTmp_Swap
            tmp_Low = tmp_Low + 1
            tmp_High = tmp_High - 1
        End If
    Wend
    If (lng_Low < tmp_High) Then QuickSort vArray, lng_Low, tmp_High
    If (tmp_Low < lng_High) Then QuickSort vArray, tmp_Low, lng_High
lbl_Exit:
    Exit Sub
End Sub