lboxex.ctl

此源码为vb圣经编码

'**Start Required**
    InitializeIPAOHook m_IPAOHook, Me
'**End Required**
    ResetWindowColors
    m_BlockDrawItemID = -1
    m_FakeCaretIndex = -1
    m_fusWinStyle = WS_VSCROLL Or WS_HSCROLL Or WS_CHILD Or WS_CLIPSIBLINGS Or LBS_NOTIFY
End Sub

Private Sub UserControl_InitProperties()
    m_Appearance = [3D]
    StyleBit(LBS_HASSTRINGS) = True
    InitializeMode
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_Appearance = PropBag.ReadProperty("Appearance", [3D])
    StyleBit(LBS_NOINTEGRALHEIGHT) = Not PropBag.ReadProperty("IntegralHeight", False)
    SetMultiSelect PropBag.ReadProperty("MultiSelect", vbMultiSelectNone)
    m_CheckStyle = PropBag.ReadProperty("MultiSelectStyle", lbexMsNoCheck)
    StyleBit(LBS_NODATA) = Not PropBag.ReadProperty("StoreData", True)
    StyleBit(LBS_HASSTRINGS) = PropBag.ReadProperty("StoreStrings", True)
    StyleBit(LBS_SORT) = PropBag.ReadProperty("Sorted", False)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    InitializeMode
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Appearance", m_Appearance
    PropBag.WriteProperty "IntegralHeight", Not StyleBit(LBS_NOINTEGRALHEIGHT)
    PropBag.WriteProperty "StoreData", Not StyleBit(LBS_NODATA)
    PropBag.WriteProperty "StoreStrings", StyleBit(LBS_HASSTRINGS)
    PropBag.WriteProperty "Sorted", StyleBit(LBS_SORT)
    PropBag.WriteProperty "MultiSelect", MultiSelect
    PropBag.WriteProperty "MultiSelectStyle", m_CheckStyle
    PropBag.WriteProperty "Font", UserControl.Font, Ambient.Font
End Sub

Private Sub UserControl_Terminate()
    If Not m_fDesign Then
        'WARNING: If you put a breakpoint after the UnSubClass calls,
        'then you must not expand the Me value in the locals window.
        'This attempts to evaluate all public property procedures, some
        'of which rely on a current subclass.
        If m_hWndParent Then UnSubClass m_SubClassParent, m_hWndParent
        If m_hWndLB Then UnSubClass m_SubClassLB, m_hWndLB
        m_hWndParent = 0
        m_hWndLB = 0
        ResetWindowColors True 'Free GDI objects
    End If
End Sub

Private Sub UserControl_Paint()
Dim rct As RECT
    If m_fDesign Then
        With UserControl
            If m_Appearance = [3D] Then
                GetClientRect .hWnd, rct
                DrawEdge .hDC, rct, EDGE_SUNKEN, BF_RECT
                .CurrentX = 4
                .CurrentY = 2
            Else
                Rectangle .hDC, 0, 0, .ScaleWidth, .ScaleHeight
                .CurrentX = 3
                .CurrentY = 1
            End If
            UserControl.Print .Ambient.DisplayName
        End With
    End If
End Sub

Private Sub UserControl_Resize()
Dim Shift As Integer
Static fResizing As Boolean
Dim rctLB As RECT
Dim rctCtrl As RECT
Dim hWnd As Long
    If fResizing Then Exit Sub
    If m_hWndLB Then
        #If SUPPORTOLDSHELL Then
        If Not IsNewShell And m_Appearance = [3D] Then Shift = 2
        #End If
        SetWindowPos m_hWndLB, 0, Shift, Shift, ScaleWidth - 2 * Shift, ScaleHeight - 2 * Shift, SWP_NOZORDER Or SWP_NOACTIVATE
        If Not StyleBit(LBS_NOINTEGRALHEIGHT) Then
            hWnd = UserControl.hWnd
            fResizing = True
            GetWindowRect m_hWndLB, rctLB
            GetWindowRect hWnd, rctCtrl
            SetWindowPos hWnd, 0, 0, 0, rctCtrl.Right - rctCtrl.Left, rctLB.Bottom - rctLB.Top + 2 * Shift, SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_NOMOVE
            fResizing = False
        End If
    End If
End Sub

Public Property Get Appearance() As LbExAppearance
    Appearance = m_Appearance
End Property
Public Property Let Appearance(ByVal New_Appearance As LbExAppearance)
    If m_fDesign Then
        If m_Appearance <> New_Appearance Then
            If New_Appearance < [3D] Or New_Appearance > Flat Then Err.Raise 5
            m_Appearance = New_Appearance
            UserControl.Refresh
        End If
    Else
        Err.Raise 382
    End If
End Property

Private Sub DrawCheckBox(pDIS As DRAWITEMSTRUCT, prc As RECT, CheckStyle As LbExMultiSelectStyle)
Dim hBrushOld As Long, hPenOld As Long
Dim pLogBrush As LOGBRUSH
Dim hDC As Long
Dim rct As RECT
    If pDIS.itemAction And (ODA_SELECT Or ODA_DRAWENTIRE) Then
        #If SUPPORTOLDSHELL Then
        If Not IsNewShell Or CheckStyle = lbexMsXCheck Then
        #Else
        If CheckStyle = lbexMsXCheck Then
        #End If
            hDC = pDIS.hDC
            SetBkColor hDC, m_Colors(clrWindow)
            '??? Use SysColorBrush
            hPenOld = SelectObject(hDC, GDIObjects(clrWindowText))
            hBrushOld = SelectObject(hDC, GDIObjects(clrWindow))
            With prc
                'Ignore error checking, it isn't worth it.
                Rectangle hDC, .Left + 2, _
                               .Top + 2, _
                               .Left + 3 + (.Bottom - .Top - 5), _
                               .Bottom - 2
                If pDIS.itemState And ODS_SELECTED Then
                    MoveToEx hDC, .Left + 2, .Top + 2, ByVal 0
                    LineTo hDC, .Left + 2 + (.Bottom - .Top - 5), .Bottom - 3
                    MoveToEx hDC, .Left + 2 + (.Bottom - .Top - 5), .Top + 2, ByVal 0
                    LineTo hDC, .Left + 2, .Bottom - 3
                End If
            End With
            'Clean up hDC
            SelectObject hDC, hPenOld
            SelectObject hDC, hBrushOld
        Else
            hDC = pDIS.hDC
            rct = prc
            rct.Right = rct.Left + prc.Bottom - prc.Top
            If CheckStyle = lbexMs3DCheckBox Then
                DrawFrameControl pDIS.hDC, rct, DFC_BUTTON, _
                     DFCS_BUTTONCHECK - CBool(pDIS.itemState And ODS_SELECTED) * DFCS_CHECKED
            Else
                rct = prc
                rct.Right = rct.Left + prc.Bottom - prc.Top
                If pDIS.itemState And ODS_SELECTED Then DrawFrameControl hDC, rct, 2, 1
                With rct
                    .Left = prc.Left + 1
                    .Right = .Left + 1 + (prc.Bottom - prc.Top - 4)
                    .Top = prc.Top + 1
                    .Bottom = prc.Bottom - 2
                    hPenOld = SelectObject(hDC, GDIObjects(clrButtonShadow))
                    If pDIS.itemState And ODS_SELECTED Then
                        MoveToEx pDIS.hDC, .Left, .Top, ByVal 0&
                        'UNDONE: polygon this?
                        LineTo hDC, .Right, .Top
                        LineTo hDC, .Right, .Bottom
                        LineTo hDC, .Left, .Bottom
                        LineTo hDC, .Left, .Top
                    Else
                        Rectangle hDC, .Left, .Top, .Right + 1, .Bottom + 1
                    End If
                    SelectObject hDC, hPenOld
                End With
            End If
        End If
    End If
    With prc
        .Left = .Left + .Bottom - .Top
    End With
End Sub

Private Function DrawItemText(pDIS As DRAWITEMSTRUCT, prc As RECT)
Dim hBrushOld As Long, hPenOld As Long
Dim clrText As GDIHandles, clrBack As GDIHandles
Dim hDC As Long
Dim strItem As String, cbItem As Integer
    hDC = pDIS.hDC
    If CBool(m_CheckStyle) And pDIS.itemAction And ODA_SELECT Then
        DrawItemText = True
        Exit Function
    Else
        'This could all be done with less code, but more API calls.
        'Until we can short circuit, use this approach. (CaretIndex is an API call).
        If pDIS.itemID = -1 Then
            clrBack = clrWindow
            clrText = clrWindowText
        Else
            If m_CheckStyle Then
                If pDIS.itemState And ODS_FOCUS Then
                    clrBack = clrHighlight
                    clrText = clrHighlightText
                ElseIf HasFocus Then
                    clrBack = clrWindow
                    clrText = clrWindowText
                Else
                    If pDIS.itemID = CaretIndex Then
                        clrBack = clrHighlight
                        clrText = clrHighlightText
                    Else
                        clrBack = clrWindow
                        clrText = clrWindowText
                    End If
                End If
            Else
                If pDIS.itemState And ODS_SELECTED Then
                    clrBack = clrHighlight
                    clrText = clrHighlightText
                Else
                    clrBack = clrWindow
                    clrText = clrWindowText
                End If
            End If
        End If
        SetTextColor hDC, m_Colors(clrText)
        SetBkColor hDC, m_Colors(clrBack)
        hBrushOld = SelectObject(hDC, GDIObjects(clrBack))
        hPenOld = SelectObject(hDC, GetStockObject(NULL_PEN))
        With prc
            Rectangle hDC, .Left, .Top, .Right + 1, .Bottom + 1
        End With
        'Clean up hDC
        SelectObject hDC, hBrushOld
        SelectObject hDC, hPenOld
    End If
    If Not pDIS.itemID Then
        If Not pDIS.itemID Then
            strItem = ListString(pDIS.itemID)
        End If
        If StrPtr(strItem) Then
            With prc
                .Left = .Left + 1
                DrawItemText = DrawText(hDC, strItem, -1, prc, _
                        DT_VCENTER Or DT_LEFT Or DT_SINGLELINE Or DT_NOPREFIX Or DT_NOCLIP)
                .Left = .Left - 1
            End With
        End If
    End If
End Function

Private Function DrawFocus(pDIS As DRAWITEMSTRUCT, prc As RECT) As Boolean
    If pDIS.itemAction And (ODA_FOCUS Or ODA_DRAWENTIRE) Then
        If pDIS.itemState And ODS_FOCUS Then
            If HasFocus Then
                DrawFocusRect pDIS.hDC, prc
            ElseIf QueryForceHasFocus Then
                DrawFocusRect pDIS.hDC, prc
            End If
        End If
    End If
    DrawFocus = True
End Function

Public Sub Clear()
    DoMsg LB_RESETCONTENT
    DoMsg LB_SETHORIZONTALEXTENT, 0, 0
    m_iLastTopIndex = -1
End Sub

Public Property Let ListCount(ByVal New_ListCount As Long)
Dim l&
    If m_fHasData Then
        If m_fHasStrings Then
            Err.Raise 5, , "StoreStrings must be False"
        Else
            Clear
            For l& = 1 To New_ListCount
                DoMsg LB_ADDSTRING
            Next
        End If
    Else
        DoMsg LB_SETCOUNT, New_ListCount
    End If
End Property
Public Property Get ListCount() As Long
    NoPropertySheet
    ListCount = DoMsg(LB_GETCOUNT)
End Property
Public Function AddItem(NewItem As String, Optional ByVal Index As Long = -1) As Long
    If m_fHasStrings Then
        If StrPtr(NewItem) = 0 Then NewItem = ""
        If Not Index Then
            AddItem = DoMsgString(LB_ADDSTRING, 0, NewItem)
        Else
            AddItem = DoMsgString(LB_INSERTSTRING, Index, NewItem)
        End If
    ElseIf m_fHasData Then
        If Not Index Then
            AddItem = DoMsg(LB_ADDSTRING)
        Else
            AddItem = DoMsg(LB_INSERTSTRING, Index)
        End If
    Else
        Err.Raise 5, , "StoreStrings or StoreData must be True"
    End If
End Function
Public Sub RemoveItem(ByVal Index As Long)
    DoMsg LB_DELETESTRING, Index
End Sub
Public Property Get List(ByVal Index As Long) As String
    NoPropertySheet
    List = ListString(Index)
End Property
Public Property Get ItemData(ByVal Index As Long) As Long
    If m_fHasData Then
        ItemData = DoMsg(LB_GETITEMDATA, Index, 0)
    Else
        Err.Raise 5, , "Not supported when StoreData property is False"
    End If
End Property

Public Property Let ItemData(ByVal Index As Long, ByVal Value As Long)
    If m_fHasData Then
        DoMsg LB_SETITEMDATA, Index, Value
    Else
        Err.Raise 5, , "Not supported when StoreData property is False"
    End If
End Property

Public Property Get ListIndex() As Long
    NoPropertySheet
    If DoMsg(LB_GETCOUNT) Then
        ListIndex = CaretIndex