図形をカーソルキーで自由に移動させるVBAコード

前回の図形（オートシェイプ）を操作する方法を流用して、今回はキーボードのカーソルキー（上下左右の矢印キー）で図形を自由に移動させるVBAコードをサンプル公開します。

動作イメージは以下の通りで星をカーソルキーで自由に移動させます。
尚、カーソルで移動可能な範囲は四角形内とします。

指定されたキーが押されたか判定する関数

カーソルキーが押されたかどうかを判定する為にはUser32.dllに含まれるWin32APIの関数「GetAsyncKeyState」を使います。

最初に標準モジュールに以下のコードを記載しましょう。

Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

ちなみに標準モジュールはVBE(Visual Basic Editor)を起動（[Alt]+[F11]）して、[挿入(I)]　→　[標準モジュール(M)]で作成する事が出来ます。

GetAsyncKeyState関数は指定されたキーが押されている間、0以外の数値を返しますので以下の用法でキーが押されたかどうかを判定します。

'矢印左キー（←）の引数は37
If GetAsyncKeyState(37) <> 0 Then
    MsgBox "←キーが押されています。"
End If

尚、今回利用するキーの引数は以下の通りです。

←キー：37
→キー：39
↑キー：38
↓キー：40
ESCキー：27

尚、その他のキーについてはこちらのサイトをご参考下さい⇒EXCEL VBA GetAsyncKeyState:キーコード一覧

VBAコード

上記を踏まえて実際にVBAコードを作成します。
サンプルではボタンをクリックした際の動作に以下のコードを設定しています。

Private Sub CommandButton1_Click()
Dim i As Long
Dim objStar As Shape
Dim starWidth As Long
Dim starHeight As Long
Dim boxLeft As Long
Dim boxRight As Long
Dim boxTop As Long
Dim boxBottom As Long
Dim lngLeft As Long
Dim lngTop As Long

'オートシェイプ（星16）のサイズを取得
starWidth = ActiveSheet.Shapes("star16").Width
starHeight = ActiveSheet.Shapes("star16").Height

'オートシェイプ（四角形）のサイズを取得
boxLeft = ActiveSheet.Shapes("正方形/長方形 10").Left
boxRight = boxLeft + ActiveSheet.Shapes("正方形/長方形 10").Width _
                                                    - starWidth
boxTop = ActiveSheet.Shapes("正方形/長方形 10").Top
boxBottom = boxTop + ActiveSheet.Shapes("正方形/長方形 10").Height _
                                                    - starHeight

'オートシェイプ（星16）の初期位置を設定
lngLeft = boxLeft   '左位置
lngTop = boxTop     '上位置

Do
    '右(→)の処理
    If GetAsyncKeyState(39) <> 0 Then
        If lngLeft > boxRight Then
            lngLeft = boxRight
        Else
            lngLeft = lngLeft + 1
        End If
        '左位置を設定する
        ActiveSheet.Shapes("star16").Left = lngLeft
        '画面に表示する
        DoEvents
    End If

    '左(←)の処理
    If GetAsyncKeyState(37) <> 0 Then
        If lngLeft < boxLeft Then
            lngLeft = boxLeft
        Else
            lngLeft = lngLeft - 1
        End If
        '左位置を設定する
        ActiveSheet.Shapes("star16").Left = lngLeft
        '画面に表示する
        DoEvents
    End If

    '上(↑)の処理
    If GetAsyncKeyState(38) <> 0 Then
        If lngTop < boxTop Then
            lngTop = boxTop
        Else
            lngTop = lngTop - 1
        End If
        '上位置を設定する
        ActiveSheet.Shapes("star16").Top = lngTop
        '画面に表示する
        DoEvents
    End If

    '下(↓)の処理
    If GetAsyncKeyState(40) <> 0 Then
        If lngTop > boxBottom Then
            lngTop = boxBottom
        Else
            lngTop = lngTop + 1
        End If
        '上位置を設定する
        ActiveSheet.Shapes("star16").Top = lngTop
        '画面に表示する
        DoEvents
    End If

    'Escの処理
    If GetAsyncKeyState(27) <> 0 Then
        '左位置を設定する
        ActiveSheet.Shapes("star16").Left = boxLeft
        '上位置を設定する
        ActiveSheet.Shapes("star16").Top = boxTop
        '画面に表示する
        DoEvents

        Exit Sub

    End If

Loop

End Sub