home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / CozIcon_v1187206442005.psc / ColorPicker.ctl < prev    next >
Text File  |  2005-03-26  |  5KB  |  157 lines
  1. VERSION 5.00
  2. Begin VB.UserControl ColorPicker 
  3.    AutoRedraw      =   -1  'True
  4.    ClientHeight    =   3600
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   4800
  8.    ScaleHeight     =   240
  9.    ScaleMode       =   3  'Pixel
  10.    ScaleWidth      =   320
  11. End
  12. Attribute VB_Name = "ColorPicker"
  13. Attribute VB_GlobalNameSpace = False
  14. Attribute VB_Creatable = True
  15. Attribute VB_PredeclaredId = False
  16. Attribute VB_Exposed = False
  17. Option Explicit
  18. 'Event Declarations:
  19. Event Pick(ByVal Button As Integer, ByVal Clr As Long)
  20. Dim mClrs() As Long
  21. 'Default Property Values:
  22. Const m_def_SelWidth = 16
  23. Const m_def_SelHeight = 16
  24. 'Property Variables:
  25. Dim m_SelWidth As Integer
  26. Dim m_SelHeight As Integer
  27.  
  28. Public Sub AddColor(ByVal Clr As Long)
  29. Dim i As Integer
  30. i = UBound(mClrs()) + 1
  31. ReDim Preserve mClrs(i)
  32.  
  33. mClrs(i) = Clr
  34. End Sub
  35.  
  36. Public Sub ClearColors()
  37. ReDim mClrs(0)
  38. End Sub
  39.  
  40. Private Sub DrawInvertedBox(ByVal X As Integer, ByVal Y As Integer, ByVal W As Integer, ByVal H As Integer, ByVal BackClr As Long)
  41. Line (X, Y)-(X + W, Y + H), BackClr, BF
  42.  
  43. Line (X, Y)-(X + W, Y), 0 'top high
  44. Line (X, Y + 1)-(X + W - 1, Y + 1), RGB(128, 128, 128)
  45.  
  46. Line (X, Y)-(X, Y + H), 0 'left high
  47. Line (X + 1, Y + 1)-(X + 1, Y + H - 1), RGB(128, 128, 128)
  48.  
  49. Line (X + W, Y)-(X + W, Y + H + 1), vbWhite 'right shadow
  50. Line (X + W - 1, Y + 1)-(X + W - 1, Y + H), RGB(192, 192, 192)  'right shadow
  51.  
  52. Line (X, Y + H)-(X + W, Y + H), vbWhite 'bottom shadow
  53. Line (X, Y + H - 1)-(X + W - 1, Y + H - 1), RGB(192, 192, 192) 'bottom shadow
  54.  
  55. Refresh
  56. End Sub
  57.  
  58. Public Sub ShowColors()
  59. Dim i As Integer
  60. Dim X As Integer
  61. Dim Y As Integer
  62.  
  63. For i = 1 To UBound(mClrs())
  64. Debug.Print i, mClrs(i)
  65.  Call DrawInvertedBox(X, Y, m_SelWidth, m_SelHeight, mClrs(i))
  66.  X = X + m_SelWidth
  67.  If X + m_SelWidth > ScaleWidth Then X = 0: Y = Y + m_SelHeight
  68.  Debug.Print X, Y
  69. Next i
  70. Refresh
  71. End Sub
  72.  
  73. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  74. 'MappingInfo=UserControl,UserControl,-1,BackColor
  75. Public Property Get BackColor() As OLE_COLOR
  76. Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
  77.     BackColor = UserControl.BackColor
  78. End Property
  79.  
  80. Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  81.     UserControl.BackColor() = New_BackColor
  82.     PropertyChanged "BackColor"
  83. End Property
  84.  
  85. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  86. 'MappingInfo=UserControl,UserControl,-1,BorderStyle
  87. Public Property Get BorderStyle() As Integer
  88. Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
  89.     BorderStyle = UserControl.BorderStyle
  90. End Property
  91.  
  92. Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
  93.     UserControl.BorderStyle() = New_BorderStyle
  94.     PropertyChanged "BorderStyle"
  95. End Property
  96.  
  97. Private Sub UserControl_Initialize()
  98. ReDim mClrs(0)
  99. End Sub
  100.  
  101. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  102. If Button <> 1 And Button <> 2 Then Exit Sub
  103. RaiseEvent Pick(Button, Point(Int(X / m_SelWidth) * m_SelWidth + 4, Int(Y / m_SelHeight) * m_SelHeight + 4))
  104. End Sub
  105.  
  106. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  107. If Button <> 1 And Button <> 2 Then Exit Sub
  108. RaiseEvent Pick(Button, Point(Int(X / m_SelWidth) * m_SelWidth + 4, Int(Y / m_SelHeight) * m_SelHeight + 4))
  109. End Sub
  110.  
  111. 'Load property values from storage
  112. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  113.  
  114.     UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
  115.     UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
  116.     m_SelWidth = PropBag.ReadProperty("SelWidth", m_def_SelWidth)
  117.     m_SelHeight = PropBag.ReadProperty("SelHeight", m_def_SelHeight)
  118. End Sub
  119.  
  120. 'Write property values to storage
  121. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  122.  
  123.     Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
  124.     Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 0)
  125.     Call PropBag.WriteProperty("SelWidth", m_SelWidth, m_def_SelWidth)
  126.     Call PropBag.WriteProperty("SelHeight", m_SelHeight, m_def_SelHeight)
  127. End Sub
  128.  
  129. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  130. 'MemberInfo=7,0,0,16
  131. Public Property Get SelWidth() As Integer
  132.     SelWidth = m_SelWidth
  133. End Property
  134.  
  135. Public Property Let SelWidth(ByVal New_SelWidth As Integer)
  136.     m_SelWidth = New_SelWidth
  137.     PropertyChanged "SelWidth"
  138. End Property
  139.  
  140. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  141. 'MemberInfo=7,0,0,16
  142. Public Property Get SelHeight() As Integer
  143.     SelHeight = m_SelHeight
  144. End Property
  145.  
  146. Public Property Let SelHeight(ByVal New_SelHeight As Integer)
  147.     m_SelHeight = New_SelHeight
  148.     PropertyChanged "SelHeight"
  149. End Property
  150.  
  151. 'Initialize Properties for User Control
  152. Private Sub UserControl_InitProperties()
  153.     m_SelWidth = m_def_SelWidth
  154.     m_SelHeight = m_def_SelHeight
  155. End Sub
  156.  
  157.