在VB60中指定位置插入文字.docx

在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