図形オートシェイプ内のテキスト検索マクロ作成についての質問

質問

VBS2年目のプログラマーです。
Excelで図形オートシェイプ内のテキストが検索できないので、
マクロを作成してみようと思いましたが2点問題が発生しましたので
解決方法または実現方法をご教授ねがいます。

（目標マクロ機能概要）
(1)InputBoxで検索文字列を入力
(2)検索文字列と一致するテキストを持つ図形を選択
(3)検索文字列と一致する次の図形を検索するかをMsgboxから選択
　(この時、一致する図形は選択されている状態であってほしい)
(4)(3)で次の図形を検索しない、または図形をすべて検索するとマクロ終了
（問題)
１．機能概要(2)の選択される図形が現在のExcel画面外にある場合、画面が移動しないため、どこに検索ヒットした図形があるか使用者がわからない
２．機能概要(3)で、Msgbox実行時に図形選択が表示されず現在どの図形を選択しているのか使用者がわからない

問題1は、autoshapeオブジェクトのtop,left属性などを
使うしかないのかなとぼんやり考えています。

以下、コードです。
お忙しいところ、申し訳ありませんが
以上、よろしくお願いします。
**************************
Sub GetShapesText()
Dim wk_shp As Shape 'オートシェイプ格納変数
Dim wk_search_str As String '検索文字列変数

'*** 検索文字列入力処理 ***
wk_search_str = InputBox("検索する図形オートシェイプのテキストを入力してください。", "オートシェイプ内テキスト検索")
If (Len(wk_search_str) = 0) Then
'検索文字列が未入力の場合は、マクロ終了
Exit Sub
End If

'*** オートシェイプ検索処理 ***
For Each wk_shp In ActiveSheet.Shapes
If InStr(wk_shp.Name, "Line") = 0 Then 'オートシェイプが線(Line)以外の場合のみ以下を処理
If (InStr(wk_shp.TextFrame.Characters.Text, wk_search_str) > 0) Then 'オートシェイプのテキストに検索文字列が含まれる場合のみ以下を処理
wk_shp.Select '検索ヒットしたオートシェイプを選択
wk_next_search_flg = MsgBox("次を検索しますか？", vbYesNo)
If (wk_next_search_flg = 7) Then
'次を検索しない場合は、検索を終了
Exit For
End If
End If
End If
Next
End Sub
**************************

回答No.1

end-u · ベストアンサー

こんにちは。
QNo.2107566 を参考にして、TextBoxを使うか、
wk_shp.DrawingObject.Select
...とすれば良いです。
（DrawingObject も TextBox も隠しObjectですが、便利ですよ）

回答No.4

onlyrom

またまた登場、onlyromです。
VBAには慣れていらっしゃるようなのでお気づきだとは思いますが、一言。

＞'●●●　図形の乗ってるセルを表示画面の左上隅へ移動
＞ActiveWindow.ScrollRow = Selection.TopLeftCell.Row - 1
＞ActiveWindow.ScrollColumn = Selection.TopLeftCell.Column - 1

これは表示画面の左上隅（セルＡ１）ではなくより見やすくするために、
表示画面のセルＢ２の位置に表示しているわけですが、
－１　をしてますので当然、実際の図形が、１行目または１列目にあった場合はエラーになりますので、
そこらは修正願います。
もちろん、－１　を省いてもいいですが。。。

回答No.3

fumufumu_2006

１．TopLeftCell.Selectで画面移動
２．選択表示用のシェープで表示
問題点追加
If InStr(wk_shp.Name, "Line") = 0 Then 'オートシェイプが線(Line)以外の場合のみ以下を処理
ではなく
If wk_shp.Type = msoTextBox Then 'オートシェイプがtextboxの場合のみ以下を処理
で処理対象を選択にしないと、line以外のシェープも対象になり、wk_shp.TextFrame.Characters.Textでエラーになる。

という訳で、以下ではどうでしょうか？

Sub GetShapesText()
Dim wk_shp As Shape 'オートシェイプ格納変数
Dim wk_search_str As String '検索文字列変数
Dim wk_next_search_flg As Integer
'選択表示用のダミーシェープ
Dim mark1 As Shape
Dim mark2 As Shape
Dim mark3 As Shape
Dim mark4 As Shape
Set mark1 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 5, 5)
Set mark2 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 5, 5)
Set mark3 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 5, 5)
Set mark4 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 5, 5)

'*** 検索文字列入力処理 ***
wk_search_str = InputBox("検索する図形オートシェイプのテキストを入力してください。", "オートシェイプ内テキスト検索")
If (Len(wk_search_str) = 0) Then
'検索文字列が未入力の場合は、マクロ終了
Exit Sub
End If

'*** オートシェイプ検索処理 ***
For Each wk_shp In ActiveSheet.Shapes
'If InStr(wk_shp.Name, "Line") = 0 Then 'オートシェイプが線(Line)以外の場合のみ以下を処理
If wk_shp.Type = msoTextBox Then 'オートシェイプがtextboxの場合のみ以下を処理
If (InStr(wk_shp.TextFrame.Characters.Text, wk_search_str) > 0) Then 'オートシェイプのテキストに検索文字列が含まれる場合のみ以下を処理
'wk_shp.Select '検索ヒットしたオートシェイプを選択
'選択表示用のダミーシェープ表示位置
mark1.Left = wk_shp.Left - 2
mark1.Top = wk_shp.Top - 2
mark2.Left = wk_shp.Left + wk_shp.Width - 2
mark2.Top = wk_shp.Top - 2
mark3.Left = wk_shp.Left - 2
mark3.Top = wk_shp.Top + wk_shp.Height - 2
mark4.Left = wk_shp.Left + wk_shp.Width - 2
mark4.Top = wk_shp.Top + wk_shp.Height - 2
'選択シェープのあるセルにフォーカスを移動
wk_shp.TopLeftCell.Select

wk_next_search_flg = MsgBox("次を検索しますか？", vbYesNo)
'If (wk_next_search_flg = 7) Then
If (wk_next_search_flg = vbNo) Then
'次を検索しない場合は、検索を終了
Exit For
End If
End If
End If
Next
'選択表示用のダミーシェープ削除
mark1.Delete
mark2.Delete
mark3.Delete
mark4.Delete
End Sub

p.s.
ANo.1さんのDrawingObjectというのは、初めて知りました。
こういうのもあるんですね。

回答No.2

onlyrom

（１）選択した図形が表示画面を外れていた場合

　　　選択した図形を表示画面の左上隅へ表示する
　　　乗ってるセルを表示画面の左上隅へ移動させればいい

（２）MsgBox表示でどの図形を選択しているか不明になる

　　　これは仕方のないことなので代案として
　　　選択した図形を「決まった色（例えば黄色）」に塗りつぶし
　　　MsgBoxが消えたときもとの色にもどしておく

という感じでどうでしょう。

'-------------------------------------------------
Sub GetShapesText()
Dim wk_shp As Shape 'オートシェイプ格納変数
Dim wk_search_str As String '検索文字列変数
Dim wk_next_search_flg

Dim myIro As Integer

'*** 検索文字列入力処理 ***
wk_search_str = InputBox("検索する図形オートシェイプのテキストを入力してください。", "オートシェイプ内テキスト検索")
If (Len(wk_search_str) = 0) Then
'検索文字列が未入力の場合は、マクロ終了
Exit Sub
End If

'*** オートシェイプ検索処理 ***
For Each wk_shp In ActiveSheet.Shapes
If InStr(wk_shp.Name, "Line") = 0 Then 'オートシェイプが線(Line)以外の場合のみ以下を処理
If (InStr(wk_shp.TextFrame.Characters.Text, wk_search_str) > 0) Then 'オートシェイプのテキストに検索文字列が含まれる場合のみ以下を処理
wk_shp.Select '検索ヒットしたオートシェイプを選択

'●●●　図形の乗ってるセルを表示画面の左上隅へ移動

ActiveWindow.ScrollRow = Selection.TopLeftCell.Row - 1
ActiveWindow.ScrollColumn = Selection.TopLeftCell.Column - 1

'●●●　選択した図形の塗りつぶし色を保持
'●●●　選択した図形が分かるように黄色に塗りつぶす＆再描画

myIro = Selection.ShapeRange.Fill.ForeColor.SchemeColor
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13
DoEvents

wk_next_search_flg = MsgBox("次を検索しますか？", vbYesNo)

'●●● 選択した図形の色を元へ戻す

Selection.ShapeRange.Fill.ForeColor.SchemeColor = myIro

If (wk_next_search_flg = 7) Then
'次を検索しない場合は、検索を終了
Exit For
End If
End If
End If
Next
End Sub
'--------------------------------------------

それから、ActiveXコントロールなどが配置してあると質問者の提示のコードではエラーが出ますがそれらはそのままの状態ですので、エラー処理はご自分で。

以上。