Giả lập tính năng Freeze pane cho Listbox trên Userform

[ongke0711]

Rảnh rỗi tôi cũng mày mò làm nháy thử tính năng Freeze Pane của Excel Sheet áp dụng cho Listbox trên Userform xem thử. Cách xử lý này vẫn còn nhiều bất cập do khả năng lập trình vẫn còn hạn chế. Các bạn tham khảo cho vui vậy.
- Chưa lập trình được việc dùng thanh cuộn cho tính năng freeze pane này.
- Chắc cũng còn nhiều lỗi do chưa tính đến.

Link file demo: https://www.mediafire.com/file/9u0hdcq3xh7odt2/FreezePane_ListBox.xlsm/file

- Copy clsFreezePaneListBox vào Class module.
- Copy 2 module: modCommands và modGlobalVariables vào Standard module.
- Code cho Userform: Thiết lập các thông số cho listbox và gán vào class module.

- Codde Userform:

Option Explicit

Dim Listbox_freezepane As clsFreezePaneListBox  'Khai bao listbox can dung freeze pane

Private Sub UserForm_Initialize()
    Me.BackColor = RGB(41, 74, 97)

    Call settingListBox     'Thiet lap thuoc tinh cua listbox truoc khi gan cho class

    Set Listbox_freezepane = New clsFreezePaneListBox
    Set Listbox_freezepane.ListBoxControl = Me.lstDSKH
    Listbox_freezepane.Initialize
    blnFreeze = False   'Khong ap dung freeze pane khi mo form.
 
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set Listbox_freezepane = Nothing
End Sub

Sub settingListBox()
    Dim lastRw As Long, lastCol As Long, sht As Worksheet
 
    Set sht = Sheets("DSKhachHang")
    lastRw = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
    lastCol = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
 
    With lstDSKH
        .ColumnCount = 7
        .ColumnWidths = "100;150;200;80;120;80;500"
        .ColumnHeads = True
        .RowSource = "A2:G" & lastRw
    End With
 
    Me.lblSoDong = Me.lblSoDong.Caption & " " & lastRw
    Me.lblSoCot = Me.lblSoCot.Caption & " " & lastCol
End Sub

- Code class module: clsFreezePaneListBox:

Option Explicit

Private WithEvents oListBox As MSForms.listBox
'Private colIndex As Long
Private arrColWidths As Variant
Private arrOldColWidths As Variant
Private strOldColWidths As String
Private myBar As CommandBar    ' Object

Public Property Get ListBoxControl() As MSForms.listBox
    Set ListBoxControl = oListBox
End Property

Public Property Set ListBoxControl(reg_Control As MSForms.listBox)
    Set oListBox = reg_Control
End Property

Public Sub Initialize()
    strOldColWidths = oListBox.ColumnWidths
    arrColWidths = Split(oListBox.ColumnWidths, ";")
    arrOldColWidths = arrColWidths
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    Set oListBox = Nothing
    myBar.Delete
End Sub

Private Sub oListBox_KeyDown(ByVal keyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    makeFreezePane keyCode
End Sub

Private Sub oListBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
 
    '# Tao menu nut chuot phai de thuc hien Freeze/Unfreeze Pane
    If Button = 2 Then
        On Error Resume Next
        CommandBars.Item("FreezePane").Delete
        On Error GoTo 0
        Set myBar = CommandBars _
                    .Add(name:="FreezePane", Position:=msoBarPopup, Temporary:=False)
        Dim CB1 As CommandBarButton, CB2 As CommandBarButton
        Set CB1 = myBar.Controls.Add(type:=msoControlButton)
            CB1.Caption = "Freeze pane": CB1.OnAction = "'" & ThisWorkbook.name & "'!" & "freezePaneCbar": CB1.FaceId = 988
        Set CB2 = myBar.Controls.Add(type:=msoControlButton)
            CB2.Caption = "Unfreeze pane": CB2.OnAction = "'" & ThisWorkbook.name & "'!" & "unFreezePaneCbar": CB2.FaceId = 987
        myBar.ShowPopup
    End If

End Sub

'# Gia lap freeze pane thong qua bam phim mui ten Trai/Phai
'# Khong dung duoc cho thanh cuon (scrollbar) cua listbox.
'-------------------------------------------------------------
Sub makeFreezePane(ByVal keyCode As MSForms.ReturnInteger)
    Dim k As Long, strNewColWidths As String
 
    If blnFreeze = False Then   'Khi chon UnfreezePane --> tra columnwith ve chuoi width goc.
        oListBox.ColumnWidths = strOldColWidths
        Exit Sub
    End If
 
    Select Case keyCode
    Case vbKeyLeft
        keyCode = 0
        If colIndex = oListBox.ColumnCount - 2 Then Exit Sub    '-2: de chua lai cot cuoi cung
        colIndex = colIndex + 1
        arrColWidths(colIndex) = "0 pt"     'Thay width cac cot dang di chuyen thanh 0 va noi vao chuoi width goc
        For k = 0 To oListBox.ColumnCount - 1
            strNewColWidths = strNewColWidths & arrColWidths(k) & ";"
        Next
        strNewColWidths = Left(strNewColWidths, Len(strNewColWidths) - 1)
        oListBox.ColumnWidths = strNewColWidths

    Case vbKeyRight
        keyCode = 0
        If colIndex < 1 Then
            keyCode = 0
            Exit Sub
        End If
        If colIndex = selectedColIndex Then Exit Sub    'Khi tra nguoc, se ngung o cot duoc chon ban dau de freeze.
        arrColWidths(colIndex) = arrOldColWidths(colIndex)
        For k = 0 To oListBox.ColumnCount - 1
            strNewColWidths = strNewColWidths & arrColWidths(k) & ";"
        Next
        strNewColWidths = Left(strNewColWidths, Len(strNewColWidths) - 1)
        oListBox.ColumnWidths = strNewColWidths
        colIndex = colIndex - 1
    End Select
End Sub

-Code module: modCommands

Option Explicit

Sub Button1_Click()
    frmDSKH.Show
End Sub

'# Dung cho clsFreezePaneListBox
'# Dung chon so thu tu cot bat dau freeze pane
'---------------------------------------------------------
Public Sub freezePaneCbar()
    Dim x As String
 
    blnFreeze = True
    colIndex = 0
nhaplai:
    x = InputBox("Nhap so thu tu cot can freeze: ", ".:: Chon cot")
    If x = "" Then  'Bam Cancel, Enter nhung khong nhap gia tri
        blnFreeze = False
        Exit Sub
    End If
 
    If IsNumeric(x) Then
        If Val(x) = 0 Then
            MsgBox "So khong hop le." & vbCrLf _
                & "Nhap so tu 1 -3."
            GoTo nhaplai
        ElseIf Val(x) > 3 Then
            MsgBox "So cot khong > 3"
            GoTo nhaplai
        End If
    Else
        MsgBox "Ban phai nhap so."
        GoTo nhaplai
    End If

    colIndex = Val(x) - 1
    selectedColIndex = colIndex
End Sub

'# Dung cho clsFreezePaneListBox #
'---------------------------------
Sub unFreezePaneCbar()
    blnFreeze = False
End Sub

- Code module: modGlobalVariables

Option Explicit

'/Bien dung cho clsFreezePaneListBox ***
Public colIndex As Long
Public selectedColIndex As Long     'Luu so thu tu cot chon ban dau de dung cho nut phai chuot khi tra ve
Public blnFreeze As Boolean         'Bien luu tinh trang co Freeze hay Unfreeze pane
'------------------------------------------/

 

[ongke0711]

Hiển thị các cột checkbox trong Listbox của Userform Excel

Cách tôi làm là dùng mảng để tạo nguồn cho Listbox. Khi đó có thể can thiệt vào mảng để đổi giá trị True/False thành Checkbox.
Cách làm này có hạn chế là thiết kế cố định Label cho cột và không dùng thanh cuộn ngang (scrollbar) được.

With Me.ListBox1
        .ColumnCount = UBound(myArr, 2)
        .ColumnHeads = False
        '.MultiSelect = fmMultiSelectExtended
        '.ListStyle = fmListStyleOption
     
        For i = 1 To 28
            For j = 5 To 9
                If myArr(i, j) = 0 Then
                    myArr(i, j) = ChrW(&H2610)
                Else
                    myArr(i, j) = ChrW(&H2611)
                End If
            Next
        Next
        .List = myArr
    End With

 

[donghung1512]

Hiển thị các cột checkbox trong Listbox của Userform Excel

Có thể hiển thị được checkbox các cột ( tùy chọn) trong Listview VBA không bác?

 

[ongke0711]

Có thể hiển thị được checkbox các cột ( tùy chọn) trong Listview VBA không bác?

Listview chưa ngâm cứu bạn à .
Tôi không có làm ứng dụng gì trong Excel nên không biết nhiều cho lắm.