lboxex.ctl

此源码为vb圣经编码

VERSION 5.00
Begin VB.UserControl ListBoxEx 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   ClientHeight    =   450
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1200
   ClipControls    =   0   'False
   ScaleHeight     =   30
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   80
   ToolboxBitmap   =   "LBoxEx.ctx":0000
End
Attribute VB_Name = "ListBoxEx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'***************************************************************
Option Explicit
Public Enum LbExAppearance
    [3D]
    Flat
End Enum
Public Enum LbExMultiSelectStyle
    lbexMsNoCheck
    lbexMsFlatCheckBox
    lbexMs3DCheckBox
    lbexMsXCheck
End Enum

Event ListString(ByVal Index As Long, Text As String)
Event QuerySetSelection(ByVal Index As Long, ByVal SelState As Boolean, Cancel As Boolean, Message As String, MessageTitle As String, MessageFlags As VBA.VbMsgBoxStyle)
Attribute QuerySetSelection.VB_Description = "Called when the selection of an item  is about to change for a simple multiselect ListBox.  Set cancel to True to prevent selection.  Fill in Message parameters to show a message (don't show a message box yourself)."
Event Click(ByVal Index As Long)
Event NewTopIndex(ByVal Index As Long)
Attribute NewTopIndex.VB_Description = "Notification fired when ListBox is scrolled."
Event AfterSelectionMessage(ByVal Result As VBA.VbMsgBoxResult)
Attribute AfterSelectionMessage.VB_Description = "If QuerySetSelection is canceled and a message is shown, AfterSelectionMessage is fired with the return value from the MsgBox call."

'**Start Required**
Implements OleTypes.IHookAccelerator
Private m_IPAOHook As IPAOHook
'**End Required**

Private m_fusWinStyle As Long
Private m_hWndLB As Long
Private m_fDesign As Boolean
Private m_Appearance As LbExAppearance
Private m_CheckStyle As LbExMultiSelectStyle

Private m_SubClassLB As SubClassData
Private m_CheckWidth As Integer
Private m_FakeCaretIndex As Long

Private m_SubClassParent As SubClassData
Private m_hWndParent As Long
Private m_BlockDrawItemID As Long
Private m_fHasStrings As Boolean
Private m_fHasData As Boolean

'Cache system colors
Private Enum GDIHandles
    clrWindowText
    clrButtonShadow
    clrGrayText
    clrWindow
    clrHighlight
    clrHighlightText
    clrLastPen = clrGrayText
    clrLastBrush = clrHighlight
End Enum

Private m_Colors(0 To 5) As Long
Private m_hGDIObjects(0 To 4) As Long

Private m_IFont As IFont
Private m_iLastTopIndex As Long

Public QuickNotify As IQuickNotify

Friend Function WindowProcParent(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_DRAWITEM
            With g_DerefDrawItemStruct
                .Owner.SA.pvData = lParam
                If HandleDrawItem(.pSA(0)) Then
                    WindowProcParent = 1
                    Exit Function
                End If
            End With
        Case WM_SYSCOLORCHANGE
            ResetWindowColors
        Case WM_CTLCOLORLISTBOX
            If lParam = m_hWndLB Then
                WindowProcParent = DefWindowProc(hWnd, uMsg, wParam, lParam)
                Exit Function
            End If
    End Select
'**Start Required**
    WindowProcParent = CallWindowProc(m_SubClassParent.wndprocNext, hWnd, uMsg, wParam, lParam)
    If uMsg = WM_SETFOCUS Then SetFocusAPI m_hWndLB
'**End Required**
    #If SUPPORTOLDSHELL Then
    If Not IsNewShell Then
        If uMsg = WM_PAINT Then
            If m_Appearance = [3D] Then Draw3DEdge
        End If
    End If
    #End If
End Function

Private Function HandleDrawItem(pDIS As DRAWITEMSTRUCT) As Boolean
Dim TrackRect As RECT
    If pDIS.hwndItem <> m_hWndLB Then Exit Function
    SyncFont
    If pDIS.itemID <> m_BlockDrawItemID Then
        TrackRect = pDIS.rcItem
        If m_CheckStyle Then DrawCheckBox pDIS, TrackRect, m_CheckStyle
        DrawItemText pDIS, TrackRect
        DrawFocus pDIS, TrackRect
    ElseIf pDIS.itemID = -1 Then
        TrackRect = pDIS.rcItem
        DrawItemText pDIS, TrackRect
        DrawFocus pDIS, TrackRect
    End If
    HandleDrawItem = True
End Function

#If SUPPORTOLDSHELL Then
Private Sub Draw3DEdge()
Dim TrackRect As RECT
Dim rct As RECT
    GetWindowRect m_hWndLB, rct
    With TrackRect
        .Left = 0
        .Top = 0
        .Right = .Left + rct.Right - rct.Left + 4
        .Bottom = .Top + rct.Bottom - rct.Top + 4
    End With
    DrawEdge hDC, TrackRect, EDGE_SUNKEN, BF_RECT
End Sub
#End If

Friend Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim xPos As Integer
Dim iClickIndex As Long
Dim iCurIndex As Long
Dim iCurSel As Long
Dim fResetSel As Boolean
Static fSelectionToggled As Boolean
Static strMsg As String
Static strMsgTitle As String
Static MsgBoxFlags As VBA.VbMsgBoxStyle
'**Start Required**
    Select Case uMsg
        Case WM_SETFOCUS
            'Get in-place frame and make sure it is set to our in-between
            'implementation of IOleInPlaceActiveObject in order to catch
            'TranslateAccelerator calls
            OverrideActiveObject m_IPAOHook, Me
        Case WM_MOUSEACTIVATE
            If GetFocus <> m_hWndLB Then
                SetFocusAPI UserControl.hWnd
                WindowProc = MA_NOACTIVATE
                Exit Function
            End If
'**End Required**
        Case WM_KEYDOWN
            If vbKeySpace = LOWORD(wParam) Then
                'Use to toggle multiselected state
                If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
                    iClickIndex = CaretIndex
                    If iClickIndex >= DoMsg(LB_GETCOUNT) Then iClickIndex = -1
                    If Not iClickIndex Then GoSub ToggleSelection
                End If
            End If
        Case WM_LBUTTONDOWN
            If StyleBit(LBS_MULTIPLESEL Or LBS_EXTENDEDSEL) Then
                fSelectionToggled = False
                'NT4.0, LB_ITEMFROMPOINT acts differently than Win95
                'so it can't be used here.
                iClickIndex = DoMsg(LB_GETTOPINDEX, 0, 0) + HIWORD(lParam) \ DoMsg(LB_GETITEMHEIGHT, 0, 0)
                If iClickIndex >= DoMsg(LB_GETCOUNT) Then iClickIndex = -1
                If Not iClickIndex Then
                    iCurIndex = CaretIndex
                    xPos = LOWORD(lParam)
                    If m_CheckStyle And xPos >= m_CheckWidth And iClickIndex <> iCurIndex Then
                        'Keep the current selected state to retoggle later.
                        iCurSel = DoMsg(LB_GETSEL, iClickIndex, 0)
                        fResetSel = True
                        m_BlockDrawItemID = iClickIndex
                    Else
                        iCurSel = DoMsg(LB_GETSEL, iClickIndex, 0)
                        If Not SetSelection(iClickIndex, Not CBool(iCurSel), strMsg, strMsgTitle, MsgBoxFlags) Then
                            fResetSel = True
                            m_BlockDrawItemID = iClickIndex
                        Else
                            fSelectionToggled = True
                        End If
                    End If
                End If
            End If
        Case WM_LBUTTONUP
            ShowMessage strMsg, strMsgTitle, MsgBoxFlags
            iClickIndex = DoMsg(LB_GETTOPINDEX, 0, 0) + HIWORD(lParam) \ DoMsg(LB_GETITEMHEIGHT, 0, 0)
            If iClickIndex >= 0 Then
                If iClickIndex <= DoMsg(LB_GETCOUNT) Then RaiseEvent Click(iClickIndex)
            End If
        Case WM_LBUTTONDBLCLK
            If m_CheckStyle And Not fSelectionToggled Then
                iClickIndex = DoMsg(LB_GETTOPINDEX, 0, 0) + HIWORD(lParam) \ DoMsg(LB_GETITEMHEIGHT, 0, 0)
                If iClickIndex >= DoMsg(LB_GETCOUNT) Then iClickIndex = -1
                If Not iClickIndex Then GoSub ToggleSelection
            End If
    End Select
    'It's hard to get all messages which change the topindex,
    'check every time.
    SetTopIndex DoMsg(LB_GETTOPINDEX)
'**Start Required**
    WindowProc = CallWindowProc(m_SubClassLB.wndprocNext, hWnd, uMsg, wParam, lParam)
'**End Required**
    If fResetSel Then
        m_BlockDrawItemID = -1
        DoMsg LB_SETSEL, iCurSel, iClickIndex
    End If
    Exit Function
ToggleSelection:
    iCurSel = DoMsg(LB_GETSEL, iClickIndex, 0)
    If Not SetSelection(iClickIndex, Not CBool(iCurSel), strMsg, strMsgTitle, MsgBoxFlags) Then
        ShowMessage strMsg, strMsgTitle, MsgBoxFlags
    Else
        DoMsg LB_SETSEL, -(Not -iCurSel), iClickIndex
    End If
    Exit Function
    Return
End Function
'**Start Required**
Private Sub IHookAccelerator_TranslateAccelerator(lpmsg As OleTypes.MSG, hrReturnCode As Long)
'**End Required**
    'Return code defaults to S_FALSE (1)
    With lpmsg
        If .Message = WM_KEYDOWN Then
            Select Case LOWORD(lpmsg.wParam)
                Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd
                    DoMsg .Message, .wParam, .lParam
                    hrReturnCode = 0
            End Select
        End If
    End With
'**Start Required**
End Sub
'**End Required**

Private Sub ShowMessage(Message As String, Title As String, Flags As VBA.VbMsgBoxStyle)
Dim Result As VBA.VbMsgBoxResult
    If Len(Message) Then
        If Len(Title) = 0 Then Title = App.Title
        Result = MsgBox(Message, Flags, Title)
        RaiseEvent AfterSelectionMessage(Result)
        Message = vbNullString
        Title = vbNullString
    End If
End Sub

Public Property Get hWnd() As Long
    hWnd = m_hWndLB
End Property

Private Function QueryForceHasFocus() As Boolean
    QueryForceHasFocus = GetFocus = UserControl.hWnd
End Function

Private Sub SetTopIndex(ByVal Index As Long)
    If Index <> m_iLastTopIndex Then
        m_iLastTopIndex = Index
        RaiseEvent NewTopIndex(Index)
    End If
End Sub

Private Function SetSelection(ByVal Index As Long, ByVal SelState As Boolean, Message As String, Title As String, Flags As VBA.VbMsgBoxStyle) As Boolean
Dim fCancel As Boolean
    If StyleBit(LBS_MULTIPLESEL) Then
        Message = vbNullString
        Title = vbNullString
        Flags = 0
        If Not QuickNotify Is Nothing Then
            QuickNotify.QuerySetSelection Index, SelState, fCancel, Message, Title, Flags
        Else
            RaiseEvent QuerySetSelection(Index, SelState, fCancel, Message, Title, Flags)
        End If
        If fCancel Then
            If Len(Message) = 0 Then Beep
        End If
        SetSelection = Not fCancel
    Else
        SetSelection = True
    End If
End Function

Private Property Get ListString(ByVal Index As Long) As String
Attribute ListString.VB_Description = "Called when an item is drawn if the StoreStrings property is False."
    If m_fHasStrings Then
        ListString = String$(DoMsg(LB_GETTEXTLEN, Index), 0)
        DoMsgString LB_GETTEXT, Index, ListString
    ElseIf Not QuickNotify Is Nothing Then
        QuickNotify.ListString Index, ListString
    Else
        RaiseEvent ListString(Index, ListString)
    End If
End Property

Private Sub UserControl_AmbientChanged(PropertyName As String)
    If m_fDesign Then
        If PropertyName = "DisplayName" Then UserControl.Refresh
    End If
End Sub

Private Sub UserControl_Initialize()