背景:朋友工作中有多个Word文件,每次做更新时都要更新文档内的日期,每次手工更改都比较耗费时间,加上公司电脑不能装未授权的软件,且只支持英文,于是就根据这个需求,参考一些网上的代码,并做了一些升级,增加了界面、备份等功能,制作出这个VBA。下面是几个主要部分的VBA代码。
'窗体界面
Private Sub CommandButton1_Click() 'Replace按钮
Call Start_replace
Unload Me
End Sub
Private Sub CommandButton2_Click() 'Clear按钮
'CheckBox1.Value = False
'CheckBox2.Value = False
'CheckBox3.Value = False
'CheckBox4.Value = False
TextBox1.Value = ""
TextBox2.Value = ""
End Sub
'调用窗体界面(模块1)
Sub Replace_text()
UserForm1.Show
End Sub
'开始替换(模块2)
Public Sub Start_replace()
Application.ScreenUpdating = False '关闭屏幕闪
Dim myFile$, myPath$, backup_file, Backup_path, i%, myDoc As Object, myBackup As Object, myAPP As Object, txt$, Re_txt$
Set myAPP = New Word.Application
With Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
.Title = "选择目标文件夹"
If .Show = -1 Then
myPath = .SelectedItems(1) '读取选择的文件路径
Else
Exit Sub
End If
End With
myPath = myPath & ""
MatchCase_Value = UserForm1.CheckBox1.Value
MatchWholeWord_Value = UserForm1.CheckBox2.Value
MatchByte_Value = UserForm1.CheckBox3.Value
MatchWildcards_Value = UserForm1.CheckBox4.Value
Backup = UserForm1.CheckBox5.Value
Be_replaced = UserForm1.TextBox1.Value
Replace_with = UserForm1.TextBox2.Value
txt = Be_replaced
Re_txt = Replace_with
myAPP.Visible = True '是否显示打开文档
'Backup
If (Backup = True) Then
Backup_path = "E:\backup\"
backup_file = Dir(myPath & "\*.doc*")
Do While backup_file <> ""
Set myBackup = myAPP.Documents.Open(myPath & "\" & backup_file)
myBackup.SaveAs "E:\backup\" & backup_file
myBackup.Close
backup_file = Dir
Loop
End If
'Replace
myFile = Dir(myPath & "\*.doc*")
Count = 0
Do While myFile <> "" '文件不为空
Set myDoc = myAPP.Documents.Open(myPath & "\" & myFile)
If myDoc.ProtectionType = wdNoProtection Then '是否受保护
With myDoc.Content.Find
.Text = txt
.Replacement.Text = Re_txt
.Forward = True
.Wrap = 2
.Format = False
.MatchCase = MatchCase_Value
.MatchWholeWord = MatchWholeWord_Value
.MatchByte = MatchByte_Value
.MatchWildcards = MatchWildcards_Value
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
End If
myDoc.Save
myDoc.Close
myFile = Dir
Count = Count + 1
Loop
myAPP.Quit '关掉临时进程
Application.ScreenUpdating = True
If (Backup = True) Then
MsgBox (Count & " documents replaced successfully and backup in " & Backup_path)
ElseIf (Backup = False) Then
MsgBox (Count & " documents replaced successfully!")
End If
End Sub
- 不足之处:目前还只能对一个文件夹里的全部word批量替换,不能进行选择;不能实时查看到匹配到内容,所以建议替换时将文件拷贝到临时文件夹再进行替换。(尽管有备份功能)
- 本文Word下载地址
链接:https://pan.baidu.com/s/1ZsrfjK3GY4cLOlkm-h12rQ
提取码:mup5