オプションボタンの管理ツール：指定ボタンの色変更

Excel VBA 作ってみた

昨日は、シート上に配置された複数のオプションボタンについて、以下の情報を取得してユーザーフォームに表示してみた。

  1. 名称
  2. グループ名
  3. キャプション（表示）

infoment.hatenablog.com

さて、ここからどうするかだが、何をするにもオプションボタンを指定しなければ始まらない。そこで今日は、どのオプションボタンが指定されたか、見える化することに挑戦する。
f:id:Infoment:20190417230204p:plain

今回の作戦は、こうだ。

  1. ボタンの文字色と背景色を、予め取得しておく。
  2. リストボックスで選択されたボタンの色を変える。
  3. リストボックスで選択されたグループの色を丸ごと変える。
  4. ユーザーフォーム終了時に、色を元に戻す。

そこで、色を格納する配列を準備することにした。複数のサブルーチンで繰り返し使用するため、各ボタンをセットするコレクションと併せてモジュールレベル変数にする。

Option Explicit

Dim col As Collection
Dim myForeColor() As Long
Dim myBackColor() As Long

初期化の際に、元の色を取得しておく必要がある。そこで、初期化の部分にそれを追加する。

Private Sub UserForm_Initialize()
    Set col = New Collection
    
    Dim myObj As Excel.OLEObject
        For Each myObj In ActiveSheet.OLEObjects
            If myObj.progID = "Forms.OptionButton.1" Then
                col.Add myObj
            End If
        Next
    
    ' 今回追加。
    ReDim myForeColor(1 To col.Count)
    ReDim myBackColor(1 To col.Count)
        
    Dim Dict As Dictionary
    Set Dict = New Dictionary
    Dim ListSeq() As Variant
    ReDim ListSeq(1 To col.Count, 1 To 3)
    Dim i As Long
        For i = 1 To col.Count
            With col.Item(i).Object
                ListSeq(i, 1) = col.Item(i).Name
                ListSeq(i, 2) = .GroupName
                ListSeq(i, 3) = .Caption
                
                ' 色の保存。今回追加。
                myForeColor(i) = .ForeColor
                myBackColor(i) = .BackColor
                
                ' 重複除去のために辞書を用いているため、アイテム不問。
                Dict(.GroupName) = 1
            End With
        Next
        
        GroupListBox.List = Dict.Keys
        DetailListBox.List = ListSeq
End Sub

ユーザーフォーム終了時には色を元に戻すため、それについても処理を追加する。

Private Sub UserForm_Terminate()
    Dim i As Long
        For i = 1 To col.Count
            With col.Item(i).Object
                .ForeColor = myForeColor(i)
                .BackColor = myBackColor(i)
            End With
        Next
End Sub

さて、まずグループ名を選択する場合については、リストボックスで選択された値と同じ名前のグループ名であれば、色を変えるという処理にする。
※このリストボックスは、値を一つしか選択できない仕様にしてある。

Private Sub GroupListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim i As Long
        For i = 1 To col.Count
            With col.Item(i).Object
                If .GroupName = GroupListBox.Value Then
                    .ForeColor = vbYellow
                    .BackColor = 192
                Else
                    .ForeColor = myForeColor(i)
                    .BackColor = myBackColor(i)
                End If
            End With
        Next
End Sub

次に詳細リスト側については、複数を選択できる仕様にしてあるため、選択 ⇔ 非選択の状態を一つずつ確認して、ボタンに反映させる仕様とした。

Private Sub DetailListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim i As Long
        For i = 1 To DetailListBox.ListCount
            With col.Item(i).Object
                Select Case DetailListBox.Selected(i - 1)
                    Case True
                        .ForeColor = vbYellow
                        .BackColor = 192
                    Case False
                        .ForeColor = myForeColor(i)
                        .BackColor = myBackColor(i)
                End Select
            End With
        Next
End Sub

結果は、このようになった。
f:id:Infoment:20190417231530g:plain

まずは、こんなところか。直すところはあるが、今日はこれで時間切れ。
なお、今日までの最新コードは ↓ こちらです。

参考まで。