怎么样使用vb控制word的类模块？

在ＶＢ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赋值

'********************************************************************************

Set mywdapp = CreateObject("word.application")

If Err.Number <> 0 Then

C_ErrMsg = 1

RaiseEvent HaveError

Exit Sub

End If

End Sub

Public Sub ViewDoc()

Attribute ViewDoc.VB_Description = "显示Word程序界面"

mywdapp.Visible = True

End Sub

Public Sub AddNewPage()

Attribute AddNewPage.VB_Description = "插入分页符"

mysel.InsertBreak Type:=wdPageBreak

End Sub

Public Sub WordCut()

Attribute WordCut.VB_Description = "剪切模板所有内容到剪切板"

'保存模板页面内容

mysel.WholeStory

mysel.Cut

mysel.HomeKey Unit:=wdStory

End Sub

Public Sub WordCopy()

Attribute WordCopy.VB_Description = "拷贝模板所有内容到剪切板"

mysel.WholeStory

mysel.Copy

mysel.HomeKey Unit:=wdStory

End Sub

Public Sub WordDel()

mysel.WholeStory

mysel.Delete

mysel.HomeKey Unit:=wdStory

End Sub

Public Sub WordPaste()

Attribute WordPaste.VB_Description = "拷贝剪切板内容到当前位置"

'插入模块内容

mysel.Paste

End Sub

Public Sub CloseDoc()

Attribute CloseDoc.VB_Description = "关闭Word文件模板"

'********************************************************************************

'关闭Word文件模本

'********************************************************************************

On Error Resume Next

mywdapp.ActiveDocument.Close False

If Err.Number <> 0 Then

C_ErrMsg = 3

Exit Sub

End If

End Sub

Public Sub QuitWord()

'********************************************************************************

'关闭Word程序

'********************************************************************************

On Error Resume Next

mywdapp.Quit

If Err.Number <> 0 Then

C_ErrMsg = 3

Exit Sub

End If

End Sub

Public Sub SavetoDoc()

Attribute SavetoDoc.VB_Description = "保存当前文档为FileName指定文件"

On Error Resume Next

'并另存为文件FileName

If Len(C_newDoc) = 0 Then

C_ErrMsg = 2

RaiseEvent HaveError

Exit Sub

End If

mywdapp.ActiveDocument.SaveAs (C_newDoc)

If Err.Number <> 0 Then

C_ErrMsg = 3

RaiseEvent HaveError

Exit Sub

End If

End Sub

Public Property Get TemplateDoc() As String

Attribute TemplateDoc.VB_Description = "模板文件名."

TemplateDoc = C_TemplateDoc

End Property

Public Property Let TemplateDoc(ByVal vNewValue As String)

C_TemplateDoc = vNewValue

End Property

Public Property Get newdoc() As String

Attribute newdoc.VB_Description = "执行CloseDoc方法时，将模板文件另存为此文件名指定的新文件.如果不指定，在执行CloseDoc方法时，将产生一个错误"

newdoc = C_newDoc

End Property

Public Property Let newdoc(ByVal vNewValue As String)

C_newDoc = vNewValue

End Property

Public Property Get PicFile() As String

Attribute PicFile.VB_Description = "图像文件名"

PicFile = C_PicFile

End Property

Public Property Let PicFile(ByVal vNewValue As String)

C_PicFile = vNewValue

End Property

Public Property Get ErrMsg() As Integer

Attribute ErrMsg.VB_Description = "错误信息.ErrMsg代码: 1-word没有安装 2-缺少参数 3-没权限写文件 4-文件不存在"

ErrMsg = C_ErrMsg

End Property

本文地址：http://www.45fan.com/a/question/68083.html