home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 53 / IOPROG_53.ISO / soft / vbasic / MyButton.ZIP / EllipticButton.ctl (.txt) next >
Encoding:
Visual Basic Form  |  1999-10-10  |  13.3 KB  |  361 lines
  1. VERSION 5.00
  2. Begin VB.UserControl CaptionButton 
  3.    ClientHeight    =   744
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   1344
  7.    ScaleHeight     =   744
  8.    ScaleWidth      =   1344
  9.    ToolboxBitmap   =   "ELLIPT~1.ctx":0000
  10.    Begin VB.CommandButton Command1 
  11.       Caption         =   "Button"
  12.       Height          =   732
  13.       Left            =   0
  14.       Style           =   1  'Graphical
  15.       TabIndex        =   0
  16.       Top             =   0
  17.       Width           =   1332
  18.    End
  19. Attribute VB_Name = "CaptionButton"
  20. Attribute VB_GlobalNameSpace = False
  21. Attribute VB_Creatable = True
  22. Attribute VB_PredeclaredId = False
  23. Attribute VB_Exposed = True
  24. Dim CaptionColorVar As OLE_COLOR
  25. Private colButtons As New Collection
  26. Private Const KeyConst = "K"
  27. Private Const FormName = "ThunderFormDC"
  28. Private Const PROP_COLOR = "SMDColor"
  29. Private Const PROP_HWNDPARENT = "SMDhWndParent"
  30. Private Const PROP_LPWNDPROC = "SMDlpWndProc"
  31. Private Const GWL_WNDPROC = -4
  32. Private Const ODA_SELECT = &H2
  33. Private Const ODS_SELECTED = &H1
  34. Private Const ODS_FOCUS = &H10
  35. Private Const ODS_BUTTONDOWN = ODS_FOCUS + ODS_SELECTED
  36. Private Const WM_DESTROY = &H2
  37. Private Const WM_DRAWITEM = &H2B
  38. Private Type RECT
  39. Left As Long
  40. Top As Long
  41. Right As Long
  42. Bottom As Long
  43. End Type
  44. Private Type Size
  45. cx As Long
  46. cy As Long
  47. End Type
  48. Private Type DRAWITEMSTRUCT
  49. CtlType As Long
  50. CtlID As Long
  51. itemID As Long
  52. itemAction As Long
  53. itemState As Long
  54. hWndItem As Long
  55. hDC As Long
  56. rcItem As RECT
  57. itemData As Long
  58. End Type
  59. Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
  60. (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, _
  61. ByVal wParam As Long, lParam As DRAWITEMSTRUCT) As Long
  62. Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
  63. (ByVal hWnd As Long, ByVal lpClassName As String, _
  64. ByVal nMaxCount As Long) As Long
  65. Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
  66. Private Declare Function GetProp Lib "user32" Alias "GetPropA" _
  67. (ByVal hWnd As Long, ByVal lpString As String) As Long
  68. Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias _
  69. "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpSz As String, _
  70. ByVal cbString As Long, lpSize As Size) As Long
  71. Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
  72. (ByVal hWnd As Long, ByVal lpString As String) As Long
  73. Private Declare Function SetProp Lib "user32" Alias "SetPropA" _
  74. (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
  75. Private Declare Function SetTextColor Lib "gdi32" _
  76. (ByVal hDC As Long, ByVal crColor As Long) As Long
  77. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  78. (ByVal hWnd As Long, _
  79. ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  80. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  81. Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
  82. (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, _
  83. ByVal lpString As String, ByVal nCount As Long) As Long
  84. Private Function FindButton(sKey As String) As Boolean
  85. Dim cmdButton As CommandButton
  86. On Error Resume Next
  87. Set cmdButton = colButtons.Item(sKey)
  88. FindButton = (Err.Number = 0)
  89. End Function
  90. Private Function GetFormHandle(hWndButton As Long) As Long
  91. Dim hWndParent As Long
  92. Dim l As Long
  93. Dim ClassName As String * 128
  94. hWndParent = GetParent(hWndButton)
  95. Do Until (hWndParent = 0)
  96. l = GetClassName(hWndParent, ClassName, Len(ClassName))
  97. If Left(ClassName, l) = FormName Then Exit Do
  98. hWndParent = GetParent(hWndParent)
  99. GetFormHandle = hWndParent
  100. End Function
  101. Private Function GetKey(hWnd As Long) As String
  102. GetKey = KeyConst & hWnd
  103. End Function
  104. Private Function ProcessButton(ByVal hWnd As Long, _
  105. ByVal uMsg As Long, ByVal wParam As Long, _
  106. lParam As DRAWITEMSTRUCT, sKey As String) As Long
  107. Dim cmdButton As CommandButton
  108. Dim bRC As Boolean
  109. Dim lRC As Long
  110. Dim x As Long
  111. Dim y As Long
  112. Dim lpWndProc As Long
  113. Dim lButtonWidth As Long
  114. Dim lButtonHeight As Long
  115. Dim lPrevColor As Long
  116. Dim lColor As Long
  117. Dim TextSize As Size
  118. Dim sCaption As String
  119. Const PushOffset = 2
  120. Set cmdButton = colButtons.Item(sKey)
  121. sCaption = cmdButton.Caption
  122. lColor = GetProp(cmdButton.hWnd, PROP_COLOR)
  123. lPrevColor = SetTextColor(lParam.hDC, lColor)
  124. lRC = GetTextExtentPoint32(lParam.hDC, _
  125. sCaption, Len(sCaption), TextSize)
  126. lButtonHeight = lParam.rcItem.Bottom - lParam.rcItem.Top
  127. lButtonWidth = lParam.rcItem.Right - lParam.rcItem.Left
  128. If (lParam.itemAction = ODA_SELECT) And (lParam.itemState = ODS_BUTTONDOWN) Then
  129. cmdButton.SetFocus
  130. DoEvents
  131. x = (lButtonWidth - TextSize.cx + PushOffset) \ 2
  132. y = (lButtonHeight - TextSize.cy + PushOffset) \ 2
  133. x = (lButtonWidth - TextSize.cx) \ 2
  134. y = (lButtonHeight - TextSize.cy) \ 2
  135. End If
  136. lpWndProc = GetProp(hWnd, PROP_LPWNDPROC)
  137. ProcessButton = CallWindowProc(lpWndProc, hWnd, uMsg, wParam, lParam)
  138. bRC = TextOut(lParam.hDC, x, y, sCaption, Len(sCaption))
  139. lRC = SetTextColor(lParam.hDC, lPrevColor)
  140. ProcessButton_Exit:
  141. Set cmdButton = Nothing
  142. End Function
  143. Private Sub RemoveForm(hWndParent As Long)
  144. Dim hWndButton As Long
  145. Dim i As Integer
  146. UnsubclassForm hWndParent
  147. On Error GoTo RemoveForm_Exit
  148. For i = colButtons.Count - 1 To 0 Step -1
  149. hWndButton = colButtons(i).hWnd
  150. If GetProp(hWndButton, PROP_HWNDPARENT) = hWndParent Then
  151. RemoveProp hWndButton, PROP_COLOR
  152. RemoveProp hWndButton, PROP_HWNDPARENT
  153. colButtons.Remove i
  154. End If
  155. Next i
  156. RemoveForm_Exit:
  157. Exit Sub
  158. End Sub
  159. Private Function UnsubclassForm(hWnd As Long) As Boolean
  160. Dim lRC As Long
  161. Dim lpWndProc As Long
  162. lpWndProc = GetProp(hWnd, PROP_LPWNDPROC)
  163. If lpWndProc = 0 Then
  164. UnsubclassForm = False
  165. lRC = SetWindowLong(hWnd, GWL_WNDPROC, lpWndProc)
  166. RemoveProp hWnd, PROP_LPWNDPROC
  167. UnsubclassForm = True
  168. End If
  169. End Function
  170. Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, _
  171. ByVal wParam As Long, lParam As DRAWITEMSTRUCT) As Long
  172. Dim lpWndProc As Long
  173. Dim bProcessButton As Boolean
  174. Dim sButtonKey As String
  175. bProcessButton = False
  176. If (uMsg = WM_DRAWITEM) Then
  177. sButtonKey = GetKey(lParam.hWndItem)
  178. bProcessButton = FindButton(sButtonKey)
  179. End If
  180. If bProcessButton Then
  181. ProcessButton hWnd, uMsg, wParam, lParam, sButtonKey
  182. lpWndProc = GetProp(hWnd, PROP_LPWNDPROC)
  183. WindowProc = CallWindowProc(lpWndProc, hWnd, uMsg, wParam, lParam)
  184. If uMsg = WM_DESTROY Then RemoveForm hWnd
  185. End If
  186. End Function
  187. Private Function RegisterButton(Button As CommandButton, Forecolor As Long)
  188. Dim hWndParent As Long
  189. Dim lpWndProc As Long
  190. Dim sButtonKey As String
  191. sButtonKey = GetKey(Button.hWnd)
  192. If FindButton(sButtonKey) Then
  193. SetProp Button.hWnd, PROP_COLOR, Forecolor
  194. Button.Refresh
  195. hWndParent = GetFormHandle(Button.hWnd)
  196. If (hWndParent = 0) Then
  197. RegisterButton = False
  198. Exit Function
  199. End If
  200. colButtons.Add Button, sButtonKey
  201. SetProp Button.hWnd, PROP_COLOR, Forecolor
  202. SetProp Button.hWnd, PROP_HWNDPARENT, hWndParent
  203. lpWndProc = GetProp(hWndParent, PROP_LPWNDPROC)
  204. If (lpWndProc = 0) Then
  205. lpWndProc = SetWindowLong(hWndParent, _
  206. GWL_WNDPROC, AddressOf WindowProc)
  207. SetProp hWndParent, PROP_LPWNDPROC, lpWndProc
  208. End If
  209. End If
  210. RegisterButton = True
  211. End Function
  212. Private Function UnregisterButton(Button As CommandButton) As Boolean
  213. Dim hWndParent As Long
  214. Dim sKeyButton As String
  215. sKeyButton = GetKey(Button.hWnd)
  216. If (FindButton(sKeyButton) = False) Then
  217. UnregisterButton = False
  218. Exit Function
  219. End If
  220. hWndParent = GetProp(Button.hWnd, PROP_HWNDPARENT)
  221. UnregisterButton = UnsubclassForm(hWndParent)
  222. colButtons.Remove sKeyButton
  223. RemoveProp Button.hWnd, PROP_COLOR
  224. RemoveProp Button.hWnd, PROP_HWNDPARENT
  225. End Function
  226. Event Click()
  227. Event KeyDown(KeyCode As Integer, Shift As Integer)
  228. Event KeyPress(KeyAscii As Integer)
  229. Event KeyUp(KeyCode As Integer, Shift As Integer)
  230. Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  231. Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  232. Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  233. Dim Temp As String, Code As String, DataString As String
  234. Private Sub Command1_Click()
  235. RaiseEvent Click
  236. End Sub
  237. Public Sub AboutBox()
  238. Attribute AboutBox.VB_UserMemId = -552
  239. MsgBox "This Control Is FreeWare. If you got any questions or suggestions E-mail us to VBActiveX@hotmail.com" + Chr(13) + "Check For Updates and new controls at Go.To/VBHelp", , "About this control"
  240. End Sub
  241. Private Sub Command1_KeyDown(KeyCode As Integer, Shift As Integer)
  242. RaiseEvent KeyDown(KeyCode, Shift)
  243. End Sub
  244. Private Sub Command1_KeyPress(KeyAscii As Integer)
  245. RaiseEvent KeyPress(KeyAscii)
  246. End Sub
  247. Private Sub Command1_KeyUp(KeyCode As Integer, Shift As Integer)
  248. RaiseEvent KeyUp(KeyCode, Shift)
  249. End Sub
  250. Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  251. RaiseEvent MouseDown(Button, Shift, x, y)
  252. End Sub
  253. Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  254. RaiseEvent MouseMove(Button, Shift, x, y)
  255. End Sub
  256. Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  257. RaiseEvent MouseUp(Button, Shift, x, y)
  258. End Sub
  259. Private Sub UserControl_Initialize()
  260. CaptionColorVar = vbBlack
  261. End Sub
  262. Private Sub UserControl_Resize()
  263. Command1.Width = UserControl.Width
  264. Command1.Height = UserControl.Height
  265. End Sub
  266. Public Property Get BackColor() As OLE_COLOR
  267.     BackColor = Command1.BackColor
  268. End Property
  269. Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  270.     Command1.BackColor() = New_BackColor
  271.     PropertyChanged "BackColor"
  272. End Property
  273. Public Property Get CaptionColor() As OLE_COLOR
  274.     CaptionColor = CaptionColorVar
  275. End Property
  276. Public Property Let CaptionColor(ByVal New_CaptionColor As OLE_COLOR)
  277.     CaptionColorVar = New_CaptionColor
  278.     RegisterButton Command1, CaptionColorVar
  279.     PropertyChanged "CaptionColor"
  280. End Property
  281. Public Property Get Enabled() As Boolean
  282.     Enabled = Command1.Enabled
  283. End Property
  284. Public Property Let Enabled(ByVal New_Enabled As Boolean)
  285.     Command1.Enabled() = New_Enabled
  286.     PropertyChanged "Enabled"
  287. End Property
  288. Public Property Get Font() As Font
  289.     Set Font = Command1.Font
  290. End Property
  291. Public Property Set Picture(ByVal New_Picture As Picture)
  292.     Set Command1.Picture = New_Picture
  293.     PropertyChanged "Picture"
  294. End Property
  295. Public Property Set DisabledPicture(ByVal New_DisabledPicture As Picture)
  296.     Set Command1.DisabledPicture = New_DisabledPicture
  297.     PropertyChanged "DisabledPicture"
  298. End Property
  299. Public Property Get Picture() As Picture
  300.      Set Picture = Command1.Picture
  301. End Property
  302. Public Property Get DisabledPicture() As Picture
  303.      Set DisabledPicture = Command1.DisabledPicture
  304. End Property
  305. Public Property Set Font(ByVal New_Font As Font)
  306.     Set Command1.Font = New_Font
  307.     PropertyChanged "Font"
  308. End Property
  309. Public Property Get DownPicture() As Picture
  310.      Set DownPicture = Command1.DownPicture
  311. End Property
  312. Public Property Set DownPicture(ByVal New_DownPicture As Picture)
  313.     Set Command1.DownPicture = New_DownPicture
  314.     PropertyChanged "DownPicture"
  315. End Property
  316. Public Property Get MousePointer() As MousePointerConstants
  317.     MousePointer = Command1.MousePointer
  318. End Property
  319. Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
  320.     Command1.MousePointer() = New_MousePointer
  321.     PropertyChanged "MousePointer"
  322. End Property
  323. Public Property Get MouseIcon() As Picture
  324.     Set MouseIcon = Command1.MouseIcon
  325. End Property
  326. Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
  327.     Set Command1.MouseIcon() = New_MouseIcon
  328.     PropertyChanged "MouseIcon"
  329. End Property
  330. Public Property Get Caption() As String
  331.     Caption = Command1.Caption
  332. End Property
  333. Public Property Let Caption(ByVal New_Caption As String)
  334.     Command1.Caption() = New_Caption
  335.     PropertyChanged "Caption"
  336. End Property
  337. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  338.     Command1.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
  339.     CaptionColorVar = PropBag.ReadProperty("CaptionColor", &H80000012)
  340.     Command1.Enabled = PropBag.ReadProperty("Enabled", True)
  341.     Set Font = PropBag.ReadProperty("Font", Ambient.Font)
  342.     Set Picture = PropBag.ReadProperty("Picture", "")
  343.     Set DisabledPicture = PropBag.ReadProperty("DisabledPicture", "")
  344.     Set DownPicture = PropBag.ReadProperty("DownPicture", "")
  345.     Command1.MousePointer = PropBag.ReadProperty("MousePointer", 0)
  346.     Set MouseIcon = PropBag.ReadProperty("MouseIcon", "")
  347.     Command1.Caption = PropBag.ReadProperty("Caption", "Button")
  348. End Sub
  349. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  350.     Call PropBag.WriteProperty("BackColor", Command1.BackColor, &H8000000F)
  351.     Call PropBag.WriteProperty("CaptionColor", CaptionColorVar, &H80000012)
  352.     Call PropBag.WriteProperty("Enabled", Command1.Enabled, True)
  353.     Call PropBag.WriteProperty("Font", Font, Ambient.Font)
  354.     Call PropBag.WriteProperty("Picture", Picture, "")
  355.     Call PropBag.WriteProperty("DisabledPicture", DisabledPicture, "")
  356.     Call PropBag.WriteProperty("DownPicture", DownPicture, "")
  357.     Call PropBag.WriteProperty("MousePointer", Command1.MousePointer, 0)
  358.     Call PropBag.WriteProperty("MouseIcon", Command1.MouseIcon, "")
  359.     Call PropBag.WriteProperty("Caption", Command1.Caption, "Button")
  360. End Sub
  361.