第1个回答 2011-06-24
宏就是一个偷懒的命令 编好一个宏以后可以1步解决很多繁琐的设置 宏可以在所有PPT中使用 前提要保存好 给你一个简单的宏
Sub 批量替换()
Dim ChangedCount As Integer
Dim FileName As String, Mask As String
Dim FindCount As Long
Dim CurPresentation As Presentation
Dim Path As String, FindString As String, ReplaceString As String
Dim oSld As Slide
Dim oShp As Shape
Dim oTxtRng As TextRange
Dim oTmpRng As TextRange
Path = InputBox("请输入路径名称：", "参数输入(1/3)")
FindString = InputBox("请输入查找文本：", "参数输入(2/3)")
ReplaceString = InputBox("请输入替换文本：", "参数输入(3/3)")
If Path = "" Or FindString = "" Or ReplaceString = "" Then
MsgBox "每个参数均不能为空！", vbCritical, "出错"
Exit Sub
End If
ChangedCount = 0
FindCount = 0
Mask = "*.ppt"
If Right(Path, 1) <> "\" Then Path = Path & "\"
FileName = Dir(Path & Mask)
On Error Resume Next
Err.Clear
Do Until FileName = ""
DoEvents
Set CurPresentation = Presentations.Open(FileName:=Path & FileName, ReadOnly:=msoFalse, WithWindow:=msoFalse)
For Each oSld In CurPresentation.Slides
For Each oShp In oSld.Shapes
Err.Clear
Set oTxtRng = oShp.TextFrame.TextRange
If Err.Number = 0 Then
Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
Replacewhat:=ReplaceString, MatchCase:=False, _
WholeWords:=True)
If oTmpRng Is Nothing Then oTxtRng = Replace(oTxtRng, FindString, ReplaceString, , , vbTextCompare)'解决中文无法替换问题（下同）
Do While Not oTmpRng Is Nothing
FindCount = FindCount + 1
Set oTxtRng = oTxtRng.Characters(oTmpRng.Start + oTmpRng.Length, _
oTxtRng.Length)
Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
Replacewhat:=ReplaceString, MatchCase:=False, _
WholeWords:=True)
If oTmpRng Is Nothing Then oTxtRng = Replace(oTxtRng, FindString, ReplaceString, , , vbTextCompare)
Loop
End If
Next oShp
Next oSld
CurPresentation.Save
CurPresentation.Close
FileName = Dir
Loop
MsgBox "替换完毕！"
Close
End Sub