ListBoxの複数選択可否を切り替える

昨日は、選択したCheckBox（フォームコントロール）のキャプションを変更することに挑戦した。
infoment.hatenablog.com

一応、予定した動作は実現できたものの、リストボックスの選択数によって判断する箇所が多く、（個人的に）どうもスマートでない。

そこで、次の段階に進む前に、微修正してみた。

今回追加したのは、このチェックボックス。

こうすることで、コードの方はスッキリした。使い勝手の方も、さほど気にならない。今回は一応の中締めとして、現時点で関係するマクロを一通り記載しておく。

標準モジュール

Function SetCheckBox(target_range As Range, _
            Optional cb_name As String = vbNullString, _
            Optional cb_caption As String = vbNullString) As CheckBox
    Dim CB As CheckBox
        ' チェックボックス配置。
        With target_range
            Set CB = ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
        End With
        
        ' 名前とキャプションの指定があれば、それに変更する。
        If cb_name <> vbNullString Then CB.Name = cb_name
        If cb_caption <> vbNullString Then
            CB.Caption = cb_caption
            
            ' サイズ獲得用にActiveXコントロール配置。
            Dim CBX As OLEObject
            ' サイズさえ取れれば良いので、配置位置は不問。
            Set CBX = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1")
            ' 途中で折り返したままサイズ調整されないよう、充分な長さに引き伸ばしておく。
                CBX.Width = 1000
            ' 指定キャプションをセットして、サイズを自動調整。
                CBX.Object.Caption = cb_caption
                CBX.Object.AutoSize = True
            
            ' フォームコントロールのチェックボックスにサイズ反映。
                CB.Width = CBX.Width
                CB.Height = CBX.Height
                
            ' 不要になったActiveXコントロールを削除。
                CBX.Delete
        End If
        
    Set SetCheckBox = CB
End Function

Public Property Get CBs() As CheckBoxes
    Set CBs = ActiveSheet.CheckBoxes
End Property

Public Property Get CheckBoxList() As Variant
    Dim arr() As Variant
        If CBs.Count = 0 Then
            CheckBoxList = Array()
            Exit Property
        Else
            ReDim arr(1 To CBs.Count, 1 To 2)
        End If
    Dim i
        For i = 1 To CBs.Count
            arr(i, 1) = CBs.Item(i).Name
            arr(i, 2) = CBs.Item(i).Caption
        Next
        CheckBoxList = arr
End Property

ユーザーフォーム（CBsEditForm）

Private Sub UserForm_Initialize()
    ' 初期値は、空白無視とする。
    ' ※使い勝手を考慮。
    IgnoreBlankCheck = True
    ' 既存のチェックボックス一覧をリストボックスに反映。
    CBsListBox.List = CheckBoxList
End Sub

Private Sub UserForm_Terminate()
    ' チェックボックスへの一時的着色を、
    ' ユーザーフォームを閉じる際に解消。
    Dim i As Long
        For i = 0 To CBsListBox.ListCount - 1
            CBs.Item(i + 1).Interior.Color = xlNone
        Next
End Sub

Private Sub CloseButton_Click()
    Unload Me
End Sub

Private Sub CBsListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim i As Long
        ' リストボックスの選択状況に合わせて、
        ' チェックボックスを着色する。
        For i = 0 To CBsListBox.ListCount - 1
            With CBs.Item(i + 1)
                If CBsListBox.Selected(i) Then
                    .Interior.Color = vbRed
                    ' 透明度70％
                    .ShapeRange.Fill.Transparency = 0.7
                Else
                    .Interior.Color = xlNone
                End If
            End With
        Next
        
        ' リストが単一選択モードの場合、変更キャプション名入力補助として
        ' テキストボックスをフォーカス。
        If CBsListBox.MultiSelect = fmMultiSelectSingle Then
            NewCaptionInputBox.SetFocus
        End If
End Sub

Private Sub SetCheckBoxButton_Click()
    Dim r As Range
        For Each r In Selection
            ' 空白を無視しないか、または空白でない場合のみチェックボックス配置。
            If IgnoreBlankCheck = False Or r.Value <> vbNullString Then
                ' CheckBox配置。
                SetCheckBox r, , r.Value
                ' 置き換えのため、セルの文字を削除。
                r.ClearContents
            End If
        Next
        ' チェックボックスの増減があるため、リストボックスをリセット。
        ResetCBsListBox
End Sub

Private Sub CaptionChangeButton_Click()
    
    Dim SelectedIndex As Long
        SelectedIndex = CBsListBox.ListIndex
        
        ' チェックボックス選択確認。
        If SelectedIndex = -1 Then
            MsgBox "対象となるCheckBoxが未選択です。"
            Exit Sub
        End If
    
        ' チェックボックスのキャプション変更。
        CBs.Item(SelectedIndex + 1).Caption = NewCaptionInputBox.Value
        ' 次の入力に備え、テキストボックスを初期化。
        NewCaptionInputBox.Value = vbNullString
        ' キャプション変更を反映するために、リストボックスをリセット。
        ResetCBsListBox
        ' どのチェックボックスが選ばれていたかを明示するため、改めて
        ' 対象をリストから選択。
        CBsListBox.Selected(SelectedIndex) = True
End Sub

Private Sub MultiSelectCheck_Click()
    ' リストボックスの複数選択可否を確認。
    Select Case MultiSelectCheck.Value
        ' 選択可の場合。
        Case True
            CBsListBox.MultiSelect = fmMultiSelectMulti
        ' 選択不可の場合。
        Case False
            CBsListBox.MultiSelect = fmMultiSelectSingle
    End Select
    
    ' 選択可否に合わせて、キャプション変更ボタンの有効無効を切り替え。
    ' ※片方が有効の時、もう片方が無効の関係。
    CaptionChangeButton.Enabled = Not MultiSelectCheck.Value
End Sub

Private Sub ResetCBsListBox()
    CBsListBox.Clear
    CBsListBox.List = CheckBoxList
End Sub

今後の展開で変わる部分もあると思うが、取り敢えず今は、こんな感じだ。
早速動かして、確認してみよう。

前回より、少しマシになったかな。
明日に続きます。

参考まで。