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 代码中不少没用到的代码，测试时候用来着，懒得优化了

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!