home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / demos / VB_CCE / VB5CCEIN.EXE / AXButton.ctl < prev    next >
Encoding:
Text File  |  1997-01-11  |  19.9 KB  |  412 lines
  1. VERSION 5.00
  2. Begin VB.UserControl AXButtonCtl 
  3.    CanGetFocus     =   0   'False
  4.    ClientHeight    =   2610
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   3135
  8.    ClipControls    =   0   'False
  9.    ForwardFocus    =   -1  'True
  10.    LockControls    =   -1  'True
  11.    PropertyPages   =   "AXButton.ctx":0000
  12.    ScaleHeight     =   2610
  13.    ScaleWidth      =   3135
  14.    ToolboxBitmap   =   "AXButton.ctx":0004
  15.    Begin VB.Line lnRight 
  16.       BorderColor     =   &H00808080&
  17.       BorderWidth     =   2
  18.       Visible         =   0   'False
  19.       X1              =   3030
  20.       X2              =   3030
  21.       Y1              =   60
  22.       Y2              =   2520
  23.    End
  24.    Begin VB.Line lnBottom 
  25.       BorderColor     =   &H00808080&
  26.       BorderWidth     =   2
  27.       Visible         =   0   'False
  28.       X1              =   60
  29.       X2              =   3030
  30.       Y1              =   2520
  31.       Y2              =   2520
  32.    End
  33.    Begin VB.Line lnTop 
  34.       BorderColor     =   &H80000014&
  35.       BorderWidth     =   2
  36.       Visible         =   0   'False
  37.       X1              =   60
  38.       X2              =   2970
  39.       Y1              =   60
  40.       Y2              =   60
  41.    End
  42.    Begin VB.Line lnLeft 
  43.       BorderColor     =   &H80000014&
  44.       BorderWidth     =   2
  45.       Visible         =   0   'False
  46.       X1              =   60
  47.       X2              =   60
  48.       Y1              =   60
  49.       Y2              =   2490
  50.    End
  51. End
  52. Attribute VB_Name = "AXButtonCtl"
  53. Attribute VB_GlobalNameSpace = False
  54. Attribute VB_Creatable = True
  55. Attribute VB_PredeclaredId = False
  56. Attribute VB_Exposed = True
  57. Option Explicit
  58. '------------------------------------------------------------------
  59. ' API Declares...
  60. '------------------------------------------------------------------
  61. Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
  62. Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
  63. Private Declare Function ReleaseCapture Lib "user32" () As Long
  64.  
  65. '------------------------------------------------------------------
  66. ' Private Variables...
  67. '------------------------------------------------------------------
  68. Dim MouseDown As Boolean                        ' Flag - set when left button is pressed down
  69. Dim MouseOver As Boolean                        ' Flag - set when mouse pointer is over button
  70. Dim MouseCaptured As Boolean                    ' Flag - set when mouse pointer is captured by button control
  71. Dim ClearURLOnly As Boolean                     '
  72. Dim ClearPictureOnly As Boolean                 '
  73.  
  74. Dim StaticWidth As Long
  75. Dim StaticHeight As Long
  76. Dim gPicture As StdPicture                      ' Global picture property variable
  77. Dim gURLPicture As String                       ' Global URL picture property string variable
  78.  
  79. Const pPICTURE = "Picture"                      ' Picture property name constant
  80. Const pURLPICTURE = "URLPicture"                ' URLPicture property name constant
  81. Const Bdr = 10
  82. Const SND_ASYNC = &H1
  83. Const EVENT_MenuCommand = "MenuCommand"         ' Sound event name for button mousedown event
  84. Const EVENT_MenuPopup = "MenuPopup"             ' Sound event name for button enterover event
  85.  
  86. '------------------------------------------------------------------
  87. ' Private Enum...
  88. '------------------------------------------------------------------
  89. Enum ButtonState
  90.     Up = 0                                      ' Draw button raised up border
  91.     Down = 1                                    ' Draw button sunken down border
  92.     Flat = 2                                    ' Draw button flat - no border
  93. End Enum
  94.  
  95. '------------------------------------------------------------------
  96. ' Container Event Declarations:
  97. '------------------------------------------------------------------
  98. Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  99. Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  100. Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  101. Event Click()
  102.  
  103. '------------------------------------------------------------------
  104. Private Sub UserControl_Click()
  105. '------------------------------------------------------------------
  106.     RaiseEvent Click                            ' Dispatch click event to container.
  107. '------------------------------------------------------------------
  108. End Sub
  109. '------------------------------------------------------------------
  110.  
  111. '------------------------------------------------------------------
  112. Private Sub UserControl_Initialize()
  113. '------------------------------------------------------------------
  114.     StaticWidth = UserControl.Width             ' Get default button size
  115.     StaticHeight = UserControl.Height
  116. '------------------------------------------------------------------
  117. End Sub
  118. '------------------------------------------------------------------
  119.  
  120. '------------------------------------------------------------------
  121. Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
  122. '------------------------------------------------------------------
  123.     On Error GoTo ErrorHandler
  124.     
  125.     If (AsyncProp.PropertyName = pPICTURE) Then ' Picture download is complete
  126.         ClearPictureOnly = True
  127.         Set Picture = AsyncProp.Value           ' Store picture data to property...
  128.     End If
  129. '------------------------------------------------------------------
  130. ErrorHandler:
  131. '------------------------------------------------------------------
  132.     ClearPictureOnly = False
  133. '------------------------------------------------------------------
  134. End Sub
  135. '------------------------------------------------------------------
  136.  
  137. '------------------------------------------------------------------
  138. Private Sub UserControl_InitProperties()
  139. '------------------------------------------------------------------
  140.     SetButtonState Up                                   ' Draw button flat
  141. '------------------------------------------------------------------
  142. End Sub
  143. '------------------------------------------------------------------
  144.  
  145. '------------------------------------------------------------------
  146. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  147. '------------------------------------------------------------------
  148.     If ((Button And vbLeftButton) = vbLeftButton) Then  ' Only do if left mouse button was pressed
  149.         MouseDown = True                                ' Set MouseDown state flag
  150.         SetButtonState Down                             ' Draw button down
  151.         PlaySound EVENT_MenuCommand, 0, SND_ASYNC       ' Play event sound for mousedown...
  152.     End If
  153.     RaiseEvent MouseDown(Button, Shift, X, Y)           ' Dispatch mousedown event to container.
  154. '------------------------------------------------------------------
  155. End Sub
  156. '------------------------------------------------------------------
  157.  
  158. '------------------------------------------------------------------
  159. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  160. '------------------------------------------------------------------
  161.     If ((Button And vbLeftButton) = vbLeftButton) Then  ' Only do if left mouse button was pressed
  162.         MouseDown = False                               ' Clear MouseDown flag
  163.         SetButtonState Up                               ' Draw button up
  164.     End If
  165.     
  166.     MouseCaptured = True                                ' Reset MouseCaptured flag
  167.     SetCapture UserControl.hWnd                         ' ReCapture Mouse, Click seems to disable previous captures...
  168.     RaiseEvent MouseUp(Button, Shift, X, Y)             ' Dispatch mouseup event to container.
  169. '------------------------------------------------------------------
  170. End Sub
  171. '------------------------------------------------------------------
  172.  
  173. '------------------------------------------------------------------
  174. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  175. '------------------------------------------------------------------
  176.     With UserControl
  177.         ' Determine if mouse is currently moving over button.
  178.         MouseOver = (0 <= X) And (X <= .Width) And (0 <= Y) And (Y <= .Height)
  179.         
  180.         ' Determine if left mouse button is down
  181.         MouseDown = ((Button And vbLeftButton) = vbLeftButton)
  182.         
  183.         If MouseOver Then
  184.             If MouseDown Then
  185.                 SetButtonState Down                         ' Draw button down...
  186.             Else
  187.                 SetButtonState Up                           ' Draw button up
  188.             End If
  189.             If Not MouseCaptured Then                       ' Mouse captured
  190.                 PlaySound EVENT_MenuPopup, 0, SND_ASYNC     ' Play mouse move enter event sound
  191.                 SetCapture .hWnd                            ' Capture all mouse movements and send to UserControl
  192.                 MouseCaptured = True                        ' Set MouseCaptured flag
  193.             End If
  194.         Else
  195.             If MouseDown Then
  196.                 SetButtonState Up                           ' Draw button up
  197.             Else
  198.                 SetButtonState Flat                         ' Draw button flat
  199.                 If MouseCaptured Then
  200.                     ReleaseCapture                          ' Release outside capture of mouse button
  201.                     MouseCaptured = False                   ' Turn capture flag off...
  202.                 End If
  203.             End If
  204.         End If
  205.     End With
  206.     RaiseEvent MouseMove(Button, Shift, X, Y)               ' Dispatch mousemove event to container
  207. '------------------------------------------------------------------
  208. End Sub
  209. '------------------------------------------------------------------
  210.  
  211. '------------------------------------------------------------------
  212. Private Sub SetButtonState(State As ButtonState)
  213. '------------------------------------------------------------------
  214.     Select Case State                               ' Determine draw state
  215.     Case Up                                         ' Draw button up
  216.         lnTop.BorderColor = vb3DHighlight           ' Set appropriate color for lines...
  217.         lnLeft.BorderColor = vb3DHighlight
  218.         lnBottom.BorderColor = vb3DShadow
  219.         lnRight.BorderColor = vb3DShadow
  220.     Case Down                                       ' Draw button down
  221.         lnTop.BorderColor = vb3DShadow              ' Set appropriate color for lines...
  222.         lnLeft.BorderColor = vb3DShadow
  223.         lnBottom.BorderColor = vb3DHighlight
  224.         lnRight.BorderColor = vb3DHighlight
  225.     End Select
  226.     
  227.     lnBottom.Visible = (State <> Flat)              ' Show or Hide lines based on state of button
  228.     lnTop.Visible = (State <> Flat)
  229.     lnLeft.Visible = (State <> Flat)
  230.     lnRight.Visible = (State <> Flat)
  231. '------------------------------------------------------------------
  232. End Sub
  233. '------------------------------------------------------------------
  234.  
  235. '------------------------------------------------------------------
  236. Public Property Let URLPicture(ByVal Url As String)
  237. Attribute URLPicture.VB_ProcData.VB_Invoke_PropertyPut = ";Misc"
  238. '------------------------------------------------------------------
  239.     If (gURLPicture <> Url) Then                    ' Do only if value has changed...
  240.         ClearPictureOnly = Not ClearURLOnly         ' If Picture property is not being set by the URLPicture _
  241.                                                       property then clear the URLPicture value...
  242.         gURLPicture = Url                           ' Save url string value to global variable
  243.         PropertyChanged pURLPICTURE                 ' Notify property bag of property change
  244.             
  245.         If Not ClearURLOnly Then
  246.             On Error GoTo ErrorHandler              ' Handle Error if URL is unavailable or Invalid...
  247.             If (Url <> "") Then
  248.                 UserControl.AsyncRead Url, vbAsyncTypePicture, pPICTURE ' Begin async download of picture file...
  249.             Else
  250.                 Set Picture = Nothing
  251.             End If
  252.         End If
  253.     End If
  254. '------------------------------------------------------------------
  255. ErrorHandler:
  256. '------------------------------------------------------------------
  257.     ClearPictureOnly = False
  258. '------------------------------------------------------------------
  259. End Property
  260. '------------------------------------------------------------------
  261.  
  262. '------------------------------------------------------------------
  263. Public Property Get URLPicture() As String
  264. '------------------------------------------------------------------
  265.     URLPicture = gURLPicture                        ' Return URL string value
  266. '------------------------------------------------------------------
  267. End Property
  268. '------------------------------------------------------------------
  269.  
  270. '------------------------------------------------------------------
  271. Public Property Set Picture(ByVal Image As Picture)
  272. '------------------------------------------------------------------
  273.     If Not ClearPictureOnly Then
  274.         ClearURLOnly = True                         ' If Picture property is not being set by the URLPicture
  275.         URLPicture = ""                             ' property then clear the URLPicture value...
  276.         ClearURLOnly = False                        ' If Picture property is not being set by the URLPicture
  277.     End If
  278.     
  279.     If (Not Image Is Nothing) Then
  280.         If (Image.Handle = 0) Then Set Image = Nothing
  281.     End If
  282.     Set gPicture = Image                            ' Store image to global variable
  283.     
  284.     With UserControl
  285.         If Not Image Is Nothing Then                ' Check for Null picture value
  286.             StaticWidth = .ScaleX(gPicture.Width, vbHimetric, vbTwips)   ' Save size of bitmap
  287.             StaticHeight = .ScaleY(gPicture.Height, vbHimetric, vbTwips)
  288.         End If
  289.         .Cls                                        ' Clear previous picture image...
  290.     End With
  291.     
  292.     UserControl_Resize                              ' Resize button to fit image
  293.     UserControl_Paint                               ' Refresh image on button...
  294.     PropertyChanged pPICTURE                        ' Notify property bag of property change
  295. '------------------------------------------------------------------
  296. End Property
  297. '------------------------------------------------------------------
  298.  
  299. '------------------------------------------------------------------
  300. Public Property Get Picture() As Picture
  301. Attribute Picture.VB_ProcData.VB_Invoke_Property = "StandardPicture"
  302. '------------------------------------------------------------------
  303.     Set Picture = gPicture                          ' Return value of picture property
  304. '------------------------------------------------------------------
  305. End Property
  306. '------------------------------------------------------------------
  307.  
  308. '------------------------------------------------------------------
  309. Private Sub UserControl_Paint()
  310. '------------------------------------------------------------------
  311.     If (gPicture Is Nothing) Then Exit Sub          ' Don't draw if picture is invalid...
  312.     
  313.     ' Draw picture from property to usercontrol...
  314.     With UserControl
  315.         .PaintPicture gPicture, _
  316.                      .ScaleX(lnLeft.BorderWidth, vbTwips, vbHimetric), _
  317.                      .ScaleY(lnTop.BorderWidth, vbTwips, vbHimetric), _
  318.                      .ScaleX(.Width - (2 * lnLeft.BorderWidth), vbTwips, vbHimetric), _
  319.                      .ScaleY(.Height - (2 * lnTop.BorderWidth), vbTwips, vbHimetric), _
  320.                       0, _
  321.                       0, _
  322.                       gPicture.Width, _
  323.                       gPicture.Height
  324.     End With
  325. '------------------------------------------------------------------
  326. End Sub
  327. '------------------------------------------------------------------
  328.  
  329. '------------------------------------------------------------------
  330. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  331. '------------------------------------------------------------------
  332.     Dim Pic As StdPicture
  333.     Dim Url As String
  334. '------------------------------------------------------------------
  335.     On Error GoTo ErrorHandler                      ' Handler weird host problems
  336.     
  337.     If UserControl.Ambient.UserMode Then            ' Are we hosted in an IDE ???
  338.         SetButtonState Flat                         ' Draw button flat
  339.     Else
  340.         SetButtonState Up                           ' Draw button flat
  341.     End If
  342.     
  343.     ' Read in the properties that have been saved into the PropertyBag...
  344.     With PropBag
  345.         Url = .ReadProperty(pURLPICTURE, "")        ' Read URLPicture property value
  346.         If (Url <> "") Then                         ' If a URL has been entered...
  347.             URLPicture = Url                        ' Attempt to download it now, URL may be unavailable at this time
  348.         Else
  349.             Set Pic = .ReadProperty(pPICTURE, Nothing) ' Read Picture property value
  350.             If Not (Pic Is Nothing) Then            ' URL is not available
  351.                 Set Picture = Pic                   ' Use existing picture (This is used only if URL is empty)
  352.             End If
  353.         End If
  354.     End With
  355. '------------------------------------------------------------------
  356. ErrorHandler:
  357. '------------------------------------------------------------------
  358. ' Just quit nicely...
  359. '------------------------------------------------------------------
  360. End Sub
  361. '------------------------------------------------------------------
  362.  
  363. '------------------------------------------------------------------
  364. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  365. '------------------------------------------------------------------
  366.     On Error GoTo ErrorHandler                      ' Handler weird host problems
  367.     With PropBag
  368.         .WriteProperty pURLPICTURE, gURLPicture     ' Write URLPicture property to propertybag
  369.         .WriteProperty pPICTURE, gPicture           ' Write Picture property to propertybag
  370.     End With
  371. '------------------------------------------------------------------
  372. ErrorHandler:
  373. '------------------------------------------------------------------
  374. ' Just quit nicely...
  375. '------------------------------------------------------------------
  376. End Sub
  377. '------------------------------------------------------------------
  378.  
  379. '------------------------------------------------------------------
  380. Private Sub UserControl_Resize()
  381. '------------------------------------------------------------------
  382.     Dim W As Long, H As Long, L As Long, T As Long
  383. '------------------------------------------------------------------
  384.     L = 1                                           ' Set default left position
  385.     T = 1                                           ' Set default top position
  386.     With UserControl
  387.         If gPicture Is Nothing Then                 ' If picture is invalid valid
  388.             StaticWidth = .Width                    ' Update static width size
  389.             StaticHeight = .Height                  ' Update static height size
  390.         Else                                        ' Picture is valid...
  391.             .Width = StaticWidth                    ' Fix control size to picture width
  392.             .Height = StaticHeight                  ' ...
  393.         End If
  394.         W = .ScaleWidth - Bdr                       ' Calculate w position for lines
  395.         H = .ScaleHeight - Bdr                      ' Calculate h position for lines
  396.     End With
  397.     With lnLeft
  398.         .X1 = L:    .X2 = L:    .Y1 = T:    .Y2 = H  ' Move lines to new positions
  399.     End With
  400.     With lnRight
  401.         .X1 = W:    .X2 = W:    .Y1 = T:    .Y2 = H
  402.     End With
  403.     With lnTop
  404.         .X1 = L:    .X2 = W:    .Y1 = T:    .Y2 = T
  405.     End With
  406.     With lnBottom
  407.         .X1 = L:    .X2 = W:    .Y1 = H:    .Y2 = H
  408.     End With
  409. '------------------------------------------------------------------
  410. End Sub
  411. '------------------------------------------------------------------
  412.