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