word批量转换成html

去年项目中需要chm格式的用户手册，下载了个chm生成器Easychm试用了一下，OK，好用，可惜不是免费的，生成的chm标题不能改！不过还是很感谢那些开发出此工具的人们啊。

制作chm，首先得将一个个word文档拆分，然后将其转换成html格式，该项目的用户手册word版就有800多页呢，拆成小word后，，一个个手动转换成html么。百度了一下如何批量转换，没找到合适的方法（搜索方式有问题么）。于是向同学求助，同学用word录制了一个宏，可将某个文件下所有的word（不支持嵌套文件夹啊）批量转换为html，给力啊，此处分享给大家（宏的内容如下表所示），如何有更好的方法，希望大家也能共享啊（平时编写用户手册甚多，希望有更好的方法优化工作）。

Wordtohtml宏

Sub WH_WORD2HTML() ' ' WH_WORD2HTML 宏 ' '        Dim strFolder As String        Dim varFileList As Variant        Dim FSO As Object, myFile As Object        Dim myResults As Variant        Dim l As Long                '显示打开文件夹对话框        With Application.FileDialog(msoFileDialogFolderPicker)        .Show        If .SelectedItems.Count = 0 Then Exit Sub '未选择文件夹        strFolder = .SelectedItems(1)        End With                 '获取文件夹中的所有文件列表        varFileList = fcnGetFileList(strFolder)                If Not IsArray(varFileList) Then        MsgBox "未找到文件", vbInformation        Exit Sub        End If                '获取文件的详细信息，并放到数组中        ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)                                myResults(0, 0) = "文件名"        myResults(0, 1) = "大小（字节）"        myResults(0, 2) = "创建时间"        myResults(0, 3) = "修改时间"        myResults(0, 4) = "访问时间"         myResults(0, 5) = "完整路径"               Set FSO = CreateObject("Scripting.FileSystemObject")          For l = 0 To UBound(varFileList)        Set myFile = FSO.GetFile(strFolder + "/" +CStr(varFileList(l)))        myResults(l + 1, 0) = CStr(varFileList(l))        myResults(l + 1, 1) = myFile.Size        myResults(l + 1, 2) = myFile.DateCreated        myResults(l + 1, 3) = myFile.DateLastModified        myResults(l + 1, 4) = myFile.DateLastAccessed        myResults(l + 1, 5) = myFile.Path         path0 = myFile.Path        path0 = StrReverse(path0)        path1 = Split(path0, "\")        path0 = Replace(path0, path1(0), "")        path0 = StrReverse(path0)          tofilename = Replace(CStr(varFileList(l)), "docx","html") '目标文件名        ChangeFileOpenDirectory path0        Documents.Open FileName:=CStr(varFileList(l)),ConfirmConversions:=False, ReadOnly:= _            False, AddToRecentFiles:=False, PasswordDocument:="",PasswordTemplate:= _            "", Revert:=False, WritePasswordDocument:="",WritePasswordTemplate:="", _            Format:=wdOpenFormatAuto, XMLTransform:=""        ActiveDocument.SaveAs FileName:=tofilename, FileFormat:=wdFormatHTML, _            LockComments:=False, Password:="", AddToRecentFiles:=True,WritePassword _            :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _            SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=_            False        ActiveWindow.View.Type = wdWebView        ActiveWindow.Close            Next l                Set myFile = Nothing        '置空文件        Set FSO = Nothing        '置空FSO   End Sub   Private Function fcnGetFileList(ByVal strPath As String, OptionalstrFilter As String) As Variant        ' 如果文件夹中包含文件返回一个二维数组，否则返回False          Dim f As String        Dim i As Integer        Dim FileList() As String                If strFilter = "" Then strFilter = "*.*"                Select Case Right$(strPath, 1)        Case "/", "/"        strPath = Left$(strPath, Len(strPath) - 1)        End Select                ReDim Preserve FileList(0)                f = Dir$(strPath & "/" & strFilter)        Do While Len(f) > 0        ReDim Preserve FileList(i) As String        FileList(i) = f        i = i + 1        f = Dir$()        Loop                If FileList(0) <> Empty Then        fcnGetFileList = FileList        Else        fcnGetFileList = False        End If        End Function