指定フォルダ以下のパワーポイントファイル内の文字列を一括置換するVBScript

ちょっと必要だったので作りました。
拡張子とあと他ちょこっといじればExcelとかWordにも転用できると思います。

テンポラリな用途なのでかなり乱暴に書いてます。
置換作業前に開いてるファイルの保存を必ずして下さい。
作業中のファイルが消えてしまいます（やっちまいました）。

msgbox "Powerpointが起動中の場合は、終了してから操作を行なって下さい。"

Dim folderPath
folderPath = InputBox("フォルダパスを入力して下さい。","指定フォルダ以下のファイルの文字列を置換します。")

Dim sysObj
Set sysObj = CreateObject("Scripting.FileSystemObject")
if sysObj.FolderExists(folderPath) = false then
    msgbox "不正なフォルダです"
    WScript.Quit
end if

Dim fromStr
Dim toStr

fromStr = InputBox("置換する元の文字列を入力して下さい。","置換する元の文字列を入力して下さい。")
if fromStr = "" then
    '置換前が指定されなければ終了
    WScript.Quit
end if

toStr = InputBox("置換後の文字列を入力して下さい。","置換後の文字列を入力して下さい。")

if msgbox(folderPath & "以下のパワポファイルを" & fromStr & "から" & toStr  & "に置換してもいいですか？",vbYesNo + vbQuestion) = vbYes then

    Dim poworPoint
    Set poworPoint = CreateObject("PowerPoint.Application")
    poworPoint.Visible = True
    Dim Target

    '指定フォルダの中のファイル
    For Each oFile In sysObj.GetFolder(folderPath).files
     Target =  oFile.Name
     '拡張子の判別
      If LCase(sysObj.GetExtensionName(Target)) = "ppt" Or LCase(sysObj.GetExtensionName(Target)) = "pptx" Then
       ''Targetに対する処理
       Call repSub(folderPath & "\" & Target, fromStr,toStr, poworPoint)
      End If
    Next

    poworPoint.Quit
    Set poworPoint = Nothing
end if

Sub repSub(filePath, fromStr, toStr, poworPoint)
On Error Resume Next
  With poworPoint.Presentations.Open(filePath)
  For Each myS In poworPoint.ActivePresentation.Slides
     For Each mySP In myS.Shapes
       mySP.TextFrame.TextRange = Replace(mySP.TextFrame.TextRange, fromStr, toStr)
     Next
  Next
 .Save
 .Close
  End With
End Sub

補足
こちらを参考にしました→ http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1016644705