vbAccelerator - Contents of code file: cPickItems.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cPickItems"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private m_hWnd As Long

Friend Sub fInit(ByVal hWnd As Long)
   m_hWnd = hWnd
End Sub
Private Function pbVerify(ctl As vbalPicker) As Boolean
   If gbValidOwner(m_hWnd, ctl) Then
      pbVerify = True
   End If
End Function

Public Sub Clear()
Dim ctl As vbalPicker
   If pbVerify(ctl) Then
      ctl.fClear
   End If
End Sub

Public Sub Remove(Index As Variant)
Dim ctl As vbalPicker
   If pbVerify(ctl) Then
      ctl.fRemoveItem Index
   End If
End Sub

Public Function Add( _
      Optional Before As Variant, _
      Optional Key As Variant, _
      Optional Style As EVPLPickItemTypes = evplIcon, _
      Optional Caption As String = "", _
      Optional Icon As Long = -1 _
   ) As cPickItem
Dim ctl As vbalPicker
Dim lID As Long
Dim lPtr As Long
Dim cI As pcItem
Dim sKeyBefore As String

   If pbVerify(ctl) Then
      
      ' Key:
      lID = gNewID()
      If IsMissing(Key) Then
         Key = "C" & lID
      Else
         If Not ctl.fCheckNewKey(Key) Then
            Exit Function
         End If
      End If
      
      ' Before:
      If Not IsMissing(Before) Then
         If ctl.fGetItem(Before, lPtr, cI) Then
            sKeyBefore = cI.Key
         End If
      End If
      
      Dim cR As New cPickItem
      lPtr = ctl.fAddItem(sKeyBefore, Key, lID, Style, Caption, Icon, cR)
      If Not (lPtr = 0) Then
         Set Add = cR
      End If
   End If
End Function

Public Sub AddOfficeColours(Optional KeyPrefix As Variant, Optional ByVal
 bLargePalette As Boolean = False)
Dim sKey As String
Dim bGenKey As Boolean
Dim nIndexEnd As Long
Dim i As Long
Dim itmX As cPickItem
   
   bGenKey = (Not IsMissing(KeyPrefix))
   If bGenKey Then
      sKey = KeyPrefix
   End If
   If bLargePalette Then
      nIndexEnd = 40
   Else
      nIndexEnd = 16
   End If
   For i = 1 To nIndexEnd
      If bGenKey Then
         Set itmX = Add(, KeyPrefix & i, evplColour)
      Else
         Set itmX = Add(, , evplColour)
      End If
      itmX.Color = pOfficeColour(bLargePalette, i)
   Next i
End Sub

Private Function pOfficeColour(ByVal bLargePalette As Boolean, ByVal nIndex As
 Long) As OLE_COLOR
   If bLargePalette Then
      Select Case nIndex
      Case 1: pOfficeColour = &H0&
      Case 2: pOfficeColour = &H3399&
      Case 3: pOfficeColour = &H3333&
      Case 4: pOfficeColour = &H3300&
      Case 5: pOfficeColour = &H663300
      Case 6: pOfficeColour = &H800000
      Case 7: pOfficeColour = &H993333
      Case 8: pOfficeColour = &H333333
      
      Case 9: pOfficeColour = &H80&
      Case 10: pOfficeColour = &H66FF&
      Case 11: pOfficeColour = &H8080&
      Case 12: pOfficeColour = &H8000&
      Case 13: pOfficeColour = &H808000
      Case 14: pOfficeColour = &HFF0000
      Case 15: pOfficeColour = &H996666
      Case 16: pOfficeColour = &H808080
      
      Case 17: pOfficeColour = &HFF&
      Case 18: pOfficeColour = &H99FF&
      Case 19: pOfficeColour = &HCC99&
      Case 20: pOfficeColour = &H669933
      Case 21: pOfficeColour = &HCCCC33
      Case 22: pOfficeColour = &HFF6633
      Case 23: pOfficeColour = &H800080
      Case 24: pOfficeColour = &H999999
      
      Case 25: pOfficeColour = &HFF00FF
      Case 26: pOfficeColour = &HCCFF&
      Case 27: pOfficeColour = &HFFFF&
      Case 28: pOfficeColour = &HFF00&
      Case 29: pOfficeColour = &HFFFF00
      Case 30: pOfficeColour = &HFFCC00
      Case 31: pOfficeColour = &H663399
      Case 32: pOfficeColour = &HC0C0C0
      
      Case 33: pOfficeColour = &HCC99FF
      Case 34: pOfficeColour = &H99CCFF
      Case 35: pOfficeColour = &H99FFFF
      Case 36: pOfficeColour = &HCCFFCC
      Case 37: pOfficeColour = &HFFFFCC
      Case 38: pOfficeColour = &HFFCC99
      Case 39: pOfficeColour = &HFF99CC
      Case 40: pOfficeColour = &HFFFFFF
      End Select
   Else
      Select Case nIndex
      Case 1: pOfficeColour = &H0&
      Case 2: pOfficeColour = &H808080
      Case 3: pOfficeColour = &H80&
      Case 4: pOfficeColour = &H8080&
      Case 5: pOfficeColour = &H8000&
      Case 6: pOfficeColour = &H808000
      Case 7: pOfficeColour = &H800000
      Case 8: pOfficeColour = &H800080
      
      Case 9: pOfficeColour = &HFFFFFF
      Case 10: pOfficeColour = &HC0C0C0
      Case 11: pOfficeColour = &HFF&
      Case 12: pOfficeColour = &HFFFF&
      Case 13: pOfficeColour = &HFF00&
      Case 14: pOfficeColour = &HFFFF&
      Case 15: pOfficeColour = &HFF0000
      Case 16: pOfficeColour = &HFF00FF
      End Select
   End If
End Function

Public Property Get Item(Index As Variant) As cPickItem
Attribute Item.VB_UserMemId = 0
Dim ctl As vbalPicker
Dim cI As pcItem
Dim lPtr As Long
   
   If pbVerify(ctl) Then
      If ctl.fGetItem(Index, lPtr, cI) Then
         Dim cR As New cPickItem
         cR.fInit m_hWnd, lPtr, cI.Key
         Set Item = cR
      End If
   End If
   
End Property

Public Property Get Count() As Long
Dim ctl As vbalPicker
   If pbVerify(ctl) Then
      Count = ctl.fItemCount
   End If
End Property