home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Visual Database / Visual BASIC 5.0 (Ent. Edition) / Vb5ent Extractor.EXE / VB / SAMPLES / COMPTOOL / ACTVCOMP / CTLPLUS / CPSHAPEL.CTL next >
Encoding:
Text File  |  1996-11-26  |  17.9 KB  |  454 lines
  1. VERSION 5.00
  2. Begin VB.UserControl ShapeLabel 
  3.    BackStyle       =   0  'Transparent
  4.    ClientHeight    =   1575
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   2820
  8.    ClipControls    =   0   'False
  9.    ForwardFocus    =   -1  'True
  10.    PropertyPages   =   "CPShapeL.ctx":0000
  11.    ScaleHeight     =   1575
  12.    ScaleWidth      =   2820
  13.    Begin VB.Label lblCaption 
  14.       Alignment       =   2  'Center
  15.       AutoSize        =   -1  'True
  16.       BackStyle       =   0  'Transparent
  17.       Caption         =   "Caption"
  18.       Height          =   195
  19.       Left            =   840
  20.       TabIndex        =   0
  21.       Top             =   360
  22.       Width           =   555
  23.    End
  24.    Begin VB.Shape shpBack 
  25.       BorderStyle     =   0  'Transparent
  26.       FillColor       =   &H000000FF&
  27.       FillStyle       =   0  'Solid
  28.       Height          =   735
  29.       Left            =   600
  30.       Shape           =   2  'Oval
  31.       Top             =   360
  32.       Width           =   1575
  33.    End
  34. End
  35. Attribute VB_Name = "ShapeLabel"
  36. Attribute VB_GlobalNameSpace = False
  37. Attribute VB_Creatable = True
  38. Attribute VB_PredeclaredId = False
  39. Attribute VB_Exposed = True
  40. Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
  41. Option Explicit
  42. ' ShapeLabel Notes:
  43. '
  44. ' 1) Nearly all of this code was generated
  45. '    by the ActiveX Control Interface
  46. '    Wizard.  Where code has been added or
  47. '    modified manually, it is commented.
  48. ' 2) The UserControl's ForwardFocus property
  49. '    was set to True, to make focus work as
  50. '    it does for ordinary Label controls.
  51. ' 3)
  52. '
  53.  
  54. Const RESIZE_AdjustX As Single = 0.07
  55. Const RESIZE_AdjustY As Single = 0.03
  56.  
  57. ' Storage for property values.  (Most property
  58. '   values for ShapeLabel are stored in properties
  59. '   of the UserControl or its constituent controls.)
  60. Private m_Alignment As AlignmentConstants
  61.  
  62. 'Event Declarations:
  63. Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
  64. Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
  65. Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
  66. Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
  67. Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
  68. Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
  69. Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
  70. Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
  71. Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
  72.  
  73. ' The BackColor property was manually remapped
  74. '   to the Shape control's FillColor property,
  75. '   because that's what fills in the shape
  76. '   that appears as ShapeLabel's background.
  77. '
  78. Public Property Get BackColor() As OLE_COLOR
  79. Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
  80.     BackColor = shpBack.FillColor
  81. End Property
  82.  
  83. Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  84.     shpBack.FillColor() = New_BackColor
  85.     PropertyChanged "BackColor"
  86. End Property
  87.  
  88. ' ForeColor is mapped to the Label control's
  89. '   ForeColor, because ShapeLabel's ForeColor
  90. '   should control the font color.  The Label
  91. '   control's background is Transparent, so
  92. '   the BackColor doesn't matter.
  93. '
  94. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  95. 'MappingInfo=lblCaption,lblCaption,-1,ForeColor
  96. Public Property Get ForeColor() As OLE_COLOR
  97. Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
  98.     ForeColor = lblCaption.ForeColor
  99. End Property
  100.  
  101. Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
  102.     lblCaption.ForeColor() = New_ForeColor
  103.     PropertyChanged "ForeColor"
  104. End Property
  105.  
  106. ' To work the same way other controls' Enabled
  107. '   properties do, Enabled must have the correct
  108. '   Procedure ID.  The Interface Wizard doesn't
  109. '   set this; it must be done manually.  Use
  110. '   the Property Attributes dialog, accessed
  111. '   from the Tools menu, to set Procedure ID
  112. '   to Enabled for the Enabled property.  The
  113. '   Procedure ID box is on the Advanced section
  114. '   of the dialog.  Select Enabled in the Name
  115. '   box to view attributes for the Enabled
  116. '   property.
  117. '
  118. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  119. 'MappingInfo=UserControl,UserControl,-1,Enabled
  120. Public Property Get Enabled() As Boolean
  121. Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
  122. Attribute Enabled.VB_UserMemId = -514
  123.     Enabled = UserControl.Enabled
  124. End Property
  125.  
  126. Public Property Let Enabled(ByVal New_Enabled As Boolean)
  127.     UserControl.Enabled() = New_Enabled
  128.     PropertyChanged "Enabled"
  129. End Property
  130.  
  131. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  132. 'MappingInfo=lblCaption,lblCaption,-1,Font
  133. Public Property Get Font() As Font
  134. Attribute Font.VB_Description = "Returns a Font object."
  135. Attribute Font.VB_UserMemId = -512
  136.     Set Font = lblCaption.Font
  137. End Property
  138.  
  139. Public Property Set Font(ByVal New_Font As Font)
  140.     Set lblCaption.Font = New_Font
  141.     PropertyChanged "Font"
  142.     ' Manually added: Changing the font
  143.     '   may require adjusting the position
  144.     '   of the Label control.
  145.     Call UserControl_Resize
  146. End Property
  147.  
  148. ' Manually added property type BorderStyleConstants.
  149. '
  150. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  151. 'MappingInfo=shpBack,shpBack,-1,BorderStyle
  152. Public Property Get BorderStyle() As BorderStyleConstants
  153. Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
  154.     BorderStyle = shpBack.BorderStyle
  155. End Property
  156. Public Property Let BorderStyle(ByVal New_BorderStyle As BorderStyleConstants)
  157.     ' Validation supplied by shpBack.
  158.     shpBack.BorderStyle() = New_BorderStyle
  159.     PropertyChanged "BorderStyle"
  160. End Property
  161.  
  162. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  163. 'MappingInfo=UserControl,UserControl,-1,Refresh
  164. Public Sub Refresh()
  165. Attribute Refresh.VB_Description = "Forces a complete repaint of a object."
  166.     UserControl.Refresh
  167. End Sub
  168.  
  169. ' This is an example of double mapping.
  170. '   In order for ShapeLabel's Click event
  171. '   to work properly, it must be raised
  172. '   when the user clicks on the label, as
  173. '   well as when she clicks on the body
  174. '   of the control.  The Interface Wizard
  175. '   doesn't generate code for double
  176. '   mapping.
  177. Private Sub lblCaption_Click()
  178.     RaiseEvent Click
  179. End Sub
  180. Private Sub UserControl_Click()
  181.     RaiseEvent Click
  182. End Sub
  183.  
  184. ' Manually added mapping for Label's
  185. '   DblClick event.
  186. Private Sub lblCaption_DblClick()
  187.     RaiseEvent DblClick
  188. End Sub
  189. Private Sub UserControl_DblClick()
  190.     RaiseEvent DblClick
  191. End Sub
  192.  
  193. ' Manually added mapping for Label's
  194. '   MouseDown event.
  195. Private Sub lblCaption_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  196.     ' See comment in lblCaption_MouseMove.
  197.     RaiseEvent MouseDown(Button, Shift, _
  198.         ScaleX(X + lblCaption.Left, vbTwips, vbContainerPosition), _
  199.         ScaleY(Y + lblCaption.Height, vbTwips, vbContainerPosition))
  200. End Sub
  201. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  202.     ' See comment in UserConrol_MouseMove.
  203.     RaiseEvent MouseDown(Button, Shift, _
  204.         ScaleX(X, vbTwips, vbContainerPosition), _
  205.         ScaleY(Y, vbTwips, vbContainerPosition))
  206. End Sub
  207.  
  208. ' Manually added mapping for Label's
  209. '   MouseMove event.
  210. Private Sub lblCaption_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  211.     ' The mouse position (X, Y) must be translated
  212.     '   into the container's coordinates.  Since
  213.     '   it's relative to the Label, it must first
  214.     '   be translated into UserControl coordinates,
  215.     '   by adding lblCaption.Top and .Left.  (These
  216.     '   can be added because the ScaleMode of the
  217.     '   UserControl is Twips, the same as the
  218.     '   coordinates of the Label.  If this were not
  219.     '   so, another conversion would be required.)
  220.     '
  221.     RaiseEvent MouseMove(Button, Shift, _
  222.         ScaleX(X + lblCaption.Left, vbTwips, vbContainerPosition), _
  223.         ScaleY(Y + lblCaption.Height, vbTwips, vbContainerPosition))
  224. End Sub
  225. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  226.     ' The mouse position (X, Y) must be translated
  227.     '   into the container's coordinates (which
  228.     '   might, for example, be pixels).
  229.     '
  230.     ' Note that we could make this more general by
  231.     '   replacing vbTwips with UserControl.ScaleMode.
  232.     '   That way it would always work, even if we
  233.     '   later changed the ScaleMode.  However, this
  234.     '   would mean two method calls instead of two
  235.     '   constants.  On the theory that MouseMove
  236.     '   should be as fast as possible, vbTwips is
  237.     '   used here instead.  (Of course, if you change
  238.     '   the ScaleMode at run time, then you must use
  239.     '   UserControl.ScaleMode instead of vbTwips!)
  240.     '
  241.     RaiseEvent MouseMove(Button, Shift, _
  242.         ScaleX(X, vbTwips, vbContainerPosition), _
  243.         ScaleY(Y, vbTwips, vbContainerPosition))
  244. End Sub
  245.  
  246. ' Manually added mapping for Label's
  247. '   MouseUp event.
  248. Private Sub lblCaption_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  249.     ' See comment in lblCaption_MouseMove.
  250.     RaiseEvent MouseUp(Button, Shift, _
  251.         ScaleX(X + lblCaption.Left, vbTwips, vbContainerPosition), _
  252.         ScaleY(Y + lblCaption.Height, vbTwips, vbContainerPosition))
  253. End Sub
  254. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  255.     ' See comment in UserControl_MouseMove.
  256.     RaiseEvent MouseUp(Button, Shift, _
  257.         ScaleX(X, vbTwips, vbContainerPosition), _
  258.         ScaleY(Y, vbTwips, vbContainerPosition))
  259. End Sub
  260.  
  261. ' Manually added property type AlignmentConstants.
  262. '
  263. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  264. 'MappingInfo=lblCaption,lblCaption,-1,Alignment
  265. Public Property Get Alignment() As AlignmentConstants
  266. Attribute Alignment.VB_Description = "Returns/sets the alignment of a CheckBox or OptionButton, or a control's text."
  267.     Alignment = m_Alignment
  268. End Property
  269.  
  270. Public Property Let Alignment(ByVal New_Alignment As AlignmentConstants)
  271.     ' Alignment isn't stored in a constituent
  272.     '   control property, so we have to supply
  273.     '   our own validation code.
  274.     Select Case New_Alignment
  275.         Case vbCenter
  276.         Case vbLeftJustify
  277.         Case vbRightJustify
  278.         Case Else
  279.             ' Invalid Property Value
  280.             Err.Raise 380
  281.     ' If you break here while running ShapeLabel,
  282.     '   right-click in the code window, select
  283.     '   Toggle from the context menu, and then
  284.     '   select Break on Unhandled Errors.  You
  285.     '   can then press F5 to continue running
  286.     '   the demo.
  287.     End Select
  288.     m_Alignment = New_Alignment
  289.     PropertyChanged "Alignment"
  290.     ' Changing alignment can affect positions
  291.     '   of constituent controls.
  292.     Call UserControl_Resize
  293. End Property
  294.  
  295. ' Property type (OLE_COLOR) for BorderColor
  296. '   had to be added manually.
  297. '
  298. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  299. 'MappingInfo=shpBack,shpBack,-1,BorderColor
  300. Public Property Get BorderColor() As OLE_COLOR
  301. Attribute BorderColor.VB_Description = "Returns/sets the color of an object's border."
  302.     BorderColor = shpBack.BorderColor
  303. End Property
  304.  
  305. Public Property Let BorderColor(ByVal New_BorderColor As OLE_COLOR)
  306.     shpBack.BorderColor() = New_BorderColor
  307.     PropertyChanged "BorderColor"
  308. End Property
  309.  
  310. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  311. 'MappingInfo=shpBack,shpBack,-1,BorderWidth
  312. Public Property Get BorderWidth() As Integer
  313. Attribute BorderWidth.VB_Description = "Returns or sets the width of a control's border."
  314.     BorderWidth = shpBack.BorderWidth
  315. End Property
  316.  
  317. Public Property Let BorderWidth(ByVal New_BorderWidth As Integer)
  318.     shpBack.BorderWidth() = New_BorderWidth
  319.     PropertyChanged "BorderWidth"
  320. End Property
  321.  
  322. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  323. 'MappingInfo=lblCaption,lblCaption,-1,Caption
  324. Public Property Get Caption() As String
  325. Attribute Caption.VB_Description = "Returns/sets the text displayed in an object's title bar or below an object's icon."
  326.     Caption = lblCaption.Caption
  327. End Property
  328.  
  329. Public Property Let Caption(ByVal New_Caption As String)
  330.     lblCaption.Caption() = New_Caption
  331.     PropertyChanged "Caption"
  332.     ' Manually added: Changing the caption
  333.     '   may require adjusting the position
  334.     '   of the Label control.
  335.     Call UserControl_Resize
  336. End Property
  337.  
  338. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  339. 'MappingInfo=UserControl,UserControl,-1,hDC
  340. Public Property Get hDC() As Long
  341. Attribute hDC.VB_Description = "Returns a handle (from Microsoft Windows) to the object's device context."
  342.     hDC = UserControl.hDC
  343. End Property
  344.  
  345. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  346. 'MappingInfo=UserControl,UserControl,-1,hWnd
  347. Public Property Get hWnd() As Long
  348. Attribute hWnd.VB_Description = "Returns a handle (from Microsoft Windows) to an object's window."
  349.     hWnd = UserControl.hWnd
  350. End Property
  351.  
  352. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  353. 'MappingInfo=UserControl,UserControl,-1,MouseIcon
  354. Public Property Get MouseIcon() As Picture
  355. Attribute MouseIcon.VB_Description = "Sets a custom mouse icon."
  356.     Set MouseIcon = UserControl.MouseIcon
  357. End Property
  358.  
  359. Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
  360.     Set UserControl.MouseIcon = New_MouseIcon
  361.     PropertyChanged "MouseIcon"
  362. End Property
  363.  
  364. ' Manually added property type MousePointerConstants.
  365. '
  366. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  367. 'MappingInfo=UserControl,UserControl,-1,MousePointer
  368. Public Property Get MousePointer() As MousePointerConstants
  369. Attribute MousePointer.VB_Description = "Returns/sets the type of mouse pointer displayed when over part of an object."
  370.     MousePointer = UserControl.MousePointer
  371. End Property
  372.  
  373. Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
  374.     ' Validation is supplied by UserControl.
  375.     UserControl.MousePointer() = New_MousePointer
  376.     PropertyChanged "MousePointer"
  377. End Property
  378.  
  379. ' Manually added property type ShapeConstants.
  380. '
  381. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  382. 'MappingInfo=shpBack,shpBack,-1,Shape
  383. Public Property Get Shape() As ShapeConstants
  384. Attribute Shape.VB_Description = "Returns/sets a value indicating the appearance of a control."
  385.     Shape = shpBack.Shape
  386. End Property
  387.  
  388. Public Property Let Shape(ByVal New_Shape As ShapeConstants)
  389.     ' Validation is provided by shpBack.
  390.     shpBack.Shape() = New_Shape
  391.     PropertyChanged "Shape"
  392. End Property
  393.  
  394. 'Load property values from storage
  395. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  396.  
  397.     shpBack.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
  398.     lblCaption.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
  399.     UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
  400.     Set Font = PropBag.ReadProperty("Font", Ambient.Font)
  401.     shpBack.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
  402.     m_Alignment = PropBag.ReadProperty("Alignment", 2)
  403.     shpBack.BorderColor = PropBag.ReadProperty("BorderColor", -2147483640)
  404.     shpBack.BorderWidth = PropBag.ReadProperty("BorderWidth", 1)
  405.     lblCaption.Caption = PropBag.ReadProperty("Caption", "Caption")
  406.     Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
  407.     UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0)
  408.     shpBack.Shape = PropBag.ReadProperty("Shape", 2)
  409. End Sub
  410.  
  411. Private Sub UserControl_Resize()
  412.     Dim sngCaptionTop As Single
  413.     Dim sngCaptionLeft As Single
  414.     
  415.     ' The Shape control that provides the
  416.     '   background for ShapeLabel is resized
  417.     '   to cover the whole control.
  418.     shpBack.Move 0, 0, ScaleWidth, ScaleHeight
  419.     ' The Label control that displays ShapeLabel's
  420.     '   caption is placed according to the value
  421.     '   of the Alignment property.
  422.     Select Case Alignment
  423.         Case vbCenter
  424.             sngCaptionLeft = (ScaleWidth - lblCaption.Width) / 2
  425.         Case vbLeftJustify
  426.             sngCaptionLeft = RESIZE_AdjustX * ScaleWidth
  427.         Case vbRightJustify
  428.             sngCaptionLeft = ScaleWidth - lblCaption.Width - RESIZE_AdjustX * ScaleWidth
  429.     End Select
  430.     ' A VerticalAlignment property would
  431.     '   work similarly; it would require
  432.     '   its own Enum.
  433.     sngCaptionTop = (ScaleHeight - lblCaption.Height) / 2 - RESIZE_AdjustY * ScaleHeight
  434.     '
  435.     lblCaption.Move sngCaptionLeft, sngCaptionTop
  436. End Sub
  437.  
  438. 'Write property values to storage
  439. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  440.     Call PropBag.WriteProperty("BackColor", shpBack.BackColor, &H80000005)
  441.     Call PropBag.WriteProperty("ForeColor", lblCaption.ForeColor, &H80000012)
  442.     Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
  443.     Call PropBag.WriteProperty("Font", Font, Ambient.Font)
  444.     Call PropBag.WriteProperty("BorderStyle", shpBack.BorderStyle, 0)
  445.     Call PropBag.WriteProperty("Alignment", m_Alignment, 2)
  446.     Call PropBag.WriteProperty("BorderColor", shpBack.BorderColor, -2147483640)
  447.     Call PropBag.WriteProperty("BorderWidth", shpBack.BorderWidth, 1)
  448.     Call PropBag.WriteProperty("Caption", lblCaption.Caption, "Caption")
  449.     Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
  450.     Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0)
  451.     Call PropBag.WriteProperty("Shape", shpBack.Shape, 2)
  452. End Sub
  453.  
  454.