ExcelVBAで図形内テキストを検索するアドイン自作

 1Option Explicit
 2
 3' ブックオープン時（アドイン読み込み時）にショートカットキー設定
 4Private Sub Workbook_Open()
 5    Application.OnKey "^+f", "showForm"  ' [Ctrl]+[Shift]+[f]
 6End Sub
 7
 8' ブッククローズ時にショートカットキー設定解除
 9Private Sub Workbook_BeforeClose(Cancel As Boolean)
10    Application.OnKey "^+f"   ' [Ctrl]+[Shift]+[f]
11End Sub

 1Option Explicit
 2
 3' 次を検索
 4Private Sub CommandButton1_Click()
 5    Call searchShapeText(TextBox1.Value, ComboBox1.ListIndex)
 6End Sub
 7
 8' キャンセル
 9Private Sub CommandButton2_Click()
10    Unload UserForm1
11End Sub

  1'参考サイト
  2'https://qiita.com/ctrlzr/items/e8c0ffab8fe029b25fb7
  3
  4Option Explicit
  5
  6Public oldWd As String  ' 前回キーワード
  7Public oldPl As Integer ' 前回検索場所
  8Public spIdx As Integer ' 図形インデックス
  9Public gFlg As Integer  ' 発見フラグ
 10
 11Public Sub showForm()
 12    With UserForm1
 13        .Show vbModeless
 14        .ComboBox1.AddItem "シート"
 15        .ComboBox1.AddItem "ブック"
 16        .TextBox1.Value = oldWd
 17        .ComboBox1.ListIndex = oldPl
 18    End With
 19End Sub
 20
 21' wd: 検索キーワード, pl: 検索場所(0:シート、1:ブック)
 22Public Sub searchShapeText(wd As String, pl As Integer)
 23
 24    Dim ret As Boolean
 25    Dim st As Worksheet
 26    Dim spArr() As Shape
 27
 28    If (Len(wd) = 0) Then
 29        MsgBox "検索文字列を入力してください"
 30        Exit Sub
 31    End If
 32
 33    If wd <> oldWd Or pl <> oldPl Then
 34        oldWd = wd
 35        oldPl = pl
 36        spIdx = 0
 37        gFlg = False
 38    End If
 39
 40    If pl = 0 Then ' シート
 41        Call makeShapeArr(ActiveSheet.Shapes, spArr)
 42    Else           ' ブック
 43        For Each st In ActiveWorkbook.Worksheets
 44            Call makeShapeArr(st.Shapes, spArr)
 45        Next
 46    End If
 47
 48    ret = searchShapeString(spArr, wd)
 49    If Not ret Then MsgBox "検索対象が見つかりません", vbExclamation, "図形内テキスト検索"
 50End Sub
 51
 52' 検索対象の図形を配列に積み上げる
 53' sps: 図形コレクション(ShapesまたはGroupItems), spArr: 図形配列
 54Private Sub makeShapeArr(sps As Variant, spArr() As Shape)
 55    Dim sp As Shape
 56    Dim idx As Long
 57    For Each sp In sps
 58        If (sp.Type = msoGroup) Then
 59            Call makeShapeArr(sp.GroupItems, spArr)
 60        ElseIf (sp.Type = msoComment) Then
 61        ElseIf (sp.Type = msoGraphic) Then
 62        Else
 63            If Not isArrayInit(spArr) Then
 64                ReDim spArr(0)
 65                Set spArr(0) = sp
 66            Else
 67                idx = UBound(spArr) + 1
 68                ReDim Preserve spArr(idx)
 69                Set spArr(idx) = sp
 70            End If
 71        End If
 72    Next
 73End Sub
 74
 75' 参考サイト: https://zukucode.com/2019/08/vba-array-init.html
 76' True: 初期化済み、False:未初期化
 77Private Function isArrayInit(arr As Variant) As Boolean
 78On Error GoTo ERROR_
 79    isArrayInit = IIf(UBound(arr) >= 0, True, False)
 80    Exit Function
 81ERROR_:
 82    If Err.Number = 9 Then
 83        isArrayInit = False
 84    Else
 85        '想定外エラー
 86    End If
 87End Function
 88
 89Private Function searchShapeString(spArr() As Shape, wd As String) As Boolean
 90    Dim sp  As Shape
 91    Dim s   As String
 92    Dim pos As Long
 93    Dim lFlg As Boolean
 94
 95    lFlg = False
 96    Do While True
 97        Set sp = spArr(spIdx)
 98        If (sp.TextFrame2.HasText = msoTrue) Then
 99            s = sp.TextFrame2.TextRange.Text
100            pos = InStr(s, wd)
101            ' 図形内に検索ワードが見つかった場合
102            If (pos > 0) Then
103                ActiveWorkbook.Worksheets(getParentSheet(sp.parent)).Activate
104                'sp.TopLeftCell.Select 'テキスト範囲選択を解除するため、カレントセルを選択する
105                sp.TextFrame2.TextRange.Characters(pos, Len(wd)).Select
106                On Error Resume Next
107                    ActiveWindow.ScrollRow = sp.TopLeftCell.Row - 10
108                    If Err.Number = 1004 Then
109                        ActiveWindow.ScrollRow = sp.TopLeftCell.Row
110                    End If
111                    ActiveWindow.ScrollColumn = sp.TopLeftCell.Column -1
112                    If Err.Number = 1004 Then
113                        ActiveWindow.ScrollColumn = sp.TopLeftCell.Column
114                    End If
115                On Error GoTo 0
116                lFlg = True
117                gFlg = True
118            End If
119        End If
120CONTINUE:
121        If spIdx = UBound(spArr) Then
122            If gFlg Then
123                spIdx = 0
124                If lFlg Then
125                    searchShapeString = True
126                    Exit Function
127                End If
128            Else
129                searchShapeString = False
130                Exit Function
131            End If
132        Else
133            spIdx = spIdx + 1
134            If lFlg Then
135                searchShapeString = True
136                Exit Function
137            End If
138        End If
139    Loop
140End Function
141
142' 図形が置かれているシートのシート番号を取得
143Private Function getParentSheet(parent As Variant) As Long
144    Dim ret As Long
145    If TypeName(parent) = "Worksheet" Then
146        ret = parent.Index
147    Else
148        ret = getParentSheet(parent.parent) ' グループ化されている場合
149    End If
150    getParentSheet = ret
151End Function