word文档批量转换为html格式-蒲公英云

有时需要将doc/docx格式的文档批量转换为html格式的网页文件，可以使用以下VBA脚本执行批量转换的操作，需要在安装了宏功能的Word中执行。

以下脚本会搜索指定目录中的doc文档，并逐个进行处理，执行以下操作：

将doc文档的标题属性修改为文件名，以使生成的网页文件显示的标题为文件名；
对图片大小进行统一按比例缩放，防止图片过大影响展示；

将生成的html文件保存在指定的目录中。

Private Declare Function GetTickCount Lib “kernel32” () As Long

‘’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’
Private num_file As Integer
Private FileType_htm As String
Private FileType_doc As String
Private path_src_start As String ‘记录源路径
Private path_des_start As String ‘记录目标路径
Private LogFile As String ‘日志文件路径

Private Sub CommandButton1_Click()

'从指定目录开始处理，下面的路径最后不带“\”
path_src_start = "D:\word" '保存.doc文件的目录
path_des_start = path_src_start '保存需要生成.htm文件的目录
'开始执行
start

End Sub

Sub start()

num_file = 0
FileType_htm = ".htm"
FileType_doc = ".doc"
Dim time_start, time_end, second_spend, minute_spend, minute_tail As Long
MsgBox ("需要处理的目录路径：" & path_src_start & vbCrLf _
    & "保存处理结果的目录路径：" & path_des_start) 'vbCrLf为回车换行
'记录开始时间
time_start = GetTickCount()
'开始搜索
LogFile = Chr(34) & path_des_start & "\转换记录.txt" & Chr(34) 'chr(34)为"，echo >>时，若文件路径中存在空格，需要用""包含
Open path_des_start & "\转换记录.txt" For Output As #1
search path_src_start, path_des_start
'完成搜索
time_end = GetTickCount()
writeLog ("处理文件数量：" & num_file)
'获得花费时间
time_spend = time_end - time_start
second_spend = time_spend \ 1000
minute_spend = second_spend \ 60
minute_tail = second_spend - minute_spend * 60
output = "处理用时：" & minute_spend & "分" & minute_tail & "秒"
writeLog (output)
Close #1
MsgBox ("处理完毕" & vbCrLf _
    & "处理文件数量：" & num_file & vbCrLf _
    & output)

End Sub

‘搜索文件，path_src为源文件路径，path_des为需要保存.doc文件的路径
Sub search(path_src, path_des)

Dim fs, fold, fls, fl
Set fs = CreateObject("Scripting.FileSystemObject")
Set fold = fs.getfolder(path_src)
'首先对当前目录的指定文件进行处理
If fold.Files.Count <> 0 Then
    Set fls = fold.Files
    For Each fl In fls
        '判断是否为.htm文件，需判断文件名中是否出现了指定的后缀，且处于最后（防止.html文件匹配.htm）
        judge = InStrRev(fl.Name, FileType_doc)
        If judge <> 0 And judge + Len(FileType_doc) - 1 = Len(fl.Name) Then
            '处理.doc文件
            operDocFile path_src, fl.Name, path_src
        End If
    Next
End If
'再对子目录进行递归
If fold.SubFolders.Count <> 0 Then
    Set fls = fold.SubFolders
    For Each fl In fls
        search path_src & "\" & fl.Name, path_des & "\" & fl.Name
    Next
End If

End Sub

‘处理.doc文件，path_src为.doc文件所在目录路径，FileName为.doc文件名，path_des为.htm文件需要保存的目录路径
Sub operDocFile(path_src, FileName, path_des)

filePath_doc = path_src & "\" & FileName
FileName_Only = Left(FileName, InStrRev(FileName, ".") - 1) '去掉后缀的文件名，开头没有'\'
filePath_htm = path_des & "\" & FileName_Only & FileType_htm '对应.htm文件的路径
'判断对应的.htm是否已生成
If Dir(filePath_htm) = "" Then
    writeLog ("--开始处理文件：" & filePath_doc)
    Documents.Open (filePath_doc) '打开答案.mht文件
    modifyTitle (FileName_Only) '修改.doc文档的标题属性为文件名
    operPics '修改图片大小
    saveDoc2Htm (filePath_htm) '保存为.htm文件
    ActiveDocument.Close '关闭打开的文件
    writeLog ("--处理文件成功：" & filePath_htm)
    num_file = num_file + 1 '已处理文件数加1
End If

End Sub

‘将.doc文件通过word保存为.htm文件，destPath为.htm文件完整路径
Sub saveDoc2Htm(destPath)

'另存为.htm文件
ActiveDocument.SaveAs FileName:=destPath, FileFormat:= _
    wdFormatFilteredHTML, LockComments:=False, Password:="", AddToRecentFiles:= _
    False, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
    False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
    SaveAsAOCELetter:=False

End Sub

‘修改.doc文档的标题属性
Sub modifyTitle(title)

ActiveDocument.BuiltInDocumentProperties("Title") = title '修改.doc文档标题属性
ActiveDocument.Save '保存

End Sub

‘对图片进行处理
Sub operPics()

Selection.WholeStory '全选
pic_num = Selection.InlineShapes.Count '获得图片个数
For i = 1 To pic_num
    '对图片大小进行处理
    operPicSize i
Next i
'不保存原始doc-ActiveDocument.Save

End Sub

‘对图片大小进行处理，将未完全显示出来的图片放大至固定宽
Sub operPicSize(currentPic)

fixed_width = 800 '设置固定宽度
fixed_width_min = 500 '设置固定宽度的最小值
minus_width = 50 '设置每次减少的宽度
'计算图片原始宽度
pic_width_raw = (Selection.InlineShapes(currentPic).Width * 100) / Selection.InlineShapes(currentPic).ScaleWidth
writeLog ("图片显示比例：" & Selection.InlineShapes(currentPic).ScaleWidth & " 图片显示宽度：" & Selection.InlineShapes(currentPic).Width & " 图片原始宽度：" & pic_width_raw)
If Selection.InlineShapes(currentPic).ScaleWidth < 100# Then
    '图片显示比例小于100%，需要设置固定宽度
    '尝试从800到500，与图片显示宽度进行比较，
    try = 0
    Do
        fixed_width_current = fixed_width - minus_width * try
        '循环到最小固定宽度时结束
        If fixed_width_current < fixed_width_min Then
            Exit Do
        End If
        try = try + 1
        If fixed_width_current < pic_width_raw Then
            '若图片原始宽度比当前尝试的固定宽度大，则使用当前的固定宽度
            '计算长宽比保持不变的图片新高度
            height_new = (fixed_width_current / Selection.InlineShapes(currentPic).Width) * Selection.InlineShapes(currentPic).Height
            Selection.InlineShapes(currentPic).Width = fixed_width_current
            Selection.InlineShapes(currentPic).Height = height_new
            writeLog ("修改后图片显示宽度：" & fixed_width_current)
            Exit Do
        End If
    Loop
End If