求助如何用word的VBA将HTML或mht文件批量转换为word？

PurpleIdea

求助如何用word的VBA将HTML或mht文件批量转换为word？希望大神们能给到代码，谢谢！
备注：之前用2003的excel转换过，转换后的文件格式排版都乱了。

PurpleIdea

没人回复，只能捣鼓代码了。

1. Sub HtmlToWord()
   
2.     On Error Resume Next
   
3.     Dim webdoc As Document
   
4.     Dim Fp$, Fn$, Fm$, Mf As Object
   
5.    
   
6.     Fp = ActiveDocument.Path & ""
   
7.     Fn = Dir(Fp & "*.html")
   
8.     MkDir Fp & "已转换"
   
9.     MkDir Fp & "原始文件"
   
10.     Set Mf = CreateObject("scripting.filesystemobject")
    
11.     Application.DisplayAlerts = False
    
12. 
    
13.     Do While Fp & Fn <> Fp & ""
    
14.    
    
15.        Fm = Left(Fn, Len(Fn) - 4) & "docx"
    
16.       
    
17.        Set webdoc = Documents.Open(FileName:=Fp & Fn, Visible:=1)
    
18. 
    
19.        Documents.Open FileName:=Fp & Fn, _
    
20.        ConfirmConversions:=False, _
    
21.        ReadOnly:=False, _
    
22.        AddToRecentFiles:=False, _
    
23.        PasswordDocument:="", _
    
24.        PasswordTemplate:="", _
    
25.        Revert:=False, _
    
26.        WritePasswordDocument:="", _
    
27.        WritePasswordTemplate:="", _
    
28.        Format:=wdOpenFormatAuto, _
    
29.        XMLTransform:=""
    
30.       
    
31.        ActiveDocument.SaveAs2 FileName:=Fp & Fm, _
    
32.        FileFormat:=wdFormatXMLDocument, _
    
33.        LockComments:=False, _
    
34.        Password:="", _
    
35.        AddToRecentFiles:=True, _
    
36.        WritePassword:="", _
    
37.        ReadOnlyRecommended:=False, _
    
38.        EmbedTrueTypeFonts:=False, _
    
39.        SaveNativePictureFormat:=False, _
    
40.        SaveFormsData:=False, _
    
41.        SaveAsAOCELetter:=False, _
    
42.        CompatibilityMode:=15
    
43.       
    
44.        ActiveWindow.Close
    
45.       
    
46.        Mf.Movefile Fp & Fn, Fp & "原始文件" & Fn
    
47.        Mf.Movefile Fp & Fm, Fp & "已转换" & Fm
    
48.       
    
49.        Fn = Dir
    
50.    
    
51.     Loop
    
52.    
    
53.     Application.DisplayAlerts = True
    
54.    
    
55.     Application.Quit
    
56. 
    
57. End Sub

复制代码