vb6 转换mht到 doc

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) '全部替换函数 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 '清除文件实例 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 '文件路径 Dim Folder() As String '文件夹路径 Dim a, b, c As Long Dim Spath As String Spath = Dir(Path & FileType) '查找第一个文件 i = 0 Do While Len(Spath) '循环到没有文件为止 a = a + 1 ReDim Preserve Files(1 To a) Files(a) = Path & Spath '将文件目录和文件名组合,并存放到数组中 '处理 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 = "正在生成" & i Spath = Dir '查找下一个文件 DoEvents '让出控制权 Loop Spath = Dir(Path & "/", vbDirectory) '查找第一个文件夹 Do While Len(Spath) '循环到没有文件夹为止 If Left(Spath, 1) <> "." Then '为了防止重复查找 If GetAttr(Path & "/" & Spath) And vbDirectory Then '如果是文件夹则。。。。。。 b = b + 1 ReDim Preserve Folder(1 To b) Folder(b) = Path & Spath & "/" '将目录和文件夹名称组合形成新的目录,并存放到数组中 End If End If Spath = Dir '查找下一个文件夹 DoEvents '让出控制权 Loop For c = 1 To b '使用递归方法，遍历所有目录 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 代码中不少没用到的代码，测试时候用来着，懒得优化了