程序设计 VB控制word的类模块,查找、替换Word文档内容【柳湾吧】

LLL_LYY
.
10

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

送TA礼物

IP属地:山西

1楼2009-04-04 21:14回复

LLL_LYY
.
10

        .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

IP属地:山西

2楼2009-04-04 21:14

南昌眠矿州催网络科技

已解答3分钟自测，在线测试分析您的身体情况如何，糖尿症的问题点击查看详情，立即进入自测

2025-04-05 02:37广告

立即查看

LLL_LYY
.
10

        .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

IP属地:山西

3楼2009-04-04 21:14

LLL_LYY
.
10

        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

IP属地:山西

4楼2009-04-04 21:14

LLL_LYY
.
10

    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

IP属地:山西

5楼2009-04-04 21:14

LLL_LYY
.
10

    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

IP属地:山西

6楼2009-04-04 21:14

日	一	二	三	四	五	六

程序设计 VB控制word的类模块,查找、替换Word文档内容

登录百度账号

扫二维码下载贴吧客户端