home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / Ceritifica186212372005.psc / Controls / XpButton.ctl (.txt) next >
Encoding:
Visual Basic Form  |  2004-11-13  |  25.2 KB  |  739 lines
  1. VERSION 5.00
  2. Begin VB.UserControl DMSXpButton 
  3.    Appearance      =   0  'Flat
  4.    BackColor       =   &H00FFFFFF&
  5.    ClientHeight    =   1380
  6.    ClientLeft      =   0
  7.    ClientTop       =   0
  8.    ClientWidth     =   2535
  9.    BeginProperty Font 
  10.       Name            =   "Tahoma"
  11.       Size            =   8.25
  12.       Charset         =   0
  13.       Weight          =   400
  14.       Underline       =   0   'False
  15.       Italic          =   0   'False
  16.       Strikethrough   =   0   'False
  17.    EndProperty
  18.    ForeColor       =   &H80000006&
  19.    ScaleHeight     =   92
  20.    ScaleMode       =   0  'User
  21.    ScaleWidth      =   169
  22.    ToolboxBitmap   =   "XpButton.ctx":0000
  23.    Begin VB.Timer HoverTimer 
  24.       Enabled         =   0   'False
  25.       Interval        =   1
  26.       Left            =   120
  27.       Top             =   240
  28.    End
  29. Attribute VB_Name = "DMSXpButton"
  30. Attribute VB_GlobalNameSpace = False
  31. Attribute VB_Creatable = True
  32. Attribute VB_PredeclaredId = False
  33. Attribute VB_Exposed = False
  34. Option Explicit
  35. 'mouse over effects
  36. Private Declare Function WindowFromPoint Lib "USER32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
  37. Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
  38. 'draw and set rectangular area of the control
  39. Private Declare Function GetClientRect Lib "USER32" (ByVal hwnd As Long, lpRect As RECT) As Long
  40. Private Declare Function SetRect Lib "USER32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  41. Private Declare Function FillRect Lib "USER32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  42. Private Declare Function FrameRect Lib "USER32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  43. Private Declare Function SetCapture Lib "USER32" (ByVal hwnd As Long) As Long
  44. 'draw by pixel or by line
  45. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  46. Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
  47. Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
  48. Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
  49. Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  50. Private Const PS_SOLID = 0
  51. 'select and delete created objects
  52. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  53. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  54. 'create regions of pixels and remove them to make the control transparent
  55. Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  56. Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
  57. Private Declare Function SetWindowRgn Lib "USER32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
  58. Private Const RGN_DIFF = 4
  59. 'set text color and draw it to the control
  60. Private Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
  61. Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  62. Private Declare Function DrawText Lib "USER32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
  63. Private Const DT_CALCRECT = &H400
  64. Private Const DT_WORDBREAK = &H10
  65. Private Const DT_CENTER = &H1
  66. Private Type RECT
  67.   Left As Long
  68.   Top As Long
  69.   Right As Long
  70.   Bottom As Long
  71. End Type
  72. Private Type POINTAPI
  73.   X As Long
  74.   Y As Long
  75. End Type
  76. Public Event Click()
  77. Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  78. Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  79. Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  80. Public Event KeyPress(KeyAscii As Integer)
  81. Public Event KeyDown(KeyCode As Integer, Shift As Integer)
  82. Public Event KeyUp(KeyCode As Integer, Shift As Integer)
  83. Public Event MouseOver()
  84. Public Event MouseOut()
  85. Private rc As RECT
  86. Private w As Long, H As Long
  87. Private rgMain As Long, rgn1 As Long
  88. Private isOver As Boolean
  89. Private flgHover As Integer
  90. Private flgFocus As Boolean
  91. Private LastButton As Integer
  92. Private LastKey As Integer
  93. Private r As Long, l As Long, t As Long, b As Long
  94. Private mEnabled As Boolean
  95. Private mCaption As String
  96. Private mForeHover As OLE_COLOR
  97. Private Sub DrawButton()
  98. Dim pt As POINTAPI, pen As Long, hpen As Long
  99.   With UserControl
  100.     'left top corner
  101.     hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
  102.     pen = SelectObject(.hdc, hpen)
  103.     MoveToEx .hdc, l, t + 1, pt
  104.     LineTo .hdc, l + 2, t
  105.     SelectObject .hdc, pen
  106.     DeleteObject hpen
  107.     hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
  108.     pen = SelectObject(.hdc, hpen)
  109.     MoveToEx .hdc, l + 2, t, pt
  110.     LineTo .hdc, l, t + 2
  111.     SelectObject .hdc, pen
  112.     DeleteObject hpen
  113.     SetPixel .hdc, l, t + 2, RGB(37, 87, 131)
  114.     SetPixel .hdc, l + 1, t + 2, RGB(191, 206, 220)
  115.     SetPixel .hdc, l + 2, t + 1, RGB(192, 207, 221)
  116.     'top line
  117.     hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
  118.     pen = SelectObject(.hdc, hpen)
  119.     MoveToEx .hdc, l + 3, t, pt
  120.     LineTo .hdc, r - 2, t
  121.     SelectObject .hdc, pen
  122.     DeleteObject hpen
  123.     'right top corner
  124.     hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
  125.     pen = SelectObject(.hdc, hpen)
  126.     MoveToEx .hdc, r - 2, t, pt
  127.     LineTo .hdc, r + 1, t + 3
  128.     SelectObject .hdc, pen
  129.     DeleteObject hpen
  130.     hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
  131.     pen = SelectObject(.hdc, hpen)
  132.     MoveToEx .hdc, r - 1, t, pt
  133.     LineTo .hdc, r, t + 2
  134.     SetPixel .hdc, r, t + 1, RGB(122, 149, 168)
  135.     SetPixel .hdc, r - 2, t + 1, RGB(213, 223, 232)
  136.     SetPixel .hdc, r - 1, t + 2, RGB(191, 206, 219)
  137.     SelectObject .hdc, pen
  138.     DeleteObject hpen
  139.     'right line
  140.     hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
  141.     pen = SelectObject(.hdc, hpen)
  142.     MoveToEx .hdc, r, t + 3, pt
  143.     LineTo .hdc, r, b - 3
  144.     SelectObject .hdc, pen
  145.     DeleteObject hpen
  146.     'right bottom corner
  147.     hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
  148.     pen = SelectObject(.hdc, hpen)
  149.     MoveToEx .hdc, r, b - 3, pt
  150.     LineTo .hdc, r - 3, b
  151.     SelectObject .hdc, pen
  152.     DeleteObject hpen
  153.     hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
  154.     pen = SelectObject(.hdc, hpen)
  155.     MoveToEx .hdc, r, b - 2, pt
  156.     LineTo .hdc, r - 2, b
  157.     SetPixel .hdc, r - 2, b - 2, RGB(177, 183, 182)
  158.     SetPixel .hdc, r - 1, b - 3, RGB(182, 189, 189)
  159.     SelectObject .hdc, pen
  160.     DeleteObject hpen
  161.     'bottom line
  162.     hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
  163.     pen = SelectObject(.hdc, hpen)
  164.     MoveToEx .hdc, l + 3, b - 1, pt
  165.     LineTo .hdc, r - 2, b - 1
  166.     SelectObject .hdc, pen
  167.     DeleteObject hpen
  168.     'left bottom corner
  169.     hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
  170.     pen = SelectObject(.hdc, hpen)
  171.     MoveToEx .hdc, l, b - 3, pt
  172.     LineTo .hdc, l + 3, b
  173.     SelectObject .hdc, pen
  174.     DeleteObject hpen
  175.     hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
  176.     pen = SelectObject(.hdc, hpen)
  177.     MoveToEx .hdc, l, b - 2, pt
  178.     LineTo .hdc, l + 2, b
  179.     SetPixel .hdc, l + 1, b - 3, RGB(191, 199, 202)
  180.     SetPixel .hdc, l + 2, b - 2, RGB(163, 174, 180)
  181.     SelectObject .hdc, pen
  182.     DeleteObject hpen
  183.     'left line
  184.     hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
  185.     pen = SelectObject(.hdc, hpen)
  186.     MoveToEx .hdc, l, t + 3, pt
  187.     LineTo .hdc, l, b - 3
  188.     SelectObject .hdc, pen
  189.     DeleteObject hpen
  190.   End With
  191. End Sub
  192. Private Sub DrawFocus()
  193. Dim pt As POINTAPI, pen As Long, hpen As Long
  194. Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
  195.   With UserControl
  196.     'top line
  197.     hpen = CreatePen(PS_SOLID, 1, RGB(206, 231, 251))
  198.     pen = SelectObject(.hdc, hpen)
  199.     MoveToEx .hdc, l + 2, t + 1, pt
  200.     LineTo .hdc, r - 1, t + 1
  201.     SelectObject .hdc, pen
  202.     DeleteObject hpen
  203.     hpen = CreatePen(PS_SOLID, 1, RGB(188, 212, 246))
  204.     pen = SelectObject(.hdc, hpen)
  205.     MoveToEx .hdc, l + 1, t + 2, pt
  206.     LineTo .hdc, r, t + 2
  207.     SelectObject .hdc, pen
  208.     DeleteObject hpen
  209.     'draw gradient
  210.     ColorR = 186
  211.     ColorG = 211
  212.     ColorB = 246
  213.     For i = t + 3 To b - 4 Step 1
  214.       hpen = CreatePen(PS_SOLID, 2, RGB(ColorR, ColorG, ColorB))
  215.       pen = SelectObject(.hdc, hpen)
  216.       MoveToEx .hdc, l + 2, i, pt
  217.       LineTo .hdc, l + 2, i + 1
  218.       MoveToEx .hdc, r - 1, i, pt
  219.       LineTo .hdc, r - 1, i + 1
  220.       SelectObject .hdc, pen
  221.       DeleteObject hpen
  222.       If ColorB >= 228 Then
  223.         ColorR = ColorR - 4
  224.         ColorG = ColorG - 3
  225.         ColorB = ColorB - 1
  226.       End If
  227.     Next i
  228.     hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
  229.     pen = SelectObject(.hdc, hpen)
  230.     MoveToEx .hdc, l + 1, b - 3, pt
  231.     LineTo .hdc, r - 1, b - 3
  232.     SelectObject .hdc, pen
  233.     DeleteObject hpen
  234.     SetPixel .hdc, l + 2, b - 2, RGB(77, 125, 193)
  235.     hpen = CreatePen(PS_SOLID, 1, RGB(97, 125, 229))
  236.     pen = SelectObject(.hdc, hpen)
  237.     MoveToEx .hdc, l + 3, b - 2, pt
  238.     LineTo .hdc, r - 2, b - 2
  239.     SetPixel .hdc, r - 2, b - 2, RGB(77, 125, 193)
  240.     SelectObject .hdc, pen
  241.     DeleteObject hpen
  242.   End With
  243. End Sub
  244. Private Sub DrawHighlight()
  245. Dim pt As POINTAPI, pen As Long, hpen As Long
  246. Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
  247.   With UserControl
  248.     'top line
  249.     hpen = CreatePen(PS_SOLID, 1, RGB(255, 240, 207))
  250.     pen = SelectObject(.hdc, hpen)
  251.     MoveToEx .hdc, l + 2, t + 1, pt
  252.     LineTo .hdc, r - 1, t + 1
  253.     SelectObject .hdc, pen
  254.     DeleteObject hpen
  255.     hpen = CreatePen(PS_SOLID, 1, RGB(253, 216, 137))
  256.     pen = SelectObject(.hdc, hpen)
  257.     MoveToEx .hdc, l + 1, t + 2, pt
  258.     LineTo .hdc, r, t + 2
  259.     SelectObject .hdc, pen
  260.     DeleteObject hpen
  261.     'draw gradient
  262.     ColorR = 254
  263.     ColorG = 223
  264.     ColorB = 154
  265.     For i = t + 2 To b - 3 Step 1
  266.       hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
  267.       pen = SelectObject(.hdc, hpen)
  268.       MoveToEx .hdc, l + 1, i, pt
  269.       LineTo .hdc, l + 1, i + 1
  270.       MoveToEx .hdc, r - 1, i, pt
  271.       LineTo .hdc, r - 1, i + 1
  272.       SelectObject .hdc, pen
  273.       DeleteObject hpen
  274.       If ColorB >= 49 Then
  275.         ColorR = ColorR - 1
  276.         ColorG = ColorG - 3
  277.         ColorB = ColorB - 7
  278.       End If
  279.     Next i
  280.     ColorR = 252
  281.     ColorG = 210
  282.     ColorB = 121
  283.     For i = t + 3 To b - 3 Step 1
  284.       hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
  285.       pen = SelectObject(.hdc, hpen)
  286.       MoveToEx .hdc, l + 2, i, pt
  287.       LineTo .hdc, l + 2, i + 1
  288.       MoveToEx .hdc, r - 2, i, pt
  289.       LineTo .hdc, r - 2, i + 1
  290.       SelectObject .hdc, pen
  291.       DeleteObject hpen
  292.       If ColorB >= 57 Then
  293.         ColorR = ColorR - 1
  294.         ColorG = ColorG - 4
  295.         ColorB = ColorB - 8
  296.       End If
  297.     Next i
  298.     hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
  299.     pen = SelectObject(.hdc, hpen)
  300.     MoveToEx .hdc, l + 3, b - 3, pt
  301.     LineTo .hdc, r, b - 3
  302.     SelectObject .hdc, pen
  303.     DeleteObject hpen
  304.         
  305.     hpen = CreatePen(PS_SOLID, 1, RGB(229, 151, 0))
  306.     pen = SelectObject(.hdc, hpen)
  307.     MoveToEx .hdc, l + 2, b - 2, pt
  308.     LineTo .hdc, r - 1, b - 2
  309.     SelectObject .hdc, pen
  310.     DeleteObject hpen
  311.   End With
  312. End Sub
  313. Private Sub DrawButtonFace()
  314. Dim pt As POINTAPI, pen As Long, hpen As Long
  315. Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
  316.   With UserControl
  317.     .AutoRedraw = True
  318.     .Cls
  319.     .ScaleMode = 3
  320.     'draw gradient
  321.     ColorR = 255
  322.     ColorG = 255
  323.     ColorB = 253
  324.     For i = t + 3 To b - 3 Step 1
  325.       hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
  326.       pen = SelectObject(.hdc, hpen)
  327.       MoveToEx .hdc, l, i, pt
  328.       LineTo .hdc, r, i
  329.       SelectObject .hdc, pen
  330.       DeleteObject hpen
  331.       
  332.       If ColorB >= 230 Then
  333.         ColorR = ColorR - 1
  334.         ColorG = ColorG - 1
  335.         ColorB = ColorB - 1
  336.       End If
  337.     Next i
  338.     'bottom shadow
  339.     hpen = CreatePen(PS_SOLID, 1, RGB(214, 208, 197))
  340.     pen = SelectObject(.hdc, hpen)
  341.     MoveToEx .hdc, l, b - 2, pt
  342.     LineTo .hdc, r, b - 2
  343.     SelectObject .hdc, pen
  344.     DeleteObject hpen
  345.     hpen = CreatePen(PS_SOLID, 1, RGB(226, 223, 214))
  346.     pen = SelectObject(.hdc, hpen)
  347.     MoveToEx .hdc, l, b - 3, pt
  348.     LineTo .hdc, r, b - 3
  349.     SelectObject .hdc, pen
  350.     DeleteObject hpen
  351.     hpen = CreatePen(PS_SOLID, 1, RGB(236, 235, 230))
  352.     pen = SelectObject(.hdc, hpen)
  353.     MoveToEx .hdc, l, b - 4, pt
  354.     LineTo .hdc, r, b - 4
  355.     SelectObject .hdc, pen
  356.     DeleteObject hpen
  357.   End With
  358. End Sub
  359. Private Sub DrawButtonDown()
  360. Dim pt As POINTAPI, pen As Long, hpen As Long
  361. Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
  362.   With UserControl
  363.     .AutoRedraw = True
  364.     .Cls
  365.     .ScaleMode = 3
  366.     'draw gradient
  367.     ColorR = 239
  368.     ColorG = 238
  369.     ColorB = 231
  370.     For i = t + 3 To b - 2 Step 4
  371.       hpen = CreatePen(PS_SOLID, 4, RGB(ColorR, ColorG, ColorB))
  372.       pen = SelectObject(.hdc, hpen)
  373.       MoveToEx .hdc, l, i, pt
  374.       LineTo .hdc, r, i
  375.       SelectObject .hdc, pen
  376.       DeleteObject hpen
  377.       If ColorB >= 218 Then
  378.         ColorR = ColorR - 1
  379.         ColorG = ColorG - 1
  380.         ColorB = ColorB - 1
  381.       End If
  382.     Next i
  383.     'top shadow
  384.     hpen = CreatePen(PS_SOLID, 1, RGB(209, 204, 192))
  385.     pen = SelectObject(.hdc, hpen)
  386.     MoveToEx .hdc, l, t + 1, pt
  387.     LineTo .hdc, r, t + 1
  388.     SelectObject .hdc, pen
  389.     DeleteObject hpen
  390.     hpen = CreatePen(PS_SOLID, 1, RGB(220, 216, 207))
  391.     pen = SelectObject(.hdc, hpen)
  392.     MoveToEx .hdc, l, t + 2, pt
  393.     LineTo .hdc, r, t + 2
  394.     SelectObject .hdc, pen
  395.     DeleteObject hpen
  396.     'bottom shadow
  397.     hpen = CreatePen(PS_SOLID, 1, RGB(234, 233, 227))
  398.     pen = SelectObject(.hdc, hpen)
  399.     MoveToEx .hdc, l, b - 3, pt
  400.     LineTo .hdc, r, b - 3
  401.     SelectObject .hdc, pen
  402.     DeleteObject hpen
  403.     hpen = CreatePen(PS_SOLID, 1, RGB(242, 241, 238))
  404.     pen = SelectObject(.hdc, hpen)
  405.     MoveToEx .hdc, l, b - 2, pt
  406.     LineTo .hdc, r, b - 2
  407.     SelectObject .hdc, pen
  408.     DeleteObject hpen
  409.   End With
  410. End Sub
  411. Private Sub DrawButtonDisabled()
  412. Dim pt As POINTAPI, pen As Long, hpen As Long
  413. Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
  414. Dim hBrush As Long
  415.   With UserControl
  416.     .AutoRedraw = True
  417.     .Cls
  418.     .ScaleMode = 3
  419.     hBrush = CreateSolidBrush(RGB(245, 244, 234))
  420.     FillRect UserControl.hdc, rc, hBrush
  421.     DeleteObject hBrush
  422.     hBrush = CreateSolidBrush(RGB(201, 199, 186))
  423.     FrameRect UserControl.hdc, rc, hBrush
  424.     DeleteObject hBrush
  425.     'Left top corner
  426.     SetPixel .hdc, l, t + 1, RGB(216, 213, 199)
  427.     SetPixel .hdc, l + 1, t + 1, RGB(216, 213, 199)
  428.     SetPixel .hdc, l + 1, t, RGB(216, 213, 199)
  429.     SetPixel .hdc, l + 1, t + 2, RGB(234, 233, 222)
  430.     SetPixel .hdc, l + 2, t + 1, RGB(234, 233, 222)
  431.     'right top corner
  432.     SetPixel .hdc, r - 1, t, RGB(216, 213, 199)
  433.     SetPixel .hdc, r - 1, t + 1, RGB(216, 213, 199)
  434.     SetPixel .hdc, r, t + 1, RGB(216, 213, 199)
  435.     SetPixel .hdc, r - 2, t + 1, RGB(234, 233, 222)
  436.     SetPixel .hdc, r - 1, t + 2, RGB(234, 233, 222)
  437.     'left bottom corner
  438.     SetPixel .hdc, l, b - 2, RGB(216, 213, 199)
  439.     SetPixel .hdc, l + 1, b - 2, RGB(216, 213, 199)
  440.     SetPixel .hdc, l + 1, b - 1, RGB(216, 213, 199)
  441.     SetPixel .hdc, l + 1, b - 3, RGB(234, 233, 222)
  442.     SetPixel .hdc, l + 2, b - 2, RGB(234, 233, 222)
  443.     'right bottom corner
  444.     SetPixel .hdc, r, b - 2, RGB(216, 213, 199)
  445.     SetPixel .hdc, r - 1, b - 2, RGB(216, 213, 199)
  446.     SetPixel .hdc, r - 1, b - 1, RGB(216, 213, 199)
  447.     SetPixel .hdc, r - 1, b - 3, RGB(234, 233, 222)
  448.     SetPixel .hdc, r - 2, b - 2, RGB(234, 233, 222)
  449.   End With
  450. End Sub
  451. Private Sub DrawButton2()
  452. Dim pt As POINTAPI, pen As Long, hpen As Long
  453. Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
  454. Dim hBrush As Long
  455.   With UserControl
  456.     hBrush = CreateSolidBrush(RGB(0, 60, 116))
  457.     FrameRect UserControl.hdc, rc, hBrush
  458.     DeleteObject hBrush
  459.     'Left top corner
  460.     SetPixel .hdc, l, t + 1, RGB(122, 149, 168)
  461.     SetPixel .hdc, l + 1, t + 1, RGB(37, 87, 131)
  462.     SetPixel .hdc, l + 1, t, RGB(122, 149, 168)
  463.     'SetPixel .hdc, l + 1, t + 2, RGB(191, 206, 220)
  464.     'SetPixel .hdc, l + 2, t + 1, RGB(192, 207, 221)
  465.     'right top corner
  466.     SetPixel .hdc, r - 1, t, RGB(122, 149, 168)
  467.     SetPixel .hdc, r - 1, t + 1, RGB(37, 87, 131)
  468.     SetPixel .hdc, r, t + 1, RGB(122, 149, 168)
  469.     'SetPixel .hdc, r - 2, t + 1, RGB(234, 233, 222)
  470.     'SetPixel .hdc, r - 1, t + 2, RGB(234, 233, 222)
  471.     'left bottom corner
  472.     SetPixel .hdc, l, b - 2, RGB(122, 149, 168)
  473.     SetPixel .hdc, l + 1, b - 2, RGB(37, 87, 131)
  474.     SetPixel .hdc, l + 1, b - 1, RGB(122, 149, 168)
  475.     'SetPixel .hdc, l + 1, b - 3, RGB(234, 233, 222)
  476.     'SetPixel .hdc, l + 2, b - 2, RGB(234, 233, 222)
  477.     'right bottom corner
  478.     SetPixel .hdc, r, b - 2, RGB(122, 149, 168)
  479.     SetPixel .hdc, r - 1, b - 2, RGB(37, 87, 131)
  480.     SetPixel .hdc, r - 1, b - 1, RGB(122, 149, 168)
  481.     'SetPixel .hdc, r - 1, b - 3, RGB(234, 233, 222)
  482.     'SetPixel .hdc, r - 2, b - 2, RGB(234, 233, 222)
  483.   End With
  484. End Sub
  485. Private Sub RedrawButton(Optional ByVal Stat As Integer = -1)
  486.   If mEnabled Then
  487.     If Stat = 1 And LastButton = 1 Then
  488.       DrawButtonDown
  489.     Else
  490.       DrawButtonFace
  491.       If isOver = True Then
  492.         DrawHighlight
  493.       Else
  494.         If flgFocus = True Then
  495.           DrawFocus
  496.         End If
  497.       End If
  498.     End If
  499.     DrawButton2
  500.   Else
  501.     DrawButtonDisabled
  502.   End If
  503.   DrawCaption
  504.   MakeRegion
  505. End Sub
  506. Private Sub DrawCaption()
  507. Dim vh As Long, rcTxt As RECT
  508.   With UserControl
  509.     GetClientRect .hwnd, rcTxt
  510.     If mEnabled Then
  511.       If isOver Then
  512.         SetTextColor .hdc, mForeHover
  513.       Else
  514.         SetTextColor .hdc, .ForeColor
  515.       End If
  516.     Else
  517.       SetTextColor .hdc, RGB(161, 161, 146)
  518.     End If
  519.     vh = DrawText(.hdc, mCaption, Len(mCaption), rcTxt, DT_CALCRECT Or DT_CENTER Or DT_WORDBREAK)
  520.     'If Button = 1 Then
  521.     '  SetRect rcTxt, 0, (.ScaleHeight * 0.5) - (vh * 0.5) + 1, .ScaleWidth, (.ScaleHeight * 0.5) + (vh * 0.5) + 1
  522.     '  DrawText .hdc, mCaption, Len(mCaption), rcTxt, DT_CENTER Or DT_WORDBREAK
  523.     'Else
  524.       SetRect rcTxt, 0, (.ScaleHeight * 0.5) - (vh * 0.5), .ScaleWidth, (.ScaleHeight * 0.5) + (vh * 0.5)
  525.       DrawText .hdc, mCaption, Len(mCaption), rcTxt, DT_CENTER Or DT_WORDBREAK
  526.     'End If
  527.   End With
  528. End Sub
  529. Private Sub HoverTimer_Timer()
  530.   If Not isMouseOver Then
  531.     HoverTimer.Enabled = False
  532.     isOver = False
  533.     flgHover = 0
  534.     RedrawButton 0
  535.     RaiseEvent MouseOut
  536.   End If
  537. End Sub
  538. Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
  539.   LastButton = 1
  540.   Call UserControl_Click
  541. End Sub
  542. Private Sub UserControl_Click()
  543.   If LastButton = 1 Then
  544.     RedrawButton 0
  545.     UserControl.Refresh
  546.     RaiseEvent Click
  547.   End If
  548. End Sub
  549. Private Sub UserControl_DblClick()
  550.   If LastButton = 1 Then
  551.     Call UserControl_MouseDown(1, 0, 0, 0)
  552.     SetCapture hwnd
  553.   End If
  554. End Sub
  555. Private Sub UserControl_GotFocus()
  556.   flgFocus = True
  557.   RedrawButton 1
  558. End Sub
  559. Private Sub UserControl_InitProperties()
  560.   Set UserControl.Font = Ambient.Font
  561.   mCaption = Ambient.DisplayName
  562.   mEnabled = True
  563. End Sub
  564. Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  565.   LastKey = KeyCode
  566.   Select Case KeyCode
  567.     Case vbKeySpace, vbKeyReturn
  568.       RedrawButton 1
  569.     Case vbKeyLeft, vbKeyRight 'right and down arrows
  570.       SendKeys "{Tab}"
  571.     Case vbKeyDown, vbKeyUp 'left and up arrows
  572.       SendKeys "+{Tab}"
  573.   End Select
  574.   RaiseEvent KeyDown(KeyCode, Shift)
  575. End Sub
  576. Private Sub UserControl_KeyPress(KeyAscii As Integer)
  577.   RaiseEvent KeyPress(KeyAscii)
  578. End Sub
  579. Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
  580.   If ((KeyCode = vbKeySpace) And (LastKey = vbKeySpace)) Or ((KeyCode = vbKeyReturn) And (LastKey = vbKeyReturn)) Then
  581.     RedrawButton 0
  582.     LastButton = 1
  583.     UserControl.Refresh
  584.     RaiseEvent Click
  585.   End If
  586.   RaiseEvent KeyUp(KeyCode, Shift)
  587. End Sub
  588. Private Sub UserControl_LostFocus()
  589.   flgFocus = False
  590.   RedrawButton 0
  591. End Sub
  592. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  593.   If mEnabled = True Then
  594.     LastButton = Button
  595.     UserControl.Refresh
  596.     If Button <> 2 Then RedrawButton 1
  597.     RaiseEvent MouseDown(Button, Shift, X, Y)
  598.   End If
  599. End Sub
  600. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  601.   If Button < 2 Then
  602.     If Not isMouseOver Then
  603.       If flgHover = 0 Then Exit Sub
  604.       RedrawButton 0
  605.     Else
  606.       If flgHover = 1 Then Exit Sub
  607.       flgHover = 1
  608.       If Button = 0 And Not isOver Then
  609.         HoverTimer.Enabled = True
  610.         isOver = True
  611.         flgHover = 0
  612.         RedrawButton 0
  613.         RaiseEvent MouseOver
  614.       ElseIf Button = 1 Then
  615.         isOver = True
  616.         RedrawButton 1
  617.         isOver = False
  618.       End If
  619.     End If
  620.   End If
  621.   RaiseEvent MouseMove(Button, Shift, X, Y)
  622. End Sub
  623. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  624.   RedrawButton 0
  625.   UserControl.Refresh
  626.   RaiseEvent MouseUp(Button, Shift, X, Y)
  627. End Sub
  628. Private Sub UserControl_Resize()
  629.   GetClientRect UserControl.hwnd, rc
  630.   With rc
  631.     r = .Right - 1: l = .Left: t = .Top: b = .Bottom
  632.     w = .Right: H = .Bottom
  633.   End With
  634.   RedrawButton 0
  635. End Sub
  636. Private Function isMouseOver() As Boolean
  637. Dim pt As POINTAPI
  638. GetCursorPos pt
  639. isMouseOver = (WindowFromPoint(pt.X, pt.Y) = hwnd)
  640. End Function
  641. Private Sub MakeRegion()
  642.   DeleteObject rgMain
  643.   rgMain = CreateRectRgn(0, 0, w, H)
  644.   rgn1 = CreateRectRgn(0, 0, 1, 1)            'Left top coner
  645.   CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
  646.   DeleteObject rgn1
  647.   rgn1 = CreateRectRgn(0, H - 1, 1, H)      'Left bottom corner
  648.   CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
  649.   DeleteObject rgn1
  650.   rgn1 = CreateRectRgn(w - 1, 0, w, 1)      'Right top corner
  651.   CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
  652.   DeleteObject rgn1
  653.   rgn1 = CreateRectRgn(w - 1, H - 1, w, H) 'Right bottom corner
  654.   CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
  655.   DeleteObject rgn1
  656.   SetWindowRgn UserControl.hwnd, rgMain, True
  657. End Sub
  658. Public Property Get Enabled() As Boolean
  659.   Enabled = mEnabled
  660. End Property
  661. Public Property Let Enabled(ByVal newValue As Boolean)
  662.   mEnabled = newValue
  663.   PropertyChanged "Enabled"
  664.   UserControl.Enabled = newValue
  665.   RedrawButton 0
  666. End Property
  667. Public Property Get Font() As Font
  668.   Set Font = UserControl.Font
  669. End Property
  670. Public Property Set Font(ByVal newValue As Font)
  671.   Set UserControl.Font = newValue
  672.   RedrawButton 0
  673.   PropertyChanged "Font"
  674. End Property
  675. Public Property Get Caption() As String
  676.   Caption = mCaption
  677. End Property
  678. Public Property Let Caption(ByVal newValue As String)
  679.   mCaption = newValue
  680.   RedrawButton 0
  681.   SetAccessKeys
  682.   PropertyChanged "Caption"
  683. End Property
  684. Public Property Get ForeColor() As OLE_COLOR
  685.   ForeColor = UserControl.ForeColor
  686. End Property
  687. Public Property Let ForeColor(ByVal newValue As OLE_COLOR)
  688.   UserControl.ForeColor = newValue
  689.   RedrawButton 0
  690.   PropertyChanged "ForeColor"
  691. End Property
  692. Public Property Get ForeHover() As OLE_COLOR
  693.   ForeHover = mForeHover
  694. End Property
  695. Public Property Let ForeHover(ByVal newValue As OLE_COLOR)
  696.   mForeHover = newValue
  697.   PropertyChanged "ForeHover"
  698. End Property
  699. Private Sub UserControl_Show()
  700.   RedrawButton 0
  701. End Sub
  702. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  703.   With PropBag
  704.     mEnabled = .ReadProperty("Enabled", True)
  705.     Set UserControl.Font = .ReadProperty("Font", Ambient.Font)
  706.     mCaption = .ReadProperty("Caption", Ambient.DisplayName)
  707.     UserControl.ForeColor = .ReadProperty("ForeColor", Ambient.ForeColor)
  708.     mForeHover = .ReadProperty("ForeHover", UserControl.ForeColor)
  709.   End With
  710.   UserControl.Enabled = mEnabled
  711.   SetAccessKeys
  712. End Sub
  713. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  714.   With PropBag
  715.     .WriteProperty "Enabled", mEnabled, True
  716.     .WriteProperty "Font", UserControl.Font, Ambient.Font
  717.     .WriteProperty "Caption", mCaption, Ambient.DisplayName
  718.     .WriteProperty "ForeColor", UserControl.ForeColor
  719.     .WriteProperty "ForeHover", mForeHover, Ambient.ForeColor
  720.   End With
  721. End Sub
  722. Private Sub SetAccessKeys()
  723. Dim i As Long
  724. UserControl.AccessKeys = ""
  725.   If Len(mCaption) > 1 Then
  726.     i = InStr(1, mCaption, "&", vbTextCompare)
  727.     If (i < Len(mCaption)) And (i > 0) Then
  728.       If Mid$(mCaption, i + 1, 1) <> "&" Then
  729.         UserControl.AccessKeys = LCase$(Mid$(mCaption, i + 1, 1))
  730.       Else
  731.         i = InStr(i + 2, mCaption, "&", vbTextCompare)
  732.         If Mid$(mCaption, i + 1, 1) <> "&" Then
  733.           UserControl.AccessKeys = LCase$(Mid$(mCaption, i + 1, 1))
  734.         End If
  735.       End If
  736.     End If
  737.   End If
  738. End Sub
  739.