コード
前回は表内のワードを検索する為にシェイプが表かどうか判定する機能を実装しました(前回の記事)。今回は検索ツールをアドイン化してGUIアプリにします。まず前回のコードにAuto_Open関数を追記します、コードは下記の様になります。
'VBA標準モジュール
Option Explicit
'今回追記
Public Sub Auto_open()
With UserForm1
.Show vbModeless 'ユーザーフォームを開く
End With
End Sub
Sub findTest(txt As String)
Dim prs As Presentation 'プレゼンテーション
Dim sld As Slide 'スライド
Dim shp As Shape 'シェイプ
Dim gshp As Shape 'グループシェイプ
Dim txtRng As TextRange 'テキストレンジ
Dim foundtext As TextRange '文字発見用テキストレンジ
Dim flgFind As Boolean '文字発見フラグ
Dim sldNum As Integer '文字発見字のスライドNo
Dim msg As String 'メッセージ内容
Dim btm As Integer 'ボタン種類
Dim ttl As String 'タイトル
Dim response As Integer 'ボタン押した後の反応
Dim row As Integer '表行数用
Dim col As Integer '表桁数用
msg = "見つけたよ!!"
btm = 4
ttl = "メッセージ"
flgFind = False
For Each prs In Presentations '全プレゼンテーションをループ
For Each sld In prs.Slides '全スライドをループ
For Each shp In sld.Shapes '全図形をループ
If shp.HasTextFrame Then 'テキストフレーム有り
Set txtRng = shp.TextFrame.TextRange
Set foundtext = txtRng.Find(txt, msoFalse, msoFalse)
'文字を発見した時
If Not (foundtext Is Nothing) Then
flgFind = True '文字発見
With foundtext
sldNum = sld.SlideIndex '検索ワードが記載されたスライドNo代入
prs.Windows(1).Activate '検索ワードがあるプレゼンテーションをアクティブ化
ActiveWindow.View.GotoSlide Index:=sldNum '検索ワードがあるスライドを開く
response = MsgBox(msg, btm, ttl) 'メッセージの返答に対する返り値
'ボタンを押した後の反応
If response = vbYes Then 'YESの場合
shp.Select '検索ワードを含むシェイプを選択
Exit Sub 'FindTestから抜ける
End If
End With
End If
Else
If shp.Type = msoGroup Then 'グループを見つけた場合
For Each gshp In shp.GroupItems
If gshp.HasTextFrame Then 'テキストフレーム有り
Set txtRng = gshp.TextFrame.TextRange
Set foundtext = txtRng.Find(FindWhat:=txt, MatchCase:=msoFalse, WholeWords:=msoFalse) ' 文字発見字のスライドを開く
'文字を発見した時
If Not (foundtext Is Nothing) Then
flgFind = True '文字発見
With foundtext
sldNum = sld.SlideIndex
prs.Windows(1).Activate
ActiveWindow.View.GotoSlide Index:=sldNum '編集中専用
response = MsgBox(msg, btm, ttl)
'ボタンを押した後の反応
If response = vbYes Then 'YESの場合
shp.Select
Exit Sub 'リターン
End If
End With
End If
End If
Next
ElseIf shp.Type = msoTable Then '表を見つけた場合
With shp.Table
For row = 1 To .Rows.Count
For col = 1 To .Columns.Count
Set txtRng = .Cell(row, col).Shape.TextFrame.TextRange
Set foundtext = txtRng.Find(FindWhat:=txt, MatchCase:=msoFalse, WholeWords:=msoFalse) ' 文字発見字のスライドを開く
'文字を発見した時
If Not (foundtext Is Nothing) Then
flgFind = True '文字発見
With foundtext
sldNum = sld.SlideIndex
prs.Windows(1).Activate
ActiveWindow.View.GotoSlide Index:=sldNum '編集中専用
ActiveWindow.View.GotoSlide Index:=sldNum '編集中専用
response = MsgBox(msg, btm, ttl)
'ボタンを押した後の反応
If response = vbYes Then 'YESの場合
shp.Table.Cell(row, col).Shape.Select
Exit Sub 'リターン
End If
End With
End If
Next col
Next row
End With
End If
End If
Next
Next
Next
If flgFind = False Then
MsgBox ("ごめんなさい、見つけられませんでした・・・")
Else
MsgBox ("検索終了")
End If
End Sub
Sub emptyTest()
Dim str1 As String
Dim str2 As String
str1 = ""
str2 = "abc"
If (str1 = "") Then
MsgBox "str1は空白だ"
Else
MsgBox "str1は空白でない"
End If
If (str2 = "") Then
MsgBox "str2は空白だ"
Else
MsgBox "str2は空白でない"
End If
End Sub
Sub forEachTest()
Dim prs As Presentation 'プレゼンテーション
Dim sld As Slide 'スライド
Dim shp As Shape 'シェイプ
For Each prs In Presentations
MsgBox prs.Name 'パワポのファイル名表示
For Each sld In prs.Slides
MsgBox sld.Name 'スライド名表示
For Each shp In sld.Shapes
MsgBox shp.Name 'シェイプ名表示
Next
Next
Next
End Sub
あとの作業は簡単で以下手順で行います。
アドインの作り方

アドイン化ができたら立ち上げてみましょう。アドインを開くとAuto_Open関数が走りフォームをShowする仕組みとなっています。適当なプレゼンテーションを開いて検索してみると動作したと思います。これで検索ツールは完成です。
次回からは「らくらくフォント設定ツール」を作っていきます。