home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / AvalonSoft1750435262004.psc / ColorPicker.ctl < prev    next >
Text File  |  2004-05-26  |  9KB  |  300 lines
  1. VERSION 5.00
  2. Begin VB.UserControl ColorPicker 
  3.    AutoRedraw      =   -1  'True
  4.    ClientHeight    =   525
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   2055
  8.    EditAtDesignTime=   -1  'True
  9.    ScaleHeight     =   35
  10.    ScaleMode       =   3  'Pixel
  11.    ScaleWidth      =   137
  12.    ToolboxBitmap   =   "ColorPicker.ctx":0000
  13. End
  14. Attribute VB_Name = "ColorPicker"
  15. Attribute VB_GlobalNameSpace = False
  16. Attribute VB_Creatable = True
  17. Attribute VB_PredeclaredId = False
  18. Attribute VB_Exposed = True
  19. Option Explicit
  20.  
  21. Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  22. Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
  23.  
  24. Private RClr As RECT
  25. Private RBut As RECT
  26.  
  27. Private IsInFocus As Boolean
  28. Private IsButDown As Boolean
  29.  
  30. 'Default Property Values:
  31. Private Const m_def_Color = &HFFFFFF
  32. Private Const m_def_BoxSize = 14
  33. Private Const m_def_Spacing = 0
  34.  
  35. 'Property Variables:
  36. Private m_Color                 As OLE_COLOR
  37. Private m_BoxSize               As Integer
  38. Private m_Spacing               As Integer
  39.  
  40. Event Click()
  41. Event DblClick()
  42. Event KeyDown(KeyCode As Integer, Shift As Integer)
  43. Event KeyPress(KeyAscii As Integer)
  44. Event KeyUp(KeyCode As Integer, Shift As Integer)
  45. Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  46. Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  47. Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  48. Event Resize()
  49.  
  50. Private Sub UserControl_Click()
  51.    RaiseEvent Click
  52. End Sub
  53.  
  54. Private Sub UserControl_GotFocus()
  55.     IsInFocus = True
  56.     Call RedrawControl(m_Color)
  57. End Sub
  58.  
  59. Private Sub UserControl_Initialize()
  60.   ScaleMode = vbPixels
  61.   Call UserControl_InitProperties
  62. End Sub
  63.  
  64. Private Sub UserControl_LostFocus()
  65.   IsInFocus = False
  66.   Call RedrawControl(m_Color)
  67. End Sub
  68.  
  69. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  70.   RaiseEvent MouseDown(Button, Shift, x * Screen.TwipsPerPixelX, y * Screen.TwipsPerPixelY)
  71.     
  72.   If Button = 1 Then
  73.     If (x >= ScaleLeft And x <= ScaleWidth) And (y >= ScaleTop And y <= ScaleHeight) Then
  74.       IsButDown = True
  75.       Call RedrawControl(m_Color)
  76.     End If
  77.   End If
  78. End Sub
  79.  
  80. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  81.   RaiseEvent MouseMove(Button, Shift, x * Screen.TwipsPerPixelX, y * Screen.TwipsPerPixelY)
  82.     
  83.   If IsButDown Then
  84.     If Not ((x >= ScaleLeft And x <= ScaleWidth) And (y >= ScaleTop And y <= ScaleHeight)) Then
  85.       IsButDown = False
  86.       Call RedrawControl(m_Color)
  87.     End If
  88.   End If
  89. End Sub
  90.  
  91. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  92.   RaiseEvent MouseUp(Button, Shift, x * Screen.TwipsPerPixelX, y * Screen.TwipsPerPixelY)
  93.     
  94.   If Button = 1 Then
  95.     If IsButDown Then
  96.       IsButDown = False
  97.       Call RedrawControl(m_Color)
  98.     End If
  99.         
  100.     If ((x >= ScaleLeft And x <= ScaleWidth) And (y >= ScaleTop And y <= ScaleHeight)) Then
  101.       Call ShowPalette
  102.     End If
  103.   End If
  104. End Sub
  105.  
  106. Private Sub UserControl_Resize()
  107.     RaiseEvent Resize
  108.     If Height < 285 Then Height = 285
  109.     
  110.     Call RedrawControl(m_Color)
  111. End Sub
  112.  
  113. Private Sub UserControl_DblClick()
  114.     RaiseEvent DblClick
  115. End Sub
  116.  
  117. Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  118.     RaiseEvent KeyDown(KeyCode, Shift)
  119. End Sub
  120.  
  121. Private Sub UserControl_KeyPress(KeyAscii As Integer)
  122.     RaiseEvent KeyPress(KeyAscii)
  123. End Sub
  124.  
  125. Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
  126.     RaiseEvent KeyUp(KeyCode, Shift)
  127. End Sub
  128.  
  129. Private Sub RedrawControl(lColor As Long)
  130.   Dim rct As RECT
  131.   Dim Brsh As Long, Color As Long
  132.   Dim tJunk As PointAPI
  133.   Dim hPen As Long
  134.   Dim hPenOld As Long
  135.     
  136.   Dim x1 As Long, y1 As Long
  137.   Dim x2 As Long, y2 As Long
  138.     
  139.   x1 = ScaleLeft
  140.   y1 = ScaleTop
  141.   x2 = ScaleWidth
  142.   y2 = ScaleHeight
  143.     
  144.   Cls
  145.     
  146.   'Draw background
  147.   If Not IsButDown Then
  148.     hPen = CreatePen(PS_SOLID, 1, vbWhite) ' GetSysColor(vbWhite And &H1F&))
  149.     hPenOld = SelectObject(hdc, hPen)
  150.     
  151.     Call MoveToEx(hdc, x1, y1, tJunk)
  152.     Call LineTo(hdc, x2 - 1, y1)
  153.     Call MoveToEx(hdc, x1, y1, tJunk)
  154.     Call LineTo(hdc, x1, y2 - 1)
  155.     Call DeleteObject(hPen)
  156.     Call DeleteObject(hPenOld)
  157.     
  158.     hPen = CreatePen(PS_SOLID, 1, GetSysColor(vbButtonText And &H1F&))
  159.     hPenOld = SelectObject(hdc, hPen)
  160.     
  161.     Call MoveToEx(hdc, x2 - 1, y1, tJunk)
  162.     Call LineTo(hdc, x2 - 1, y2 - 1)
  163.     Call LineTo(hdc, x1, y2 - 1)
  164.     
  165.     Call DeleteObject(hPen)
  166.     Call DeleteObject(hPenOld)
  167.   End If
  168.   
  169.   'Draw button
  170.   Dim CurFontName As String
  171.   CurFontName = Font.Name
  172.   Font.Name = "Marlett"
  173.   Call OleTranslateColor(vbButtonFace, ByVal 0&, Color)
  174.   Brsh = CreateSolidBrush(Color)
  175.   If IsButDown Then
  176.     Call SetRect(RBut, x2 - 10, y2 - 10, x2 - 2, y2 - 2)
  177.     Call SetRect(rct, RBut.Left + 2, RBut.Top, RBut.right, RBut.bottom)
  178.     Call DrawText(hdc, "6", 1&, rct, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
  179.   Else
  180.     Call SetRect(RBut, x2 - 10, y2 - 10, x2 - 2, y2 - 2)
  181.     Call SetRect(rct, RBut.Left + 1, RBut.Top, RBut.right, RBut.bottom - 1)
  182.     Call DrawText(hdc, "6", 1&, rct, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
  183.   End If
  184.   Font.Name = CurFontName
  185.   Call DeleteObject(Brsh)
  186.   Call DeleteObject(Color)
  187.   
  188.   'Draw Color
  189.   Call OleTranslateColor(lColor, ByVal 0&, Color)
  190.   Brsh = CreateSolidBrush(Color)
  191.   Call SetRect(RClr, 2, 2, x2 - 3, y2 - 10)
  192.   Call FillRect(hdc, RClr, Brsh)
  193.   Call SetRect(RClr, 2, 2, x2 - 10, y2 - 3)
  194.   Call FillRect(hdc, RClr, Brsh)
  195.   Call DeleteObject(Brsh)
  196.   Call DeleteObject(Color)
  197.   
  198.   hPen = CreatePen(PS_SOLID, 1, GetSysColor(vbButtonText And &H1F&))
  199.   hPenOld = SelectObject(hdc, hPen)
  200.   
  201.   Call MoveToEx(hdc, 2, 2, tJunk)
  202.   Call LineTo(hdc, x2 - 3, 2)
  203.   Call MoveToEx(hdc, 2, 2, tJunk)
  204.   Call LineTo(hdc, 2, y2 - 3)
  205.   
  206.   Call DeleteObject(hPen)
  207.   Call DeleteObject(hPenOld)
  208.   
  209.   hPen = CreatePen(PS_SOLID, 1, vbWhite) 'GetSysColor(vbScrollBars And &H1F&))
  210.   hPenOld = SelectObject(hdc, hPen)
  211.     
  212.   Call MoveToEx(hdc, x2 - 3, 2, tJunk)
  213.   Call LineTo(hdc, x2 - 3, y2 - 10)
  214.   Call LineTo(hdc, x2 - 10, y2 - 10)
  215.   Call LineTo(hdc, x2 - 10, y2 - 3)
  216.   Call LineTo(hdc, 2, y2 - 3)
  217.     
  218.   Call DeleteObject(hPen)
  219.   Call DeleteObject(hPenOld)
  220. End Sub
  221.  
  222. Private Sub ShowPalette()
  223.   Dim ClrCtrlPos As RECT
  224.     
  225.   Call GetWindowRect(hWnd, ClrCtrlPos)
  226.     
  227.   m_lDefault = m_Color
  228.   Load frmColorPalette
  229.   With frmColorPalette
  230.     .Left = ClrCtrlPos.Left * Screen.TwipsPerPixelX
  231.     .Top = (ClrCtrlPos.bottom) * Screen.TwipsPerPixelY
  232.     If (.Top + .Height) > Screen.Height Then
  233.       .Top = ClrCtrlPos.Top * Screen.TwipsPerPixelY - .Height
  234.     End If
  235.         
  236.     .Show vbModal
  237.         
  238.     If Not .IsCanceled Then m_Color = .SelectedColor
  239.     Call RedrawControl(m_Color)
  240.   End With
  241.   Unload frmColorPalette
  242. End Sub
  243.  
  244. Private Sub UserControl_InitProperties()
  245.   m_BoxSize = m_def_BoxSize
  246.   m_lBoxSize = m_BoxSize
  247.   m_Spacing = m_def_Spacing
  248.   m_lSpace = m_Spacing
  249.   m_Color = m_def_Color
  250.   Height = 315
  251. End Sub
  252.  
  253. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  254.   m_BoxSize = PropBag.ReadProperty("BoxSize", m_def_BoxSize)
  255.   m_Spacing = PropBag.ReadProperty("BoxSize", m_def_Spacing)
  256.   m_Color = PropBag.ReadProperty("Color", m_def_Color)
  257.   Call RedrawControl(m_Color)
  258. End Sub
  259.  
  260. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  261.   Call PropBag.WriteProperty("BoxSize", m_BoxSize, m_def_BoxSize)
  262.   Call PropBag.WriteProperty("Spacing", m_Spacing, m_def_Spacing)
  263.   Call PropBag.WriteProperty("Color", m_Color, m_def_Color)
  264. End Sub
  265.  
  266. Public Property Get Color() As OLE_COLOR
  267. Attribute Color.VB_Description = "Returns/Sets the selected color"
  268. Attribute Color.VB_ProcData.VB_Invoke_Property = ";Appearance"
  269. Attribute Color.VB_UserMemId = 0
  270.   Color = m_Color
  271. End Property
  272.  
  273. Public Property Let Color(ByVal New_Color As OLE_COLOR)
  274.   m_Color = New_Color
  275.   PropertyChanged "Value"
  276.     
  277.   'Call RedrawControl(m_defColor)
  278. End Property
  279.  
  280. Public Property Get BoxSize() As Integer
  281.   BoxSize = m_BoxSize
  282. End Property
  283.  
  284. Public Property Let BoxSize(ByVal New_BoxSize As Integer)
  285.   m_BoxSize = New_BoxSize
  286.   m_lBoxSize = m_BoxSize
  287.   PropertyChanged "BoxSize"
  288. End Property
  289.  
  290. Public Property Get Spacing() As Integer
  291.   Spacing = m_Spacing
  292. End Property
  293.  
  294. Public Property Let Spacing(ByVal New_Spacing As Integer)
  295.   m_Spacing = New_Spacing
  296.   m_lSpace = m_Spacing
  297.   PropertyChanged "Spacing"
  298. End Property
  299.  
  300.