名前を付けて保存ダイアログから「図の圧縮」を実行してファイルを保存するVBAマクロ 関連Webサイト：https://note.com/kinuasa/n/n52b890e9b2cf

SavePicCompressedFile.vb

Option Explicit

Public Sub Sample()
  Dim SaveFilePath As String, DocumentTitle As String
  Dim wb As Excel.Workbook
  Const TargetWorkbookPath As String = "C:\Test\Excel\SampleImageFile.xlsx"
  
  With CreateObject("Scripting.FileSystemObject")
    SaveFilePath = .BuildPath(.GetParentFolderName(TargetWorkbookPath), "Compressed_" & .GetFileName(TargetWorkbookPath))
    DocumentTitle = .GetBaseName(TargetWorkbookPath)
  End With
  Set wb = Application.Workbooks.Open(TargetWorkbookPath)
  SavePicCompressedFile wb, DocumentTitle, SaveFilePath, "Web (150 ppi)"
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

'名前を付けて保存ダイアログから「図の圧縮」を実行してファイルを保存
Private Sub SavePicCompressedFile(ByVal TargetWorkbook As Excel.Workbook, _
                                  ByVal DocumentTitle As String, _
                                  ByVal SaveFilePath As String, _
                                  Optional ByVal ResolutionItem As String = "電子メール用 (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
      Exit Sub
  End Select
  
  '保存先ファイルが存在する場合は事前に削除
  Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
  If Fso.FileExists(SaveFilePath) = True Then Fso.DeleteFile SaveFilePath, True
  
  'スクリプト出力(Tempフォルダ)
  Dim ScriptFilePath As String
  Const TemporaryFolder = 2
  Const adCRLF = -1
  Const adSaveCreateOverWrite = 2
  Const adTypeText = 2
  Const adWriteLine = 1
  ScriptFilePath = Fso.BuildPath(Fso.GetSpecialFolder(TemporaryFolder).Path, "SavePicCompressedFile.ps1")
  If Fso.FileExists(ScriptFilePath) = False Then
    With CreateObject("ADODB.Stream")
      .Type = adTypeText
      .Charset = "UTF-8"
      .LineSeparator = adCRLF
      .Open
      .Position = 0
      .WriteText GetScriptCode, adWriteLine
      .SaveToFile ScriptFilePath, adSaveCreateOverWrite
      .Close
    End With
  End If
  
  'スクリプト実行
  Dim Com As String
  Com = "PowerShell -NoProfile -ExecutionPolicy Bypass -File """ & ScriptFilePath & """ ""XLMAIN"" """ & DocumentTitle & """ """ & SaveFilePath & """ """ & ResolutionItem & """"
  Shell Com, vbMinimizedFocus
  TargetWorkbook.Activate
  TargetWorkbook.Application.CommandBars.ExecuteMso "FileSaveAs" '名前を付けて保存ダイアログ表示
  Fso.DeleteFile ScriptFilePath, True '実行後にスクリプトファイルを削除
  TargetWorkbook.Close Savechanges:=False '処理後は対象ブックを保存せずに閉じる
End Sub

'スクリプトのコード取得
Private Function GetScriptCode() As String
  Dim Com As String
    Com = Com & "Param(" & vbNewLine
  Com = Com & "  [parameter(Mandatory=$true)][ValidateSet(""XLMAIN"", ""OpusApp"", ""PPTFrameClass"")][string]$ClassName," & vbNewLine
  Com = Com & "  [parameter(Mandatory=$true)][string]$DocumentTitle," & vbNewLine
  Com = Com & "  [parameter(Mandatory=$true)][string]$SaveFilePath," & vbNewLine
  Com = Com & "  [parameter(Mandatory=$true)][string]$ResolutionItem" & vbNewLine
  Com = Com & ")" & vbNewLine
  Com = Com & "" & vbNewLine
  Com = Com & "$source = @""" & vbNewLine
  Com = Com & "using System;" & vbNewLine
  Com = Com & "using System.Threading;" & vbNewLine
  Com = Com & "using System.Windows.Automation;" & vbNewLine
  Com = Com & "namespace UIAutTools" & vbNewLine
  Com = Com & "{" & vbNewLine
  Com = Com & "    public class Element" & vbNewLine
  Com = Com & "    {" & vbNewLine
  Com = Com & "        public static void SavePicCompressedFile(string className, string documentTitle, string saveFilePath, string resolutionItem)" & vbNewLine
  Com = Com & "        {" & vbNewLine
  Com = Com & "            Thread.Sleep(200);" & vbNewLine
  Com = Com & "            //名前を付けて保存ダイアログ取得" & vbNewLine
  Com = Com & "            AutomationElement elmApp = null;" & vbNewLine
  Com = Com & "            PropertyCondition cndAppCollection = new PropertyCondition(AutomationElement.ClassNameProperty, className, PropertyConditionFlags.IgnoreCase);" & vbNewLine
  Com = Com & "            foreach (AutomationElement app in AutomationElement.RootElement.FindAll(TreeScope.Children, cndAppCollection))" & vbNewLine
  Com = Com & "            {" & vbNewLine
  Com = Com & "                if (app.Current.Name.Contains(documentTitle))" & vbNewLine
  Com = Com & "                {" & vbNewLine
  Com = Com & "                    elmApp = app;" & vbNewLine
  Com = Com & "                    break;" & vbNewLine
  Com = Com & "                }" & vbNewLine
  Com = Com & "            }" & vbNewLine
  Com = Com & "            if (elmApp == null) { return; }" & vbNewLine
  Com = Com & "            AndCondition cndSaveAsDialog = new AndCondition(new Condition[] { new PropertyCondition(AutomationElement.NameProperty, ""名前を付けて保存""), new PropertyCondition(AutomationElement.ClassNameProperty, ""#32770"") });" & vbNewLine
  Com = Com & "            AutomationElement elmSaveAsDialog = elmApp.FindFirst(TreeScope.Subtree, cndSaveAsDialog);" & vbNewLine
  Com = Com & "            if (elmSaveAsDialog == null) { return; }" & vbNewLine
  Com = Com & "" & vbNewLine
  Com = Com & "            //ツール(L) -> 「図(画像)の圧縮」項目選択" & vbNewLine
  Com = Com & "            AndCondition cndToolMenuItem = new AndCondition(new Condition[] { new PropertyCondition(AutomationElement.NameProperty, ""ツール(L)""), new PropertyCondition(AutomationElement.ControlTypeProperty, ControlType.MenuItem) });" & vbNewLine
  Com = Com & "            AutomationElement elmToolMenuItem = elmSaveAsDialog.FindFirst(TreeScope.Subtree, cndToolMenuItem);" & vbNewLine
  Com = Com & "            InvokePattern iptnToolMenuItem = elmToolMenuItem.GetCurrentPattern(InvokePattern.Pattern) as InvokePattern;" & vbNewLine
  Com = Com & "            iptnToolMenuItem.Invoke();" & vbNewLine
  Com = Com & "            AndCondition cndContextMenu = new AndCondition(new Condition[] { new PropertyCondition(AutomationElement.ClassNameProperty, ""#32768""), new PropertyCondition(AutomationElement.ControlTypeProperty, ControlType.Menu) });" & vbNewLine
  Com = Com & "            AutomationElement elmContextMenu = AutomationElement.RootElement.FindFirst(TreeScope.Children, cndContextMenu);" & vbNewLine
  Com = Com & "            PropertyCondition cndPicCompressMenuItem = new PropertyCondition(AutomationElement.NameProperty, ""図の圧縮(C)...""); //Excel" & vbNewLine
  Com = Com & "            AutomationElement elmPicCompressMenuItem = elmContextMenu.FindFirst(TreeScope.Children, cndPicCompressMenuItem);" & vbNewLine
  Com = Com & "            if (elmPicCompressMenuItem == null)" & vbNewLine
  Com = Com & "            {" & vbNewLine
  Com = Com & "                cndPicCompressMenuItem = new PropertyCondition(AutomationElement.NameProperty, ""図の圧縮(P)...""); //Word" & vbNewLine
  Com = Com & "                elmPicCompressMenuItem = elmContextMenu.FindFirst(TreeScope.Children, cndPicCompressMenuItem);" & vbNewLine
  Com = Com & "" & vbNewLine
  Com = Com & "            }" & vbNewLine
  Com = Com & "            if (elmPicCompressMenuItem == null)" & vbNewLine
  Com = Com & "            {" & vbNewLine
  Com = Com & "                cndPicCompressMenuItem = new PropertyCondition(AutomationElement.NameProperty, ""画像の圧縮(C)...""); //PowerPoint" & vbNewLine
  Com = Com & "                elmPicCompressMenuItem = elmContextMenu.FindFirst(TreeScope.Children, cndPicCompressMenuItem);" & vbNewLine
  Com = Com & "" & vbNewLine
  Com = Com & "            }" & vbNewLine
  Com = Com & "            InvokePattern iptnPicCompressMenuItem = elmPicCompressMenuItem.GetCurrentPattern(InvokePattern.Pattern) as InvokePattern;" & vbNewLine
  Com = Com & "            iptnPicCompressMenuItem.Invoke();" & vbNewLine
  Com = Com & "            Thread.Sleep(200);" & vbNewLine
  Com = Com & "" & vbNewLine
  Com = Com & "            //画像の圧縮ダイアログ取得" & vbNewLine
  Com = Com & "            AndCondition cndPicCompressDialog = new AndCondition(new Condition[] { new PropertyCondition(AutomationElement.NameProperty, ""画像の圧縮""), new PropertyCondition(AutomationElement.ClassNameProperty, ""NUIDialog"") });" & vbNewLine
  Com = Com & "            AutomationElement elmPicCompressDialog = elmApp.FindFirst(TreeScope.Subtree, cndPicCompressDialog);" & vbNewLine
  Com = Com & "            if (elmPicCompressDialog == null) { return; }" & vbNewLine
  Com = Com & "" & vbNewLine
  Com = Com & "            //解像度ラジオボタン選択" & vbNewLine
  Com = Com & "            PropertyCondition cndResRadioGroup = new PropertyCondition(AutomationElement.ClassNameProperty, ""NetUIRadioGroup"");" & vbNewLine
  Com = Com & "            AutomationElement elmResRadioGroup = elmPicCompressDialog.FindFirst(TreeScope.Subtree, cndResRadioGroup);" & vbNewLine
  Com = Com & "            PropertyCondition cndResRadioButton = new PropertyCondition(AutomationElement.ClassNameProperty, ""NetUIRadioButton"");" & vbNewLine
  Com = Com & "            foreach (AutomationElement elmResRadioButton in elmResRadioGroup.FindAll(TreeScope.Subtree, cndResRadioButton))" & vbNewLine
  Com = Com & "            {" & vbNewLine
  Com = Com & "                if (elmResRadioButton.Current.Name.Contains(resolutionItem))" & vbNewLine
  Com = Com & "                {" & vbNewLine
  Com = Com & "                    SelectionItemPattern sptnResRadioButton = elmResRadioButton.GetCurrentPattern(SelectionItemPattern.Pattern) as SelectionItemPattern;" & vbNewLine
  Com = Com & "                    sptnResRadioButton.Select();" & vbNewLine
  Com = Com & "                    break;" & vbNewLine
  Com = Com & "                }" & vbNewLine
  Com = Com & "            }" & vbNewLine
  Com = Com & "" & vbNewLine
  Com = Com & "            //OKボタン(画像の圧縮ダイアログ)クリック" & vbNewLine
  Com = Com & "            AndCondition cndPicCompressOKButton = new AndCondition(new Condition[] { new PropertyCondition(AutomationElement.NameProperty, ""OK""), new PropertyCondition(AutomationElement.ClassNameProperty, ""NetUIButton"") });" & vbNewLine
  Com = Com & "            AutomationElement elmPicCompressOKButton = elmPicCompressDialog.FindFirst(TreeScope.Subtree, cndPicCompressOKButton);" & vbNewLine
  Com = Com & "            InvokePattern iptnPicCompressOKButton = elmPicCompressOKButton.GetCurrentPattern(InvokePattern.Pattern) as InvokePattern;" & vbNewLine
  Com = Com & "            iptnPicCompressOKButton.Invoke();" & vbNewLine
  Com = Com & "" & vbNewLine
  Com = Com & "            //ファイル名入力" & vbNewLine
  Com = Com & "            AndCondition cndFileNameEditControl = new AndCondition(new Condition[] { new PropertyCondition(AutomationElement.NameProperty, ""ファイル名:""), new PropertyCondition(AutomationElement.ControlTypeProperty, ControlType.Edit) });" & vbNewLine
  Com = Com & "            AutomationElement elmFileNameEditControl = elmSaveAsDialog.FindFirst(TreeScope.Subtree, cndFileNameEditControl);" & vbNewLine
  Com = Com & "            ValuePattern vptnFileNameEditControl = elmFileNameEditControl.GetCurrentPattern(ValuePattern.Pattern) as ValuePattern;" & vbNewLine
  Com = Com & "            vptnFileNameEditControl.SetValue(saveFilePath);" & vbNewLine
  Com = Com & "" & vbNewLine
  Com = Com & "            //保存(S)ボタンクリック" & vbNewLine
  Com = Com & "            AndCondition cndSaveButton = new AndCondition(new Condition[] { new PropertyCondition(AutomationElement.NameProperty, ""保存(S)""), new PropertyCondition(AutomationElement.ClassNameProperty, ""Button"") });" & vbNewLine
  Com = Com & "            AutomationElement elmSaveButton = elmSaveAsDialog.FindFirst(TreeScope.Subtree, cndSaveButton);" & vbNewLine
  Com = Com & "            InvokePattern iptnSaveButton = elmSaveButton.GetCurrentPattern(InvokePattern.Pattern) as InvokePattern;" & vbNewLine
  Com = Com & "            iptnSaveButton.Invoke();" & vbNewLine
  Com = Com & "        }" & vbNewLine
  Com = Com & "    }" & vbNewLine
  Com = Com & "}" & vbNewLine
  Com = Com & """@" & vbNewLine
  Com = Com & "Add-Type -TypeDefinition $source -ReferencedAssemblies(""UIAutomationClient"", ""UIAutomationTypes"")" & vbNewLine
  Com = Com & "[UIAutTools.Element]::SavePicCompressedFile($ClassName, $DocumentTitle, $SaveFilePath, $ResolutionItem)" & vbNewLine
  GetScriptCode = Com
End Function