vb6 转换mht到 doc

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

 

Dim wordApp As ObjectDim wordDoc As ObjectDim paths(200) As StringDim names(200) As StringDim cpath As StringFunction doword(filepath, names)OpenWord (filepath)b = SaveAsWord(cpath, names)'b = SaveAsWord("D:/www/cword/word", names)End FunctionFunction OpenWord(filename) '打开指定word文档Set wordApp = CreateObject("Word.Application")wordApp.Visible = FalseSet 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:=wdReplaceAllEnd 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 FunctionPrivate Sub Command2_Click()Label1.Visible = TrueLabel1.Caption = "成功转换" & SearchFiles(cpath, "*.doc") & "篇"End SubFunction SearchFiles(Path As String, FileType As String)Dim Files() As String '文件路径Dim Folder() As String '文件夹路径Dim a, b, c As LongDim Spath As StringSpath = Dir(Path & FileType) '查找第一个文件i = 0Do 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 + 1Label1.Caption = "正在生成" & i Spath = Dir '查找下一个文件 DoEvents '让出控制权LoopSpath = 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 '让出控制权LoopFor c = 1 To b '使用递归方法，遍历所有目录 SearchFiles Folder(c), FileTypeNextSearchFiles = iEnd FunctionPrivate Sub Dir1_Change()cpath = Dir1.Path + "/"End SubPrivate Sub Drive1_Change()Dir1.Path = Drive1.DriveEnd Sub

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