vb6 转换mht到 doc，接上一篇 只能生产word，上面提到虽然是doc的后缀其实还是mht的编码，上传百度文库等会遇到文档识别错误，下面我们用vb6 将文档转化一下，其实很简单，就是打开再另存为，调用了 word组件，所以速度很慢，暂时没有很好的解决办法

Dim wordApp As Object Dim wordDoc As Object Dim paths(200) As String Dim names(200) As String Dim cpath As String Function doword(filepath,names) OpenWord (filepath) b = SaveAsWord(cpath,names) 'b = SaveAsWord("D:/www/cword/word",names) End Function Function OpenWord(filename) '打开指定word文档 Set wordApp = CreateObject("Word.Application") wordApp.Visible = False Set wordDoc = wordApp.Documents.Open(filename) End Function '============替换关键字=========== Function ReplaceWord(SearchStr,ReplaceStr) '全部替换<a href="/tag/hanshu/" target="_blank" class="keywords">函数</a> wordApp.Selection.Find.ClearFormatting wordApp.Selection.Find.Replacement.ClearFormatting With wordApp.Selection.Find .Text = SearchStr .Replacement.Text = ReplaceStr .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With wordApp.Selection.Find.Execute Replace:=wdReplaceAll End Function '==================另存为=================== Function SaveAsWord(DiskStr,NameStr) wordApp.ChangeFileOpenDirectory DiskStr wordDoc.SaveAs filename:=NameStr,FileFormat:=wdFormatDocument _,LockComments:=False,Password:="",AddToRecentFiles:=True,_ WritePassword:="",ReadOnlyRecommended:=False,EmbedTrueTypeFonts:=False,_ SaveNativePictureFormat:=False,SaveFormsData:=False,SaveAsAOCELetter:= _ False wordApp.Documents.Close wordApp.Quit End Function '===================清除对象============ Function CloseWord() Set wordDoc = Nothing '清除<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>实例 Set wordApp = Nothing '清除WORD实例 End Function Private Sub Command2_Click() Label1.Visible = True Label1.Caption = "成功转换" & SearchFiles(cpath,"*.doc") & "篇" End Sub Function SearchFiles(Path As String,FileType As String) Dim Files() As String '<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>路径 Dim Folder() As String '<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>夹路径 Dim a,b,c As Long Dim Spath As String Spath = Dir(Path & FileType) '查找第一个<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a> i = 0 Do While Len(Spath) '循环到没有<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>为止 a = a + 1 ReDim Preserve Files(1 To a) Files(a) = Path & Spath '将<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>目录和<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>名组合,并存放到数组中 '处理 a = doword(Files(a),Spath) ' 'Text1.Text = Files(a) ' paths(i) = Files(a) 'names(i) = Spath List1.AddItem paths(i) '加入list控件中 i = i + 1 Label1.Caption = "正在<a href="/tag/shengcheng/" target="_blank" class="keywords">生成</a>" & i Spath = Dir '查找下一个<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a> DoEvents '让出控制权 Loop Spath = Dir(Path & "/",vbDirectory) '查找第一个<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>夹 Do While Len(Spath) '循环到没有<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>夹为止 If Left(Spath,1) <> "." Then '为了防止重复查找 If GetAttr(Path & "/" & Spath) And vbDirectory Then '如果是<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>夹则。。。。。。 b = b + 1 ReDim Preserve Folder(1 To b) Folder(b) = Path & Spath & "/" '将目录和<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>夹<a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a>组合形成新的目录,并存放到数组中 End If End If Spath = Dir '查找下一个<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>夹 DoEvents '让出控制权 Loop For c = 1 To b '使用递归<a href="/tag/fangfa/" target="_blank" class="keywords">方法</a>，遍历所有目录 SearchFiles Folder(c),FileType Next SearchFiles = i End Function Private Sub Dir1_Change() cpath = Dir1.Path + "/" End Sub Private Sub Drive1_Change() Dir1.Path = Drive1.Drive End Sub

ps 代码中不少没用到的代码，测试时候用来着，懒得优化了