Файлы mht сохранить как docx

Sub CopyFromMhtAndSaveSelectionAsDocx()
' сохраняет как Word-документ выделеный в открытом .mht-файле блок (включая рисунки), 
' папка сохранения и название те же что у MHT файла
 
docpath = ActiveDocument.Path ' путь MHT файла
docname = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 3)' название MHT файла без расширения (точка остаётся)
 
Selection.Copy ' копируем нужное из MHT файла
ActiveWindow.Close ' закрываем  MHT файл, так как Word не допускает сохранение с названием открытого файла (у меня так)
 
Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0 ' создаём новый Word-документ
Selection.PasteAndFormat (wdPasteDefault) ' вставка скопированного в новый документ
 
ChangeFileOpenDirectory docpath ' задаём путь для сохранения
' сохраняем с именем docname и прибавлением расширения "docx":
ActiveDocument.SaveAs FileName:=docname & "docx", FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
    
ActiveWindow.Close ' закрываем  "docx" файл
   
End Sub

Private Sub SaveHTMLtoDoc()
    Dim iCount%, objDoc As Word.Document
    For iCount = Documents.Count To 1 Step -1
        Set objDoc = Documents(iCount)
        If LCase(objDoc.Name) Like "*.mht" Then
           objDoc.SaveAs Replace(objDoc.FullName, ".mht", ".docx")
           objDoc.Close 'False
        End If
    Next
End Sub

Sub SaveAllOpenedMhtAsDocx()
 
For i = Documents.Count To 1 Step -1
 docpath = ActiveDocument.Path
 docname = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 3) & "docx"
 
 ChangeFileOpenDirectory docpath
 ActiveDocument.SaveAs FileName:=docname, FileFormat:= _
 wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
 :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
 :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
 SaveAsAOCELetter:=False
 ActiveWindow.Close
Next
 
End Sub

Private Sub SaveHTMLtoDoc()
    Dim iCount%, objDoc As Word.Document
    For iCount = Documents.Count To 1 Step -1
        Set objDoc = Documents(iCount)
        If LCase(objDoc.Name) Like "*.mht" Then
           objDoc.SaveAs Replace(objDoc.FullName, ".mht", ".docx"), wdFormatXMLDocument
           objDoc.Close 'False
        End If
    Next
End Sub

Sub SaveAllOpenedMhtAsDocx2()
 For i = Documents.Count To 1 Step -1
      docname = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 3) & "docx"
      ActiveDocument.SaveAs docname, wdFormatXMLDocument
      ActiveWindow.Close
 Next
End Sub

Sub SaveAllOpenedMhtAsDocx()
For i = Documents.Count To 1 Step -1
    docpath = ActiveDocument.Path ' путь MHT файла
    docname = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 3) & "docx"
    ChangeFileOpenDirectory docpath
    ActiveDocument.SaveAs docname, wdFormatXMLDocument
    ActiveWindow.Close
Next i
End Sub