【word关键字替换】

必需安装office

office的安装就不说了。对于wps它默认使用的JS，如果你安装VB包应该也可以。也可以自己用js在WPS上写一个。

对于office可以自己使用word的宏功能写出来，这里记录一下自己简单写的

Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
'判断文件是否打开，若打开就将其关闭
Function WordDocIsOpen(ByVal strDocName As String) As Boolean
 	Dim objWordApp As Object
	Dim objWordDoc As Object

	On Error Resume Next '此句不能少

    strDocName = UCase$(strDocName)
    Set objWordApp = GetObject(, "Word.Application")
    For Each objWordDoc In objWordApp.Documents
        If UCase$(objWordDoc.FullName) = strDocName Then
            objWordDoc.Close '如果文件已被打开，则先将其关闭
            WordDocIsOpen = True
            Exit For
        End If
        Next
            Set objWordDoc = Nothing
            Set objWordApp = Nothing
End Function

Sub SleepEx(T As Long) '防止卡UI
    Dim time1 As Long
    time1 = timeGetTime
    Do
    DoEvents
    Loop While timeGetTime - time1 < T
End Sub

Private Sub CommandButton1_Click()
'Application.ScreenUpdating = False'屏蔽该行能实时显示
Dim fileNumNow$, fileNum As Integer, myDocFile$, myTmpFile$, myPath$, i%, myDoc As Object, myAPP As Object, txt$, Re_txt$

Set myAPP = New Word.Application

'Set myTB1 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 350, 72, 90, 80)
ActiveDocument.Shapes.Range(Array("Text Box 3")).Select
Selection.ShapeRange.TextFrame.TextRange = ""
ActiveDocument.Shapes.Range(Array("Text Box 2")).Select
Selection.ShapeRange.TextFrame.TextRange = ""
'myTB1.TextFrame.TextRange = ""
'Application.ScreenRefresh'刷新界面无用

'myTB1.Select
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "选择目标文件夹"
    If .Show = -1 Then
      myPath = .SelectedItems(1)
    Else
      Selection.ShapeRange.TextFrame.TextRange = ""
      'Selection.ShapeRange.Delete
      myAPP.Quit '关掉临时进程
      Exit Sub
    End If
End With

myPath = myPath & "\"
myDocFile = Dir(myPath & "*.doc*")
txt = InputBox("需要替换的文字：")
Re_txt = InputBox("替换成：")
myAPP.Visible = False '是否显示打开文档
'替换doc文 件
Do While myDocFile <> ""
    If WordDocIsOpen(myPath & myDocFile) = False Then '如果文件已被打开，则先将其关闭后再执行替换
        On Error GoTo PROC_ERR1
        Set myDoc = myAPP.Documents.Open(myPath & myDocFile)

        If myDoc.ProtectionType = wdNoProtection Then '是否受保护
            With myDoc.Content.Find
                .Text = txt
                .Replacement.Text = Re_txt
                .Forward = True
                .Wrap = 2
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2
                
            End With
            With myDoc
                .UpdateStylesOnOpen = False
                .AttachedTemplate = ""
                .RemovePersonalInformation = True
            End With

        End If
        myDoc.Save
        myDoc.Close
        myAPP.Visible = False '是否显示打开文档
        myDocFile = Dir '转到下一个文件
        fileNum = fileNum + 1
        fileNumNow = ("已修改" & fileNum & "个文档")
        ActiveDocument.Shapes.Range(Array("Text Box 2")).Select
        Selection.ShapeRange.TextFrame.TextRange = fileNumNow
        SleepEx (20)
PROC_ERR1:     '这里正确了也会进去
        If Err.Number > 0 Then
            ActiveDocument.Shapes.Range(Array("Text Box 3")).Select
            fileNumNow = ("“" & myDocFile & "”" & "文件操作失败")
            Selection.TypeText Text:=fileNumNow
            Selection.TypeParagraph
            myDocFile = Dir '转到下一个文件
            myAPP.Visible = False '是否显示打开文档
        On Error GoTo -1 '处理掉前面的出错进程，又开启一个新的，也会报错
        End If
    End If
Loop

'难得研究，直接复制上面替换tmp文件内容
myTmpFile = Dir(myPath & "*.tmp*")
Do While myTmpFile <> ""
    If WordDocIsOpen(myPath & myTmpFile) = False Then '如果文件已被打开，则先将其关闭后再执行替换
        On Error GoTo PROC_ERR2
        Set myDoc = myAPP.Documents.Open(myPath & myTmpFile)

        If myDoc.ProtectionType = wdNoProtection Then '是否受保护
            With myDoc.Content.Find
                .Text = txt
                .Replacement.Text = Re_txt
                .Forward = True
                .Wrap = 2
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2
                
            End With
            With myDoc
                .UpdateStylesOnOpen = False
                .AttachedTemplate = ""
                .RemovePersonalInformation = False
            End With

        End If
        myDoc.Save
        myDoc.Close

        myTmpFile = Dir '转到下一个文件
        fileNum = fileNum + 1
        fileNumNow = ("已修改" & fileNum & "个文档")
        ActiveDocument.Shapes.Range(Array("Text Box 2")).Select
        Selection.ShapeRange.TextFrame.TextRange = fileNumNow
        SleepEx (20)
PROC_ERR2:     '这里正确了也会进去
        If Err.Number > 0 Then
            ActiveDocument.Shapes.Range(Array("Text Box 3")).Select
            fileNumNow = ("“" & myTmpFile & "”" & "文件操作失败")
            Selection.TypeText Text:=fileNumNow
            Selection.TypeParagraph
            myTmpFile = Dir '转到下一个文件
        On Error GoTo -1 '处理掉前面的出错进程，又开启一个新的，也会报错
        End If
    End If
Loop
    myAPP.Quit '关掉临时进程
    
    'Application.ScreenUpdating = True
    ActiveDocument.Shapes.Range(Array("Text Box 2")).Select
    Selection.ShapeRange.TextFrame.TextRange = ""
    
    'myTB1.Select
    'Selection.ShapeRange.Delete
    MsgBox ("全部替换完毕！")
End Sub

也可以通过下面连接直接下载原文件
链接：https://pan.baidu.com/s/1fHOh-8TG18ZGkOnP7tS1eg
提取码：qwer