VBAでオートシェイプを操作する | システムエンジニアライフ

VBAでオートシェイプを操作する

ヘッダー広告
スポンサードリンク

前回の投稿から期間が空いてしまいました。

私結婚式前でして、色々と忙しく記事を更新できていませんでした。
結婚式はまだ終わっていませんが、ピークを過ぎて少しずつ落ち着いてきましたので、これからはもう少し早めに更新できるようにしたいと思います。

さて今回のテーマはVBAでオートシェイプを操作する方法になります。
Sierにいると設計書からテストエビデンス、お客様との連絡、スケジュールの管理とあらゆる場面でEXCELで資料を作成すると思います。
そのためオートシェイプを使う機会も多いと思います。
オートシェイプを使えばより綺麗に作れたり、わかりやすくできたりと便利だからです。

そこで今回はオートシェイプを使って、より効果的な処理をVBAで行おうと思います。

オートシェイプを使ったプログラム

クリックされたオートシェイプ内のテキストを取得する

まず最初に紹介するマクロは、オートシェイプをクリックした際に、クリックしたオートシェイプ内のテキストを表示するというものです。

まず以下のようにオートシェイプが入ったシートがあるとします。

ここで、2つあるオートシェイプをどちらかをクリックした時に、クリックされた方のオートシェイプ内のテキストに設定してある、セルのアドレス情報を取得しようと思います。

まずは対象のオートシェイプを右クリック→マクロを登録を選択します。

そして、マクロ名(M): に登録するマクロ名を入力→編集(E)を選択して、マクロを登録します。

今回は、「Shape_Click」というマクロ名で登録します。

そして作成されたモジュールに以下のコードをコピペすればマクロの登録が完了となります。

Option Explicit

Public Sub Shape_Click()

    Dim Shp As Shape
    Dim CellAddress As String
    
    Set Shp = ActiveSheet.Shapes(Application.Caller)
    
    'クリックされたオートシェイプに設定されている値を取得する。
    CellAddress = Shp.TextFrame.Characters.Text
    
    MsgBox "『" & CellAddress & "』のオートシェイプがクリックされました。", vbInformation, "インフォメーション"
    
End Sub

これでオートシェイプをクリックすると、オートシェイプ内のテキストを取得することが可能となりました。
実際にクリックするとこのようになります。

●コード解説

Set Shp = ActiveSheet.Shapes(Application.Caller)

Application.Callerを使用することによって、マクロを呼び出した方法を取得します。
今回の場合は、オートシェイプをクリックしマクロを実行したため、『Shape_Click』を呼び出したオートシェイプの名前を取得できます。


その名前から対象のオートシェイプを取得してShapeオブジェクトにセットしています。

CellAddress = Shp.TextFrame.Characters.Text

そして、Shapeオブジェクトの、TextFrame.Characters.Textプロパティを取得することで、オートシェイプ内のテキストを取得できるようになります。

今回はオートシェイプ内のテキストをメッセージとして出力しているだけですが、これを応用することで色々と便利なツールを作成することが出来るようになります。

注意点

オートシェイプをコピーして作成してしまうと以下のように、オートシェイプの名前が同一のものが作成されてしまいます。
今回の場合は、A3セルとB5セルのオートシェイプはどちらも『吹出1』という名前のオートシェイプとなっています。

そのまま実行してしまうと、どのオートシェイプを実行しているのかをマクロが判断できず、以下のようにクリックしたはずのオートシェイプ内のテキストが取得できないという事象が発生します。

以下は、「B5セル」のテキストが入ったオートシェイプをクリックしたはずが、「A3セル」というメッセージが返却されてしまいました。


そのため、オートシェイプのコピペをした場合には、名前が重複しないようにを変更する必要があるのでご注意ください。
重複するオートシェイプ名がないかは以下の「オートシェイプ名の重複チェック」をご参照ください。

オートシェイプをクリックした時に実行するマクロを、自動で設定するマクロ

上記でクリックされたオートシェイプ内のテキストを取得するをご紹介しましたが、オートシェイプが多数ある場合に、全てのオートシェイプにマクロを登録するのは大変かと思います。
そこで『シート内の全てのオートシェイプに、自動でマクロを登録するマクロ』 をご紹介させていただきます。

Option Explicit

Public Sub Set_OnClick()

    Dim Shp As Shape
    Dim ShpCount As Long
    
    ShpCount = 0
    
    '全てのオートシェイプにクリックした時に実行するプロシージャを設定
    For Each Shp In ActiveSheet.Shapes
        
        Shp.OnAction = "Shape_Click"
    
        ShpCount = ShpCount + 1
    Next
    
    MsgBox "『" & ShpCount & "』個のオートシェイプにOnClickプロシージャが設定されました。", _
                    vbInformation, "インフォメーション"
    
End Sub

コード解説

Shp.OnAction = “Shape_Click”

オートシェイプ内のOnActionプロパティに実行するプロシージャーをセットすることで、クリック時のマクロを設定することが可能となります。

これによって、全てのオートシェイプに自動でマクロを登録することが可能となります。
応用すれば、他のブックのオートシェイプにも登録可能となるので、色々と使える場面もあるかと思います。

オートシェイプ名の重複チェック

クリックされたオートシェイプ内のテキストを取得するでオートシェイプ名の重複がある場合には、クリックしたはずのオートシェイプを判定出来ない場合があるとお伝えしました。

オートシェイプを多数作成しなくてはいけない場合も多くあると思います。
その時にはコピペで作成することも多いと思うので、ついついオートシェイプ名を修正し忘れてしまうこともあると思います。
そのために『オートシェイプ名の重複がないかを確認する』マクロを作成しました。

Option Explicit

Private Const LIST_ADD As Long = 100

'オートシェイプ名に重複がないことを確認する
Public Sub ShapeNameCheck()

    Dim Shp As Shape
    Dim ShapeName() As String
    Dim ShapeCount As Long
    Dim i As Long
    Dim DiffName As String
    Dim KeyDup As Boolean
    
    
    ReDim ShapeName(LIST_ADD - 1)
    
    ShapeCount = 0
    '対象シートの全てのオートシェイプを精査
    For Each Shp In ActiveSheet.Shapes
        
        ShapeName(ShapeCount) = Shp.Name
              
        ShapeCount = ShapeCount + 1
        
        '配列上限を超えたらプラスする
        If ShapeCount Mod LIST_ADD = 0 Then
            ReDim Preserve ShapeName(ShapeCount + LIST_ADD - 1)
        End If
    Next
    
    If ShapeCount = 0 Then
        MsgBox "オートシェイプは見つかりませんでした。", vbInformation, "処理終了"
        
        Exit Sub
    End If
    
    ReDim Preserve ShapeName(ShapeCount - 1)
    
    'オートシェイプ名を並び替え
    Call ListSort(ShapeName)
    
    '全てのオートシェイプ名を調査し、同一の名前ものが存在するかチェック
    KeyDup = False
    DiffName = ShapeName(0)
    For i = 1 To ShapeCount - 1
        If DiffName = ShapeName(i) Then
            KeyDup = True
            Exit For
        End If
    Next
    
    If KeyDup = True Then
        MsgBox "オートシェイプ名が重複しています。", vbCritical, "処理結果"
    Else
        MsgBox "オートシェイプに重複は見つかりませんでした", vbInformation, "処理結果"
    End If
    
End Sub

Private Sub ListSort(ByRef ShapeName() As String)
    
    Dim i As Long
    Dim L As Long
    Dim U As Long
  
    For i = 0 To UBound(ShapeName) - 1
        
        L = LBound(ShapeName)
        U = UBound(ShapeName)
    
        Call QuickSort(ShapeName, L, U)
        
    Next

End Sub
Private Sub QuickSort(ByRef ShapeName() As String, ByVal L As Long, ByVal U As Long)

    Dim i As Long
    Dim j As Long
    Dim S As Variant
    Dim Tmp As String
    
    S = ShapeName(Int((L + U) / 2))
    
    i = L
    j = U
        
    Do
    
        Do While ShapeName(i) < S
            i = i + 1
        Loop
        Do While ShapeName(j) > S
            j = j - 1
        Loop
        
      If i >= j Then Exit Do
      
      Tmp = ShapeName(i)
      
      ShapeName(i) = ShapeName(j)
      ShapeName(j) = Tmp
      
      i = i + 1
      j = j - 1
    Loop
      
    If (L < i - 1) Then QuickSort ShapeName, L, i - 1
    If (U > j + 1) Then QuickSort ShapeName, j + 1, U
      
End Sub

このコードの解説はしませんが、オートシェイプ名が重複しているか判断できますので、ご活用いただければと思います。
このコードを応用すれば、重複しているオートシェイプ名を自動で変更することも可能ですので、オートシェイプを使ったマクロを作成したい場合にはご参考にしていただければ幸いです。

まとめ

今回は、『クリックされたオートシェイプ内のテキストを取得する』、『オートシェイプをクリックした時に実行するマクロを、自動で設定するマクロ』、『オートシェイプ名の重複チェック』という3つのオートシェイプに関するマクロをご紹介しました。

Sierでは色々なことにEXCELを使っています。
その中でオートシェイプを使うこともかなり多くあると思いますので、今回ご紹介したマクロを活用いただき、少しでも効率化していただければと思います。

この記事は久しぶりの投稿となりましたが、やはりブログの更新は楽しいことを思い出しました。
個人的に結婚式で忙しい時期でありますが、これからは少しずつ空いてくると思いますので、またちょいちょい更新していこうと思います。

フッター広告

スポンサードリンク



シェアする

  • このエントリーをはてなブックマークに追加

フォローする