用VB如何在WORD指定位置上插入文字

用VB如何在WORD指定位置上插入文字在VB6.0中，操作word，使用它强大的查找、替换、删除、复制、翦切功能。

还可以把特定字符替换成图片。

有了它你就可以使用数据库中的内容或图片文件替换word文件中的特定字符。

只要把下列内容复制到写字板中，另存为SetWord.cls文件，然后在把它添加到工程中，就可以使用了。

VERSION 1.0 CLASSBEGINMultiUse = -1 'TruePersistable = 0 'NotPersistableDataBindingBehavior = 0 'vbNoneDataSourceBehavior = 0 'vbNoneMTSTransactionMode = 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 IntegerPublic Event HaveError()Attribute HaveError.VB_Description = "出错时激发此事件.出错代码为ErrMsg属性"'*************************************************** ************'ErrMsg代码：1－word没有安装2 - 缺少参数3 - 没权限写文件' 4 - 文件不存在''*************************************************** ************Public Function ReplacePic(FindStr As String, Optional TimeAs Integer = 0) As IntegerAttribute ReplacePic.VB_Description = "查找FindStr,并替换为PicFile所指向的图片文件,替换次数由time参数确定,为0时，替换所有"'*************************************************** *****************************' 从Word.Range对象mysel中查找所有FindStr，并替换为PicFile图像' 替换次数由time参数确定，为0时，替换所有'*************************************************** *****************************If Len(C_PicFile) = 0 ThenC_ErrMsg = 2Exit FunctionEnd IfDim i As IntegerDim findtxt As Booleanmysel.Find.ClearFormattingmysel.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 = FalseEnd Withmysel.HomeKey Unit:=wdStoryfindtxt = mysel.Find.Execute(Replace:=True) If Not findtxt ThenReplacePic = 0Exit FunctionEnd Ifi = 1Do While findtxtmysel.InlineShapes.AddPicture FileName:=C_PicFileIf i = Time Then Exit Doi = i + 1mysel.HomeKey Unit:=wdStoryfindtxt = mysel.Find.Execute(Replace:=True)LoopReplacePic = iEnd FunctionPublic Function FindThis(FindStr As String) As Boolean Attribute FindThis.VB_Description = "查找FindStr,如果模板中有FindStr则返回True"If Len(FindStr) = 0 ThenC_ErrMsg = 2Exit FunctionEnd Ifmysel.Find.ClearFormattingmysel.Find.Replacement.ClearFormattingWith mysel.Find.Text = FindStr.Replacement.Text = "".Forward = True.Wrap = wdFindContinue.Format = False.MatchCase = False.MatchWholeWord = False.MatchByte = True.MatchWildcards = False.MatchSoundsLike = False.MatchAllWordForms = FalseEnd Withmysel.HomeKey Unit:=wdStoryFindThis = mysel.Find.ExecuteEnd FunctionPublic 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 BooleanIf Len(FindStr) = 0 ThenC_ErrMsg = 2RaiseEvent HaveErrorExit FunctionEnd Ifmysel.Find.ClearFormattingmysel.Find.Replacement.ClearFormattingWith mysel.Find.Text = FindStr.Replacement.Text = RepStr.Forward = True.Wrap = wdFindContinue.Format = False.MatchCase = False.MatchWholeWord = False.MatchByte = True.MatchWildcards = False.MatchSoundsLike = False.MatchAllWordForms = FalseEnd WithIf Time > 0 ThenFor i = 1 To Timemysel.HomeKey Unit:=wdStoryfindtxt = mysel.Find.Execute(Replace:=wdReplaceOne) If Not findtxt Then Exit ForNextIf i = 1 And Not findtxt ThenReplaceChar = 0ElseReplaceChar = iEnd IfElsemysel.Find.Execute Replace:=wdReplaceAllEnd IfEnd FunctionPublic Function GetPic(PicData() As Byte, FileName As String) As BooleanAttribute GetPic.VB_Description = "把图像数据PicData,存为PicFile指定的文件"'*************************************************** *****************************' 把图像数据PicData,存为PicFile指定的文件'*************************************************** *****************************On Error Resume NextIf Len(FileName) = 0 ThenC_ErrMsg = 2RaiseEvent HaveErrorExit FunctionEnd IfOpen FileName For Binary As #1If Err.Number <> 0 ThenC_ErrMsg = 3Exit FunctionEnd If'二进制文件用Get,Put存放，读取数据Put #1, , PicDataClose #1C_PicFile = FileNameGetPic = TrueEnd FunctionPublic Sub DeleteToEnd()Attribute DeleteToEnd.VB_Description = "删除从当前位置到结尾的所有内容"mysel.EndKey Unit:=wdStory, Extend:=wdExtendmysel.Delete Unit:=wdCharacter, Count:=1End SubPublic Sub MoveEnd()Attribute MoveEnd.VB_Description = "光标移动到文档结尾" '光标移动到文档结尾mysel.EndKey Unit:=wdStoryEnd SubPublic Sub GotoLine(LineTime As Integer)mysel.GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=LineTime, Name:=""End SubPublic Sub OpenDoc(view As Boolean)Attribute OpenDoc.VB_Description = "打开Word文件,View确定是否显示Word界面"On Error Resume Next'*************************************************** *****************************' 打开Word文件，并给全局变量mysel赋值'*************************************************** *****************************If Len(C_TemplateDoc) = 0 Thenmywdapp.Documents.AddElsemywdapp.Documents.Open (C_TemplateDoc)End IfIf Err.Number <> 0 ThenC_ErrMsg = 4RaiseEvent HaveErrorExit SubEnd Ifmywdapp.Visible = viewmywdapp.ActivateSet mysel = mywdapp.Application.Selection'mysel.SelectEnd SubPublic Sub OpenWord()On Error Resume Next'*************************************************** *****************************' 打开Word程序，并给全局变量mywdapp赋值'*************************************************** *****************************Set mywdapp = CreateObject("word.application")If Err.Number <> 0 ThenC_ErrMsg = 1RaiseEvent HaveErrorExit SubEnd IfEnd SubPublic Sub ViewDoc()Attribute ViewDoc.VB_Description = "显示Word程序界面" mywdapp.Visible = TrueEnd SubPublic Sub AddNewPage()Attribute AddNewPage.VB_Description = "插入分页符" mysel.InsertBreak Type:=wdPageBreakEnd SubPublic Sub WordCut()Attribute WordCut.VB_Description = "剪切模板所有内容到剪切板"'保存模板页面内容mysel.WholeStorymysel.Cutmysel.HomeKey Unit:=wdStoryEnd SubPublic Sub WordCopy()Attribute WordCopy.VB_Description = "拷贝模板所有内容到剪切板"mysel.WholeStorymysel.Copymysel.HomeKey Unit:=wdStoryEnd SubPublic Sub WordDel()mysel.WholeStorymysel.Deletemysel.HomeKey Unit:=wdStoryEnd SubPublic Sub WordPaste()Attribute WordPaste.VB_Description = "拷贝剪切板内容到当前位置"'插入模块内容mysel.PasteEnd SubPublic Sub CloseDoc()Attribute CloseDoc.VB_Description = "关闭Word文件模板" '*************************************************** *****************************' 关闭Word文件模本'*************************************************** *****************************On Error Resume Nextmywdapp.ActiveDocument.Close FalseIf Err.Number <> 0 ThenC_ErrMsg = 3Exit SubEnd IfEnd SubPublic Sub QuitWord()'*************************************************** *****************************' 关闭Word程序'*************************************************** *****************************On Error Resume Nextmywdapp.QuitIf Err.Number <> 0 ThenC_ErrMsg = 3Exit SubEnd IfEnd SubPublic Sub SavetoDoc()Attribute SavetoDoc.VB_Description = "保存当前文档为FileName指定文件"On Error Resume Next'并另存为文件FileNameIf Len(C_newDoc) = 0 ThenC_ErrMsg = 2RaiseEvent HaveErrorExit SubEnd Ifmywdapp.ActiveDocument.SaveAs (C_newDoc)If Err.Number <> 0 ThenC_ErrMsg = 3RaiseEvent HaveErrorExit SubEnd IfEnd SubPublic Property Get TemplateDoc() As StringAttribute TemplateDoc.VB_Description = "模板文件名." TemplateDoc = C_TemplateDocEnd PropertyPublic Property Let TemplateDoc(ByVal vNewValue As String) C_TemplateDoc = vNewValueEnd PropertyPublic Property Get newdoc() As StringAttribute newdoc.VB_Description = "执行CloseDoc方法时，将模板文件另存为此文件名指定的新文件.如果不指定，在执行CloseDoc方法时，将产生一个错误"newdoc = C_newDocEnd PropertyPublic Property Let newdoc(ByVal vNewValue As String)C_newDoc = vNewValueEnd PropertyPublic Property Get PicFile() As StringAttribute PicFile.VB_Description = "图像文件名"PicFile = C_PicFileEnd PropertyPublic Property Let PicFile(ByVal vNewValue As String)C_PicFile = vNewValueEnd PropertyPublic Property Get ErrMsg() As IntegerAttribute ErrMsg.VB_Description = "错误信息.ErrMsg代码: 1-word没有安装2-缺少参数3-没权限写文件4-文件不存在"ErrMsg = C_ErrMsgEnd Property。