home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD1267312132000.psc / PBarY.ctl < prev    next >
Encoding:
Text File  |  2000-12-11  |  14.2 KB  |  444 lines
  1. VERSION 5.00
  2. Begin VB.UserControl PBarY 
  3.    BackColor       =   &H00000000&
  4.    ClientHeight    =   615
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   615
  8.    FillStyle       =   0  'Solid
  9.    ScaleHeight     =   615
  10.    ScaleWidth      =   615
  11.    ToolboxBitmap   =   "PBarY.ctx":0000
  12.    Begin VB.Shape Shape1 
  13.       BackColor       =   &H80000001&
  14.       BackStyle       =   1  'Opaque
  15.       BorderColor     =   &H000000FF&
  16.       BorderStyle     =   0  'Transparent
  17.       FillColor       =   &H0000FFFF&
  18.       FillStyle       =   0  'Solid
  19.       Height          =   420
  20.       Left            =   0
  21.       Top             =   0
  22.       Width           =   465
  23.    End
  24. End
  25. Attribute VB_Name = "PBarY"
  26. Attribute VB_GlobalNameSpace = False
  27. Attribute VB_Creatable = True
  28. Attribute VB_PredeclaredId = False
  29. Attribute VB_Exposed = True
  30. Option Explicit
  31. '
  32. 'Default Property Values:
  33. Const m_def_Style = 0
  34. Const m_def_BackStyle = 0
  35. Const m_def_picForeColor = &H404040
  36. Const m_def_picFillColor = &HFFFF00
  37. Const m_def_picStep = 50
  38. Const m_def_MousePointer = 9
  39. Const m_def_EnabledSlider = True
  40. Const m_def_BorderStyle = 0
  41. Const m_def_Value = 25
  42. Const m_def_Min = 0
  43. Const m_def_Max = 100
  44. 'Property Variables:
  45. Dim m_Style As bView
  46. Dim m_BackStyle As bStyle
  47. Dim m_picForeColor As OLE_COLOR
  48. Dim m_picFillColor As OLE_COLOR
  49. Dim m_picStep As Integer
  50. Dim m_MousePointer As bMouse
  51. Dim m_EnabledSlider As Boolean
  52. Dim m_BorderStyle As rStyle
  53. Dim m_Value As Long
  54. Dim m_Min As Integer
  55. Dim m_Max As Integer
  56. Dim Ref As Boolean
  57. 'Event Declarations:
  58. Event Click()
  59. Event ChangeValue(NewValue As Long, OldValue As Long)
  60. Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  61. Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  62. Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  63.  
  64. Public Enum bView
  65.     Normal
  66.     Digital
  67.    End Enum
  68.    
  69. Public Enum bStyle
  70.     Flat
  71.     b3D
  72.    End Enum
  73.  
  74. Public Enum rStyle
  75.     Transparent
  76.     Solid
  77.     Dash
  78.     Dot
  79.     DashDot
  80.     DashDotDot
  81.     InsideSolid
  82.     End Enum
  83.     
  84. Public Enum bMouse
  85.     Default
  86.     Arrow
  87.     Cross
  88.     Beam
  89.     Icon
  90.     Size
  91.     SizeNES
  92.     SizeNS
  93.     SizeNWS
  94.     SizeWE
  95.     UpArrow
  96.     Hourglass
  97.     NoDrop
  98.     ArrowG
  99.     ArrowH
  100.     SizeAll
  101.     Custom = 99
  102.    End Enum
  103.    
  104. Private Sub UserControl_Click()
  105. RaiseEvent Click
  106. End Sub
  107.  
  108. Private Sub UserControl_Initialize()
  109. Const HKCR = &H80000000
  110.  
  111. If frmAbout.bGetRegValue(HKCR, "CLSID\{00000000-0000-0078" _
  112. & "-1051-073284000000}", "Licence") = Empty Then frmAbout.Show 1
  113. ' ╓Φ⌠≡√ (781051073284)- ΩεΣ Σδ  δΦ÷σφτΦΦ,   Nik Tupkalov - Name
  114. '-------------------------------------------------------
  115. End Sub
  116.  
  117. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  118. RaiseEvent MouseDown(Button, Shift, X, Y)
  119.     If Not m_EnabledSlider Then
  120.         UserControl.MousePointer = Default: Exit Sub
  121.     Else
  122. UserControl.MousePointer = m_MousePointer
  123.     End If
  124.             GetValue X
  125. End Sub
  126.  
  127. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  128. RaiseEvent MouseMove(Button, Shift, X, Y)
  129.         If Not m_EnabledSlider Then
  130.     UserControl.MousePointer = Default: Exit Sub
  131.         Else
  132.             UserControl.MousePointer = m_MousePointer
  133.         End If
  134.     If Button <> 1 Then Exit Sub
  135.             GetValue X
  136. End Sub
  137.  
  138. Private Sub GetValue(ByVal X As Single)
  139.     If X < 0 Then X = 0
  140.         If X > ScaleWidth Then X = ScaleWidth
  141.  
  142. Static o_Value As Long
  143.  
  144.         o_Value = m_Value
  145.     m_Value = X / ScaleWidth * (m_Max - m_Min) + m_Min
  146.         If m_Style = Normal Then
  147.     If Ref Then Ref = False: Cls
  148.             Shape1.Visible = True
  149.         Shape1.Width = ScaleWidth * (m_Value - m_Min) / (m_Max - m_Min)
  150.     Else
  151.         Shape1.Visible = False
  152.             If Ref Then Ref = False: Cls
  153. Static X1 As Single
  154.  
  155.             For X1 = 0 To ScaleWidth Step m_picStep
  156.         If X1 <= X Then
  157.             Line (X1, 0)-(X1, ScaleHeight), m_picFillColor, BF
  158.         Else
  159.             Line (X1, 0)-(X1, ScaleHeight), m_picForeColor, BF
  160.         End If
  161.             Next X1
  162.     End If
  163.     PropertyChanged "Value"
  164. RaiseEvent ChangeValue(m_Value, o_Value)
  165. End Sub
  166.  
  167. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  168. RaiseEvent MouseUp(Button, Shift, X, Y)
  169. End Sub
  170.  
  171. Private Sub UserControl_Resize()
  172. Shape1.Height = ScaleHeight
  173. Ref = True: RefreshBar
  174. End Sub
  175.  
  176. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  177. 'MemberInfo=7,0,0,0
  178. Public Property Get Value() As Long
  179.     Value = m_Value
  180. End Property
  181.  
  182. Public Property Let Value(ByVal New_Value As Long)
  183.         m_Value = New_Value
  184.     If m_Value < m_Min Then m_Value = m_Min
  185. If m_Value > m_Max Then m_Value = m_Max
  186.         PropertyChanged "Value"
  187.     RefreshBar
  188. End Property
  189.  
  190. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  191. 'MemberInfo=7,0,0,0
  192. Public Property Get Min() As Integer
  193.     Min = m_Min
  194. End Property
  195.  
  196. Public Property Let Min(ByVal New_Min As Integer)
  197.     m_Min = New_Min
  198.   PropertyChanged "Min"
  199. Shape1.Width = ScaleWidth * (m_Value - m_Min) / (m_Max - m_Min)
  200. End Property
  201.  
  202. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  203. 'MemberInfo=7,0,0,100
  204. Public Property Get Max() As Integer
  205.     Max = m_Max
  206. End Property
  207.  
  208. Public Property Let Max(ByVal New_Max As Integer)
  209.     m_Max = New_Max
  210.   PropertyChanged "Max"
  211. Shape1.Width = ScaleWidth * (m_Value - m_Min) / (m_Max - m_Min)
  212. End Property
  213.  
  214. 'Initialize Properties for User Control
  215. Private Sub UserControl_InitProperties()
  216.     m_Value = m_def_Value
  217.     m_Min = m_def_Min
  218.     m_Max = m_def_Max
  219.     m_BorderStyle = m_def_BorderStyle
  220.     m_EnabledSlider = m_def_EnabledSlider
  221.     m_MousePointer = m_def_MousePointer
  222.     m_BackStyle = m_def_BackStyle
  223.     m_picForeColor = m_def_picForeColor
  224.     m_picFillColor = m_def_picFillColor
  225.     m_picStep = m_def_picStep
  226.     m_Style = m_def_Style
  227. End Sub
  228.  
  229. 'Load property values from storage
  230. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  231.  
  232.     m_Value = PropBag.ReadProperty("Value", m_def_Value)
  233.     m_Min = PropBag.ReadProperty("Min", m_def_Min)
  234.     m_Max = PropBag.ReadProperty("Max", m_def_Max)
  235.     UserControl.BackColor = PropBag.ReadProperty("BackColor", &H80000007)
  236.     Shape1.FillColor = PropBag.ReadProperty("FillColor", &HFFFF&)
  237.     Shape1.BorderColor = PropBag.ReadProperty("BorderColor", &HFF&)
  238.     m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
  239.     UserControl.BorderStyle = m_BackStyle
  240.     Shape1.BorderStyle = m_BorderStyle
  241.     m_EnabledSlider = PropBag.ReadProperty("EnabledSlider", m_def_EnabledSlider)
  242.     m_picForeColor = PropBag.ReadProperty("picForeColor", m_def_picForeColor)
  243.     m_picFillColor = PropBag.ReadProperty("picFillColor", m_def_picFillColor)
  244.     m_picStep = PropBag.ReadProperty("picStep", m_def_picStep)
  245.     m_Style = PropBag.ReadProperty("Style", m_def_Style)
  246.     m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle)
  247.     UserControl.BorderStyle = m_BackStyle
  248.     RefreshBar
  249.     If Not m_EnabledSlider Then Exit Sub
  250.     Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
  251.     m_MousePointer = PropBag.ReadProperty("MousePointer", m_def_MousePointer)
  252.     UserControl.MousePointer = m_MousePointer
  253. End Sub
  254.  
  255. Private Sub UserControl_Show()
  256. Ref = True: RefreshBar
  257. End Sub
  258.  
  259. 'Write property values to storage
  260. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  261.     Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
  262.     Call PropBag.WriteProperty("Min", m_Min, m_def_Min)
  263.     Call PropBag.WriteProperty("Max", m_Max, m_def_Max)
  264.     Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H80000007)
  265.     Call PropBag.WriteProperty("FillColor", Shape1.FillColor, &HFFFF&)
  266.     Call PropBag.WriteProperty("BorderColor", Shape1.BorderColor, &HFF&)
  267.     Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
  268.     Call PropBag.WriteProperty("EnabledSlider", m_EnabledSlider, m_def_EnabledSlider)
  269.     Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
  270.     Call PropBag.WriteProperty("MousePointer", m_MousePointer, m_def_MousePointer)
  271.     Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle)
  272.     Call PropBag.WriteProperty("picForeColor", m_picForeColor, m_def_picForeColor)
  273.     Call PropBag.WriteProperty("picFillColor", m_picFillColor, m_def_picFillColor)
  274.     Call PropBag.WriteProperty("picStep", m_picStep, m_def_picStep)
  275.     Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
  276. End Sub
  277.  
  278. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  279. 'MappingInfo=UserControl,UserControl,-1,BackColor
  280. Public Property Get BackColor() As OLE_COLOR
  281. Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
  282.     BackColor = UserControl.BackColor
  283. End Property
  284.  
  285. Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  286.     UserControl.BackColor() = New_BackColor
  287.     PropertyChanged "BackColor"
  288. End Property
  289.  
  290. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  291. 'MappingInfo=Shape1,Shape1,-1,FillColor
  292. Public Property Get FillColor() As OLE_COLOR
  293. Attribute FillColor.VB_Description = "Returns/sets the color used to fill in shapes, circles, and boxes."
  294.     FillColor = Shape1.FillColor
  295. End Property
  296.  
  297. Public Property Let FillColor(ByVal New_FillColor As OLE_COLOR)
  298.     Shape1.FillColor() = New_FillColor
  299.     PropertyChanged "FillColor"
  300. End Property
  301.  
  302. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  303. 'MappingInfo=Shape1,Shape1,-1,BorderColor
  304. Public Property Get BorderColor() As OLE_COLOR
  305. Attribute BorderColor.VB_Description = "Returns/sets the color of an object's border."
  306.     BorderColor = Shape1.BorderColor
  307. End Property
  308.  
  309. Public Property Let BorderColor(ByVal New_BorderColor As OLE_COLOR)
  310.     Shape1.BorderColor() = New_BorderColor
  311.     PropertyChanged "BorderColor"
  312. End Property
  313.  
  314. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  315. 'MemberInfo=22,0,0,0
  316. Public Property Get BorderStyle() As rStyle
  317. Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
  318.     BorderStyle = m_BorderStyle
  319. End Property
  320.  
  321. Public Property Let BorderStyle(ByVal New_BorderStyle As rStyle)
  322.     m_BorderStyle = New_BorderStyle
  323.     PropertyChanged "BorderStyle"
  324. Shape1.BorderStyle = m_BorderStyle
  325. RefreshBar
  326. End Property
  327.  
  328. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  329. 'MemberInfo=0,0,0,True
  330. Public Property Get EnabledSlider() As Boolean
  331. Attribute EnabledSlider.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
  332.     EnabledSlider = m_EnabledSlider
  333. End Property
  334.  
  335. Public Property Let EnabledSlider(ByVal New_EnabledSlider As Boolean)
  336.     m_EnabledSlider = New_EnabledSlider
  337.     PropertyChanged "EnabledSlider"
  338. End Property
  339.  
  340. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  341. 'MappingInfo=UserControl,UserControl,-1,MouseIcon
  342. Public Property Get MouseIcon() As Picture
  343. Attribute MouseIcon.VB_Description = "Sets a custom mouse icon."
  344.     Set MouseIcon = UserControl.MouseIcon
  345. End Property
  346.  
  347. Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
  348.     Set UserControl.MouseIcon = New_MouseIcon
  349.     PropertyChanged "MouseIcon"
  350. End Property
  351.  
  352. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  353. 'MemberInfo=23,0,0,0
  354. Public Property Get MousePointer() As bMouse
  355. Attribute MousePointer.VB_Description = "Returns/sets the type of mouse pointer displayed when over part of an object."
  356.     MousePointer = m_MousePointer
  357. End Property
  358.  
  359. Public Property Let MousePointer(ByVal New_MousePointer As bMouse)
  360.     m_MousePointer = New_MousePointer
  361.     PropertyChanged "MousePointer"
  362.     UserControl.MousePointer = m_MousePointer
  363. End Property
  364.  
  365. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  366. 'MemberInfo=21,0,0,0
  367. Public Property Get BackStyle() As bStyle
  368. Attribute BackStyle.VB_Description = "Returns/sets the border style for an object."
  369.     BackStyle = m_BackStyle
  370. End Property
  371.  
  372. Public Property Let BackStyle(ByVal New_BackStyle As bStyle)
  373.     m_BackStyle = New_BackStyle
  374.     PropertyChanged "BackStyle"
  375.     UserControl.BorderStyle = m_BackStyle
  376. Ref = True
  377. RefreshBar
  378. End Property
  379.  
  380. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  381. 'MemberInfo=10,0,0,vbMagenta
  382. Public Property Get picForeColor() As OLE_COLOR
  383.     picForeColor = m_picForeColor
  384. End Property
  385.  
  386. Public Property Let picForeColor(ByVal New_picForeColor As OLE_COLOR)
  387.     m_picForeColor = New_picForeColor
  388.     PropertyChanged "picForeColor"
  389. If m_Style = Digital Then RefreshBar
  390. End Property
  391.  
  392. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  393. 'MemberInfo=10,0,0,vbBlue
  394. Public Property Get picFillColor() As OLE_COLOR
  395.     picFillColor = m_picFillColor
  396. End Property
  397.  
  398. Public Property Let picFillColor(ByVal New_picFillColor As OLE_COLOR)
  399.     m_picFillColor = New_picFillColor
  400.     PropertyChanged "picFillColor"
  401. If m_Style = Digital Then RefreshBar
  402. End Property
  403.  
  404. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  405. 'MemberInfo=7,0,0,50
  406. Public Property Get picStep() As Integer
  407.     picStep = m_picStep
  408. End Property
  409.  
  410. Public Property Let picStep(ByVal New_picStep As Integer)
  411.     If New_picStep < 10 Then New_picStep = 10
  412. If New_picStep > ScaleWidth / 10 Then New_picStep = ScaleWidth / 10
  413.     m_picStep = New_picStep
  414.         PropertyChanged "picStep"
  415. If m_Style = Digital Then Ref = True: RefreshBar
  416. End Property
  417.  
  418. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  419. 'MemberInfo=24,0,0,0
  420. Public Property Get Style() As bView
  421.     Style = m_Style
  422. End Property
  423.  
  424. Public Property Let Style(ByVal New_Style As bView)
  425.     Ref = True
  426.     m_Style = New_Style
  427.     PropertyChanged "Style"
  428. RefreshBar
  429. End Property
  430.  
  431.  
  432. Private Sub RefreshBar(Optional ByVal Value As Long)
  433. If Value = Empty Then Value = m_Value
  434. GetValue ScaleWidth * (Value - m_Min) / (m_Max - m_Min)
  435. End Sub
  436. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  437. 'MemberInfo=5
  438. Public Sub AboutBox()
  439. Attribute AboutBox.VB_Description = "Show About Dialog & Resistered"
  440. Attribute AboutBox.VB_UserMemId = -552
  441. frmAbout.Show 1
  442. End Sub
  443.  
  444.