便利じゃなければプログラムじゃ無い!
仕事が楽になって業務効率がUPするシステムを提供!

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

2014/2/17 (月) • Excel, VBAコメントは受け付けていません。Read More »

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

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

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

カーソルキーが押されたかどうかを判定する為には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

コードの解説

指定範囲内で図形(star16)を移動させるための上記VBAを簡単に解説します。

稼働範囲の位置を取得

14~15行目で図形 星16 の高さ(Heightプロパティ)と幅(Widthプロパティ)を取得します。
同様に18~24行目で移動範囲の四角形のサイズを取得します。

キーボードの状態を取得する

29~95行目までDo~Loopステートメントを使い、永久ループで上下左右のカーソルキー、ESCキーの状態を取得します。

対象のキーが押された場合、左右矢印キーの場合は図形(オートシェイプ)の左位置(Leftプロパティ)を1ポイント増減させ位置を移動させます。
また、上下矢印キーの場合は上位置(Topプロパティ)を1ポイント増減させ位置を移動させます。

ESCキーが押された場合は位置を初期に戻して処理をループ処理を終了させています。

今回のサンプルファイルは以下のリンクからダウンロード可能です。
サンプルファイルをダウンロードする ※Excel2007以上
以上、今回はExcelの図形(オートシェイプ)をカーソルキーで自由に移動させる為のVBAコードでした。

タグ: , , , , , , ,

Comments are closed.