名前を付けて保存ダイアログを操作して図の圧縮を行うVBScript(Word・Excel・PowerPoint対応) 関連Webサイト：https://note.com/kinuasa/n/ndc0a547f1edd

CompressDocumentPictures.vbs

'****************************************************************************************************
' 
' 名前を付けて保存ダイアログを操作して図の圧縮を行うVBScript(Word・Excel・PowerPoint対応)
' @kinuasa
' 
' ※SavePicCompressedFile.ps1( https://gist.github.com/kinuasa/dc1436e8614aeb883a97d4fa0fbb0c3b )を同じフォルダに保存して実行
' 
'****************************************************************************************************

Option Explicit

'************************************************************
'「解像度」オプションの項目(必要に応じて変更)
'************************************************************
Const ResolutionItem = "電子メール用 (96 ppi)"
'************************************************************
Select Case ResolutionItem
  Case "元の画像の品質を保持", "HD (330 ppi)", "印刷用 (220 ppi)", "Web (150 ppi)", "電子メール用 (96 ppi)", "既定の解像度を適用"
  Case Else
    MsgBox "解像度のオプションは下記いずれかの値を指定してください：" & vbNewLine & vbNewLine & _
           "・元の画像の品質を保持" & vbNewLine & _
           "・HD (330 ppi)" & vbNewLine & _
           "・印刷用 (220 ppi)" & vbNewLine & _
           "・Web (150 ppi)" & vbNewLine & _
           "・電子メール用 (96 ppi)" & vbNewLine & _
           "・既定の解像度を適用", vbCritical + vbSystemModal
    WScript.Quit
End Select

Dim Args
Set Args = WScript.Arguments
If Args.Count < 1 Then
  MsgBox "図の圧縮を行いたいファイルを当スクリプトファイルにドラッグ＆ドロップしてください。", vbCritical + vbSystemModal
  WScript.Quit
End If

Dim ScriptFilePath
Dim Fso: Set Fso = CreateObject("Scripting.FileSystemObject")
Const ScriptFileName = "SavePicCompressedFile.ps1"
ScriptFilePath = Fso.BuildPath(Fso.GetParentFolderName(WScript.ScriptFullName), ScriptFileName)
If Fso.FileExists(ScriptFilePath) = False Then
  MsgBox "「" & ScriptFilePath & "」ファイルが見つかりません。" & vbNewLine & "当スクリプトと同じ場所に「" & ScriptFileName & "」ファイルを保存してください。", vbCritical + vbSystemModal
  WScript.Quit
End If

Dim Proc, Ps, Pid
Dim DocumentTitle, SaveFilePath, Com, i
Const SaveFilePrefix = "PicCompressed_" '保存先ファイルの接頭語(必要に応じて変更)
Const wdDoNotSaveChanges = 0
Const msoTrue = -1
Set Proc = GetObject("winmgmts:Win32_Process")
Set Ps = GetObject("winmgmts:Win32_ProcessStartup")
Ps.ShowWindow = 0
For i = 0 To Args.Count - 1
  DocumentTitle = Fso.GetBaseName(Args(i))
  SaveFilePath = Fso.BuildPath(Fso.GetParentFolderName(Args(i)), SaveFilePrefix & Fso.GetFileName(Args(i)))
  If Fso.FileExists(SaveFilePath) = True Then Fso.DeleteFile SaveFilePath, True '保存先ファイルが存在する場合は事前に削除
  Select Case LCase(Fso.GetExtensionName(Args(i)))
    'Wordファイル処理
    Case "docx", "docm", "doc"
      Com = "PowerShell -NoProfile -ExecutionPolicy Bypass -File """ & ScriptFilePath & """ ""OpusApp"" """ & DocumentTitle & """ """ & SaveFilePath & """ """ & ResolutionItem & """"
      With CreateObject("Word.Application")
        .Visible = True
        With .Documents.Open(Args(i))
          Proc.Create Com, , Ps, Pid
          .Application.CommandBars.ExecuteMso "FileSaveAs" '名前を付けて保存ダイアログ表示
          'ファイル作成待ち
          Do
            WScript.Sleep 100
          Loop While Not Fso.FileExists(SaveFilePath)
          .Close wdDoNotSaveChanges
        End With
        .Quit
      End With
    'Excelファイル処理
    Case "xlsx", "xlsm", "xls"
      Com = "PowerShell -NoProfile -ExecutionPolicy Bypass -File """ & ScriptFilePath & """ ""XLMAIN"" """ & DocumentTitle & """ """ & SaveFilePath & """ """ & ResolutionItem & """"
      With CreateObject("Excel.Application")
        .Visible = True
        With .Workbooks.Open(Args(i))
          Proc.Create Com, , Ps, Pid
          .Application.CommandBars.ExecuteMso "FileSaveAs" '名前を付けて保存ダイアログ表示
          'ファイル作成待ち
          Do
            WScript.Sleep 100
          Loop While Not Fso.FileExists(SaveFilePath)
          .Close False
        End With
        .Quit
      End With
    'PowerPointファイル処理
    Case "pptx", "pptm", "ppt"
      Com = "PowerShell -NoProfile -ExecutionPolicy Bypass -File """ & ScriptFilePath & """ ""PPTFrameClass"" """ & DocumentTitle & """ """ & SaveFilePath & """ """ & ResolutionItem & """"
      With CreateObject("PowerPoint.Application")
        .Visible = True
        With .Presentations.Open(Args(i))
          Proc.Create Com, , Ps, Pid
          .Application.CommandBars.ExecuteMso "FileSaveAs" '名前を付けて保存ダイアログ表示
          'ファイル作成待ち
          Do
            WScript.Sleep 100
          Loop While Not Fso.FileExists(SaveFilePath)
          .Saved = msoTrue
          .Close
        End With
        .Quit
      End With
    Case Else
      MsgBox "このファイルには対応していません：" & vbNewLine & Args(i), vbCritical + vbSystemModal
  End Select
Next
MsgBox "処理が終了しました。", vbInformation + vbSystemModal