imlist.ctl

这是用Vb编写的虚拟驱动程序,希望对大家有帮助.

For I = sIndex + 1 To Count
ImgCon(I).Picture = ImgCon(I - 1).Picture
Titles(I).Caption = Titles(I - 1).Caption
Tips(I).Caption = Tips(I - 1).Caption
ImgCon(I).ToolTipText = Tips(I - 1).ToolTipText
Titles(I).ToolTipText = Titles(I - 1).ToolTipText
Next I
Titles(Index).Caption = sTitle
Tips(Index).Caption = sTip
ImgCon(Index).Picture = sImage
ImgCon(Index).ToolTipText = ToolTip
Titles(Index).ToolTipText = ToolTip
sTitle = OldTitle
sTip = OldTip
OldToolTip = ToolTip
Set sImage = OldPicture
End If
Load ImgCon(Count + 1)
ImgCon(Count).Top = ImgCon(Count - 1).Top + ImgCon(Count - 1).Height + (120 / Screen.TwipsPerPixelY)
ImgCon(Count).Picture = sImage
ImgCon(Count).Visible = True
Load Titles(Count)
Titles(Count).Top = ImgCon(Count).Top
Titles(Count).Caption = sTitle
Titles(Count).Visible = True
Load Tips(Count)
Tips(Count).Top = ImgCon(Count).Top + Titles(Count).Height
Tips(Count).Caption = sTip
Tips(Count).Visible = True
ImgCon(Count).ToolTipText = ToolTip
Titles(Count).ToolTipText = ToolTip
Con.Height = ImgCon(Count).Top + ImgCon(Count).Height + (120 / Screen.TwipsPerPixelY)
UserControl_Resize
'If Not Index = -1 Then DeleteObject OldPicture.Handle
End Function
Function Remove(ByVal sIndex As Integer)
If Count = 1 Then Clear: Exit Function
For I = sIndex To Count - 1
ImgCon(I).Picture = ImgCon(I + 1).Picture
Titles(I).Caption = Titles(I + 1).Caption
Tips(I).Caption = Tips(I + 1).Caption
ImgCon(I).ToolTipText = Tips(I + 1).ToolTipText
Titles(I).ToolTipText = Titles(I + 1).ToolTipText
Next I
Unload ImgCon(Count)
Unload Titles(Count + 1)
Unload Tips(Count + 1)
UserControl_Resize
End Function
Function Count() As Integer
Count = ImgCon.UBound
End Function
Function Clear()
For I = 1 To ImgCon.UBound
Unload ImgCon(I)
Unload Titles(I)
Unload Tips(I)
Next I
Shape1.Visible = False
Con.Height = 10
UserControl_Resize
End Function
Function Title(ByVal sItem As Integer) As Variant
Title = Titles(sItem).Caption
End Function
Function SetTitle(ByVal sItem As Integer, ByVal NewTitle As Variant)
Titles(sItem).Caption = NewTitle
End Function
Function Tip(ByVal sItem As Integer) As Variant
Tip = Tips(sItem).Caption
End Function
Function SetTip(ByVal sItem As Integer, ByVal NewTip As Variant)
Tips(sItem).Caption = NewTip
End Function
Function iPicture(ByVal sItem As Integer) As IPictureDisp
Set iPicture = ImgCon(sItem).Picture
End Function
Function Setpicture(ByVal sItem As Integer, ByVal NewPic As IPictureDisp)
ImgCon(sItem).Picture = NewPic
End Function
Function ToolTip(ByVal sItem As Integer) As String
ToolTip = ImgCon(sItem).ToolTipText
End Function
Function SetToolTip(ByVal sItem As Integer, ByVal NewTip As String)
Titles(sItem).ToolTipText = NewTip
ImgCon(sItem).ToolTipText = NewTip
End Function

Private Sub UserControl_Terminate()
Clear
End Sub

Private Sub VS_Change()
On Error Resume Next
Con.Top = -(VS.Value)
End Sub
'
''WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
''MappingInfo=Titles(0),Titles,0,ForeColor
Public Property Get TitleColor() As OLE_COLOR
Attribute TitleColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
    TitleColor = Titles(0).ForeColor
End Property
'
Public Property Let TitleColor(ByVal New_TitleColor As OLE_COLOR)
    Titles(0).ForeColor() = New_TitleColor
    For I = 1 To Tips.UBound
     Titles(I).ForeColor = Titles(0).ForeColor
    Next I
    PropertyChanged "TitleColor"
End Property
'
''WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
''MappingInfo=Tips(0),Tips,0,ForeColor
Public Property Get TipColor() As OLE_COLOR
Attribute TipColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
    TipColor = Tips(0).ForeColor
End Property
'
Public Property Let TipColor(ByVal New_TipColor As OLE_COLOR)
    Tips(0).ForeColor() = New_TipColor
    For I = 1 To Tips.UBound
    Tips(I).ForeColor = Tips(0).ForeColor
    Next I
    PropertyChanged "TipColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Con,Con,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
    BackColor = Con.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    Con.BackColor() = New_BackColor
    UserControl.BackColor = Con.BackColor
    PropertyChanged "BackColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Con,Con,-1,BorderStyle
Public Property Get BackStyle() As Integer
Attribute BackStyle.VB_Description = "Returns/sets the border style for an object."
    BackStyle = Con.BorderStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As Integer)
    Con.BorderStyle() = New_BackStyle
    PropertyChanged "BackStyle"
End Property
'
''WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
''MappingInfo=Titles(0),Titles,0,Font
'Public Property Get TitleFont() As Font
'    Set TitleFont = Titles(0).Font
'End Property
'
Public Property Set TitleFont(ByVal New_TitleFont As Font)
Attribute TitleFont.VB_Description = "Returns a Font object."
    Set Titles(0).Font = New_TitleFont
    PropertyChanged "TitleFont"
    For I = 1 To Tips.UBound
    Set Titles(I).Font = Titles(0).Font
    Next I
End Property
'
''WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
''MappingInfo=Tips(0),Tips,0,Font
'Public Property Get TipFont() As Font
'    Set TipFont = Tips(0).Font
'End Property
'
Public Property Set TipFont(ByVal New_TipFont As Font)
Attribute TipFont.VB_Description = "Returns a Font object."
    Set Tips(0).Font = New_TipFont
    For I = 1 To Tips.UBound
    Set Tips(I).Font = Tips(0).Font
    Next I
    PropertyChanged "TipFont"
End Property

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Titles(0).ForeColor = PropBag.ReadProperty("TitleColor", &H80000012)
    Tips(0).ForeColor = PropBag.ReadProperty("TipColor", &H80000012)
    Con.BackColor = PropBag.ReadProperty("BackColor", &HFFFFFF)
    Con.BorderStyle = PropBag.ReadProperty("BackStyle", 0)
    Set Titles(0).Font = PropBag.ReadProperty("TitleFont", Ambient.Font)
    Set Tips(0).Font = PropBag.ReadProperty("TipFont", Ambient.Font)
    UserControl.BackColor = Con.BackColor
    m_TitleColor = PropBag.ReadProperty("TitleColor", m_def_TitleColor)
    m_TipColor = PropBag.ReadProperty("TipColor", m_def_TipColor)
    Set m_TitleFont = PropBag.ReadProperty("TitleFont", Ambient.Font)
    Set m_TipFont = PropBag.ReadProperty("TipFont", Ambient.Font)
    m_Selected = PropBag.ReadProperty("Selected", m_def_Selected)
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("TitleColor", Titles(0).ForeColor, &H80000012)
    Call PropBag.WriteProperty("TipColor", Tips(0).ForeColor, &H80000012)
    Call PropBag.WriteProperty("BackColor", Con.BackColor, &HFFFFFF)
    Call PropBag.WriteProperty("BackStyle", Con.BorderStyle, 0)
    Call PropBag.WriteProperty("TitleFont", Titles(0).Font, Ambient.Font)
    Call PropBag.WriteProperty("TipFont", Tips(0).Font, Ambient.Font)
    Call PropBag.WriteProperty("TitleColor", m_TitleColor, m_def_TitleColor)
    Call PropBag.WriteProperty("TipColor", m_TipColor, m_def_TipColor)
    Call PropBag.WriteProperty("TitleFont", m_TitleFont, Ambient.Font)
    Call PropBag.WriteProperty("TipFont", m_TipFont, Ambient.Font)
    Call PropBag.WriteProperty("Selected", m_Selected, m_def_Selected)
End Sub
Private Sub VS_Scroll()
On Error Resume Next
Con.Top = -(VS.Value)
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,2,0
Public Property Get Selected() As Integer
Attribute Selected.VB_MemberFlags = "400"
    Selected = m_Selected
End Property
Public Property Let Selected(ByVal New_Selected As Integer)
    If Ambient.UserMode = False Then Err.Raise 387
    m_Selected = New_Selected
    PropertyChanged "Selected"
    Shape1.Top = ImgCon(New_Selected).Top
End Property
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_TitleColor = m_def_TitleColor
    m_TipColor = m_def_TipColor
    Set m_TitleFont = Ambient.Font
    Set m_TipFont = Ambient.Font
    m_Selected = m_def_Selected
End Sub