drawitem.ctl

此源码为vb圣经编码

VERSION 5.00
Begin VB.UserControl OwnerDrawListBox 
   ClientHeight    =   540
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1305
   ClipControls    =   0   'False
   HasDC           =   0   'False
   ScaleHeight     =   540
   ScaleWidth      =   1305
   ToolboxBitmap   =   "DrawItem.ctx":0000
   Begin VB.ListBox lstMain 
      Height          =   390
      IntegralHeight  =   0   'False
      ItemData        =   "DrawItem.ctx":00FA
      Left            =   45
      List            =   "DrawItem.ctx":00FC
      Style           =   1  'Checkbox
      TabIndex        =   0
      Top             =   45
      Width           =   1200
   End
End
Attribute VB_Name = "OwnerDrawListBox"
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
'Event Declarations:
Event Click() 'MappingInfo=lstMain,lstMain,-1,Click
Event DblClick() 'MappingInfo=lstMain,lstMain,-1,DblClick
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=lstMain,lstMain,-1,KeyDown
Event KeyPress(KeyAscii As Integer) 'MappingInfo=lstMain,lstMain,-1,KeyPress
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=lstMain,lstMain,-1,KeyUp
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=lstMain,lstMain,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=lstMain,lstMain,-1,MouseMove
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=lstMain,lstMain,-1,MouseUp
Event Scroll() 'MappingInfo=lstMain,lstMain,-1,Scroll
Event Resize() 'MappingInfo=UserControl,UserControl,-1,Resize

Private m_SubClassMain As SubClassData
Private m_lstMainhWnd As Long
Private m_Pictures As VBA.Collection
Private m_fDesign As Boolean
Private Const SysColorBit As Long = &H80000000

'Cache system colors
Private Enum GDIColors
    clrWindowText
    clrWindow
    clrHighlight
    clrHighlightText
    clrLastPen = clrWindowText
    clrLastBrush = clrHighlight
End Enum

Private m_Colors(0 To 4) As Long
Private m_hGDIObjects(0 To 3) As Long
Private m_YUnitHimetric As OLE_YPOS_HIMETRIC

Friend Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_DRAWITEM
            'lParam for this message is actually a
            'pointer to a DRAWITEMSTRUCT, deref the data.
            With g_DerefDrawItemStruct
                .Owner.SA.pvData = lParam
                If HandleDrawItem(.pSA(0)) Then
                    'Don't let this drop through to VB's window proc
                    'Falling through will redraw with a checkbox
                    WindowProc = 1
                    Exit Function
                End If
            End With
        Case WM_SYSCOLORCHANGE
            ResetWindowColors
    End Select
    WindowProc = CallWindowProc(m_SubClassMain.wndprocNext, hWnd, uMsg, wParam, lParam)
End Function

Private Function HandleDrawItem(pDIS As DRAWITEMSTRUCT) As Boolean
    If pDIS.hwndItem <> m_lstMainhWnd Then Exit Function
    'Copy the original rectangle
    'If pDIS.itemID = -1 then there are no items
    'in the list, don't try to draw a bitmap
    If Not pDIS.itemID Then
        'This will change rcItem.Left
        'so DrawItemText is positioned correctly
        DrawItemPicture pDIS, pDIS.rcItem
    End If
    'FillRect pDIS.hdc, pDIS.rcItem, SelectObject(hdc, GDIObjects(clrWindow))
    'Draw the text for the item
    DrawItemText pDIS
    'Draw the focus rectangle if necessary
    DrawFocus pDIS
    HandleDrawItem = True
End Function

Private Sub DrawItemPicture(pDIS As DRAWITEMSTRUCT, prc As RECT)
Const TextOffset = 3
Dim Pic As IPicture
    If pDIS.itemAction And (ODA_SELECT Or ODA_DRAWENTIRE) Then
        VBoost.Assign Pic, pDIS.ItemData
        If Not Pic Is Nothing Then
            With prc
                'Render has some really weird requirements.
                'y argument, subtract 1
                'cy argument, negative
                'ySrc argument, Himetric value for 1 (not 0)
                Pic.Render pDIS.hdc, .Left, .Bottom - 1, _
                  .Bottom - .Top, .Top - .Bottom, _
                  0, m_YUnitHimetric, _
                  Pic.Width, Pic.Height, ByVal 0&
            End With
            VBoost.AssignZero Pic
        End If
    End If
    With prc
        .Left = .Left + .Bottom - .Top + TextOffset
    End With
End Sub

Private Sub DrawItemText(pDIS As DRAWITEMSTRUCT)
Dim hBrushOld, hPenOld
Dim clrText As GDIColors, clrBack As GDIColors
Dim hdc As Long
Dim strItem As String, cbItem As Integer
    hdc = pDIS.hdc
    If pDIS.itemAction And ODA_SELECT Then
        Exit Sub
    Else 'If pDIS.itemAction And (ODA_FOCUS Or ODA_DRAWENTIRE) Then
        'This could all be done with less code, but more API calls.
        'Until we can short circuit, use this approach. (LB_GETCARENTINDEX is an API call).
        If pDIS.itemID = -1 Then
            clrBack = clrWindow
            clrText = clrWindowText
        ElseIf pDIS.itemState And ODS_FOCUS Then
            clrBack = clrHighlight
            clrText = clrHighlightText
        ElseIf m_lstMainhWnd = GetFocus Then
            clrBack = clrWindow
            clrText = clrWindowText
        Else
            If pDIS.itemID = DoMsg(LB_GETCARETINDEX) Then
                clrBack = clrHighlight
                clrText = clrHighlightText
            Else
                clrBack = clrWindow
                clrText = clrWindowText
            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 pDIS.rcItem
            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
        'Get the string from the VB listbox
        If Not pDIS.itemID Then strItem = lstMain.List(pDIS.itemID)
        'DrawText with GPF with a NULL pointer, use a zero length
        'string instead. StrPtr is the only way to see the difference.
        If StrPtr(strItem) = 0 Then strItem = ""
        With pDIS.rcItem
            .Left = .Left + 1
            DrawText hdc, strItem, -1, pDIS.rcItem, _
                    DT_VCENTER Or DT_LEFT Or DT_SINGLELINE Or DT_NOPREFIX Or DT_NOCLIP
            .Left = .Left - 1
        End With
    End If
End Sub

Private Sub DrawFocus(pDIS As DRAWITEMSTRUCT)
    If pDIS.itemAction And (ODA_FOCUS Or ODA_DRAWENTIRE) Then
        If pDIS.itemState And ODS_FOCUS Then
            If m_lstMainhWnd = GetFocus Then
                DrawFocusRect pDIS.hdc, pDIS.rcItem
            End If
        End If
    End If
End Sub

Private Property Get GDIObjects(hGDI As GDIColors) 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
        If BackColor And SysColorBit Then BackColor = BackColor
        If ForeColor And SysColorBit Then ForeColor = ForeColor
        m_Colors(clrHighlight) = GetSysColor(COLOR_HIGHLIGHT)
        m_Colors(clrHighlightText) = GetSysColor(COLOR_HIGHLIGHTTEXT)
    End If
End Function

Private Function ResetGDIColor(Index As GDIColors, ByVal NewColor As OLE_COLOR)
    If m_hGDIObjects(Index) Then DeleteObject m_hGDIObjects(Index)
    m_hGDIObjects(Index) = 0
    If NewColor And SysColorBit Then
        NewColor = GetSysColor(NewColor Xor SysColorBit)
    End If
    m_Colors(Index) = NewColor
End Function

Private Function DoMsg(ByVal uMsg As Long, Optional ByVal wParam As Long, Optional ByVal lParam As Long) As Long
    DoMsg = CallWindowProc(m_SubClassMain.wndprocNext, m_lstMainhWnd, uMsg, wParam, lParam)
End Function

Private Sub UserControl_AmbientChanged(PropertyName As String)
    If m_fDesign Then
        If PropertyName = "DisplayName" Then
            lstMain.Clear
            lstMain.AddItem Ambient.DisplayName
        End If
    End If
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 error
End Sub

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