在ＶＢ6.0中，操作word，使用它强大的查找、替换、删除、复制、翦切功能。还可以把特定字符替换成图片。有了它你就可以使用数据库中的内容或图片文件替换word文件中的特定字符。 　　只要把下列内容复制到写字板中，另存为SetWord.cls文件，然后在把它添加到工程中，就可以使用了。 VERSION 1.0 CLASSBEGIN  MultiUse = -1  'True  Persistable = 0  'NotPersistable  DataBindingBehavior = 0  'vbNone  DataSourceBehavior  = 0  'vbNone  MTSTransactionMode  = 0  'NotAnMTSObjectENDAttribute VB_Name = "SetWord"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueAttribute VB_PredeclaredId = FalseAttribute VB_Exposed = FalsePrivate mywdapp As Word.ApplicationPrivate mysel As Object '属性值的模块变量Private C_TemplateDoc As StringPrivate C_newDoc As StringPrivate C_PicFile As StringPrivate C_ErrMsg As Integer Public Event HaveError()Attribute HaveError.VB_Description = "出错时激发此事件.出错代码为ErrMsg属性"'***************************************************************'ErrMsg代码：1－word没有安装　2　-　缺少参数  3　-　没权限写文件'           4　-　文件不存在''*************************************************************** Public Function ReplacePic(FindStr As String, Optional Time As Integer = 0) As IntegerAttribute ReplacePic.VB_Description = "查找FindStr,并替换为PicFile所指向的图片文件,替换次数由time参数确定,为0时，替换所有" '********************************************************************************'　　　　从Word.Range对象mysel中查找所有FindStr，并替换为PicFile图像'          替换次数由time参数确定，为0时，替换所有'******************************************************************************** If Len(C_PicFile) = 0 Then    C_ErrMsg = 2    Exit FunctionEnd If Dim i As IntegerDim 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.Execute(Replace:=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.Execute(Replace:=True)   Loop   ReplacePic = iEnd Function Public Function FindThis(FindStr As String) As BooleanAttribute FindThis.VB_Description = "查找FindStr,如果模板中有FindStr则返回True"If Len(FindStr) = 0 Then    C_ErrMsg = 2    Exit FunctionEnd 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.ExecuteEnd Function Public Function ReplaceChar(FindStr As String, RepStr As String, Optional Time As Integer = 0) As IntegerAttribute ReplaceChar.VB_Description = "查找FindStr,并替换为RepStr,替换次数由time参数确定,为0时，替换所有"'********************************************************************************'　　　　　从Word.Range对象mysel中查找FindStr，并替换为RepStr'          替换次数由time参数确定，为0时，替换所有'********************************************************************************Dim findtxt As Boolean If Len(FindStr) = 0 Then    C_ErrMsg = 2    RaiseEvent HaveError    Exit FunctionEnd 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.Execute(Replace:=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 IfEnd Function   Public Function GetPic(PicData() As Byte, FileName As String) As BooleanAttribute GetPic.VB_Description = "把图像数据PicData,存为PicFile指定的文件"'********************************************************************************'　　　　　把图像数据PicData,存为PicFile指定的文件'********************************************************************************On Error Resume Next If Len(FileName) = 0 Then    C_ErrMsg = 2    RaiseEvent HaveError    Exit FunctionEnd If Open FileName For Binary As #1 If Err.Number <> 0 Then    C_ErrMsg = 3    Exit FunctionEnd If '二进制文件用Get,Put存放，读取数据Put #1, , PicDataClose #1 C_PicFile = FileNameGetPic = True End Function Public Sub DeleteToEnd()Attribute DeleteToEnd.VB_Description = "删除从当前位置到结尾的所有内容"mysel.EndKey Unit:=wdStory, Extend:=wdExtendmysel.Delete Unit:=wdCharacter, Count:=1End Sub Public Sub MoveEnd()Attribute MoveEnd.VB_Description = "光标移动到文档结尾"'光标移动到文档结尾mysel.EndKey Unit:=wdStoryEnd Sub Public Sub GotoLine(LineTime As Integer)mysel.GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=LineTime, Name:=""End Sub Public Sub OpenDoc(view As Boolean)Attribute OpenDoc.VB_Description = "打开Word文件,View确定是否显示Word界面"On Error Resume Next '********************************************************************************'　　　　　打开Word文件，并给全局变量mysel赋值'******************************************************************************** If Len(C_TemplateDoc) = 0 Then    mywdapp.Documents.AddElse    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 = CreateObject("word.application")    If Err.Number <> 0 Then        C_ErrMsg = 1        RaiseEvent HaveError        Exit Sub    End IfEnd Sub Public Sub ViewDoc()Attribute ViewDoc.VB_Description = "显示Word程序界面"mywdapp.Visible = TrueEnd Sub Public Sub AddNewPage()Attribute AddNewPage.VB_Description = "插入分页符"mysel.InsertBreak Type:=wdPageBreakEnd Sub Public Sub WordCut()Attribute WordCut.VB_Description = "剪切模板所有内容到剪切板"    '保存模板页面内容    mysel.WholeStory    mysel.Cut    mysel.HomeKey Unit:=wdStoryEnd Sub Public Sub WordCopy()Attribute WordCopy.VB_Description = "拷贝模板所有内容到剪切板"    mysel.WholeStory    mysel.Copy    mysel.HomeKey Unit:=wdStoryEnd Sub Public Sub WordDel()    mysel.WholeStory    mysel.Delete    mysel.HomeKey Unit:=wdStoryEnd Sub Public Sub WordPaste()Attribute WordPaste.VB_Description = "拷贝剪切板内容到当前位置"'插入模块内容mysel.PasteEnd 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 SubEnd If End Sub Public Sub QuitWord()'********************************************************************************'　　　　　关闭Word程序'********************************************************************************On Error Resume Next     mywdapp.Quit    If Err.Number <> 0 Then    C_ErrMsg = 3    Exit SubEnd IfEnd Sub Public Sub SavetoDoc()Attribute SavetoDoc.VB_Description = "保存当前文档为FileName指定文件"On Error Resume Next '并另存为文件FileName If Len(C_newDoc) = 0 Then    C_ErrMsg = 2    RaiseEvent HaveError    Exit SubEnd 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 StringAttribute TemplateDoc.VB_Description = "模板文件名."TemplateDoc = C_TemplateDocEnd Property Public Property Let TemplateDoc(ByVal vNewValue As String)C_TemplateDoc = vNewValueEnd Property Public Property Get newdoc() As StringAttribute newdoc.VB_Description = "执行CloseDoc方法时，将模板文件另存为此文件名指定的新文件.如果不指定，在执行CloseDoc方法时，将产生一个错误"newdoc = C_newDocEnd Property Public Property Let newdoc(ByVal vNewValue As String)C_newDoc = vNewValueEnd Property Public Property Get PicFile() As StringAttribute PicFile.VB_Description = "图像文件名"PicFile = C_PicFileEnd Property Public Property Let PicFile(ByVal vNewValue As String)C_PicFile = vNewValueEnd Property Public Property Get ErrMsg() As IntegerAttribute ErrMsg.VB_Description = "错误信息.ErrMsg代码: 1-word没有安装 2-缺少参数 3-没权限写文件 4-文件不存在"ErrMsg = C_ErrMsgEnd Property 作者Blog：http://blog.csdn.net/Equn/

评论