VB查找并替换WORD文档中的字符串

基本要求：需安装WORD

FunctionWordReplace(FileNameAsString,SearchStringAsString,ReplaceStringAsString,OptionalSaveFileAsString="",OptionalMatchCaseAsBoolean=False)AsInteger
OnErrorGoToErrorMsg'函数运行时发生遇外或错误,转向错误提示信息

DimwordAppAsNewWord.Application
DimwordDocAsNewWord.Document
DimwordArangeAsWord.Range
DimwordSelectionAsWord.Selection
DimReplaceSignAsBoolean
DimIAsInteger

'判断将要替换的文件是否存在
IfDir(FileName)=""Then
'替换文件不存在
MsgBox"未找到"&FileName&"文件"'提示替换文件不存在信息
WordReplace=-2'返回替换文件不存在的值
ExitFunction'退出函数
EndIf

SetwordApp=CreateObject("Word.Application")'建立WORD实例
wordApp.Visible=False'屏蔽WORD实例窗体
SetwordDoc=wordApp.Documents.Open(FileName)'打开文件并赋予文件实例
SetwordSelection=wordApp.Selection'定位文件实例
SetwordArange=wordApp.ActiveDocument.Range(0,1)'指定文件编辑位置
wordArange.Select'激活编辑位置

I=0'初始化替换次数值
ReplaceSign=True'初始化是否替换成功标志
DoWhileReplaceSign
ReplaceSign=wordArange.Find.Execute(SearchString,MatchCase,,,,,,wdFindContinue,,ReplaceString,True)'查找并替换
'判断查找并替换是否成功,如果成功替换次数值递增1
IfReplaceSign=TrueThen
I=I 1
EndIf
Loop

MsgBox"已完成对文档的搜索并完成"&I&"替换。"'提示总替换次数

'如果替换成功，则提示是否保存
IfI>0Then
'判断是否需要另存
IfTrim(SaveFile)<>""Then
'需要另存
IfDir(SaveFile)=""Then
wordDoc.SaveAsSaveFile'文件另存为……
Else
'咨询是否替换文件,如果不替换则放弃本次操作,否则存在本次操作
IfMsgBox("是否替换"&SaveFile&"文件？",vbYesNo vbQuestion,"替换")=vbYesThen
wordDoc.SaveAsSaveFile'文件另存为……
EndIf
EndIf
Else
IfMsgBox("是否保存对"&SaveFile&"更改？",vbYesNo vbQuestion,"保存")=vbYesThen
wordDoc.Save'保存在原文件中
EndIf
EndIf
EndIf

WordReplace=I'返回替换次数

wordDoc.Close'关闭文档实例
wordApp.Quit'关闭WORD实例
SetwordDoc=Nothing'清除文件实例
SetwordApp=Nothing'清除WORD实例

ExitFunction

ErrorMsg:
MsgBoxErr.Number&":"&Err.Description'提示错误信息
WordReplace=-1'返回错误信息值
wordDoc.Close'关闭文档实例
wordApp.Quit'关闭WORD实例
SetwordDoc=Nothing'清除文件实例
SetwordApp=Nothing'清除WORD实例

EndFunction

注意事项：单击在菜单“工程”中的“引用”菜单项，弹出窗口，在列表框中选择“MicrosoftWordXObjectLibaray“，单击引用

在VB6.0 OfficeXP Windows测试通过->