VBCommons/ui/CSE_ListSelector.frm

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_ListSelector 
   Caption         =   "<22><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"
   ClientHeight    =   8910.001
   ClientLeft      =   45
   ClientTop       =   375
   ClientWidth     =   8400.001
   OleObjectBlob   =   "CSE_ListSelector.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "CSE_ListSelector"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' =========== List selection dialog ================
' Shared module version: 20220703
' Tested in:
' Depends on: ex_MSHook
' Required reference: Scripting
Option Explicit
Option Compare Text

Private input_ As Excel.ListObject
Private items_() As String
Private selected_ As Scripting.Dictionary
Private isUpdating_ As Boolean

Public delimiter_ As String
Public isCanceled_ As Boolean

Private Sub UserForm_Initialize()
  isUpdating_ = False
  isCanceled_ = True
  Call PositionInMiddle
End Sub

Private Sub UserForm_Finalize()
  Call HookDisable
End Sub

Private Sub UserForm_Activate()
  Call HookEnable(Me, "ProcessMouseWheelMovement")
End Sub

Private Sub UserForm_Deactivate()
  Call HookDisable
End Sub

Public Function Init(iData As Excel.ListObject, Optional bAllowNewItems As Boolean = True)
  Set input_ = iData
  delimiter_ = TBDelim.Text
  
  Call ResetSelection
  Call ScanInput
  Call OnFilter("")
  
  TBNewItem.Enabled = bAllowNewItems
  BtnAddItem.Enabled = bAllowNewItems
End Function

Public Function GetSelectedStr() As String
  Dim sText$: sText = vbNullString
  Dim vItem As Variant
  For Each vItem In selected_.Keys
    If sText <> vbNullString Then _
      sText = sText & delimiter_
    sText = sText & CStr(vItem)
  Next vItem
  GetSelectedStr = sText
End Function

' ========== Event handlers ==========
Private Sub OkBtn_Click()
  isCanceled_ = False
  Call Me.Hide
  Call HookDisable
End Sub

Private Sub CancelBtn_Click()
  isCanceled_ = True
  Call Me.Hide
  Call HookDisable
End Sub

Private Sub ClearListBtn_Click()
  Call ResetSelection
  Call OnFilter(TBFilter.Text)
End Sub

Private Sub TBFilter_Change()
  Call OnFilter(TBFilter.Text)
End Sub

Private Sub TBDelim_Change()
  delimiter_ = TBDelim.Text
End Sub

Private Sub LBItems_Change()
  If isUpdating_ Then _
    Exit Sub
    
  Dim nItem&
  For nItem = 0 To LBItems.ListCount - 1 Step 1
    Dim sText$: sText = LBItems.List(nItem)
    If LBItems.Selected(nItem) Then
      If Not selected_.Exists(sText) Then _
        Call selected_.Add(sText, 0)
    Else
      If selected_.Exists(sText) Then _
        Call selected_.Remove(sText)
    End If
  Next nItem
End Sub

Private Sub BtnAddItem_Click()
  Dim sNewItem$: sNewItem = TBNewItem.Text
  If sNewItem = vbNullString Then _
    Exit Sub
  Dim nItem&
  For nItem = LBound(items_) To UBound(items_) Step 1
    If items_(nItem) = sNewItem Then
      Call UserInteraction.ShowMessage(EM_ITEM_EXISTS, sNewItem)
      Exit Sub
    End If
  Next nItem
  
  Dim iRow As Excel.ListRow: Set iRow = input_.ListRows.Add(1)
  iRow.Range.Cells(1, 1) = sNewItem
  Call ScanInput
  Call OnFilter(TBFilter.Text)
End Sub

' ======= Mouse scrolling for listbox ========
Public Function ProcessMouseWheelMovement(nDirection&)
  If nDirection > 0 Then
    If LBItems.TopIndex > 0 Then _
      LBItems.TopIndex = LBItems.TopIndex - 1
  Else
    If LBItems.TopIndex < LBItems.ListCount - 1 Then _
      LBItems.TopIndex = LBItems.TopIndex + 1
  End If
End Function

' =========
Private Function PositionInMiddle()
  Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (Me.Height / 2)
  Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2)
  
  Me.StartUpPosition = 0
  Me.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0)
  Me.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0)
End Function

Private Function ScanInput()
  ReDim items_(1 To input_.Range.Rows.Count - 1)
  Dim nRow&
  For nRow = 2 To input_.Range.Rows.Count Step 1
    items_(nRow - 1) = input_.Range.Cells(nRow, 1)
  Next nRow
End Function

Private Function ResetSelection()
  Set selected_ = New Scripting.Dictionary
  selected_.CompareMode = TextCompare
End Function

Private Function OnFilter(sFilter$)
  Call LBItems.Clear
  Dim nItem&
  For nItem = LBound(items_) To UBound(items_) Step 1
    If sFilter = vbNullString Or VBA.InStr(1, items_(nItem), sFilter, vbTextCompare) <> 0 Then
      Call LBItems.AddItem(items_(nItem))
    End If
  Next nItem
  Call UpdateSelected
  Call UpdateCount
End Function

Private Function UpdateCount()
  TBViewCount.Value = LBItems.ListCount
  TBTotalCount.Value = ArraySize(items_)
  TBSelectedCount.Value = selected_.Count
End Function

Private Function UpdateSelected()
  isUpdating_ = True
  
  If LBItems.ListCount = 0 Then _
    Exit Function
  
  Dim nItem&
  For nItem = 0 To LBItems.ListCount - 1 Step 1
    LBItems.Selected(nItem) = selected_.Exists(LBItems.List(nItem))
  Next nItem
  
  isUpdating_ = False
End Function