ExcelVBAにて図の挿入について

Question

実現したいこと

Excelのリボンタグから挿入→図→正方形を選択
の部分まで行いたいと思っております。

前提

前提としてVBAで実装予定です。
Shapes.AddPictureで作成される図の場合該当処理をした時点で作成が完了されてしまうのですが、行いたいのはマウスで作成する動作になります。

試したこと

現在下記のサイトを参考に挿入タブまで選択できたのですが知識が不足しているためそちら以降の作業が分かっておりません。
https://www.ka-net.org/blog/?p=4624

###ソース

Option Explicit
 
Public Sub Sample()
  SelectRibbonTab "挿入"
End Sub
 
Public Sub SelectRibbonTab(ByVal tabName As String)
'リボンのタブを選択
  Dim uiAuto As UIAutomationClient.CUIAutomation
  Dim elmRibbon As UIAutomationClient.IUIAutomationElement
  Dim elmRibbonTab As UIAutomationClient.IUIAutomationElement
  Dim cndProperty As UIAutomationClient.IUIAutomationCondition
  Dim aryRibbonTab As UIAutomationClient.IUIAutomationElementArray
  Dim ptnAcc As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
  Dim accRibbon As Office.IAccessible
  Dim i As Long

  Set elmRibbonTab = Nothing '初期化
  Set uiAuto = New UIAutomationClient.CUIAutomation
  Set accRibbon = Application.CommandBars("Ribbon")
  Set elmRibbon = uiAuto.ElementFromIAccessible(accRibbon, 0)
  Set cndProperty = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "NetUIRibbonTab")
  Set aryRibbonTab = elmRibbon.FindAll(TreeScope_Subtree, cndProperty)
  For i = 0 To aryRibbonTab.Length - 1
    Debug.Print "CurrentName" & aryRibbonTab.GetElement(i).CurrentName
    If aryRibbonTab.GetElement(i).CurrentName = tabName Then
      Set elmRibbonTab = aryRibbonTab.GetElement(i)
      Exit For
    End If
  Next
  If elmRibbonTab Is Nothing Then Exit Sub
    Set ptnAcc = elmRibbonTab.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
  ptnAcc.DoDefaultAction
  
  
End Sub

有識者の方、または試したことがあるかたよろしければ助言をいただきたいです。

Comments

[meg_]

> 現在下記のサイトを参考に挿入タブまで選択できた
コードを質問に追記してください。

[kazuuumi]

すみません追記いたします。

Answer 1

SaYGOさんの指摘から若干の修正。
現状開いているアクティブブックを指定して図形を取得するよう修正

Option Explicit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'途中でコメントアウトしているSleep関数を使う場合は↑のコメントを外す
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'FindWindowを使用できるようにするため追加


Public Sub 正方形選択()

  On Error GoTo ErrorLabel
    
  Dim uia As New CUIAutomation
  Dim rootElement As IUIAutomationElement
  Dim Hwnd As Long
  Dim WinName As String
  WinName = ActiveWorkbook.name & " - Excel"
  Hwnd = FindWindow(vbNullString, WinName)
  Set rootElement = uia.ElementFromHandle(ByVal Hwnd)
  'Set rootElement = uia.GetRootElement 元処理
  
  'クイックアクセスツールバーに追加しておく必要がある
  Dim element As IUIAutomationElement
  Set element = GetSayGOChildElement(uia, rootElement, "図形", "NetUIAnchor")
  Dim menupane As IUIAutomationExpandCollapsePattern
  '図形メニューペーンを展開する。
  Set menupane = element.GetCurrentPattern(UIA_ExpandCollapsePatternId)
  menupane.Expand
  
  Sleep 100 'うまく選択されない場合はここと冒頭のコメントを外して調整。
  DoEvents 'クリック扱いになるのを防ぐ
  
  Set element = GetSayGOChildElement(uia, element, "正方形/長方形", "NetUIGalleryButton")
  
  'IUIAutomationInvokePattern だと図形が挿入されてしまう。
  Dim invokePattern As IUIAutomationSelectionItemPattern
  Set invokePattern = element.GetCurrentPattern(UIA_SelectionItemPatternId)
  invokePattern.Select
  
  
ErrorLabel:
      Debug.Print Err.Number & " " & Err.Description
      
End Sub


'指定したエレメント名、クラス名に該当する子要素を返す
Private Function GetSayGOChildElement( _
    ByRef uia As CUIAutomation, _
    ByRef parentElement As IUIAutomationElement, _
    elementName As String, _
    className As String _
  ) As IUIAutomationElement
  
  Dim element As IUIAutomationElement
  Dim cndName As IUIAutomationCondition
  Dim cndClassName As IUIAutomationCondition
  Dim cndNameAndClassName As IUIAutomationCondition
  
  Set element = Nothing
  Set cndName = uia.CreatePropertyCondition(UIA_NamePropertyId, elementName)
  Set cndClassName = uia.CreatePropertyCondition(UIA_ClassNamePropertyId, className)
  Set cndNameAndClassName = uia.CreateAndCondition(cndName, cndClassName)
  Set element = parentElement.FindFirst(TreeScope_Subtree, cndNameAndClassName)
  
  If element Is Nothing Then
    Set GetSayGOChildElement = Nothing
    Call Err.Raise(90000, "GetSayGOChildElement", "エラー：名前:「" & elementName & "」、クラス名「" & className & "」に該当するエレメントが見つかりませんでした")
  End If
  Set GetSayGOChildElement = element
  
End Function

Answer 2

質問中にあるようなコードは、リボン内のメニュー構造にかなり依存します。
つまり、異なるバージョンのエクセル（アップデート含む）では、メニュー構造やクラス名が異なってしまうため、バージョンごとにinspecter等で構造を調べコードを適切に組み替えないとすぐ動かなくなります。
（構造だけではなく、処理依存で出現するモーダルダイアログの処理や、コンポーネントごとにクリックや選択の挙動が全然異なるということもあります。ですので個人的にこの手のオートメーションを自作で行うのは茨の道と思っています。）

なお下記は参考として、自分の環境（Windows 11 Pro 64bit のMicrosoft 365 EXCEL バージョン2308）で動くコードです。
（実行するとカーソルが十字になって四角形描画モードになります）

'Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
'途中でコメントアウトしているSleep関数を使う場合は↑のコメントを外す

Public Sub 正方形選択()
    
  Dim uia As New CUIAutomation
  Dim rootElement As IUIAutomationElement
  Set rootElement = uia.GetRootElement
  
  Dim element As IUIAutomationElement
  '以下は環境依存。inspecter.exeなどで調べる。
  Set element = GetSayGOChildElement(uia, rootElement, "図形", "NetUIAnchor")
  '図形メニューペーンを展開する。
  Dim menupane As IUIAutomationExpandCollapsePattern
  Set menupane = element.GetCurrentPattern(UIA_ExpandCollapsePatternId)
  menupane.expand
  
  'Sleep 100 'うまく選択されない場合はここと冒頭のコメントを外して調整。
  DoEvents 'クリック扱いになるのを防ぐ。
  
  ' 以下は環境依存。inspecter.exeなどで調べる。
  Set element = GetSayGOChildElement(uia, element, "図形", "NetUIToolWindow")
  Set element = GetSayGOChildElement(uia, element, "図形", "NetUIGalleryContainer")
  Set element = GetSayGOChildElement(uia, element, "四角形", "NetUIGalleryCategoryContainer")
  Set element = GetSayGOChildElement(uia, element, "正方形/長方形", "NetUIGalleryButton")

  'IUIAutomationInvokePattern だと図形が挿入されてしまう。  
  Dim invokePattern As IUIAutomationSelectionItemPattern
  Set invokePattern = element.GetCurrentPattern(UIA_SelectionItemPatternId)
  invokePattern.Select
  
End Sub


'指定したエレメント名、クラス名に該当する子要素を返す
Private Function GetSayGOChildElement( _
    ByRef uia As CUIAutomation, _
    ByRef parentElement As IUIAutomationElement, _
    elementName As String, _
    className As String _
  ) As IUIAutomationElement
  
  Dim element As IUIAutomationElement
  Dim cndName As IUIAutomationCondition
  Dim cndClassName As IUIAutomationCondition
  Dim cndNameAndClassName As IUIAutomationCondition
  
  Set element = Nothing
  Set cndName = uia.CreatePropertyCondition(UIA_NamePropertyId, elementName)
  Set cndClassName = uia.CreatePropertyCondition(UIA_ClassNamePropertyId, className)
  Set cndNameAndClassName = uia.CreateAndCondition(cndName, cndClassName)
  Set element = parentElement.FindFirst(TreeScope_Subtree, cndNameAndClassName)
  
  If element Is Nothing Then
    Set GetSayGOChildElement = Nothing
    Debug.Print "エラー：名前:「" & elementName & "」、クラス名「" & className & "」に該当するエレメントが見つかりませんでした")
  End If
  Set GetSayGOChildElement = element
  
End Function

Comments

[kazuuumi]

ご指摘ありがとうございます。
まだまだ知識不足の面がありますが上記参考ソースをもとにこちらで試したところわたくしの環境(windows11 64bit Microsoft Office Personal 2021) でも同様の挙動をするところまで修正できました。
inspecterも入れるところからでしたので少し苦労いたしましたがおかげさまで構造把握が進んだ気がします。

ちなみにですが上記のようなソースは何を参考にされたか、もしくはどういった勉強をしたのか教えていただくことは可能でしょうか？

[退会済みユーザー]

上手くいったようでよかったです。
UIAutomation自体昨日初めて知った機能でしたので、まず記事のソースコードを皮切りに、キーワードで検索していろんなサイトのコードやMicrosoftの公式ドキュメント、vbaのオブジェクトブラウザを参照しながら片っ端から試して挙動を見て、少しずつ希望の動作にしていった感じです。
一番参考になったのは、
https://note.com/char0059/n/nf86b57b735ab
です。（この中にあるサンプルマクロが大変参考になった）
あとはinspecterとともに、uiAutomationSpyというツールです。

コードをすっきりさせるため関数化した部分（GetSayGOChildElement関数）は丸コピペとかではなくほぼ完全なオリジナルです。
あと図形ボタンを描画してしまわない（十字カーソル出現状態にする）ようにするためにはペーンを開いた状態でDoEventsを置き、かつIUIAutomationInvokePatternではなくIUIAutomationSelectionItemPatternを使うとうまくいく、というのも偶然見つけました。

４～５時間くらいで突貫で作ったものなので、まだまだブラッシュアップの余地はあると思います（たとえば現状のコードは、デスクトップ上の全ウィンドウから「図形」のボタンを検索するので、起動の動作が遅い）

追記：
バージョン違いでもある程度安定させる方法として、「正方形/長方形」のボタンをクイックツールバーに登録しておいて、クイックツールバーのエレメント経由で呼び出すという方法もあるな、と今さら思いました。

[kazuuumi]

はい！！ありがとうございました。
基本的に調べて書き出しを繰り返した形ですね。。
まだまだ調べる力が浅いと実感いたしました。
uiAutomationSpyに関しては少し自分も確認してみようと思います。

改善の余地があるとのことなので自分も少し調べてみたいと思います！