lboxex.ctl

此源码为vb圣经编码

    Else
        ListIndex = -1
    End If
End Property
Public Property Let ListIndex(ByVal New_ListIndex As Long)
    If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
        WindowProc m_hWndLB, LB_SETCARETINDEX, New_ListIndex, 0
    Else
        WindowProc m_hWndLB, LB_SETCURSEL, New_ListIndex, 0
    End If
End Property

Public Property Get TopIndex() As Long
    NoPropertySheet
    If DoMsg(LB_GETCOUNT) Then
        TopIndex = m_iLastTopIndex
    Else
        TopIndex = -1
    End If
End Property
Public Property Let TopIndex(ByVal New_TopIndex As Long)
    WindowProc m_hWndLB, LB_SETTOPINDEX, New_TopIndex, 0
End Property

Public Property Get Selected(ByVal Index As Long) As Boolean
    NoPropertySheet
    If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
        Selected = DoMsg(LB_GETSEL, Index)
    Else
        Err.Raise 5, , "Only applies to MultiSelect listbox."
    End If
End Property
Public Property Let Selected(ByVal Index As Long, ByVal New_Selected As Boolean)
Dim strMsg As String, strMsgTitle As String, MsgBoxFlags As VbMsgBoxStyle
    If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
        If SetSelection(Index, New_Selected, strMsg, strMsgTitle, MsgBoxFlags) Then
            DoMsg LB_SETSEL, -New_Selected, Index
        Else
            ShowMessage strMsg, strMsgTitle, MsgBoxFlags
        End If
    Else
        Err.Raise 5, , "Only applies to MultiSelect listbox."
    End If
End Property

Private Property Get GDIObjects(ByVal hGDI As GDIHandles) As Long
Dim pLogBrush As LOGBRUSH
    If m_hGDIObjects(hGDI) = 0 Then
        Select Case hGDI
            Case Is <= clrLastPen
                m_hGDIObjects(hGDI) = CreatePen(PS_SOLID, 1, m_Colors(hGDI))
            Case Is <= clrLastBrush
                With pLogBrush
                    .lbStyle = BS_SOLID
                    .lbColor = m_Colors(hGDI)
                End With
                m_hGDIObjects(hGDI) = CreateBrushIndirect(pLogBrush)
        End Select
    End If
    GDIObjects = m_hGDIObjects(hGDI)
End Property

Private Function ResetWindowColors(Optional fClearOnly As Boolean = False)
Dim i%
    For i% = 0 To 3
        If m_hGDIObjects(i%) Then DeleteObject m_hGDIObjects(i%)
        m_hGDIObjects(i%) = 0
    Next i%
    If Not fClearOnly Then
        m_Colors(clrWindow) = GetSysColor(COLOR_WINDOW)
        m_Colors(clrWindowText) = GetSysColor(COLOR_WINDOWTEXT)
        m_Colors(clrHighlight) = GetSysColor(COLOR_HIGHLIGHT)
        m_Colors(clrHighlightText) = GetSysColor(COLOR_HIGHLIGHTTEXT)
        m_Colors(clrButtonShadow) = GetSysColor(COLOR_BTNSHADOW)
        m_Colors(clrGrayText) = GetSysColor(COLOR_BTNFACE)
    End If
End Function

Private Property Get HasFocus() As Boolean
    HasFocus = m_hWndLB = GetFocus
End Property

Private Property Get CaretIndex() As Long
'LB_SETCARETINDEX causes the listbox to draw, which calls
'LB_GETCARETINDEX, which is wrong until the SETCARETINDEX
'message has finished.
    If Not m_FakeCaretIndex Then
        CaretIndex = m_FakeCaretIndex
    Else
        CaretIndex = DoMsg(LB_GETCARETINDEX, 0, 0)
    End If
End Property

Private Function DoMsg(ByVal uMsg As Long, Optional ByVal wParam As Long = 0, Optional ByVal lParam As Long = 0) As Long
    DoMsg = CallWindowProc(m_SubClassLB.wndprocNext, m_hWndLB, uMsg, wParam, lParam)
End Function

Private Function DoMsgString(ByVal uMsg As Long, ByVal wParam As Long, lParam As String) As Long
    DoMsgString = CallWindowProcAny(m_SubClassLB.wndprocNext, m_hWndLB, uMsg, wParam, ByVal lParam)
End Function

Private Sub InvalidateItemRect(ByVal Index As Long)
Dim rct As RECT
    CallWindowProc m_SubClassLB.wndprocNext, m_hWndLB, LB_GETITEMRECT, Index, VarPtr(rct)
    InvalidateRect m_hWndLB, rct, 1
End Sub

Private Sub NoPropertySheet()
    'To keep a property out of both the locals window and the
    'property sheet, check the 'Don't show in Property Browser'
    'attribute, available on the Advanced tab of the Tools/Procedure
    'Attributes dialog.  To stop the item from showing in the
    'property sheet, but still support it in the locals window,
    'use this approach.
    
    'If you stop on this error, then right click on the
    'code pane and choose Toggle/Break on Unhandled Errors.
    'You can set the default for this setting in the Tools/Options
    'dialog on the General tab.
    If m_fDesign Then Err.Raise 394 'GetNotSupported
End Sub

Private Sub DesignTimeOnly()
    If Not m_fDesign Then Err.Raise 382
End Sub

Private Sub SetDesignMode()
    On Error Resume Next
    m_fDesign = Not Ambient.UserMode
    If Err Then m_fDesign = True
    On Error GoTo 0
End Sub

Private Function SyncFont() As Boolean
Dim tmpIFont As IFont
    If Not m_IFont Is Nothing Then
        Set tmpIFont = UserControl.Font
        If m_IFont.hFont <> tmpIFont.hFont Then
            'This cuts off outside objects from accessing
            'the current font object
            m_IFont.Clone tmpIFont
            Set Me.Font = tmpIFont
            Set m_IFont = Nothing
        End If
    End If
End Function

Public Property Get Font() As Font
Dim tmpIFont As IFont
    If m_fDesign Then
        Set Font = UserControl.Font
    Else
        If m_IFont Is Nothing Then
            Set tmpIFont = UserControl.Font
            tmpIFont.Clone m_IFont
        End If
        Set Font = m_IFont
    End If
End Property

Public Property Set Font(ByVal New_Font As Font)
Dim IFont As IFont
Dim tmpFont As Font
    If m_fDesign Then
        Set UserControl.Font = New_Font
    Else
        With UserControl
            'We want to keep the old font temporarily since windows is still
            'holding a handle to it in the listbox
            Set tmpFont = .Font
            Set .Font = New_Font 'This will raise an error if New_Font is nothing
            If m_hWndLB Then
                Set IFont = New_Font
                DoMsg WM_SETFONT, IFont.hFont, 1&
                m_CheckWidth = .TextHeight("A")
                DoMsg LB_SETITEMHEIGHT, 0, m_CheckWidth
            End If
        End With
    End If
    PropertyChanged "Font"
End Property

Public Sub Refresh()
    UserControl.Refresh
End Sub

Private Sub InitializeMode()
Dim IFont As IFont
Dim Shift As Integer
Dim dwExStyle As Long
Dim Style As Long
    SetDesignMode
    If Not m_fDesign Then
        If m_hWndLB Then Exit Sub
        Style = m_fusWinStyle
        If m_Appearance = [3D] Then
            #If SUPPORTOLDSHELL Then
            If Not IsNewShell Then Shift = 2
            #End If
            dwExStyle = WS_EX_CLIENTEDGE
        Else
            Style = Style Or WS_BORDER
        End If
        m_fHasStrings = Style And LBS_HASSTRINGS
        m_fHasData = Not Style And LBS_NODATA
        If Not m_fHasData Or Not m_fHasStrings Or m_CheckStyle Then Style = Style Or LBS_OWNERDRAWFIXED
        With UserControl
            m_hWndLB = CreateWindowEx(dwExStyle, "LISTBOX", vbNullString, _
                       Style, Shift, Shift, .ScaleWidth - 2 * Shift, .ScaleHeight - 2 * Shift, .hWnd, 0, App.hInstance, ByVal 0&)
            If m_hWndLB Then
                Set IFont = .Font
                SendMessage m_hWndLB, WM_SETFONT, IFont.hFont, ByVal 1&
                m_CheckWidth = .TextHeight("A")
                SendMessage m_hWndLB, LB_SETITEMHEIGHT, 0, ByVal m_CheckWidth
                m_iLastTopIndex = -1
                SubClass m_SubClassLB, m_hWndLB, ObjPtr(Me), AddressOf RedirectLBProc
                m_hWndParent = GetParent(m_hWndLB)
                SubClass m_SubClassParent, m_hWndParent, ObjPtr(Me), AddressOf RedirectLBProcParent
                ShowWindow m_hWndLB, SW_SHOW
            End If
        End With
    End If
End Sub

Public Property Get Sorted() As Boolean
    Sorted = StyleBit(LBS_SORT)
End Property
Public Property Let Sorted(ByVal New_Sorted As Boolean)
    DesignTimeOnly
    PropertyChanged "Sorted"
    StyleBit(LBS_SORT) = New_Sorted
End Property

Public Property Get StoreStrings() As Boolean
    StoreStrings = StyleBit(LBS_HASSTRINGS)
End Property
Public Property Let StoreStrings(ByVal New_StoreStrings As Boolean)
    DesignTimeOnly
    PropertyChanged "StoreStrings"
    StyleBit(LBS_HASSTRINGS) = New_StoreStrings
    If Not New_StoreStrings And Sorted Then
        Sorted = False
    End If
    If New_StoreStrings And Not StoreData Then
        StoreData = True
    End If
End Property

Public Property Get StoreData() As Boolean
    StoreData = Not StyleBit(LBS_NODATA)
End Property
Public Property Let StoreData(ByVal New_StoreData As Boolean)
    DesignTimeOnly
    PropertyChanged "StoreData"
    StyleBit(LBS_NODATA) = Not New_StoreData
    If Not New_StoreData And StoreStrings Then
        StoreStrings = False
    End If
End Property

Public Property Get IntegralHeight() As Boolean
    IntegralHeight = Not StyleBit(LBS_NOINTEGRALHEIGHT)
End Property

Public Property Let IntegralHeight(ByVal RHS As Boolean)
    DesignTimeOnly
    PropertyChanged "IntegralHeight"
    StyleBit(LBS_NOINTEGRALHEIGHT) = Not RHS
End Property
Public Property Get MultiSelect() As MultiSelectConstants
    Select Case m_fusWinStyle And (LBS_MULTIPLESEL Or LBS_EXTENDEDSEL)
        Case LBS_MULTIPLESEL
            MultiSelect = vbMultiSelectSimple
        Case LBS_EXTENDEDSEL
            MultiSelect = vbMultiSelectExtended
        Case Else
            MultiSelect = vbMultiSelectNone
    End Select
End Property

Public Property Let MultiSelect(ByVal RHS As MultiSelectConstants)
    DesignTimeOnly
    PropertyChanged "MultiSelect"
    SetMultiSelect RHS
End Property
Private Sub SetMultiSelect(ByVal RHS As MultiSelectConstants)
    Select Case RHS
        Case vbMultiSelectSimple
            StyleBit(LBS_MULTIPLESEL) = True
            StyleBit(LBS_EXTENDEDSEL) = False
        Case vbMultiSelectExtended
            StyleBit(LBS_MULTIPLESEL) = False
            StyleBit(LBS_EXTENDEDSEL) = True
        Case vbMultiSelectNone
            StyleBit(LBS_MULTIPLESEL) = False
            StyleBit(LBS_EXTENDEDSEL) = False
            If m_CheckStyle Then MultiSelectStyle = lbexMsNoCheck
    End Select
End Sub
Public Property Get MultiSelectStyle() As LbExMultiSelectStyle
    MultiSelectStyle = m_CheckStyle
End Property
Public Property Let MultiSelectStyle(ByVal RHS As LbExMultiSelectStyle)
    If RHS < lbexMsNoCheck Or RHS > lbexMsXCheck Then Err.Raise 5
    If Not m_fDesign Then
        If 0 = (GetWindowLong(m_hWndLB, GWL_STYLE) And LBS_OWNERDRAWFIXED) Then
            Err.Raise 5, , "StoreStrings must be False to change MultiSelectStyle at runtime"
        End If
        m_CheckStyle = RHS
        UserControl.Refresh
    Else
        PropertyChanged "MultiSelectStyle"
        m_CheckStyle = RHS
    End If
End Property
Private Property Let StyleBit(ByVal Bit As Long, ByVal RHS As Boolean)
    If RHS Then
        m_fusWinStyle = m_fusWinStyle Or Bit
    Else
        m_fusWinStyle = Not (m_fusWinStyle Imp Bit)
    End If
End Property
Private Property Get StyleBit(ByVal Bit As Long) As Boolean
    StyleBit = m_fusWinStyle And Bit
End Property