home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / TButton2147383222009.psc / cTButton.cls < prev    next >
Text File  |  2009-03-22  |  11KB  |  390 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cTButton"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' ======================================================================================
  17. ' Name:         TButton Class Creates a Title Bar Button
  18. '               cTbutton.cls
  19. ' Author:       Nitin Kohli (pulsatingstar20@yahoo.com)
  20. ' Date:         20 March 2009
  21. '
  22. ' Description:  Class Draws a button Image on a Forms Title Bar
  23. '               and raises Click ,DblClick Events when user clicks
  24. '               on button.
  25. '
  26. '                Set properties
  27. '                IconFilename    : 24x24 Icon Path&filename to draw button
  28. '                IconFilenameBG  : 24x24 Icon Path&filename to draw Background
  29. '                                  button Image to lighten , Hover ,Selected effects
  30. '                Edge            : Distance of button from forms right edge
  31. '       Finally  Hwnd            : Forms handle to Draw button & subclass form
  32. '
  33. '                ResourceID      : Instead of IconFilename/IconFilenameBG
  34. '                                : ID,ID+1 will work in executable only
  35.  
  36. ' Depedencies   vbAccelerator Image List
  37. '               http://www.vbaccelerator.com/home/VB/Code/Controls/ImageList/vbAccelerator_Image_List_Control/article.asp
  38. '               cVBALImageList.cls
  39.  
  40. '               vbAccelerator SSubTmr6
  41. '               http://www.vbaccelerator.com/home/VB/Code/Libraries/Subclassing/SSubTimer_ASM_Version/VB6_ASM_SSubTmr6_Binary.asp
  42. '               Download Dll File & Resister
  43.  
  44.  
  45. 'Further Suggestions
  46.  
  47. '           Multiple Instances can be used to draw multiple buttons
  48. '           Can be basis for multi button toolbar
  49.  
  50. '           Systemwide Hook can be used to place this on all windows
  51. '           to perform action for ur application
  52. '           'Music toolbar etc
  53. '
  54. '********** Votes will be encorage more postings *****************
  55. ' ======================================================================================
  56.  
  57.  
  58. Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  59. Private Type RECT
  60.     left As Long
  61.     tOp As Long
  62.     Right As Long
  63.     Bottom As Long
  64. End Type
  65.  
  66. Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
  67. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  68.  
  69.  
  70.  
  71. Private Type tagTRACKMOUSEEVENT
  72.     cbSize As Long
  73.     dwFlags As Long
  74.     hwndTrack As Long
  75.     dwHoverTime As Long
  76. End Type
  77.  
  78. Private Declare Function TRACKMOUSEEVENT Lib "user32" Alias "TrackMouseEvent" (ByRef lpEventTrack As tagTRACKMOUSEEVENT) As Long
  79.     Private Const TME_NONCLIENT = &H10
  80.     Private Const WM_NCMOUSELEAVE = &H2A2
  81.     Private Const WM_NCPAINT = &H85
  82.     Private Const WM_NCACTIVATE = &H86
  83.     Private Const WM_ACTIVATE = &H6
  84.     Private Const WM_NCMOUSEMOVE = &HA0
  85.     Private Const WM_NCLBUTTONDOWN = &HA1
  86.     Private Const WM_NCLBUTTONUP = &HA2
  87.     Private Const WM_NCLBUTTONDBLCLK = &HA3
  88.     Private Const WM_NCHITTEST = &H84
  89.     Private Const WM_DESTROY = &H2
  90.  
  91.  
  92.  
  93.  
  94. Dim mIml                As cVBALImageList
  95.  
  96. Dim mIconFileName       As String
  97. Dim mIconFileNameBG     As String
  98. Dim mResourceID         As Long
  99. Dim mHwnd               As Long
  100. Dim mEdge               As Long
  101. Dim mbTracking          As Boolean
  102.  
  103.  
  104. Public Event Click()
  105. Public Event DblClick()
  106.  
  107. Private m_emr As EMsgResponse
  108.  
  109.  
  110.  
  111. Implements ISubclass
  112.  
  113. Public Property Let IconFilename(RHS As String)
  114.     mIconFileName = RHS
  115. End Property
  116.  
  117. Public Property Get IconFilename() As String
  118.     IconFilename = mIconFileName
  119. End Property
  120. Public Property Let IconFilenameBG(RHS As String)
  121.     mIconFileNameBG = RHS
  122. End Property
  123.  
  124. Public Property Get IconFilenameBG() As String
  125.     IconFilenameBG = mIconFileNameBG
  126. End Property
  127. Public Property Let ResourceID(RHS As Long)
  128.     mResourceID = RHS
  129. End Property
  130. Public Property Get ResourceID() As Long
  131.     ResourceID = mResourceID
  132. End Property
  133. Public Property Let Edge(RHS As Long)
  134.     mEdge = RHS
  135. End Property
  136. Public Property Get Edge() As Long
  137.     Edge = mEdge
  138. End Property
  139.  
  140.  
  141. Public Property Let hwnd(RHS As Long)
  142.     mHwnd = RHS
  143.     
  144.     With mIml
  145.         If ResourceID <> 0 Then
  146.             .AddFromResourceID mResourceID, App.hInstance, IMAGE_ICON, 1
  147.             .AddFromResourceID mResourceID + 1, App.hInstance, IMAGE_ICON, 2
  148.         Else
  149.             .AddFromFile IconFilename, IMAGE_ICON, 1
  150.             .AddFromFile IconFilenameBG, IMAGE_ICON, 2
  151.         End If
  152.     
  153.         If .ImageCount >= 2 Then
  154.         
  155.             AttachMessage Me, hwnd, WM_ACTIVATE
  156.             AttachMessage Me, hwnd, WM_NCPAINT
  157.             AttachMessage Me, hwnd, WM_NCACTIVATE
  158.             AttachMessage Me, hwnd, WM_NCMOUSEMOVE
  159.             AttachMessage Me, hwnd, WM_NCMOUSELEAVE
  160.             AttachMessage Me, hwnd, WM_NCLBUTTONDOWN
  161.             AttachMessage Me, hwnd, WM_NCLBUTTONUP
  162.             AttachMessage Me, hwnd, WM_NCLBUTTONDBLCLK
  163.             AttachMessage Me, hwnd, WM_NCHITTEST
  164.             AttachMessage Me, hwnd, WM_DESTROY
  165.             
  166.         Else
  167.             Debug.Print "Insufficient Icon Information to draw Tbutton"
  168.         End If
  169.     End With
  170.     
  171.     
  172. End Property
  173. Public Property Get hwnd() As Long
  174.     hwnd = mHwnd
  175. End Property
  176.  
  177. Private Sub Class_Initialize()
  178.     Set mIml = New cVBALImageList
  179.     With mIml
  180.         .IconSizeX = 24
  181.         .IconSizeY = 24
  182.         .ColourDepth = ILC_COLOR32
  183.         .Create
  184.     End With
  185.    m_emr = emrPostProcess
  186. End Sub
  187.  
  188.  
  189.  
  190. Private Sub Class_Terminate()
  191.     mIml.Destroy
  192.     Set mIml = Nothing
  193. End Sub
  194.  
  195. Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse)
  196.     m_emr = RHS
  197. End Property
  198.  
  199. Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse
  200.         ISubclass_MsgResponse = m_emr
  201.         
  202. End Property
  203.  
  204.  
  205. Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  206.  
  207.     Static bUserMode As Boolean
  208.     Static bButtonHover        As Boolean 'Mouse Move over Button
  209.     Static bButtonDown         As Boolean 'Mouse Down over Button
  210.     
  211.     
  212.     
  213.     Select Case iMsg
  214.     
  215.     Case WM_NCACTIVATE, WM_NCPAINT, WM_ACTIVATE
  216.     
  217.         'When UserMode Flag Set
  218.         'Let original WndProc handle messages first
  219.         'We Never know what Class User Might do in Click event
  220.         
  221.         If bUserMode Then
  222.             m_emr = emrPostProcess
  223.         Else
  224.             m_emr = emrPreProcess
  225.         End If
  226.         DrawButton
  227.         
  228.     Case WM_NCMOUSEMOVE
  229.         m_emr = emrPostProcess
  230.         
  231.         If Not mbTracking Then TrackMouse
  232.         'Redraw Button to mark mouser over
  233.         If IsOverButton(lParam) Then
  234.             If Not bButtonHover Then
  235.                 DrawButton False, True
  236.                 bButtonHover = True
  237.             End If
  238.         Else
  239.             If bButtonHover Or bButtonDown Then
  240.                 DrawButton
  241.                 bButtonHover = False
  242.                 bButtonDown = False
  243.             End If
  244.         End If
  245.  
  246.         
  247.     Case WM_NCMOUSELEAVE
  248.         'Catch Leave to restore buttons Normal image
  249.         mbTracking = False
  250.         If bButtonHover Then
  251.             DrawButton
  252.             bButtonHover = False
  253.         End If
  254.         
  255.     Case WM_NCLBUTTONDOWN
  256.         'Mouse Down on button
  257.         If IsOverButton(lParam) Then
  258.             DrawButton True, False
  259.             
  260.             bButtonHover = False
  261.             bButtonDown = True
  262.         End If
  263.         
  264.         
  265.     Case WM_NCLBUTTONUP
  266.             'Never Recived Unless Window is maximise
  267.             'Bcoz of that COSTLY WM_NCHITTEST needs to be checked for button up
  268.             'Somebody has a better idea suggest or mail me
  269.             'pulsatingstar20@yahoo.com
  270.             m_emr = emrPostProcess
  271.     Case WM_NCHITTEST
  272.         m_emr = emrPostProcess
  273.         
  274.         If IsOverButton(lParam) And bButtonDown Then
  275.             bButtonDown = False
  276.             bUserMode = True
  277.             RaiseEvent Click
  278.             bUserMode = False
  279.             DrawButton
  280.         End If
  281.         
  282.     Case WM_NCLBUTTONDBLCLK
  283.     
  284.         If IsOverButton(lParam) Then
  285.             bUserMode = True
  286.             RaiseEvent DblClick
  287.             bUserMode = False
  288.             m_emr = emrConsume
  289.         Else
  290.             m_emr = emrPostProcess
  291.         End If
  292.     Case WM_DESTROY
  293.         Call Detach
  294.     End Select
  295.     
  296.     
  297.  
  298. End Function
  299.  
  300.  
  301. Public Sub DrawButton(Optional bSelected As Boolean, Optional bCut As Boolean)
  302.     Dim lDc         As Long
  303.     Dim rec         As RECT
  304.     
  305.     lDc = GetWindowDC(hwnd)
  306.     
  307.     GetWindowRect hwnd, rec
  308.     
  309.     With rec
  310.         mIml.DrawImage 2, lDc, (.Right - .left) - Edge, 4, bSelected, bCut
  311.         mIml.DrawImage 1, lDc, (.Right - .left) - Edge, 4, bSelected, bCut
  312.     End With
  313.     
  314.     ReleaseDC hwnd, lDc
  315.     
  316. End Sub
  317.  
  318.  
  319. Private Function IsOverButton(ByVal lPos As Long)
  320.     ' Determine if the specified Coords are within our custom button
  321.  
  322.     Dim xPos As Long, ypos As Long
  323.     Dim ActiveRec As RECT
  324.     
  325.     GetWindowRect hwnd, ActiveRec
  326.     
  327.     With ActiveRec
  328.     
  329.         xPos = LoWord(lPos)
  330.         ypos = HiWord(lPos)
  331.         
  332.         .left = .Right - Edge
  333.         .Right = .left + 24
  334.         .Bottom = .tOp + 24
  335.         IsOverButton = xPos > .left And xPos < .Right And ypos > .tOp And ypos < .Bottom
  336.     End With
  337.     
  338.     
  339.     
  340.     
  341. End Function
  342.  
  343. Private Function TrackMouse()
  344.  
  345.     'Track needs to be activated to receive WM_NCMOUSELEAVE
  346.     '
  347.     
  348.     Dim trk As tagTRACKMOUSEEVENT
  349.      
  350.     mbTracking = True
  351.     
  352.     With trk
  353.         .cbSize = 16
  354.         .dwFlags = TME_NONCLIENT
  355.         .hwndTrack = hwnd
  356.     End With
  357.  
  358.     TRACKMOUSEEVENT trk
  359.     
  360.     
  361. End Function
  362.  
  363. Private Sub Detach()
  364.  
  365.     DetachMessage Me, hwnd, WM_ACTIVATE
  366.     DetachMessage Me, hwnd, WM_NCACTIVATE
  367.     DetachMessage Me, hwnd, WM_NCPAINT
  368.     DetachMessage Me, hwnd, WM_NCMOUSEMOVE
  369.     DetachMessage Me, hwnd, WM_NCMOUSELEAVE
  370.     DetachMessage Me, hwnd, WM_NCLBUTTONDOWN
  371.     DetachMessage Me, hwnd, WM_NCLBUTTONUP
  372.     DetachMessage Me, hwnd, WM_NCLBUTTONDBLCLK
  373.     DetachMessage Me, hwnd, WM_NCHITTEST
  374.     DetachMessage Me, hwnd, WM_DESTROY
  375.         
  376.  
  377. End Sub
  378. Private Property Get HiWord(ByRef lThis As Long) As Long
  379.    If (lThis And &H80000000) = &H80000000 Then
  380.       HiWord = ((lThis And &H7FFF0000) \ &H10000) Or &H8000&
  381.    Else
  382.       HiWord = (lThis And &HFFFF0000) \ &H10000
  383.    End If
  384. End Property
  385.  
  386. Private Property Get LoWord(ByRef lThis As Long) As Long
  387.    LoWord = (lThis And &HFFFF&)
  388. End Property
  389.  
  390.