在VB60中指定位置插入文字.docx
《在VB60中指定位置插入文字.docx》由会员分享，可在线阅读，更多相关《在VB60中指定位置插入文字.docx（8页珍藏版）》请在冰豆网上搜索。
在VB60中指定位置插入文字
在VB6.0中，操作word，使用它强大的查找、替换、删除、复制、翦切功能。
还可以把特定字符替换成图片。
有了它你就可以使用数据库中的内容或图片文件替换word文件中的特定字符。
只要把下列内容复制到写字板中，另存为SetWord.cls文件，然后在把它添加到工程中，就可以使用了。
VERSION1.0CLASS
BEGIN
MultiUse=-1'True
Persistable=0'NotPersistable
DataBindingBehavior=0'vbNone
DataSourceBehavior=0'vbNone
MTSTransactionMode=0'NotAnMTSObject
END
AttributeVB_Name="SetWord"
AttributeVB_GlobalNameSpace=False
AttributeVB_Creatable=True
AttributeVB_PredeclaredId=False
AttributeVB_Exposed=False
PrivatemywdappAsWord.Application
PrivatemyselAsObject
'属性值的模块变量
PrivateC_TemplateDocAsString
PrivateC_newDocAsString
PrivateC_PicFileAsString
PrivateC_ErrMsgAsInteger
PublicEventHaveError（）
AttributeHaveError.VB_Description="出错时激发此事件.出错代码为ErrMsg属性"
'***************************************************************
'ErrMsg代码：
1－word没有安装2-缺少参数3-没权限写文件
'4-文件不存在
'
'***************************************************************
PublicFunctionReplacePic（FindStrAsString,OptionalTimeAsInteger=0）AsInteger
AttributeReplacePic.VB_Description="查找FindStr,并替换为PicFile所指向的图片文件,替换次数由time参数确定,为0时，替换所有"
'********************************************************************************
'从Word.Range对象mysel中查找所有FindStr，并替换为PicFile图像
'替换次数由time参数确定，为0时，替换所有
'********************************************************************************
IfLen（C_PicFile）=0Then
C_ErrMsg=2
ExitFunction
EndIf
DimiAsInteger
DimfindtxtAsBoolean
mysel.Find.ClearFormatting
mysel.Find.Replacement.ClearFormatting
Withmysel.Find
.Text=FindStr
.Replacement.Text=""
.Forward=True
.Wrap=wdFindContinue
.Format=False
.MatchCase=False
.MatchWholeWord=False
.MatchByte=True
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
EndWith
mysel.HomeKeyUnit:
=wdStory
findtxt=mysel.Find.Execute（Replace:
=True）
IfNotfindtxtThen
ReplacePic=0
ExitFunction
EndIf
i=1
DoWhilefindtxt
mysel.InlineShapes.AddPictureFileName:
=C_PicFile
Ifi=TimeThenExitDo
i=i+1
mysel.HomeKeyUnit:
=wdStory
findtxt=mysel.Find.Execute（Replace:
=True）
Loop
ReplacePic=i
EndFunction
PublicFunctionFindThis（FindStrAsString）AsBoolean
AttributeFindThis.VB_Description="查找FindStr,如果模板中有FindStr则返回True"
IfLen（FindStr）=0Then
C_ErrMsg=2
ExitFunction
EndIf
mysel.Find.ClearFormatting
mysel.Find.Replacement.ClearFormatting
Withmysel.Find
.Text=FindStr
.Replacement.Text=""
.Forward=True
.Wrap=wdFindContinue
.Format=False
.MatchCase=False
.MatchWholeWord=False
.MatchByte=True
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
EndWith
mysel.HomeKeyUnit:
=wdStory
FindThis=mysel.Find.Execute
EndFunction
PublicFunctionReplaceChar（FindStrAsString,RepStrAsString,OptionalTimeAsInteger=0）AsInteger
AttributeReplaceChar.VB_Description="查找FindStr,并替换为RepStr,替换次数由time参数确定,为0时，替换所有"
'********************************************************************************
'从Word.Range对象mysel中查找FindStr，并替换为RepStr
'替换次数由time参数确定，为0时，替换所有
'********************************************************************************
DimfindtxtAsBoolean
IfLen（FindStr）=0Then
C_ErrMsg=2
RaiseEventHaveError
ExitFunction
EndIf
mysel.Find.ClearFormatting
mysel.Find.Replacement.ClearFormatting
Withmysel.Find
.Text=FindStr
.Replacement.Text=RepStr
.Forward=True
.Wrap=wdFindContinue
.Format=False
.MatchCase=False
.MatchWholeWord=False
.MatchByte=True
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
EndWith
IfTime>0Then
Fori=1ToTime
mysel.HomeKeyUnit:
=wdStory
findtxt=mysel.Find.Execute（Replace:
=wdReplaceOne）
IfNotfindtxtThenExitFor
Next
Ifi=1AndNotfindtxtThen
ReplaceChar=0
Else
ReplaceChar=i
EndIf
Else
mysel.Find.ExecuteReplace:
=wdReplaceAll
EndIf
EndFunction
PublicFunctionGetPic（PicData（）AsByte,FileNameAsString）AsBoolean
AttributeGetPic.VB_Description="把图像数据PicData,存为PicFile指定的文件"
'********************************************************************************
'把图像数据PicData,存为PicFile指定的文件
'********************************************************************************
OnErrorResumeNext
IfLen（FileName）=0Then
C_ErrMsg=2
RaiseEventHaveError
ExitFunction
EndIf
OpenFileNameForBinaryAs#1
IfErr.Number<>0Then
C_ErrMsg=3
ExitFunction
EndIf
'二进制文件用Get,Put存放，读取数据
Put#1,,PicData
Close#1
C_PicFile=FileName
GetPic=True
EndFunction
PublicSubDeleteToEnd（）
AttributeDeleteToEnd.VB_Description="删除从当前位置到结尾的所有内容"
mysel.EndKeyUnit:
=wdStory,Extend:
=wdExtend
mysel.DeleteUnit:
=wdCharacter,Count:
=1
EndSub
PublicSubMoveEnd（）
AttributeMoveEnd.VB_Description="光标移动到文档结尾"
'光标移动到文档结尾
mysel.EndKeyUnit:
=wdStory
EndSub
PublicSubGotoLine（LineTimeAsInteger）
mysel.GoToWhat:
=wdGoToLine,Which:
=wdGoToFirst,Count:
=LineTime,Name:
=""
EndSub
PublicSubOpenDoc（viewAsBoolean）
AttributeOpenDoc.VB_Description="打开Word文件,View确定是否显示Word界面"
OnErrorResumeNext
'********************************************************************************
'打开Word文件，并给全局变量mysel赋值
'********************************************************************************
IfLen（C_TemplateDoc）=0Then
mywdapp.Documents.Add
Else
mywdapp.Documents.Open（C_TemplateDoc）
EndIf
IfErr.Number<>0Then
C_ErrMsg=4
RaiseEventHaveError
ExitSub
EndIf
mywdapp.Visible=view
mywdapp.Activate
Setmysel=mywdapp.Application.Selection
'mysel.Select
EndSub
PublicSubOpenWord（）
OnErrorResumeNext
'********************************************************************************
'打开Word程序，并给全局变量mywdapp赋值
'********************************************************************************
Setmywdapp=CreateObject（"word.application"）
IfErr.Number<>0Then
C_ErrMsg=1
RaiseEventHaveError
ExitSub
EndIf
EndSub
PublicSubViewDoc（）
AttributeViewDoc.VB_Description="显示Word程序界面"
mywdapp.Visible=True
EndSub
PublicSubAddNewPage（）
AttributeAddNewPage.VB_Description="插入分页符"
mysel.InsertBreakType:
=wdPageBreak
EndSub
PublicSubWordCut（）
AttributeWordCut.VB_Description="剪切模板所有内容到剪切板"
'保存模板页面内容
mysel.WholeStory
mysel.Cut
mysel.HomeKeyUnit:
=wdStory
EndSub
PublicSubWordCopy（）
AttributeWordCopy.VB_Description="拷贝模板所有内容到剪切板"
mysel.WholeStory
mysel.Copy
mysel.HomeKeyUnit:
=wdStory
EndSub
PublicSubWordDel（）
mysel.WholeStory
mysel.Delete
mysel.HomeKeyUnit:
=wdStory
EndSub
PublicSubWordPaste（）
AttributeWordPaste.VB_Description="拷贝剪切板内容到当前位置"
'插入模块内容
mysel.Paste
EndSub
PublicSubCloseDoc（）
AttributeCloseDoc.VB_Description="关闭Word文件模板"
'********************************************************************************
'关闭Word文件模本
'********************************************************************************
OnErrorResumeNext
mywdapp.ActiveDocument.CloseFalse
IfErr.Number<>0Then
C_ErrMsg=3
ExitSub
EndIf
EndSub
PublicSubQuitWord（）
'********************************************************************************
'关闭Word程序
'********************************************************************************
OnErrorResumeNext
mywdapp.Quit
IfErr.Number<>0Then
C_ErrMsg=3
ExitSub
EndIf
EndSub
PublicSubSavetoDoc（）
AttributeSavetoDoc.VB_Description="保存当前文档为FileName指定文件"
OnErrorResumeNext
'并另存为文件FileName
IfLen（C_newDoc）=0Then
C_ErrMsg=2
RaiseEventHaveError
ExitSub
EndIf
mywdapp.ActiveDocument.SaveAs（C_newDoc）
IfErr.Number<>0Then
C_ErrMsg=3
RaiseEventHaveError
ExitSub
EndIf
EndSub
PublicPropertyGetTemplateDoc（）AsString
AttributeTemplateDoc.VB_Description="模板文件名."
TemplateDoc=C_TemplateDoc
EndProperty
PublicPropertyLetTemplateDoc（ByValvNewValueAsString）
C_TemplateDoc=vNewValue
EndProperty
PublicPropertyGetnewdoc（）AsString
Attributenewdoc.VB_Description="执行CloseDoc方法时，将模板文件另存为此文件名指定的新文件.如果不指定，在执行CloseDoc方法时，将产生一个错误"
newdoc=C_newDoc
EndProperty
PublicPropertyLetnewdoc（ByValvNewValueAsString）
C_newDoc=vNewValue
EndProperty
PublicPropertyGetPicFile（）AsString
AttributePicFile.VB_Description="图像文件名"
PicFile=C_PicFile
EndProperty
PublicPropertyLetPicFile（ByValvNewValueAsString）
C_PicFile=vNewValue
EndProperty
PublicPropertyGetErrMsg（）AsInteger
AttributeErrMsg.VB_Description="错误信息.ErrMsg代码:
1-word没有安装2-缺少参数3-没权限写文件4-文件不存在"
ErrMsg=C_ErrMsg
EndProperty
升级会员 