快速替换多个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