home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / App_ProFil2079588152007.psc / CB.ctl < prev    next >
Text File  |  2007-08-15  |  50KB  |  1,330 lines
  1. VERSION 5.00
  2. Begin VB.UserControl CB 
  3.    AutoRedraw      =   -1  'True
  4.    ClientHeight    =   1605
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   2205
  8.    DefaultCancel   =   -1  'True
  9.    PropertyPages   =   "CB.ctx":0000
  10.    ScaleHeight     =   107
  11.    ScaleMode       =   3  'Pixel
  12.    ScaleWidth      =   147
  13.    Begin VB.Timer OverTimer 
  14.       Enabled         =   0   'False
  15.       Interval        =   3
  16.       Left            =   0
  17.       Top             =   0
  18.    End
  19. End
  20. Attribute VB_Name = "CB"
  21. Attribute VB_GlobalNameSpace = False
  22. Attribute VB_Creatable = True
  23. Attribute VB_PredeclaredId = False
  24. Attribute VB_Exposed = False
  25. Option Explicit
  26.  
  27. #Const isOCX = False
  28.  
  29. Private Const cbVersion As String = "2.0.6"
  30.  
  31. 'CHAMELEON BUTTON copyright     2001-2002 by gonchuki      E -mail: gonchuki@ yahoo.es
  32. 'This is not the normal Cham button - Brian Lai chose to edit it and get everything he thought was useless out of the control.
  33.  
  34. 'Removed functions:
  35. 'many styles, focus rect function, special effects, colour schemes, soft bevel, mask colour toggle, greyscale, hand pointer
  36.  
  37. 'Edited functions:
  38. 'mouseover leaking problem. now it doesn't (except when in Windows 32-bit button mode)
  39.  
  40. Private Declare Function SetPixel Lib "gdi32" Alias "SetPixelV" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
  41.  
  42. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  43. Private Const COLOR_HIGHLIGHT = 13
  44. Private Const COLOR_BTNFACE = 15
  45. Private Const COLOR_BTNSHADOW = 16
  46. Private Const COLOR_BTNTEXT = 18
  47. Private Const COLOR_BTNHIGHLIGHT = 20
  48. Private Const COLOR_BTNDKSHADOW = 21
  49. Private Const COLOR_BTNLIGHT = 22
  50.  
  51. Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
  52. Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  53. 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
  54. Private Const DT_CALCRECT = &H400
  55. Private Const DT_WORDBREAK = &H10
  56. Private Const DT_CENTER = &H1 Or DT_WORDBREAK Or &H4
  57.  
  58. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  59. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  60. Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  61.  
  62. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  63. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  64.  
  65. Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
  66. Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
  67. Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  68. Private Const PS_SOLID = 0
  69.  
  70. Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  71. Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
  72. Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
  73. Private Const RGN_DIFF = 4
  74.  
  75. Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  76. Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
  77. Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
  78. Private Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT) As Long
  79.  
  80. Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
  81. Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  82.  
  83. Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
  84.  
  85. Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  86. Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
  87.  
  88. Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
  89. Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
  90.  
  91. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  92. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  93. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  94. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  95. Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
  96.  
  97. Private Type RECT
  98.     Left As Long
  99.     Top As Long
  100.     Right As Long
  101.     Bottom As Long
  102. End Type
  103.  
  104. Private Type POINTAPI
  105.     X As Long
  106.     Y As Long
  107. End Type
  108.  
  109. Private Type BITMAPINFOHEADER
  110.     biSize As Long
  111.     biWidth As Long
  112.     biHeight As Long
  113.     biPlanes As Integer
  114.     biBitCount As Integer
  115.     biCompression As Long
  116.     biSizeImage As Long
  117.     biXPelsPerMeter As Long
  118.     biYPelsPerMeter As Long
  119.     biClrUsed As Long
  120.     biClrImportant As Long
  121. End Type
  122.  
  123. Private Type RGBTRIPLE
  124.     rgbBlue As Byte
  125.     rgbGreen As Byte
  126.     rgbRed As Byte
  127. End Type
  128.  
  129. Private Type BITMAPINFO
  130.     bmiHeader As BITMAPINFOHEADER
  131.     bmiColors As RGBTRIPLE
  132. End Type
  133.  
  134. Public Enum ButtonTypes
  135.     [Windows 32-bit] = 2    'the classic windows button
  136.     [Java metal] = 5        'there are also other styles but not so different from windows one
  137.     [Simple Flat] = 7       'the standard flat button seen on toolbars
  138.     [Flat Highlight] = 8    'again the flat button but this one has no border until the mouse is over it
  139.     [Office XP] = 9         'the new Office XP button
  140. End Enum
  141.  
  142. Public Enum ColorTypes
  143.     [Use Windows] = 1
  144.     [Custom] = 2
  145. End Enum
  146.  
  147. Public Enum PicPositions
  148.     cbLeft = 0
  149.     cbRight = 1
  150.     cbTop = 2
  151.     cbBottom = 3
  152.     cbBackground = 4
  153. End Enum
  154.  
  155. 'events
  156. Public Event Click()
  157. Attribute Click.VB_MemberFlags = "200"
  158. Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  159. Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  160. Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  161. Public Event KeyPress(KeyAscii As Integer)
  162. Public Event KeyDown(KeyCode As Integer, Shift As Integer)
  163. Public Event KeyUp(KeyCode As Integer, Shift As Integer)
  164. Public Event MouseOver()
  165. Public Event MouseOut()
  166.  
  167. 'variables
  168. Private MyButtonType As ButtonTypes
  169. Private MyColorType As ColorTypes
  170. Private PicPosition As PicPositions
  171. Private He As Long  'the height of the button
  172. Private Wi As Long  'the width of the button
  173. Private BackC As Long 'back color
  174. Private BackO As Long 'back color when mouse is over
  175. Private ForeC As Long 'fore color
  176. Private ForeO As Long 'fore color when mouse is over
  177. Private MaskC As Long 'mask color
  178. Private OXPb As Long, OXPf As Long
  179. Private picNormal As StdPicture, picHover As StdPicture
  180. Private pDC As Long, pBM As Long, oBM As Long 'used for the treansparent button
  181. Private elTex As String     'current text
  182. Private rc As RECT, rc2 As RECT, rc3 As RECT, fc As POINTAPI 'text and focus rect locations
  183. Private picPT As POINTAPI, picSZ As POINTAPI  'picture Position & Size
  184. Private rgnNorm As Long
  185. Private LastButton As Byte, LastKeyDown As Byte
  186. Private isEnabled As Boolean
  187. Private HasFocus As Boolean
  188. Private cFace As Long, cLight As Long, cHighLight As Long, cShadow As Long, cDarkShadow As Long, cText As Long, cTextO As Long, cFaceO As Long, cMask As Long, XPFace As Long
  189. Private lastStat As Byte, TE As String, isShown As Boolean  'used to avoid unnecessary repaints
  190. Private isOver As Boolean, inLoop As Boolean
  191. Private captOpt As Long
  192. Private isCheckbox As Boolean, cValue As Boolean
  193.  
  194. Private Sub OverTimer_Timer()
  195.     On Error Resume Next
  196.     If Not isMouseOver Then
  197.         OverTimer.Enabled = False
  198.         isOver = False
  199.         Call Redraw(0, True)
  200.         RaiseEvent MouseOut
  201.     End If
  202. End Sub
  203.  
  204. Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
  205.     On Error Resume Next
  206.     LastButton = 1
  207.     Call UserControl_Click
  208. End Sub
  209.  
  210. Private Sub UserControl_AmbientChanged(PropertyName As String)
  211.     On Error Resume Next
  212.     If Not MyColorType = [Custom] Then
  213.         Call SetColors
  214.         Call Redraw(lastStat, True)
  215.     End If
  216. End Sub
  217.  
  218. Private Sub UserControl_Click()
  219.     On Error Resume Next
  220.     If LastButton = 1 And isEnabled Then
  221.         If isCheckbox Then cValue = Not cValue
  222.         Call Redraw(0, True) 'be sure that the normal status is drawn
  223.         UserControl.Refresh
  224.         RaiseEvent Click
  225.     End If
  226. End Sub
  227.  
  228. Private Sub UserControl_DblClick()
  229.     On Error Resume Next
  230.     If LastButton = 1 Then
  231.         Call UserControl_MouseDown(1, 0, 0, 0)
  232.         SetCapture hWnd
  233.     End If
  234. End Sub
  235.  
  236. Private Sub UserControl_GotFocus()
  237.     On Error Resume Next
  238.     HasFocus = True
  239.     Call Redraw(lastStat, True)
  240. End Sub
  241.  
  242. Private Sub UserControl_Hide()
  243.     On Error Resume Next
  244.     isShown = False
  245. End Sub
  246.  
  247. Private Sub UserControl_Initialize()
  248.     On Error Resume Next
  249.     'this makes the control to be slow, remark this line if the "not redrawing" problem is not important for you: ie, you intercept the Load_Event (with breakpoint or messageBox) and the button does not repaint...
  250.     isShown = True
  251. End Sub
  252.  
  253. Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  254.     On Error Resume Next
  255.     RaiseEvent KeyDown(KeyCode, Shift)
  256.     
  257.     LastKeyDown = KeyCode
  258.     Select Case KeyCode
  259.         Case 32 'spacebar pressed
  260.             Call Redraw(2, False)
  261.         Case 39, 40 'right and down arrows
  262.             SendKeys "{Tab}"
  263.         Case 37, 38 'left and up arrows
  264.             SendKeys "+{Tab}"
  265.     End Select
  266. End Sub
  267.  
  268. Private Sub UserControl_KeyPress(KeyAscii As Integer)
  269.     On Error Resume Next
  270.     RaiseEvent KeyPress(KeyAscii)
  271. End Sub
  272.  
  273. Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
  274. RaiseEvent KeyUp(KeyCode, Shift)
  275.  
  276. If (KeyCode = 32) And (LastKeyDown = 32) Then 'spacebar pressed, and not cancelled by the user
  277.     On Error Resume Next
  278.     If isCheckbox Then cValue = Not cValue
  279.     Call Redraw(0, False)
  280.     UserControl.Refresh
  281.     RaiseEvent Click
  282. End If
  283. End Sub
  284.  
  285. Private Sub UserControl_LostFocus()
  286.     On Error Resume Next
  287.     HasFocus = False
  288.     Call Redraw(lastStat, True)
  289. End Sub
  290.  
  291. Private Sub UserControl_InitProperties()
  292.     On Error Resume Next
  293.     isEnabled = True
  294.     elTex = Ambient.DisplayName
  295.     Set UserControl.Font = Ambient.Font
  296.     MyButtonType = [Windows 32-bit]
  297.     MyColorType = [Use Windows]
  298.     Call SetColors
  299.     BackC = cFace: BackO = BackC
  300.     ForeC = cText: ForeO = ForeC
  301.     MaskC = &HC0C0C0
  302.     Call CalcTextRects
  303. End Sub
  304.  
  305. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  306.     On Error Resume Next
  307.     RaiseEvent MouseDown(Button, Shift, X, Y)
  308.     LastButton = Button
  309.     If Button <> 2 Then Call Redraw(2, False)
  310. End Sub
  311.  
  312. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  313.     On Error Resume Next
  314.     RaiseEvent MouseMove(Button, Shift, X, Y)
  315.     If Button < 2 Then
  316.         If Not isMouseOver Then
  317.             'we are outside the button
  318.             Call Redraw(0, False)
  319.         Else
  320.             'we are inside the button
  321.             If Button = 0 And Not isOver Then
  322.                 OverTimer.Enabled = True
  323.                 isOver = True
  324.                 Call Redraw(0, True)
  325.                 RaiseEvent MouseOver
  326.             ElseIf Button = 1 Then
  327.                 isOver = True
  328.                 Call Redraw(2, False)
  329.                 isOver = False
  330.             End If
  331.         End If
  332.     End If
  333. End Sub
  334.  
  335. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  336.     On Error Resume Next
  337.     RaiseEvent MouseUp(Button, Shift, X, Y)
  338.     If Button <> 2 Then Call Redraw(0, False)
  339. End Sub
  340.  
  341. '########## BUTTON PROPERTIES ##########
  342. Public Property Get BackColor() As OLE_COLOR
  343. Attribute BackColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  344. Attribute BackColor.VB_UserMemId = -501
  345.     On Error Resume Next
  346.     BackColor = BackC
  347. End Property
  348. Public Property Let BackColor(ByVal theCol As OLE_COLOR)
  349.     On Error Resume Next
  350.     BackC = theCol
  351.     If Not Ambient.UserMode Then BackO = theCol
  352.     Call SetColors
  353.     Call Redraw(lastStat, True)
  354.     PropertyChanged "BCOL"
  355. End Property
  356.  
  357. Public Property Get BackOver() As OLE_COLOR
  358. Attribute BackOver.VB_ProcData.VB_Invoke_Property = ";Appearance"
  359.     On Error Resume Next
  360.     BackOver = BackO
  361. End Property
  362. Public Property Let BackOver(ByVal theCol As OLE_COLOR)
  363.     On Error Resume Next
  364.     BackO = theCol
  365.     Call SetColors
  366.     Call Redraw(lastStat, True)
  367.     PropertyChanged "BCOLO"
  368. End Property
  369.  
  370. Public Property Get ForeColor() As OLE_COLOR
  371. Attribute ForeColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  372. Attribute ForeColor.VB_UserMemId = -513
  373.     On Error Resume Next
  374.     ForeColor = ForeC
  375. End Property
  376. Public Property Let ForeColor(ByVal theCol As OLE_COLOR)
  377.     On Error Resume Next
  378.     ForeC = theCol
  379.     If Not Ambient.UserMode Then ForeO = theCol
  380.     Call SetColors
  381.     Call Redraw(lastStat, True)
  382.     PropertyChanged "FCOL"
  383. End Property
  384.  
  385. Public Property Get ForeOver() As OLE_COLOR
  386. Attribute ForeOver.VB_ProcData.VB_Invoke_Property = ";Appearance"
  387.     On Error Resume Next
  388.     ForeOver = ForeO
  389. End Property
  390. Public Property Let ForeOver(ByVal theCol As OLE_COLOR)
  391.     On Error Resume Next
  392.     ForeO = theCol
  393.     Call SetColors
  394.     Call Redraw(lastStat, True)
  395.     PropertyChanged "FCOLO"
  396. End Property
  397.  
  398. Public Property Get MaskColor() As OLE_COLOR
  399. Attribute MaskColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  400.     On Error Resume Next
  401.     MaskColor = MaskC
  402. End Property
  403. Public Property Let MaskColor(ByVal theCol As OLE_COLOR)
  404.     On Error Resume Next
  405.     MaskC = theCol
  406.     Call SetColors
  407.     Call Redraw(lastStat, True)
  408.     PropertyChanged "MCOL"
  409. End Property
  410.  
  411. Public Property Get ButtonType() As ButtonTypes
  412. Attribute ButtonType.VB_ProcData.VB_Invoke_Property = ";Appearance"
  413.     On Error Resume Next
  414.     ButtonType = MyButtonType
  415. End Property
  416.  
  417. Public Property Let ButtonType(ByVal newValue As ButtonTypes)
  418.     On Error Resume Next
  419.     MyButtonType = newValue
  420.     Call UserControl_Resize
  421.     PropertyChanged "BTYPE"
  422. End Property
  423.  
  424. Public Property Get Caption() As String
  425. Attribute Caption.VB_ProcData.VB_Invoke_Property = ";Text"
  426. Attribute Caption.VB_UserMemId = 0
  427.     On Error Resume Next
  428.     Caption = elTex
  429. End Property
  430.  
  431. Public Property Let Caption(ByVal newValue As String)
  432.     On Error Resume Next
  433.     elTex = newValue
  434.     Call SetAccessKeys
  435.     Call CalcTextRects
  436.     Call Redraw(0, True)
  437.     PropertyChanged "TX"
  438. End Property
  439.  
  440. Public Property Get Enabled() As Boolean
  441. Attribute Enabled.VB_ProcData.VB_Invoke_Property = ";Behavior"
  442. Attribute Enabled.VB_UserMemId = -514
  443.     On Error Resume Next
  444.     Enabled = isEnabled
  445. End Property
  446.  
  447. Public Property Let Enabled(ByVal newValue As Boolean)
  448.     On Error Resume Next
  449.     isEnabled = newValue
  450.     Call Redraw(0, True)
  451.     UserControl.Enabled = isEnabled
  452.     PropertyChanged "ENAB"
  453. End Property
  454.  
  455. Public Property Get Font() As Font
  456. Attribute Font.VB_ProcData.VB_Invoke_Property = ";Font"
  457. Attribute Font.VB_UserMemId = -512
  458.     On Error Resume Next
  459.     Set Font = UserControl.Font
  460. End Property
  461.  
  462. Public Property Set Font(ByRef newFont As Font)
  463.     On Error Resume Next
  464.     Set UserControl.Font = newFont
  465.     Call CalcTextRects
  466.     Call Redraw(0, True)
  467.     PropertyChanged "FONT"
  468. End Property
  469.  
  470. Public Property Get FontBold() As Boolean
  471. Attribute FontBold.VB_MemberFlags = "400"
  472.     On Error Resume Next
  473.     FontBold = UserControl.FontBold
  474. End Property
  475.  
  476. Public Property Let FontBold(ByVal newValue As Boolean)
  477.     On Error Resume Next
  478.     UserControl.FontBold = newValue
  479.     Call CalcTextRects
  480.     Call Redraw(0, True)
  481. End Property
  482.  
  483. Public Property Get FontItalic() As Boolean
  484. Attribute FontItalic.VB_MemberFlags = "400"
  485.     On Error Resume Next
  486.     FontItalic = UserControl.FontItalic
  487. End Property
  488.  
  489. Public Property Let FontItalic(ByVal newValue As Boolean)
  490.     On Error Resume Next
  491.     UserControl.FontItalic = newValue
  492.     Call CalcTextRects
  493.     Call Redraw(0, True)
  494. End Property
  495.  
  496. Public Property Get FontUnderline() As Boolean
  497. Attribute FontUnderline.VB_MemberFlags = "400"
  498.     On Error Resume Next
  499.     FontUnderline = UserControl.FontUnderline
  500. End Property
  501.  
  502. Public Property Let FontUnderline(ByVal newValue As Boolean)
  503.     On Error Resume Next
  504.     UserControl.FontUnderline = newValue
  505.     Call CalcTextRects
  506.     Call Redraw(0, True)
  507. End Property
  508.  
  509. Public Property Get FontSize() As Integer
  510. Attribute FontSize.VB_MemberFlags = "400"
  511.     On Error Resume Next
  512.     FontSize = UserControl.FontSize
  513. End Property
  514.  
  515. Public Property Let FontSize(ByVal newValue As Integer)
  516.     On Error Resume Next
  517.     UserControl.FontSize = newValue
  518.     Call CalcTextRects
  519.     Call Redraw(0, True)
  520. End Property
  521.  
  522. Public Property Get FontName() As String
  523. Attribute FontName.VB_MemberFlags = "400"
  524.     On Error Resume Next
  525.     FontName = UserControl.FontName
  526. End Property
  527.  
  528. Public Property Let FontName(ByVal newValue As String)
  529.     On Error Resume Next
  530.     UserControl.FontName = newValue
  531.     Call CalcTextRects
  532.     Call Redraw(0, True)
  533. End Property
  534.  
  535. Public Property Get ColorScheme() As ColorTypes
  536. Attribute ColorScheme.VB_ProcData.VB_Invoke_Property = ";Appearance"
  537.     On Error Resume Next
  538.     ColorScheme = MyColorType
  539. End Property
  540.  
  541. Public Property Let ColorScheme(ByVal newValue As ColorTypes)
  542.     On Error Resume Next
  543.     MyColorType = newValue
  544.     Call SetColors
  545.     Call Redraw(0, True)
  546.     PropertyChanged "COLTYPE"
  547. End Property
  548.  
  549. Public Property Get MousePointer() As MousePointerConstants
  550. Attribute MousePointer.VB_ProcData.VB_Invoke_Property = ";Appearance"
  551.     MousePointer = UserControl.MousePointer
  552. End Property
  553.  
  554. Public Property Let MousePointer(ByVal newPointer As MousePointerConstants)
  555.     On Error Resume Next
  556.     UserControl.MousePointer = newPointer
  557.     PropertyChanged "MPTR"
  558. End Property
  559.  
  560. Public Property Get MouseIcon() As StdPicture
  561. Attribute MouseIcon.VB_ProcData.VB_Invoke_Property = ";Appearance"
  562.     On Error Resume Next
  563.     Set MouseIcon = UserControl.MouseIcon
  564. End Property
  565.  
  566. Public Property Set MouseIcon(ByVal newIcon As StdPicture)
  567.     On Local Error Resume Next
  568.     Set UserControl.MouseIcon = newIcon
  569.     PropertyChanged "MICON"
  570. End Property
  571.  
  572. Public Property Get hWnd() As Long
  573. Attribute hWnd.VB_UserMemId = -515
  574.     On Error Resume Next
  575.     hWnd = UserControl.hWnd
  576. End Property
  577.  
  578. Public Property Get PictureNormal() As StdPicture
  579. Attribute PictureNormal.VB_ProcData.VB_Invoke_Property = ";Appearance"
  580.     On Error Resume Next
  581.     Set PictureNormal = picNormal
  582. End Property
  583. Public Property Set PictureNormal(ByVal newPic As StdPicture)
  584.     On Error Resume Next
  585.     Set picNormal = newPic
  586.     Call CalcPicSize
  587.     Call CalcTextRects
  588.     Call Redraw(lastStat, True)
  589.     PropertyChanged "PICN"
  590. End Property
  591.  
  592. Public Property Get PictureOver() As StdPicture
  593. Attribute PictureOver.VB_ProcData.VB_Invoke_Property = ";Appearance"
  594.     Set PictureOver = picHover
  595. End Property
  596. Public Property Set PictureOver(ByVal newPic As StdPicture)
  597.     On Error Resume Next
  598.     Set picHover = newPic
  599.     If isOver Then Call Redraw(lastStat, True) 'only redraw i we need to see this picture immediately
  600.     PropertyChanged "PICO"
  601. End Property
  602.  
  603. Public Property Get PicturePosition() As PicPositions
  604. Attribute PicturePosition.VB_ProcData.VB_Invoke_Property = ";Position"
  605.     On Error Resume Next
  606.     PicturePosition = PicPosition
  607. End Property
  608. Public Property Let PicturePosition(ByVal newPicPos As PicPositions)
  609.     On Error Resume Next
  610.     PicPosition = newPicPos
  611.     PropertyChanged "PICPOS"
  612.     Call CalcTextRects
  613.     Call Redraw(lastStat, True)
  614. End Property
  615.  
  616. Public Property Get CheckBoxBehaviour() As Boolean
  617.     On Error Resume Next
  618.     CheckBoxBehaviour = isCheckbox
  619. End Property
  620.  
  621. Public Property Let CheckBoxBehaviour(ByVal newValue As Boolean)
  622.     On Error Resume Next
  623.     isCheckbox = newValue
  624.     Call Redraw(lastStat, True)
  625.     PropertyChanged "CHECK"
  626. End Property
  627.  
  628. Public Property Get Value() As Boolean
  629.     Value = cValue
  630. End Property
  631.  
  632. Public Property Let Value(ByVal newValue As Boolean)
  633.     On Error Resume Next
  634.     cValue = newValue
  635.     If isCheckbox Then Call Redraw(0, True)
  636.     PropertyChanged "VALUE"
  637. End Property
  638.  
  639. Public Property Get Version() As String
  640.     On Error Resume Next
  641.     Version = cbVersion
  642. End Property
  643.  
  644. '########## END OF PROPERTIES ##########
  645.  
  646. Private Sub UserControl_Resize()
  647.     On Error Resume Next
  648.     If inLoop Then Exit Sub
  649.     'get button size
  650.     GetClientRect UserControl.hWnd, rc3
  651.     'assign these values to He and Wi
  652.     He = rc3.Bottom: Wi = rc3.Right
  653.     'build the FocusRect size and position depending on the button type
  654.     If MyButtonType >= [Simple Flat] And MyButtonType <= 9 Then
  655.         InflateRect rc3, -3, -3
  656.     Else
  657.         InflateRect rc3, -4, -4
  658.     End If
  659.     Call CalcTextRects
  660.     
  661.     If rgnNorm Then DeleteObject rgnNorm
  662.     Call MakeRegion
  663.     SetWindowRgn UserControl.hWnd, rgnNorm, True
  664.     
  665.     If He Then Call Redraw(0, True)
  666. End Sub
  667.  
  668. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  669.     On Error Resume Next
  670.     With PropBag
  671.         MyButtonType = .ReadProperty("BTYPE", 2)
  672.         elTex = .ReadProperty("TX", "")
  673.         isEnabled = .ReadProperty("ENAB", True)
  674.         Set UserControl.Font = .ReadProperty("FONT", UserControl.Font)
  675.         MyColorType = .ReadProperty("COLTYPE", 1)
  676.         BackC = .ReadProperty("BCOL", GetSysColor(COLOR_BTNFACE))
  677.         BackO = .ReadProperty("BCOLO", BackC)
  678.         ForeC = .ReadProperty("FCOL", GetSysColor(COLOR_BTNTEXT))
  679.         ForeO = .ReadProperty("FCOLO", ForeC)
  680.         MaskC = .ReadProperty("MCOL", &HC0C0C0)
  681.         UserControl.MousePointer = .ReadProperty("MPTR", 0)
  682.         Set UserControl.MouseIcon = .ReadProperty("MICON", Nothing)
  683.         Set picNormal = .ReadProperty("PICN", Nothing)
  684.         Set picHover = .ReadProperty("PICH", Nothing)
  685.         PicPosition = .ReadProperty("PICPOS", 0)
  686.         isCheckbox = .ReadProperty("CHECK", False)
  687.         cValue = .ReadProperty("VALUE", False)
  688.     End With
  689.  
  690.     UserControl.Enabled = isEnabled
  691.     Call CalcPicSize
  692.     Call CalcTextRects
  693.     Call SetAccessKeys
  694. End Sub
  695.  
  696. Private Sub UserControl_Show()
  697.     On Error Resume Next
  698.     isShown = True
  699.     Call SetColors
  700.     Call Redraw(0, True)
  701. End Sub
  702.  
  703. Private Sub UserControl_Terminate()
  704.     On Error Resume Next
  705.     isShown = False
  706.     DeleteObject rgnNorm
  707.     If pDC Then
  708.         DeleteObject SelectObject(pDC, oBM)
  709.         DeleteDC pDC
  710.     End If
  711. End Sub
  712.  
  713. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  714.     On Error Resume Next
  715.     With PropBag
  716.         Call .WriteProperty("BTYPE", MyButtonType)
  717.         Call .WriteProperty("TX", elTex)
  718.         Call .WriteProperty("ENAB", isEnabled)
  719.         Call .WriteProperty("FONT", UserControl.Font)
  720.         Call .WriteProperty("COLTYPE", MyColorType)
  721.         Call .WriteProperty("BCOL", BackC)
  722.         Call .WriteProperty("BCOLO", BackO)
  723.         Call .WriteProperty("FCOL", ForeC)
  724.         Call .WriteProperty("FCOLO", ForeO)
  725.         Call .WriteProperty("MCOL", MaskC)
  726.         Call .WriteProperty("MPTR", UserControl.MousePointer)
  727.         Call .WriteProperty("MICON", UserControl.MouseIcon)
  728.         Call .WriteProperty("PICN", picNormal)
  729.         Call .WriteProperty("PICH", picHover)
  730.         Call .WriteProperty("PICPOS", PicPosition)
  731.         Call .WriteProperty("CHECK", isCheckbox)
  732.         Call .WriteProperty("VALUE", cValue)
  733.     End With
  734. End Sub
  735.  
  736. Private Sub Redraw(ByVal curStat As Byte, ByVal Force As Boolean)
  737.     On Error Resume Next
  738.     'here is the CORE of the button, everything is drawn here
  739.     'it's not well commented but i think that everything is
  740.     'pretty self explanatory...
  741.         
  742.     If isCheckbox And cValue Then curStat = 2
  743.     
  744.     If Not Force Then  'check drawing redundancy
  745.         If (curStat = lastStat) And (TE = elTex) Then Exit Sub
  746.     End If
  747.     
  748.     If He = 0 Or Not isShown Then Exit Sub   'we don't want errors
  749.     
  750.     lastStat = curStat
  751.     TE = elTex
  752.     
  753.     Dim I As Long, stepXP1 As Single, XPFace2 As Long, tempCol As Long
  754.     
  755.     With UserControl
  756.     .Cls
  757.     If isOver And MyColorType = Custom Then tempCol = BackC: BackC = BackO: SetColors
  758.     
  759.     DrawRectangle 0, 0, Wi, He, cFace
  760.     
  761.     If isEnabled Then
  762.         If curStat = 0 Then
  763.     '#@#@#@#@#@# BUTTON NORMAL STATE #@#@#@#@#@#
  764.             Select Case MyButtonType
  765.                 Case 2 'Windows 32-bit
  766.                     Call DrawCaption(Abs(isOver))
  767.                         DrawFrame cHighLight, cDarkShadow, cLight, cShadow, False
  768.                 Case 5 'Java
  769.                     DrawRectangle 1, 1, Wi - 1, He - 1, ShiftColor(cFace, &HC)
  770.                     Call DrawCaption(Abs(isOver))
  771.                     DrawRectangle 1, 1, Wi - 1, He - 1, cHighLight, True
  772.                     DrawRectangle 0, 0, Wi - 1, He - 1, ShiftColor(cShadow, -&H1A), True
  773.                     mSetPixel 1, He - 2, ShiftColor(cShadow, &H1A)
  774.                     mSetPixel Wi - 2, 1, ShiftColor(cShadow, &H1A)
  775.                 Case 7, 8 'Flat buttons
  776.                     Call DrawCaption(Abs(isOver))
  777.                     If (MyButtonType = [Simple Flat]) Then
  778.                         DrawFrame cHighLight, cShadow, 0, 0, False, True
  779.                     ElseIf isOver Then
  780.                         If MyButtonType = [Flat Highlight] Then
  781.                             DrawFrame cHighLight, cShadow, 0, 0, False, True
  782.                         Else
  783.                             DrawFrame cHighLight, cDarkShadow, cLight, cShadow, False, False
  784.                         End If
  785.                     End If
  786.                 Case 9 'Office XP
  787.                     If isOver Then DrawRectangle 1, 1, Wi, He, OXPf
  788.                     Call DrawCaption(Abs(isOver))
  789.                     If isOver Then DrawRectangle 0, 0, Wi, He, OXPb, True
  790.             End Select
  791.             Call DrawPictures(0)
  792.         ElseIf curStat = 2 Then
  793.     '#@#@#@#@#@# BUTTON IS DOWN #@#@#@#@#@#
  794.             Select Case MyButtonType
  795.                 Case 2 'Windows 32-bit
  796.                     Call DrawCaption(2)
  797.                         DrawFrame cDarkShadow, cHighLight, cShadow, cLight, False
  798.                 Case 5 'Java
  799.                     DrawRectangle 1, 1, Wi - 2, He - 2, ShiftColor(cShadow, &H10), False
  800.                     DrawRectangle 0, 0, Wi - 1, He - 1, ShiftColor(cShadow, -&H1A), True
  801.                     DrawLine Wi - 1, 1, Wi - 1, He, cHighLight
  802.                     DrawLine 1, He - 1, Wi - 1, He - 1, cHighLight
  803.                     SetTextColor .hdc, cTextO
  804.                     DrawText .hdc, elTex, Len(elTex), rc, DT_CENTER
  805.                  Case 7, 8 'Flat buttons
  806.                     Call DrawCaption(2)
  807.                     DrawFrame cShadow, cHighLight, 0, 0, False, True
  808.                 Case 9 'Office XP
  809.                     If isOver Then DrawRectangle 0, 0, Wi, He, Abs(MyColorType = 2) * ShiftColor(OXPf, -&H20) + Abs(MyColorType <> 2) * ShiftColorOXP(OXPb, &H80)
  810.                     Call DrawCaption(2)
  811.                     DrawRectangle 0, 0, Wi, He, OXPb, True
  812.             End Select
  813.             Call DrawPictures(1)
  814.         End If
  815.     Else
  816.     '#~#~#~#~#~# DISABLED STATUS #~#~#~#~#~#
  817.         Select Case MyButtonType
  818.             Case 2 'Windows 32-bit
  819.                 Call DrawCaption(3)
  820.                 DrawFrame cHighLight, cDarkShadow, cLight, cShadow, False
  821.             Case 5 'Java
  822.                 Call DrawCaption(4)
  823.                 DrawRectangle 0, 0, Wi, He, cShadow, True
  824.             Case 7, 8 'Flat buttons
  825.                 Call DrawCaption(3)
  826.                 If MyButtonType = [Simple Flat] Then DrawFrame cHighLight, cShadow, 0, 0, False, True
  827.             Case 9 'Office XP
  828.                 Call DrawCaption(4)
  829.         End Select
  830.         Call DrawPictures(2)
  831.     End If
  832.     End With
  833.     If isOver And MyColorType = Custom Then BackC = tempCol: SetColors
  834. End Sub
  835.  
  836. Private Sub DrawRectangle(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As Long, Optional OnlyBorder As Boolean = False)
  837.     On Error Resume Next
  838.     Dim bRECT As RECT
  839.     Dim hBrush As Long
  840.     bRECT.Left = X
  841.     bRECT.Top = Y
  842.     bRECT.Right = X + Width
  843.     bRECT.Bottom = Y + Height
  844.     hBrush = CreateSolidBrush(Color)
  845.     If OnlyBorder Then
  846.         FrameRect UserControl.hdc, bRECT, hBrush
  847.     Else
  848.         FillRect UserControl.hdc, bRECT, hBrush
  849.     End If
  850.     DeleteObject hBrush
  851. End Sub
  852.  
  853. Private Sub DrawLine(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Color As Long)
  854.     On Error Resume Next
  855.     'a fast way to draw lines
  856.     Dim pt As POINTAPI
  857.     Dim oldPen As Long, hPen As Long
  858.     With UserControl
  859.         hPen = CreatePen(PS_SOLID, 1, Color)
  860.         oldPen = SelectObject(.hdc, hPen)
  861.         
  862.         MoveToEx .hdc, X1, Y1, pt
  863.         LineTo .hdc, X2, Y2
  864.         
  865.         SelectObject .hdc, oldPen
  866.         DeleteObject hPen
  867.     End With
  868. End Sub
  869.  
  870. Private Sub DrawFrame(ByVal ColHigh As Long, ByVal ColDark As Long, ByVal ColLight As Long, ByVal ColShadow As Long, ByVal ExtraOffset As Boolean, Optional ByVal Flat As Boolean = False)
  871.     On Error Resume Next
  872.     'a very fast way to draw windows-like frames
  873.     Dim pt As POINTAPI
  874.     Dim frHe As Long, frWi As Long, frXtra As Long
  875.     frHe = He - 1 + ExtraOffset: frWi = Wi - 1 + ExtraOffset: frXtra = Abs(ExtraOffset)
  876.     With UserControl
  877.         '=============================
  878.         If ButtonType = [Windows 32-bit] Then Call DeleteObject(SelectObject(.hdc, CreatePen(PS_SOLID, 1, ColHigh)))
  879.         '=============================
  880.         MoveToEx .hdc, frXtra, frHe, pt
  881.         LineTo .hdc, frXtra, frXtra
  882.         LineTo .hdc, frWi, frXtra
  883.         '=============================
  884.         If ButtonType = [Windows 32-bit] Then Call DeleteObject(SelectObject(.hdc, CreatePen(PS_SOLID, 1, ColDark)))
  885.         '=============================
  886.         LineTo .hdc, frWi, frHe
  887.         LineTo .hdc, frXtra - 1, frHe
  888.         MoveToEx .hdc, frXtra + 1, frHe - 1, pt
  889.         If Flat Then Exit Sub
  890.         '=============================
  891.         If ButtonType = [Windows 32-bit] Then Call DeleteObject(SelectObject(.hdc, CreatePen(PS_SOLID, 1, ColLight)))
  892.         '=============================
  893.         LineTo .hdc, frXtra + 1, frXtra + 1
  894.         LineTo .hdc, frWi - 1, frXtra + 1
  895.         '=============================
  896.         If ButtonType = [Windows 32-bit] Then Call DeleteObject(SelectObject(.hdc, CreatePen(PS_SOLID, 1, ColShadow)))
  897.         '=============================
  898.         LineTo .hdc, frWi - 1, frHe - 1
  899.         LineTo .hdc, frXtra, frHe - 1
  900.     End With
  901. End Sub
  902.  
  903. Private Sub mSetPixel(ByVal X As Long, ByVal Y As Long, ByVal Color As Long)
  904.     On Error Resume Next
  905.     Call SetPixel(UserControl.hdc, X, Y, Color)
  906. End Sub
  907.  
  908. Private Sub SetColors()
  909.     On Error Resume Next
  910.     'this function sets the colors taken as a base to build
  911.     'all the other colors and styles.
  912.     
  913.     If MyColorType = Custom Then
  914.         cFace = ConvertFromSystemColor(BackC)
  915.         cFaceO = ConvertFromSystemColor(BackO)
  916.         cText = ConvertFromSystemColor(ForeC)
  917.         cTextO = ConvertFromSystemColor(ForeO)
  918.         cShadow = ShiftColor(cFace, -&H40)
  919.         cLight = ShiftColor(cFace, &H1F)
  920.         cHighLight = ShiftColor(cFace, &H2F) 'it should be 3F but it looks too lighter
  921.         cDarkShadow = ShiftColor(cFace, -&HC0)
  922.         OXPb = ShiftColor(cFace, -&H80)
  923.         OXPf = cFace
  924.     Else
  925.     'if MyColorType is 1 or has not been set then use windows colors
  926.         cFace = GetSysColor(COLOR_BTNFACE)
  927.         cFaceO = cFace
  928.         cShadow = GetSysColor(COLOR_BTNSHADOW)
  929.         cLight = GetSysColor(COLOR_BTNLIGHT)
  930.         cDarkShadow = GetSysColor(COLOR_BTNDKSHADOW)
  931.         cHighLight = GetSysColor(COLOR_BTNHIGHLIGHT)
  932.         cText = GetSysColor(COLOR_BTNTEXT)
  933.         cTextO = cText
  934.         OXPb = GetSysColor(COLOR_HIGHLIGHT)
  935.         OXPf = ShiftColorOXP(OXPb)
  936.     End If
  937.     cMask = ConvertFromSystemColor(MaskC)
  938.     XPFace = ShiftColor(cFace, &H30, False)
  939. End Sub
  940.  
  941. Private Sub MakeRegion()
  942.     On Error Resume Next
  943.     'this function creates the regions to "cut" the UserControl
  944.     'so it will be transparent in certain areas
  945.     
  946.     Dim rgn1 As Long, rgn2 As Long
  947.         
  948.         DeleteObject rgnNorm
  949.         rgnNorm = CreateRectRgn(0, 0, Wi, He)
  950.         rgn2 = CreateRectRgn(0, 0, 0, 0)
  951.         
  952.     Select Case MyButtonType
  953.         Case 1, 5 'Windows 16-bit, Java
  954.             rgn1 = CreateRectRgn(0, He, 1, He - 1)
  955.             CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
  956.             DeleteObject rgn1
  957.             rgn1 = CreateRectRgn(Wi, 0, Wi - 1, 1)
  958.             CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
  959.             DeleteObject rgn1
  960.             If MyButtonType <> 5 Then  'the above was common code
  961.                 rgn1 = CreateRectRgn(0, 0, 1, 1)
  962.                 CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
  963.                 DeleteObject rgn1
  964.                 rgn1 = CreateRectRgn(Wi, He, Wi - 1, He - 1)
  965.                 CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
  966.                 DeleteObject rgn1
  967.             End If
  968.     End Select
  969.     DeleteObject rgn2
  970. End Sub
  971.  
  972. Private Sub SetAccessKeys()
  973.     On Error Resume Next
  974.     'this is a TRUE access keys parser
  975.     'the basic rule is that if an ampersand is followed by another,
  976.     '  a single ampersand is drawn and this is not the access key.
  977.     '  So we continue searching for another possible access key.
  978.     
  979.     '   I only do a second pass because no one writes text like "Me & them & everyone"
  980.     '   so the caption prop should be "Me && them && &everyone", this is rubbish and a
  981.     '   search like this would only waste time
  982.     Dim ampersandPos As Long
  983.     
  984.     'we first clear the AccessKeys property, and will be filled if one is found
  985.     UserControl.AccessKeys = ""
  986.     
  987.     If Len(elTex) > 1 Then
  988.         ampersandPos = InStr(1, elTex, "&", vbTextCompare)
  989.         If (ampersandPos < Len(elTex)) And (ampersandPos > 0) Then
  990.             If Mid$(elTex, ampersandPos + 1, 1) <> "&" Then 'if text is sonething like && then no access key should be assigned, so continue searching
  991.                 UserControl.AccessKeys = LCase$(Mid$(elTex, ampersandPos + 1, 1))
  992.             Else 'do only a second pass to find another ampersand character
  993.                 ampersandPos = InStr(ampersandPos + 2, elTex, "&", vbTextCompare)
  994.                 If Mid$(elTex, ampersandPos + 1, 1) <> "&" Then
  995.                     UserControl.AccessKeys = LCase$(Mid$(elTex, ampersandPos + 1, 1))
  996.                 End If
  997.             End If
  998.         End If
  999.     End If
  1000. End Sub
  1001.  
  1002. Private Function ShiftColor(ByVal Color As Long, ByVal Value As Long, Optional isXP As Boolean = False) As Long
  1003.     On Error Resume Next
  1004.     'this function will add or remove a certain color
  1005.     'quantity and return the result
  1006.     
  1007.     Dim Red As Long, Blue As Long, Green As Long
  1008.     
  1009.     'this is just a tricky way to do it and will result in weird colors for WinXP and KDE2
  1010.     'If isSoft Then Value = Value \ 2
  1011.     
  1012.     If Not isXP Then 'for XP button i use a work-aroud that works fine
  1013.         Blue = ((Color \ &H10000) Mod &H100) + Value
  1014.     Else
  1015.         Blue = ((Color \ &H10000) Mod &H100)
  1016.         Blue = Blue + ((Blue * Value) \ &HC0)
  1017.     End If
  1018.     Green = ((Color \ &H100) Mod &H100) + Value
  1019.     Red = (Color And &HFF) + Value
  1020.     
  1021.     'a bit of optimization done here, values will overflow a
  1022.     ' byte only in one direction... eg: if we added 32 to our
  1023.     ' color, then only a > 255 overflow can occurr.
  1024.     If Value > 0 Then
  1025.         If Red > 255 Then Red = 255
  1026.         If Green > 255 Then Green = 255
  1027.         If Blue > 255 Then Blue = 255
  1028.     ElseIf Value < 0 Then
  1029.         If Red < 0 Then Red = 0
  1030.         If Green < 0 Then Green = 0
  1031.         If Blue < 0 Then Blue = 0
  1032.     End If
  1033.     
  1034.     'more optimization by replacing the RGB function by its correspondent calculation
  1035.     ShiftColor = Red + 256& * Green + 65536 * Blue
  1036. End Function
  1037.  
  1038. Private Function ShiftColorOXP(ByVal theColor As Long, Optional ByVal Base As Long = &HB0) As Long
  1039.     On Error Resume Next
  1040.     Dim Red As Long, Blue As Long, Green As Long
  1041.     Dim Delta As Long
  1042.     
  1043.     Blue = ((theColor \ &H10000) Mod &H100)
  1044.     Green = ((theColor \ &H100) Mod &H100)
  1045.     Red = (theColor And &HFF)
  1046.     Delta = &HFF - Base
  1047.     
  1048.     Blue = Base + Blue * Delta \ &HFF
  1049.     Green = Base + Green * Delta \ &HFF
  1050.     Red = Base + Red * Delta \ &HFF
  1051.     
  1052.     If Red > 255 Then Red = 255
  1053.     If Green > 255 Then Green = 255
  1054.     If Blue > 255 Then Blue = 255
  1055.     
  1056.     ShiftColorOXP = Red + 256& * Green + 65536 * Blue
  1057. End Function
  1058.  
  1059. Private Sub CalcTextRects()
  1060.     On Error Resume Next
  1061.     'this sub will calculate the rects required to draw the text
  1062.     Select Case PicPosition
  1063.         Case 0
  1064.             rc2.Left = 1 + picSZ.X: rc2.Right = Wi - 2: rc2.Top = 1: rc2.Bottom = He - 2
  1065.         Case 1
  1066.             rc2.Left = 1: rc2.Right = Wi - 2 - picSZ.X: rc2.Top = 1: rc2.Bottom = He - 2
  1067.         Case 2
  1068.             rc2.Left = 1: rc2.Right = Wi - 2: rc2.Top = 1 + picSZ.Y: rc2.Bottom = He - 2
  1069.         Case 3
  1070.             rc2.Left = 1: rc2.Right = Wi - 2: rc2.Top = 1: rc2.Bottom = He - 2 - picSZ.Y
  1071.         Case 4
  1072.             rc2.Left = 1: rc2.Right = Wi - 2: rc2.Top = 1: rc2.Bottom = He - 2
  1073.     End Select
  1074.     DrawText UserControl.hdc, elTex, Len(elTex), rc2, DT_CALCRECT Or DT_WORDBREAK
  1075.     CopyRect rc, rc2: fc.X = rc.Right - rc.Left: fc.Y = rc.Bottom - rc.Top
  1076.     Select Case PicPosition
  1077.         Case 0, 2
  1078.             OffsetRect rc, (Wi - rc.Right) \ 2, (He - rc.Bottom) \ 2
  1079.         Case 1
  1080.             OffsetRect rc, (Wi - rc.Right - picSZ.X - 4) \ 2, (He - rc.Bottom) \ 2
  1081.         Case 3
  1082.             OffsetRect rc, (Wi - rc.Right) \ 2, (He - rc.Bottom - picSZ.Y - 4) \ 2
  1083.         Case 4
  1084.             OffsetRect rc, (Wi - rc.Right) \ 2, (He - rc.Bottom) \ 2
  1085.     End Select
  1086.     CopyRect rc2, rc: OffsetRect rc2, 1, 1
  1087.     
  1088.     Call CalcPicPos 'once we have the text position we are able to calculate the pic position
  1089. End Sub
  1090.  
  1091. Public Sub DisableRefresh()
  1092.     On Error Resume Next
  1093.     'this is for fast button editing, once you disable the refresh,
  1094.     ' you can change every prop without triggering the drawing methods.
  1095.     ' once you are done, you call Refresh.
  1096.     isShown = False
  1097. End Sub
  1098.  
  1099. Public Sub Refresh()
  1100.     On Error Resume Next
  1101.     Call SetColors
  1102.     Call CalcTextRects
  1103.     isShown = True
  1104.     Call Redraw(lastStat, True)
  1105. End Sub
  1106.  
  1107. Private Function ConvertFromSystemColor(ByVal theColor As Long) As Long
  1108.     On Error Resume Next
  1109.     Call OleTranslateColor(theColor, 0, ConvertFromSystemColor)
  1110. End Function
  1111.  
  1112. Private Sub DrawCaption(ByVal State As Byte)
  1113.     On Error Resume Next
  1114.     'this code is commonly shared through all the buttons so
  1115.     ' i took it and put it toghether here for easier readability
  1116.     ' of the code, and to cut-down disk size.
  1117.     
  1118.     captOpt = State
  1119.     
  1120.     With UserControl
  1121.     Select Case State 'in this select case, we only change the text color and draw only text that needs rc2, at the end, text that uses rc will be drawn
  1122.         Case 0 'normal caption
  1123.             SetTextColor .hdc, cText
  1124.         Case 1 'hover caption
  1125.             SetTextColor .hdc, cTextO
  1126.         Case 2 'down caption
  1127.             SetTextColor .hdc, cTextO
  1128.             DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
  1129.         Case 3 'disabled embossed caption
  1130.             SetTextColor .hdc, cHighLight
  1131.             DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
  1132.             SetTextColor .hdc, cShadow
  1133.         Case 4 'disabled grey caption
  1134.             SetTextColor .hdc, cShadow
  1135.         Case 5 'WinXP disabled caption
  1136.             SetTextColor .hdc, ShiftColor(XPFace, -&H68, True)
  1137.     End Select
  1138.     'we now draw the text that is common in all the captions
  1139.     If State <> 2 Then DrawText .hdc, elTex, Len(elTex), rc, DT_CENTER
  1140.     End With
  1141. End Sub
  1142.  
  1143. Private Sub DrawPictures(ByVal State As Byte)
  1144.     On Error Resume Next
  1145.     If picNormal Is Nothing Then Exit Sub 'check if there is a main picture, if not then exit
  1146.     With UserControl
  1147.     Select Case State
  1148.         Case 0 'normal & hover
  1149.             If Not isOver Then
  1150.                 TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask, , , , (MyButtonType = [Office XP])
  1151.             Else
  1152.                 If MyButtonType = [Office XP] Then
  1153.                     TransBlt .hdc, picPT.X + 1, picPT.Y + 1, picSZ.X, picSZ.Y, picNormal, cMask, cShadow
  1154.                     TransBlt .hdc, picPT.X - 1, picPT.Y - 1, picSZ.X, picSZ.Y, picNormal, cMask
  1155.                 Else
  1156.                     If Not picHover Is Nothing Then
  1157.                         TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picHover, cMask
  1158.                     Else
  1159.                         TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask
  1160.                     End If
  1161.                 End If
  1162.             End If
  1163.         Case 1 'down
  1164.             If picHover Is Nothing Or MyButtonType = [Office XP] Then
  1165.                 Select Case MyButtonType
  1166.                 Case 5, 9
  1167.                     TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask
  1168.                 Case Else
  1169.                     TransBlt .hdc, picPT.X + 1, picPT.Y + 1, picSZ.X, picSZ.Y, picNormal, cMask
  1170.                 End Select
  1171.             Else
  1172.                 TransBlt .hdc, picPT.X + Abs(MyButtonType <> [Java metal]), picPT.Y + Abs(MyButtonType <> [Java metal]), picSZ.X, picSZ.Y, picHover, cMask
  1173.             End If
  1174.         Case 2 'disabled
  1175.             Select Case MyButtonType
  1176.             Case 5, 6, 9    'draw flat grey pictures
  1177.                 TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask, Abs(MyButtonType = [Office XP]) * ShiftColor(cShadow, &HD) + Abs(MyButtonType <> [Office XP]) * cShadow, True
  1178.             Case 3          'for WinXP draw a greyscaled image
  1179.                 TransBlt .hdc, picPT.X + 1, picPT.Y + 1, picSZ.X, picSZ.Y, picNormal, cMask, , , True
  1180.             Case Else       'draw classic embossed pictures
  1181.                 TransBlt .hdc, picPT.X + 1, picPT.Y + 1, picSZ.X, picSZ.Y, picNormal, cMask, cHighLight, True
  1182.                 TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask, cShadow, True
  1183.             End Select
  1184.     End Select
  1185.     End With
  1186.     If PicPosition = cbBackground Then Call DrawCaption(captOpt)
  1187. End Sub
  1188.  
  1189. Private Sub CalcPicSize()
  1190.     On Error Resume Next
  1191.     If Not picNormal Is Nothing Then
  1192.         picSZ.X = UserControl.ScaleX(picNormal.Width, 8, UserControl.ScaleMode)
  1193.         picSZ.Y = UserControl.ScaleY(picNormal.Height, 8, UserControl.ScaleMode)
  1194.     Else
  1195.         picSZ.X = 0: picSZ.Y = 0
  1196.     End If
  1197. End Sub
  1198.  
  1199. Private Sub CalcPicPos()
  1200.     On Error Resume Next
  1201.     'exit if there's no picture
  1202.     If picNormal Is Nothing And picHover Is Nothing Then Exit Sub
  1203.     
  1204.     If (Trim$(elTex) <> "") And (PicPosition <> 4) Then 'if there is no caption, or we have the picture as background, then we put the picture at the center of the button
  1205.         Select Case PicPosition
  1206.             Case 0 'left
  1207.                 picPT.X = rc.Left - picSZ.X - 4
  1208.                 picPT.Y = (He - picSZ.Y) \ 2
  1209.             Case 1 'right
  1210.                 picPT.X = rc.Right + 4
  1211.                 picPT.Y = (He - picSZ.Y) \ 2
  1212.             Case 2 'top
  1213.                 picPT.X = (Wi - picSZ.X) \ 2
  1214.                 picPT.Y = rc.Top - picSZ.Y - 2
  1215.             Case 3 'bottom
  1216.                 picPT.X = (Wi - picSZ.X) \ 2
  1217.                 picPT.Y = rc.Bottom + 2
  1218.         End Select
  1219.     Else 'center the picture
  1220.         picPT.X = (Wi - picSZ.X) \ 2
  1221.         picPT.Y = (He - picSZ.Y) \ 2
  1222.     End If
  1223. End Sub
  1224.  
  1225. Private Sub TransBlt(ByVal DstDC As Long, ByVal DstX As Long, ByVal DstY As Long, ByVal DstW As Long, ByVal DstH As Long, ByVal SrcPic As StdPicture, Optional ByVal TransColor As Long = -1, Optional ByVal BrushColor As Long = -1, Optional ByVal MonoMask As Boolean = False, Optional ByVal isGreyscale As Boolean = False, Optional ByVal XPBlend As Boolean = False)
  1226.     On Error Resume Next
  1227.     If DstW = 0 Or DstH = 0 Then Exit Sub
  1228.         
  1229.     Dim B As Long, H As Long, F As Long, I As Long, newW As Long
  1230.     Dim TmpDC As Long, TmpBmp As Long, TmpObj As Long
  1231.     Dim Sr2DC As Long, Sr2Bmp As Long, Sr2Obj As Long
  1232.     Dim Data1() As RGBTRIPLE, Data2() As RGBTRIPLE
  1233.     Dim Info As BITMAPINFO, BrushRGB As RGBTRIPLE, gCol As Long
  1234.     
  1235.     Dim SrcDC As Long, tObj As Long, ttt As Long
  1236.  
  1237.     SrcDC = CreateCompatibleDC(hdc)
  1238.     
  1239.     If DstW < 0 Then DstW = UserControl.ScaleX(SrcPic.Width, 8, UserControl.ScaleMode)
  1240.     If DstH < 0 Then DstH = UserControl.ScaleY(SrcPic.Height, 8, UserControl.ScaleMode)
  1241.     
  1242.     If SrcPic.Type = 1 Then 'check if it's an icon or a bitmap
  1243.         tObj = SelectObject(SrcDC, SrcPic)
  1244.     Else
  1245.         Dim br As RECT, hBrush As Long: br.Right = DstW: br.Bottom = DstH
  1246.         ttt = CreateCompatibleBitmap(DstDC, DstW, DstH): tObj = SelectObject(SrcDC, ttt)
  1247.         hBrush = CreateSolidBrush(MaskColor): FillRect SrcDC, br, hBrush
  1248.         DeleteObject hBrush
  1249.         DrawIconEx SrcDC, 0, 0, SrcPic.Handle, 0, 0, 0, 0, &H1 Or &H2
  1250.     End If
  1251.  
  1252.     TmpDC = CreateCompatibleDC(SrcDC)
  1253.     Sr2DC = CreateCompatibleDC(SrcDC)
  1254.     TmpBmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
  1255.     Sr2Bmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
  1256.     TmpObj = SelectObject(TmpDC, TmpBmp)
  1257.     Sr2Obj = SelectObject(Sr2DC, Sr2Bmp)
  1258.     ReDim Data1(DstW * DstH * 3 - 1)
  1259.     ReDim Data2(UBound(Data1))
  1260.     With Info.bmiHeader
  1261.         .biSize = Len(Info.bmiHeader)
  1262.         .biWidth = DstW
  1263.         .biHeight = DstH
  1264.         .biPlanes = 1
  1265.         .biBitCount = 24
  1266.     End With
  1267.     
  1268.     BitBlt TmpDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, vbSrcCopy
  1269.     BitBlt Sr2DC, 0, 0, DstW, DstH, SrcDC, 0, 0, vbSrcCopy
  1270.     GetDIBits TmpDC, TmpBmp, 0, DstH, Data1(0), Info, 0
  1271.     GetDIBits Sr2DC, Sr2Bmp, 0, DstH, Data2(0), Info, 0
  1272.     
  1273.     If BrushColor > 0 Then
  1274.         BrushRGB.rgbBlue = (BrushColor \ &H10000) Mod &H100
  1275.         BrushRGB.rgbGreen = (BrushColor \ &H100) Mod &H100
  1276.         BrushRGB.rgbRed = BrushColor And &HFF
  1277.     End If
  1278.     
  1279.     'If Not useMask Then TransColor = -1
  1280.     
  1281.     newW = DstW - 1
  1282.     
  1283.     For H = 0 To DstH - 1
  1284.         F = H * DstW
  1285.         For B = 0 To newW
  1286.             I = F + B
  1287.             If (CLng(Data2(I).rgbRed) + 256& * Data2(I).rgbGreen + 65536 * Data2(I).rgbBlue) <> TransColor Then
  1288.             With Data1(I)
  1289.                 If BrushColor > -1 Then
  1290.                     If MonoMask Then
  1291.                         If (CLng(Data2(I).rgbRed) + Data2(I).rgbGreen + Data2(I).rgbBlue) <= 384 Then Data1(I) = BrushRGB
  1292.                     Else
  1293.                         Data1(I) = BrushRGB
  1294.                     End If
  1295.                 Else
  1296.                     If isGreyscale Then
  1297.                         gCol = CLng(Data2(I).rgbRed * 0.3) + Data2(I).rgbGreen * 0.59 + Data2(I).rgbBlue * 0.11
  1298.                         .rgbRed = gCol: .rgbGreen = gCol: .rgbBlue = gCol
  1299.                     Else
  1300.                         If XPBlend Then
  1301.                             .rgbRed = (CLng(.rgbRed) + Data2(I).rgbRed * 2) \ 3
  1302.                             .rgbGreen = (CLng(.rgbGreen) + Data2(I).rgbGreen * 2) \ 3
  1303.                             .rgbBlue = (CLng(.rgbBlue) + Data2(I).rgbBlue * 2) \ 3
  1304.                         Else
  1305.                             Data1(I) = Data2(I)
  1306.                         End If
  1307.                     End If
  1308.                 End If
  1309.             End With
  1310.             End If
  1311.         Next
  1312.     Next
  1313.  
  1314.     SetDIBitsToDevice DstDC, DstX, DstY, DstW, DstH, 0, 0, 0, DstH, Data1(0), Info, 0
  1315.  
  1316.     Erase Data1, Data2
  1317.     DeleteObject SelectObject(TmpDC, TmpObj)
  1318.     DeleteObject SelectObject(Sr2DC, Sr2Obj)
  1319.     If SrcPic.Type = 3 Then DeleteObject SelectObject(SrcDC, tObj)
  1320.     DeleteDC TmpDC: DeleteDC Sr2DC
  1321.     DeleteObject tObj: DeleteObject ttt: DeleteDC SrcDC
  1322. End Sub
  1323.  
  1324. Private Function isMouseOver() As Boolean
  1325.     On Error Resume Next
  1326.     Dim pt As POINTAPI
  1327.     GetCursorPos pt
  1328.     isMouseOver = (WindowFromPoint(pt.X, pt.Y) = hWnd)
  1329. End Function
  1330.