批量替换ppt内容_在office宏中运行即可

批量替换ppt内容_在office宏中运行即可

Sub 批量替换ppt内容()
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