トップ > 逆引きで学ぶ ユーザーフォーム&コントロール > 追加章　遊ぶ！楽しむ！ユーザーフォーム > T-06　フォーム上のイメージの変更と背景セルに色を設定する

'フォーム上にセルに見立てたラベルを格子状に配置しています
'そのラベル群を便宜上フォームセルと呼びます
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セルアドレス
Private lngRotNumber As Long            '画像の回転番号

'■ラベルイベント(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 Button = 1 Then    'マウス左ボタン
            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
        ElseIf Button = 2 Then 'マウス右ボタン
            strImageName = Get_ImageName(.Left, .Top, X, Y) 'イメージ名 取得
            If strImageName = "" Then Exit Sub
            
            If lngRotNumber = 0 Then lngRotNumber = 1
            lngRotNumber = lngRotNumber + 1                 '回転番号更新
            If lngRotNumber = 5 Then lngRotNumber = 1
            With Controls(strImageName)                     'プロパティを受け渡し
                .Picture = Controls("Image" & lngRotNumber).Picture
                .Height = Controls("Image" & lngRotNumber).Height
                .Width = Controls("Image" & lngRotNumber).Width
                .Tag = Controls("Image" & lngRotNumber).Tag
            
                Dim lngR As Long
                Dim lngC As Long
                'Imageコントロールが移動制限範囲を超えた場合は制限内に収める
                If Label_Main.Left + Label_Main.Width - .Width < .Left Then
                    .Left = Label_Main.Left + Label_Main.Width - .Width
                End If
                If Label_Main.Top + Label_Main.Height - .Height < .Top Then
                    .Top = Label_Main.Top + Label_Main.Height - .Height
                End If
                lngC = (FCW / 2 + .Left) \ FCW
                lngR = (FCH / 2 + .Top) \ FCH
            End With
            strAddress = lngR & "," & lngC
            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

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

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

■ 購入：amazon