【VB开源代码栏目提醒】：网学会员为广大网友收集整理了，VB控制Word的类模块，查找、替换Word文档内容附源程序（转） - 计算机教材，希望对大家有所帮助！
VERSION 1.0 CLASS BEGIN MultiUse -1 True Persistable 0 NotPersistable DataBindingBehavior 0 vbNone DataSourceBehavior 0 vbNone MTSTransactionMode 0 NotAnMTSObject END Attribute VB_Name SetWord Attribute VB_GlobalNameSpace False Attribute VB_Creatable True Attribute VB_PredeclaredId False Attribute VB_Exposed False Private mywdapp As Word.Application Private mysel As Object 属性值的模块变量 Private C_TemplateDoc As String Private C_newDoc As String Private C_PicFile As String Private C_ErrMsg As Integer Public Event HaveError Attribute HaveError.VB_Description 出错时激发此事件.出错代码为ErrMsg属性 ErrMsg代码：1－word没有安装 2 - 缺少参数 3 - 没权限写文件 4 - 文件不存在 Public Function ReplacePicFindStr As String Optional Time As Integer 0 As Integer Attribute ReplacePic.VB_Description 查找FindStr并替换为PicFile所指向的图片文件替换次数由time参数确定为0时，替换所有 从Word.Range对象mysel中查找所有FindStr，并替换为PicFile图像 替换次数由time参数确定，为0时，替换所有 If LenC_PicFile 0 Then C_ErrMsg 2 Exit Function End If Dim i As Integer Dim findtxt As Boolean mysel.Find.ClearFormatting mysel.Find.Replacement.ClearFormatting With mysel.Find .Text FindStr .Replacement.Text .Forward True .Wrap wdFindContinue .Format False .MatchCase False .MatchWholeWord False .MatchByte True .MatchWildcards False .MatchSoundsLike False .MatchAllWordForms False End With mysel.HomeKey Unit:wdStory findtxt mysel.Find.ExecuteReplace:True If Not findtxt Then ReplacePic 0 Exit Function End If i 1 Do While findtxt mysel.InlineShapes.AddPicture FileName:C_PicFile If i Time Then Exit Do i i 1 mysel.HomeKey Unit:wdStory findtxt mysel.Find.ExecuteReplace:True Loop ReplacePic i End Function Public Function FindThisFindStr As String As Boolean Attribute FindThis.VB_Description 查找FindStr如果模板中有FindStr则返回True If LenFindStr 0 Then C_ErrMsg 2 Exit Function End If mysel.Find.ClearFormatting mysel.Find.Replacement.ClearFormatting With mysel.Find .Text FindStr .Replacement.Text .Forward True .Wrap wdFindContinue .Format False .MatchCase False .MatchWholeWord False .MatchByte True .MatchWildcards False .MatchSoundsLike False .MatchAllWordForms False End With mysel.HomeKey Unit:wdStory FindThis mysel.Find.Execute End Function Public Function ReplaceCharFindStr As String RepStr As String Optional Time As Integer 0 As Integer Attribute ReplaceChar.VB_Description 查找FindStr并替换为RepStr替换次数由time参数确定为0时，替换所有 从Word.Range对象mysel中查找FindStr，并替换为RepStr 替换次数由time参数确定，为0时，替换所有 Dim findtxt As Boolean If LenFindStr 0 Then C_ErrMsg 2 RaiseEvent HaveError Exit Function End If mysel.Find.ClearFormatting mysel.Find.Replacement.ClearFormatting With mysel.Find .Text FindStr .Replacement.Text RepStr .Forward True .Wrap wdFindContinue .Format False .MatchCase False .MatchWholeWord False .MatchByte True .MatchWildcards False .MatchSoundsLike False .MatchAllWordForms False End With If Time 0 Then For i 1 To Time mysel.HomeKey Unit:wdStory findtxt mysel.Find.ExecuteReplace:wdReplaceOne If Not findtxt Then Exit For Next If i 1 And Not findtxt Then ReplaceChar 0 Else ReplaceChar i End If Else mysel.Find.Execute Replace:wdReplaceAll End If End Function Public Function GetPicPicData As Byte FileName As String As Boolean Attribute GetPic.VB_Description 把图像数据PicData存为PicFile指定的文件 把图像数据PicData存为PicFile指定的文件 On Error Resume Next If LenFileName 0 Then C_ErrMsg 2 RaiseEvent HaveError Exit Function End If Open FileName For Binary As 1 If Err.Number 0 Then C_ErrMsg 3 Exit Function End If 二进制文件用GetPut存放，读取数据 Put 1 PicData Close 1 C_PicFile FileName GetPic True End Function Public Sub DeleteToEnd Attribute DeleteToEnd.VB_Description 删除从当前位置到结尾的所有内容 mysel.EndKey Unit:wdStory Extend:wdExtend mysel.Delete Unit:wdCharacter Count:1 End Sub Public Sub MoveEnd Attribute MoveEnd.VB_Description 光标移动到文档结尾 光标移动到文档结尾 mysel.EndKey Unit:wdStory End Sub Public Sub GotoLineLineTime As Integer mysel.GoTo What:wdGoToLine Which:wdGoToFirst Count:LineTime Name: End Sub Public Sub OpenDocview As Boolean Attribute OpenDoc.VB_Description 打开Word文件View确定是否显示Word界面 On Error Resume Next 打开Word文件，并给全局变量mysel赋值 If LenC_TemplateDoc 0 Then mywdapp.Documents.Add Else mywdapp.Documents.Open C_TemplateDoc End If If Err.Number 0 Then C_ErrMsg 4 RaiseEvent HaveError Exit Sub End If mywdapp.Visible view mywdapp.Activate Set mysel mywdapp.Application.Selection mysel.Select End Sub Public Sub OpenWord On Error Resume Next 打开Word程序，并给全局变量mywdapp赋值 Set mywdapp CreateObjectword.application If Err.Number 0 Then C_ErrMsg 1 RaiseEvent HaveError Exit Sub End If End Sub Public Sub ViewDoc Attribute ViewDoc.VB_Description 显示Word程序界面 mywdapp.Visible True End Sub Public Sub AddNewPage Attribute AddNewPage.VB_Description 插入分页符 mysel.InsertBreak Type:wdPageBreak End Sub Public Sub WordCut Attribute WordCut.VB_Description 剪切模板所有内容到剪切板 保存模板页面内容 mysel.WholeStory mysel.Cut mysel.HomeKey Unit:wdStory End Sub Public Sub WordCopy Attribute WordCopy.VB_Description 拷贝模板所有内容到剪切板 mysel.WholeStory mysel.Copy mysel.HomeKey Unit:wdStory End Sub Public Sub WordDel mysel.WholeStory mysel.Delete mysel.HomeKey Unit:wdStory End Sub Public Sub WordPaste Attribute WordPaste.VB_Description 拷贝剪切板内容到当前位置 插入模块内容 mysel.Paste End Sub Public Sub CloseDoc Attribute CloseDoc.VB_Description 关闭Word文件模板 关闭Word文件模本 On Error Resume Next mywdapp.ActiveDocument.Close False If Err.Number 0 Then C_ErrMsg 3 Exit Sub End If End Sub Public Sub QuitWord 关闭Word程序 On Error Resume Next mywdapp.Quit If Err.Number 0 Then C_ErrMsg 3 Exit Sub End If End Sub Public Sub SavetoDoc Attribute SavetoDoc.VB_Description 保存当前文档为FileName指定文件 On Error Resume Next 并另存为文件FileName If LenC_newDoc 0 Then C_ErrMsg 2 RaiseEvent HaveError Exit Sub End If mywdapp.ActiveDocument.SaveAs C_newDoc If Err.Number 0 Then C_ErrMsg 3 RaiseEvent HaveError Exit Sub End If End Sub Public Property Get TemplateDoc As String Attribute TemplateDoc.VB_Description 模板文件名. TemplateDoc C_TemplateDoc End Property Public Property Let TemplateDocByVal vNewValue As String C_TemplateDoc vNewValue End Property Public Property Get newdoc As String Attribute newdoc.VB_Description 执行CloseDoc方法时，将模板文件另存为此文件名指定的新文件.如果不指定，在执行CloseDoc方法时，将产生一个错误 newdoc C_newDoc End Property Public Property Let newdocByVal vNewValue As String C_newDoc vNewValue End Property Public Property Get PicFile As String Attribute PicFile.VB_Description 图像文件名 PicFile C_PicFile End Property Public Property Let PicFileByVal vNewValue As String C_PicFile vNewValue End Property Public Property Get ErrMsg As Integer Attribute ErrMsg.VB_Description 错误信息.ErrMsg代码: 1-word没有安装 2-缺少参数 3-没权限写文件 4-文件不存在 ErrMsg C_ErrMsg End Property 在ＶＢ6.0中，操作word，使用它强大的查找、替换、删除、复制、剪切功能。
相关文章
最新文件
2013-9-15
