【ExcelVBA】図形を好きなセルに移動させる

フローチャートを作りたいって事で、
前回は、作図のコードを組む事ができました。

図形が用意できたので、続ていは移動処理を考えてみようと思います。

図形を移動させると綺麗に並べるのに手間が掛かります。
わざわざセルの、グリッド線に合わせたり、目算で中央に合わせたり…

正直面倒でっす。ヽ(´～｀；）ウーン

移動させたら自動的にセル中央に揃ってくれると楽なのにと
何度思った事か。

今回は、この辺りを考えてみようと思っています。


移動のさせ方なんですが、Drag＆Dropで狙ったセルに移動させる方法が、
直感的で楽な方法なんですが、実装が困難なんです。

マウスのクリックを検知する方法が独特なんです。

フォーム上とかオブジェクト上と限定的で、
シート上では検出するのが難しいんですよね。

WindowsAPIを使えば実装できるようなんですが、
正直、敷居が高くて難しいです。

なので違う方法を考えてみます。

図形を移動させるには、
・移動させる図形を取得
・移動先のセルを取得

二つの動作が必要になります。
まずは、図形の取得を作ってみます。


・選択した図形を取得する
まず、どの図形を動かすかって事が分からないと移動させる事もできないので、
選択中の図形を特定していきます。

方法としては、二つあって、
・全図形の中から選択中の物を探す
・クリックした時に図形を取得する

全シェイプ中から探す場合、
標準モジュール

Sub SearchShape()

    Dim sh As Shape       '選択中の図形取得'
    Dim shName As String  '検索した図形の名前'
    
    '未選択の場合エラーが出る'
    On Error GoTo noChoise
    
    For Each sh In Selection.ShapeRange
    
        shName = sh.Name
    
    Next
    
    MsgBox shName
    
Exit Sub
    
noChoise:
MsgBox "選択されてません！"

End Sub

説明すると、
シート上の全図形からShapeRangeプロパティを使って検索します。
Selection.ShapeRangeとする事で、選択中か判断できます。

選択図形が分かれば、名前をストリングで取得しておけばOKでっす。

この処理を実行する際、図形が選択されてないとエラーが発生します。
お決まりのデバッグフォームが開きます。(T^T) ヒック

なので、エラーに対応しておく必要があります。

このコードをボタンに仕込んでテストしてみると、
図形移動①.jpg

未選択なら
図形移動②.jpg

続いて、図形をクリックして取得する方法ですが、
名前の取得が簡単にできるのですが、少々やっかいな部分があります。
標準モジュール

Sub ClickShape()

    Dim shName As String   '図形の名前取得'

    shName = Application.Caller
    ActiveSheet.Shapes(shName).Select
    
    MsgBox shName

End Sub

このコードを図形に埋め込むと図形の名前を取得する事ができます。
Application.Callerが名前を取得するコマンドです。

Application.Callerを設定したオブジェクトをクリックすると、
呼び出されるコマンドになります。

二つの取得方法を書きましたが、どちらにもデメリットがあります。

・全図形から選択図形取得
　図形数が増えると処理が重くなる傾向
　どれくらいの数で重くなるか検証が必要
　移動先のセルをクリックすると選択が外れて特定できない

・Application.Caller
　クリックしても選択状態にならないので、アクティブにするコードが必要になる。
　1Clickして選択状態にしてからでないとDragできない。
　図形作成の時にコードを登録する必要がある。

使い易さは、全図形から探す方が楽にコーディングができるのですが、
後で説明するんですが、SelectionChangeを使って移動させるので、
実際に使う事が出来ません…　ヽ(´～｀；）ﾗｸﾅﾉﾆ

なので面倒ですが、ApplicationCallerを使った方法で移動実装を考えてみます。


・SelectionChange
移動先のセルをクリックすると図形が付いてくる感じの設定になるのですが,
移動コードを呼び出すには、セルをクリックした事を検知する必要があります。

しかしExcelVBAでは、リアルタイムにクリックを検知させる方法が難しいので、
セルにクリック検知のコードを仕込むか、
もしくは、選択セルが変わった時に呼び出すかって二通りのパターンになります。

セル毎にコードを仕込むのは無理なので、
選択セルが変わった時に呼び出す方法で処理を考えて行きます。

セルを選択する際、アクティブなセルから違うセルをクリックする時に
呼び出されるコマンドが、シートモジュールで設定できるので、
これを利用する事で実装できます。

シートモジュールの切り替え方は、
図形移動③.jpg
VBAのObjects内にあるシートをダブルクリックすれば開く事ができます。
今回は、Sheet1に設定するのでSheet1（Sheet1）を開きます。

開いたら、（General）→ WorkSheetに切り替えます。
図形移動④.jpg
コマンドが設定できるので、SelectionChangeを選択すると、
自動的にSelectionChangeのプロシージャが書き込まれたと思います。

これがセルを切り替えるたびに呼び出されるコマンドになります。
WorkSheetイベントと言って、いろいろ用意されています。
設定は、シート単位で行う必要があります。

プロシージャを見ると、コマンドの引数がByVal Target As Rangeとなっています。
セルを切り替えた時だけ呼び出されるようになっています。

図形を選択しても呼び出されません。


・取得した図形と移動処理
クリックした図形を取得して移動させる処理を考えます。

・図形名取得プロシージャ
・移動処理プロシージャ

二つを用意する必要があるのですが、
図形名を、二つのプロシージャで共有できないと処理できないので、
モジュール内で使えるように、shapeName変数をモジュール直下で宣言しておきます。
標準モジュール2

Option Explicit

Dim shapeName As String  '図形の名前取得'


Sub ClickShape()
  
    shapeName = Application.Caller
    ActiveSheet.Shapes(shapeName).Select

End Sub


Sub ClickCell()
  
    '選択中のセルを取得'
    Dim cell As Range
    Set cell = ActiveCell
  
    '図形の移動'
    With ActiveSheet.Shapes(shapeName)
            .Top = cell.Top + (cell.Height - .Height) / 2
            .Left = cell.Left + (cell.Width - .Width) / 2
            
    End With
 
    shapeName = vbNullString
          
End Sub

ClickShapeプロシージャは図形に登録します。

ClickCellプロシージャは、セル選択時に働かせたいので、
SelectionChangeからCallして呼び出します。
シートモジュール

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Call ClickCell
    
End Sub

図形、マクロの登録
図形移動⑤.jpg
これで動かす事ができます。

ただ、この状態では、問題点だらけでっす。( ﾉД`)ｼｸｼｸ…

・作図のたびにマクロの登録が必要になる
・セルが切り替わらないと動かない
・図形が選択されてないとエラーが発生する
・図形を削除しても取得した名前が残り続ける

順に修正していきます。
マクロの登録
前回、作図のプロシージャを組んだのですが、そこに作図と同時に
図形にClickShapeプロシージャを登録するようにします。
標準モジュール1

    '図形の設定'
    With createSh
       
        .Fill.ForeColor.RGB = RGB(shData(1), shData(2), shData(3))
        .Line.Visible = msoFalse
        .OnAction = "ClickShape"    ←　図形設定にClickShapeの登録を追加する
               
        With .TextFrame.Characters
             .Text = label
             .Font.Size = 9
             .Font.Color = RGB(shData(4), shData(4), shData(4))
 
        End With
        
        
        With .TextFrame
             .HorizontalAlignment = xlHAlignCenter
             .VerticalAlignment = xlVAlignCenter
             
        End With
           
    End With

図形作成については、詳しくは前回記事を参照下さい。
設定の項目でClickShapeを登録します。
OnActionとする事でプロシージャを登録できます。プロシージャ名はストリング表記になります。

新しく作成する図形には、ClickShapeプロシージャが登録された状態になります。

続いて、セルが切り替わらないと動かないって事なんですが、
例えば、C1のセルがアクティブになってる状態で図形を選択したとします。
図形移動⑦.jpg
図形をC1に移動させようとC1をクリックしても図形の移動が起こりません。
図形を選択する場合、前回選択したセルにカーソルは残り続けます。

なので、図形選択前にアクティブにしたセルを、もう一度クリックしても
セルが切り替わった事にならないんです。

セルとシェイプの概念が違うからなのか、切り替えで面倒な部分があります。
なので、図形をクリックすると同時に切り替え可能なセルに移す必要があります。
ClickShapeプロシージャ

Sub ClickShape()

    Dim cell As Range    '図形の下のセル取得'
    
    shapeName = Application.Caller
    Application.EnableEvents = False
    
    With ActiveSheet.Shapes(shapeName)
        Range(.TopLeftCell, .BottomRightCell).Select
            
        .Select
        
    End With
    
    Application.EnableEvents = True
    
End Sub

説明すると、
切り替え可能なセルとなれば、図形の下のセルに移動させるのが無難です。
TopLeftCellは、図形が乗ってるセルの左上セル
BottomRightCell、図形が乗ってるセルの右下のセル

これをRangeに代入してやると真ん中のセル、つまり図形下のセルが割出せます。
そこにカーソルを移動させてやります。

カーソルの移動処理がつくれたのですが問題があります。
セルが切り替わるって事で、SelectionChangeが自動的に働いてしまいます。

なので、Application.EnableEvents = Falseで、このコードからセルを動かす間は、
イベントを発生させないように設定しておきます。
終わったら、Application.EnableEvents = Trueにしておかないと、
SelectionChangeが働かなくなるので注意でっす。

これで移動部分は問題なくなりました。ヽ(´▽｀)/～♪

しかし…
図形を選択してない状態でセルを切り替えるとデバッグが開きます。
また、図形を削除してセルを切り替えると図形を取得したのに、
存在してないとVBAにお叱りを受ける事になります。(T-T) グスッ

なので、ClickCellプロシージャを修正します。
ClickCellプロシージャ

Sub ClickCell()
  
    '選択中のセルを取得'
    Dim cell As Range
    Set cell = ActiveCell
  
    If Not shapeName = vbNullString Then
        
        '図形削除でエラーが発生'
        On Error GoTo shapeNothing
    
        '図形の移動'
        With ActiveSheet.Shapes(shapeName)
            .Top = cell.Top + (cell.Height - .Height) / 2
            .Left = cell.Left + (cell.Width - .Width) / 2
            
        End With
        
    End If
    
shapeNothing:
    shapeName = vbNullString
    
End Sub

図形名が取得されてなければ、移動処理を飛ばすようにします。
また、図形が削除されていた場合、移動処理を実行するとエラーが発生するので、
移動処理の手前にエラー時の対応を組み込んでおきます。

これで問題無く移動処理が行えるようになったのでテストしてみます。
図形移動⑧.jpg
上手く動いてくれました～　ヽ(´▽｀)/～♪

これで図形の移動が楽に行えるようになりました。
ただ残念な点は、やはり直感的な移動ではないんですよね。
Dragで動かせる方が楽…

なにかいい方法がないか考えてみます。

それと注意点も一つ、shapeName変数を共有する為にモジュール内で
使い回せるようにしてる点です。

何かプロシージャを追加した場合、そこでも書き換えが可能になってしまうので、
共有変数をFunctionプロパティにするなどの工夫が必要になるケースもあります。

作った本人しか使わないのなら気にしなくてもいいです。
(;^o^) ＼(ToT )あんたほんとにそれでいいの

図形を移動させるについては以上となります。
次回は、もう少し直感的な動作を作れたら更新しようと思います。
つくれるんだろうか…

それでは、このへんで
(TωT)/~~~　BYE　BYE




この記事へのコメント

コメントを書く