vb控制word的类模块,查找、替换Word文档内容

• 关 键 词：
• word
• rip
• 数据库

在ＶＢ6.0中，操作word，使用它强大的查找、替换、删除、复制、翦切功能。还可以把特定字符替换成图片。有了它你就可以使用数据库中的内容或图片文件替换word文件中的特定字符。

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

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "SetWord"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private mywdapp As Word.Application
Private mysel As Object

'属性值的模块变量
Private C_TemplateDoc As String
Private C_newDoc As String
Private C_PicFile As String
Private 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 Integer
Attribute ReplacePic.VB_Description = "查找FindStr,并替换为PicFile所指向的图片文件,替换次数由time参数确定,为0时，替换所有"

'********************************************************************************
'　　　　从Word.Range对象mysel中查找所有FindStr，并替换为PicFile图像
' 替换次数由time参数确定，为0时，替换所有
'********************************************************************************

If Len(C_PicFile) = 0 Then
C_ErrMsg = 2
Exit Function
End If

Dim i As Integer
Dim 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 = i
End Function

Public Function FindThis(FindStr As String) As Boolean
Attribute FindThis.VB_Description = "查找FindStr,如果模板中有FindStr则返回True"
If Len(FindStr) = 0 Then
C_ErrMsg = 2
Exit Function
End 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.Execute
End Function

Public Function ReplaceChar(FindStr As String, RepStr As String, Optional Time As Integer = 0) As Integer
Attribute 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 Function
End 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 If
End Function

Public Function GetPic(PicData() As Byte, FileName As String) As Boolean
Attribute GetPic.VB_Description = "把图像数据PicData,存为PicFile指定的文件"
'********************************************************************************
'　　　　　把图像数据PicData,存为PicFile指定的文件
'********************************************************************************
On Error Resume Next

If Len(FileName) = 0 Then
C_ErrMsg = 2
RaiseEvent HaveError
Exit Function
End If

Open FileName For Binary As #1

If Err.Number <> 0 Then
C_ErrMsg = 3
Exit Function
End If

'二进制文件用Get,Put存放，读取数据
Put #1, , PicData
Close #1

C_PicFile = FileName
GetPic = True

End Function

Public Sub DeleteToEnd()
Attribute DeleteToEnd.VB_Description = "删除从当前位置到结尾的所有内容"
mysel.EndKey Unit:=wdStory, Extend:=wdExtend
mysel.Delete Unit:=wdCharacter, Count:=1
End Sub

Public Sub MoveEnd()
Attribute MoveEnd.VB_Description = "光标移动到文档结尾"
'光标移动到文档结尾
mysel.EndKey Unit:=wdStory
End 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.Add
Else
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赋值
'****************************************************************************URL查看 http://www.qqread.com/vb/o229253.html 更多内容请看VB与Word编程专题，或进入讨论组讨论。

【深 度 阅 读】 相 关 文 章

Word制作贺卡实例一则

轻松破解Word与Excel的文档密码

Word长文档的制作技巧

RAR和Word文件的解密与修复