drawitem.ctl

此源码为vb圣经编码

End Sub

Private Sub UserControl_Initialize()
    Set m_Pictures = New VBA.Collection
    ResetWindowColors
End Sub

Private Sub UserControl_InitProperties()
    InitializeMode
End Sub

Public Sub AddItem(Item As String, Optional Picture As Picture, Optional Index As Integer = -1)
Dim pPic As Long
Dim IPic As IPicture
    If Not Picture Is Nothing Then
        'Get the IPicture interface from
        'Picture object.  IPicture has
        'a Render method, which we'll
        'use to draw the bitmap, icon,
        'or metafile in the list.
        Set IPic = Picture
        VBoost.Assign pPic, IPic 'ObjPtr(IPic) without AddRef/Release
        'Add pic if not in the collection
        On Error Resume Next
        m_Pictures.Item CStr(pPic)
        If Err Then
            m_Pictures.Add IPic, CStr(pPic)
        End If
        On Error GoTo 0
    End If
    With lstMain
        If Index = -1 Then
            .AddItem Item
        Else
            .AddItem Item, Index
        End If
        If pPic Then
            .ItemData(.NewIndex) = pPic
        End If
    End With
End Sub

Private Sub UserControl_Resize()
    With UserControl
        lstMain.Move 0, 0, .ScaleWidth, .ScaleHeight
    End With
    RaiseEvent Resize
End Sub

Private Sub UserControl_Terminate()
    If Not m_fDesign Then
        ResetWindowColors True
        UnSubClass m_SubClassMain, UserControl.hWnd
    End If
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
  BackColor = lstMain.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  lstMain.BackColor = New_BackColor
  PropertyChanged "BackColor"
  ResetGDIColor clrWindow, New_BackColor
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
  ForeColor = lstMain.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
  lstMain.ForeColor = New_ForeColor
  PropertyChanged "ForeColor"
  ResetGDIColor clrWindowText, New_ForeColor
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
  Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
  UserControl.Enabled() = New_Enabled
  PropertyChanged "Enabled"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,Font
Public Property Get Font() As Font
  Set Font = lstMain.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
  Set lstMain.Font = New_Font
  PropertyChanged "Font"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,Refresh
Public Sub Refresh()
  lstMain.Refresh
End Sub

Private Sub lstMain_Click()
  RaiseEvent Click
End Sub

Private Sub lstMain_DblClick()
  RaiseEvent DblClick
End Sub

Private Sub lstMain_KeyDown(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub lstMain_KeyPress(KeyAscii As Integer)
  RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub lstMain_KeyUp(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub lstMain_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  RaiseEvent MouseDown(Button, Shift, x, y)
End Sub

Private Sub lstMain_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  RaiseEvent MouseMove(Button, Shift, x, y)
End Sub

Private Sub lstMain_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  RaiseEvent MouseUp(Button, Shift, x, y)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,WhatsThisHelpID
Public Property Get WhatsThisHelpID() As Long
  WhatsThisHelpID = lstMain.WhatsThisHelpID
End Property

Public Property Let WhatsThisHelpID(ByVal New_WhatsThisHelpID As Long)
  lstMain.WhatsThisHelpID() = New_WhatsThisHelpID
  PropertyChanged "WhatsThisHelpID"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,TopIndex
Public Property Get TopIndex() As Integer
  NoPropertySheet
  TopIndex = lstMain.TopIndex
End Property

Public Property Let TopIndex(ByVal New_TopIndex As Integer)
  lstMain.TopIndex() = New_TopIndex
  PropertyChanged "TopIndex"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,ToolTipText
Public Property Get ToolTipText() As String
  ToolTipText = lstMain.ToolTipText
End Property

Public Property Let ToolTipText(ByVal New_ToolTipText As String)
  lstMain.ToolTipText() = New_ToolTipText
  PropertyChanged "ToolTipText"
End Property

Private Sub lstMain_Scroll()
  RaiseEvent Scroll
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,RemoveItem
Public Sub RemoveItem(Index As Integer)
  lstMain.RemoveItem Index
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,NewIndex
Public Property Get NewIndex() As Integer
  NoPropertySheet
  NewIndex = lstMain.NewIndex
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,ListIndex
Public Property Get ListIndex() As Integer
  NoPropertySheet
  ListIndex = lstMain.ListIndex
End Property

Public Property Let ListIndex(ByVal New_ListIndex As Integer)
  lstMain.ListIndex() = New_ListIndex
  PropertyChanged "ListIndex"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,ListCount
Public Property Get ListCount() As Integer
  NoPropertySheet
  ListCount = lstMain.ListCount
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,List
Public Property Get List(Index As Integer) As String
  NoPropertySheet
  List = lstMain.List(Index)
End Property

Public Property Let List(Index As Integer, ByVal New_List As String)
  lstMain.List(Index) = New_List
  PropertyChanged "List"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,hWnd
Public Property Get hWnd() As Long
  NoPropertySheet
  hWnd = UserControl.hWnd
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,Clear
Public Sub Clear()
  lstMain.Clear
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Dim Index As Integer

  BackColor = PropBag.ReadProperty("BackColor", vbWindowBackground)
  ForeColor = PropBag.ReadProperty("ForeColor", vbWindowText)
  UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
  Set lstMain.Font = PropBag.ReadProperty("Font", Ambient.Font)
  lstMain.WhatsThisHelpID = PropBag.ReadProperty("WhatsThisHelpID", 0)
  InitializeMode
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Dim Index As Integer

  Call PropBag.WriteProperty("BackColor", lstMain.BackColor, vbWindowBackground)
  Call PropBag.WriteProperty("ForeColor", lstMain.ForeColor, vbWindowText)
  Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
  Call PropBag.WriteProperty("Font", lstMain.Font, Ambient.Font)
  Call PropBag.WriteProperty("WhatsThisHelpID", lstMain.WhatsThisHelpID, 0)
  Call PropBag.WriteProperty("ToolTipText", lstMain.ToolTipText, "")
End Sub

Private Sub InitializeMode()
    SetDesignMode
    If m_fDesign Then
        On Error Resume Next
        lstMain.AddItem Ambient.DisplayName
    Else
        SubClass m_SubClassMain, UserControl.hWnd, ObjPtr(Me), AddressOf RedirectODLBWindowProc
        m_lstMainhWnd = lstMain.hWnd
        m_YUnitHimetric = UserControl.ScaleY(1, vbPixels, vbHimetric)
    End If
End Sub