トップ > 逆引きで学ぶ ユーザーフォーム&コントロール > 追加章 遊ぶ!楽しむ!ユーザーフォーム > T-05 フォーム上のイメージの移動にあわせて背景セルに色を設定する

T-05 フォーム上のイメージの移動にあわせて背景セルに色を設定する2022.05.03

次の書籍の第1章~5章を公開しています。
「Excel VBA 逆引きで学ぶ ユーザーフォーム&コントロール」

目次  前頁   次頁  索引

フォーム上にセルに見立てた格子状のラベルを配置しています。
便宜上それらをフォームのセルと呼んでいます。

次図は、フォームのイメージの移動に合わせて、イメージの背景セルに色を設定するサンプルです。


イメージをクリックをすると、そのイメージを掴み、掴んでいる間は、マウスポインタにあわせて移動します。 再度クリックするとイメージを離します。
イメージを移動する時に、イメージの背景セルに色が設定されます。
イメージを離すときは、近くのセルのマス目に合わせて配置されます。

このような動作の実現にはいくつかの方法が考えられますが、最も簡単だと思われる方法で実装します。

サンプルファイル ダウンロード


準備 1

ユーザーフォームを挿入し、次のコントロールを追加します。

■Labelコントロール
 役割:疑似セル 格子状に配置
 オブジェクト名:FCells_(行番号)_(列番号)
 個数:100
 幅:18(ポイント)
 高さ:18(ポイント)
 BackColor:&H00FFFFFF&
 BackStyle:1 - fmBackStyleOpaque
 BorderStyle:1 - fmBorderStyleSingle


■Imageコントロール
 役割:画像表示用
 オブジェクト名:Image1
 個数:1
 幅:36
 高さ:54
 Picture:任意の画像
 PictureSizeMode:1 - fmPictureSizeModeStretch
 BorderStyle:0 - fmBorderStyleNone
 Tag:10;11;10
 Tagプロパティの値が、色を変更するセルの相対位置となります。


■Labelコントロール
 役割:イベント感知用
 オブジェクト名:Label_Main
 個数:1
 幅:180
 高さ:180
 BackStyle:0 - fmBackStyleTransparent
 BorderStyle:0 - fmBorderStyleNone


準備 2

格子状に配置したLabelコントロールにオブジェクト名を設定します。
後の処理がしやすいように、名前に行列番号を入れておきます。
※マクロでまとめてオブジェクト名を設定する方法はこちらをご覧ください
【例】FCells_2_3 共通ベース名:「FCells_」 行番号:2 列番号:3


Imageコントロールを、フォームセル内に配置します。


イベント感知用のLabelを、格子状のLabelコントロールにぴったりとかぶせるような形で配置します。


ポイントは、イベント感知用のLabelコントロールが一番手前であることです。
感知用Labelが一番手前でない場合は、感知用Labelを選択した状態で、メニューバーの「書式」→「順序」→「最前面へ移動」を選択します。


サンプルコード

フォームモジュールに記述します。

'フォーム上にセルに見立てたラベルを格子状に配置しています
'そのラベル群を便宜上フォームセルと呼びます
Option Explicit

'定数
Private Const FCW As Single = 18        'フォーム上のセル幅
Private Const FCH As Single = 18        'フォーム上のセル高さ
Private Const FCN As String = "FCells_" 'フォーム上のセルのベース名

'変数
Private strImageName As String          'キャッチしているイメージ名
Private strAddress   As String          'キャッチしているイメージのTopLeftセルアドレス

'■ラベルイベント(Label_Main) '+++ MouseDownイベント +++ Private Sub Label_Main_MouseDown(ByVal Button As Integer, _ ByVal Shift As Integer, _ ByVal X As Single, _ ByVal Y As Single) With Label_Main If strImageName = "" Then strImageName = Get_ImageName(.Left, .Top, X, Y) Else Dim varSplit As Variant varSplit = Split(strAddress, ",") 'フォームセルの行列を元に位置設定 Controls(strImageName).Left = .Left + (Val(varSplit(1)) - 1) * FCW Controls(strImageName).Top = .Top + (Val(varSplit(0)) - 1) * FCH Call Set_BackColor(Controls(strImageName).Tag, False) strImageName = "" End If End With End Sub
'+++ MouseMoveイベント +++ Private Sub Label_Main_MouseMove(ByVal Button As Integer, _ ByVal Shift As Integer, _ ByVal X As Single, _ ByVal Y As Single) 'イメージ名が空白の場合は抜ける If strImageName = "" Then Exit Sub Dim sinLeft As Single Dim sinTop As Single Dim i As Long Dim j As Long Dim lngR As Long Dim lngC As Long With Label_Main 'イメージの中心がマウスポインタ位置になるように調整 sinLeft = .Left + X - (Controls(strImageName).Width / 2) sinTop = .Top + Y - (Controls(strImageName).Height / 2) 'Label_Main内範囲制限 If sinLeft < .Left Then sinLeft = .Left If .Left + .Width - Controls(strImageName).Width < sinLeft Then sinLeft = .Left + .Width - Controls(strImageName).Width End If If sinTop < .Top Then sinTop = .Top If .Top + .Height - Controls(strImageName).Height < sinTop Then sinTop = .Top + .Height - Controls(strImageName).Height End If '位置設定 Controls(strImageName).Left = sinLeft Controls(strImageName).Top = sinTop 'セル背景色クリア If strAddress <> "" Then Call Set_BackColor(Controls(strImageName).Tag, False) End If 'イメージ左上隅のフォームセル行列取得 lngC = (FCW / 2 + sinLeft) \ FCW lngR = (FCH / 2 + sinTop) \ FCH strAddress = lngR & "," & lngC 'セル背景色設定 Call Set_BackColor(Controls(strImageName).Tag, True) End With End Sub
'■関数 '+++ イメージ名取得関数 +++++++++++++++++++++++++++++++++++++++++ 'マウスポインタがイメージと重なっている場合にそのイメージ名を返す '【引数】 ' L:イベント感知ラベルLeft位置 ' T:イベント感知ラベルTop位置 ' X:マウスポインタX位置 ' Y:マウスポインタY位置 '【戻り値】 ' イメージ名 '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Private Function Get_ImageName(ByVal L As Single, ByVal T As Single, _ ByVal X As Single, ByVal Y As Single) As String Dim objC As MSForms.Control For Each objC In Me.Controls If TypeName(objC) = "Image" Then 'コントロールタイプ判定 With objC '重なり判定 If .Left < (L + X) And (L + X) < (.Left + .Width) Then If .Top < (T + Y) And (T + Y) < (.Top + .Height) Then Get_ImageName = .Name Exit Function End If End If End With End If Next End Function
'■サブルーチン '+++ セル背景色設定処理 ++++++++++++++++++++++++++++++++++ 'コントロールのTagプロパティに基づきセルの背景色を設定する '【引数】 ' strTag:対象コントロールのTagプロパティ ' f   :背景色設定・クリアフラグ ' True:設定 False:クリア '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Private Sub Set_BackColor(ByVal strTag As String, ByVal f As Boolean) Dim i As Long Dim j As Long 'コントロールのタグの値を参照 「;」が含まれる(複数行)場合は分割 Dim varSpTag As Variant If 0 = InStr(1, strTag, ";") Then ReDim varSpTag(0): varSpTag(0) = strTag Else varSpTag = Split(strTag, ";") End If 'イメージのTopLeftセルアドレス行列取得 Dim varSpAds As Variant varSpAds = Split(strAddress, ",") 'セル背景色設定・クリア Dim strCName As String For i = 0 To UBound(varSpTag) For j = 1 To Len(varSpTag(i)) If Mid$(varSpTag(i), j, 1) = 1 Then strCName = FCN & Val(varSpAds(0)) + i & "_" & Val(varSpAds(1)) + j - 1 If f Then Controls(strCName).BackColor = &HFFC0C0 '設定(薄紫) Else Controls(strCName).BackColor = &HFFFFFF 'クリア(白) End If End If Next Next End Sub

簡単な解説

■移動と移動制限・配置
イベント感知用のLabelコントロールを、格子状のフォームセルにぴったりと被せ、処理を実行しています。
LabelコントロールのMouseDownイベントは、そのラベル上のX位置・Y位置を取得できるため、マウスのボタンを押した時に、その位置にImageコントロールがあれば掴んだ状態にします。再度マウスのボタンを押すとImageコントロールを離します。
Imageを掴んだ状態の時は、MouseMoveイベントの処理が実行されます。

MouseMoveイベントでは、マウスポインタにあわせImageコントロールを移動させます。
基本的にマウスポインタがImageの中心になるよう位置調整を行っていますが、Imageが移動制限範囲を超える場合は、制限範囲内に留めます。

今回のサンプルでは、Labelコントロール(Label_Main)を移動制限範囲の基準にしています。このLabelはフォームセルにぴったりと重ねているため、結果としてImageの移動がセル内に制限される形になります。

またMouseMoveイベントでは、掴んでいるImageの左上隅に最も近いセルの行列を取得し、変数に格納しています。
Imageを離す場合は、この変数から行列を取得し、セルのマス目に併せて配置されるようにしています。

■背景セルの色変更
背景セルの色変更は、キャッチしているImageコントロールのTopLeftセル(イメージ左上隅の背景セル)とTagプロパティを用いています。
Tagプロパティの値は、左上マスをTopLeftセルとした対象セル範囲の相対位置を表します。
各セルの色変更の設定・非設定は「1」か「0」で表します。
「;」は行の区切りを表し、区切られたひとまとまりの「1」「0」の文字数が列数を表しています。
【例】10;11;10


Tagプロパティの位置を参照し「1」の場合は、TopLeftセルを基準とした相対位置のセルの色を薄紫に変更しています。


書籍紹介140以上のサンプルファイル付き!

知りたいがすぐわかる! やりたいがすぐできる!
「Excel VBA 逆引きで学ぶ ユーザーフォーム&コントロール」(Kindle版)
ユーザーフォームを扱えると、VBAでできることが大きく広がります!
本書では、知りたいこと、やりたいことから、逆引きで学びを深められます。

■ 購入:amazon

ページトップへ戻る
Copyright(C) 2009- 坂江 保 All Rights Reserved.