home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / ToggleBox_21379912232008.psc / OptionBox.ctl < prev    next >
Text File  |  2008-12-23  |  9KB  |  267 lines
  1. VERSION 5.00
  2. Begin VB.UserControl OptionBox 
  3.    AutoRedraw      =   -1  'True
  4.    ClientHeight    =   285
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   1800
  8.    BeginProperty Font 
  9.       Name            =   "Segoe UI"
  10.       Size            =   8.25
  11.       Charset         =   0
  12.       Weight          =   400
  13.       Underline       =   0   'False
  14.       Italic          =   0   'False
  15.       Strikethrough   =   0   'False
  16.    EndProperty
  17.    ScaleHeight     =   20
  18.    ScaleMode       =   0  'User
  19.    ScaleWidth      =   120
  20. End
  21. Attribute VB_Name = "OptionBox"
  22. Attribute VB_GlobalNameSpace = False
  23. Attribute VB_Creatable = True
  24. Attribute VB_PredeclaredId = False
  25. Attribute VB_Exposed = False
  26. Option Explicit
  27. Private Type POINTAPI
  28.     X As Long
  29.     Y As Long
  30. End Type
  31. Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
  32. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  33. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  34. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  35. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  36. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  37. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  38. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  39. Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
  40. Private Declare Function StretchDIBits& Lib "gdi32" (ByVal hdc&, ByVal X&, ByVal Y&, ByVal dx&, ByVal dy&, ByVal SrcX&, ByVal SrcY&, ByVal Srcdx&, ByVal Srcdy&, Bits As Any, BInf As Any, ByVal Usage&, ByVal Rop&)
  41. Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
  42. Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  43. Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
  44. Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
  45. Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  46.  
  47. Private HiLite&
  48. Private HiLite2&
  49. Private LoLite&
  50. Private Greyed&
  51. Private Shadow&
  52. Private mEnabled As Boolean
  53. Private cw&, ch&, X2&
  54. Private mCurrentState As Boolean
  55. Private mShadowLine As Boolean
  56. Private mBackStyle As Integer
  57. Private mCaption As String
  58.  
  59. Private xONOFF&
  60. Private wONOFF&
  61.  
  62. Public Event Click()
  63. Public Event DblClick()
  64. Public Property Get Caption() As String
  65.     Caption = mCaption
  66. End Property
  67.  
  68. Public Property Let Caption(ByVal vNewValue As String)
  69.     mCaption = vNewValue
  70.     PropertyChanged Caption
  71.     DrawControl
  72. End Property
  73.  
  74. Public Property Let Value(bVal As Boolean)
  75. mCurrentState = bVal
  76. PropertyChanged Value
  77. DrawControl
  78. End Property
  79. Public Property Get Value() As Boolean
  80. Value = mCurrentState
  81. End Property
  82.  
  83. Public Property Let BackStyle(bVal As Integer)
  84. If bVal < 1 Or bVal > 2 Or bVal = mBackStyle Then Exit Property
  85. mBackStyle = bVal
  86. PropertyChanged BackStyle
  87. DrawControl
  88. End Property
  89. Public Property Get BackStyle() As Integer
  90. BackStyle = mBackStyle
  91. End Property
  92.  
  93. Public Property Let ShadowLine(bVal As Boolean)
  94. mShadowLine = bVal
  95. PropertyChanged ShadowLine
  96. DrawControl
  97. End Property
  98. Public Property Get ShadowLine() As Boolean
  99. ShadowLine = mShadowLine
  100. End Property
  101. Private Sub SplitRGB(ByVal clr&, r&, G&, B&)
  102.     r = clr And &HFF: G = (clr \ &H100&) And &HFF: B = (clr \ &H10000) And &HFF
  103. End Sub
  104. Private Sub Gradient(dc&, X&, Y&, dx&, dy&, ByVal c1&, ByVal c2&, v As Boolean)
  105. Dim r1&, G1&, B1&, r2&, G2&, B2&, B() As Byte
  106. Dim i&, lR!, lG!, lB!, dR!, dG!, dB!, BI&(9), xx&, yy&, dd&, hRPen&
  107.     If dx = 0 Or dy = 0 Then Exit Sub
  108.     If v Then xx = 1: yy = dy: dd = dy Else xx = dx: yy = 1: dd = dx
  109.     SplitRGB c1, r1, G1, B1: SplitRGB c2, r2, G2, B2: ReDim B(dd * 4 - 1)
  110.     dR = (r2 - r1) / (dd - 1): lR = r1: dG = (G2 - G1) / (dd - 1): lG = G1: dB = (B2 - B1) / (dd - 1): lB = B1
  111.     For i = 0 To (dd - 1) * 4 Step 4: B(i + 2) = lR: lR = lR + dR: B(i + 1) = lG: lG = lG + dG: B(i) = lB: lB = lB + dB: Next
  112.     BI(0) = 40: BI(1) = xx: BI(2) = -yy: BI(3) = 2097153: StretchDIBits dc, X, Y, dx, dy, 0, 0, xx, yy, B(0), BI(0), 0, vbSrcCopy
  113. End Sub
  114.  
  115. Private Sub UserControl_Click()
  116.     RaiseEvent Click
  117. End Sub
  118.  
  119. Private Sub UserControl_InitProperties()
  120.     Value = False
  121. End Sub
  122. Private Sub UserControl_Paint()
  123. DrawControl
  124. End Sub
  125.  
  126. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  127.     With PropBag
  128.          mCurrentState = .ReadProperty("Value", False)
  129.          mShadowLine = .ReadProperty("ShadowLine", False)
  130.          mBackStyle = .ReadProperty("BackStyle", False)
  131.          mCaption = .ReadProperty("Caption", "ToggleBox")
  132.     End With
  133. End Sub
  134.  
  135. Private Sub UserControl_Show()
  136. DrawControl
  137. End Sub
  138.  
  139. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  140.     With PropBag
  141.         .WriteProperty "Value", mCurrentState
  142.         .WriteProperty "ShadowLine", mShadowLine
  143.         .WriteProperty "BackStyle", mBackStyle
  144.         .WriteProperty "Caption", mCaption
  145.     End With
  146. End Sub
  147. Sub DrawLine(ByRef dc&, X1&, Y1&, X2&, Y2&, c&)
  148. Dim p&, Pt As POINTAPI
  149.     p = CreatePen(0, 1, c): DeleteObject SelectObject(dc, p)
  150.     Pt.X = X1: Pt.Y = Y1
  151.     MoveToEx dc, X1, Y1, Pt: LineTo dc, X2, Y2
  152.     DeleteDC p
  153. End Sub
  154.  
  155. Private Sub UserControl_DblClick()
  156. mCurrentState = Not mCurrentState
  157. DrawControl
  158. RaiseEvent DblClick
  159. End Sub
  160.  
  161. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  162. mCurrentState = Not mCurrentState
  163. DrawControl
  164. End Sub
  165.  
  166. Private Sub UserControl_Resize()
  167.     
  168.     'UserControl.Width = 700
  169.     UserControl.Height = 270
  170.     
  171.     cw = UserControl.Width \ Screen.TwipsPerPixelX
  172.     ch = UserControl.Height \ Screen.TwipsPerPixelY
  173.  
  174.     wONOFF = (700 \ Screen.TwipsPerPixelX)
  175.     xONOFF = (UserControl.Width \ Screen.TwipsPerPixelX) - wONOFF
  176.  
  177.     X2 = cw \ 2
  178.     
  179.     DrawControl
  180.  
  181. End Sub
  182. Private Sub UserControl_Initialize()
  183.     
  184.     UserControl.FontName = "Segoe UI"
  185.     UserControl.FontSize = 8
  186.     UserControl.FontBold = False
  187.     
  188.     mCurrentState = False
  189.     mShadowLine = False
  190.     mBackStyle = 1
  191.     
  192.     HiLite = RGB(215, 215, 215)
  193.     HiLite2 = RGB(255, 255, 255)
  194.     LoLite = RGB(165, 165, 165)
  195.     Shadow = RGB(150, 150, 150)
  196.     Greyed = RGB(190, 190, 190)
  197.     
  198.     
  199. End Sub
  200. Sub DrawControlON()
  201.  
  202.     If mBackStyle = 1 Then
  203.     Gradient UserControl.hdc, 0, 0, cw, ch / 2, HiLite, HiLite2, True
  204.     Gradient UserControl.hdc, 0, ch / 2, cw, ch, HiLite, LoLite, True
  205.     Else
  206.     Gradient UserControl.hdc, 0, 0, cw, ch, vbWhite, HiLite, True
  207.     End If
  208.     Gradient UserControl.hdc, xONOFF + 2, 2, (wONOFF \ 2 - 2), ch - 4, RGB(59, 109, 219), RGB(108, 168, 250), True
  209.     
  210.     
  211.     If mShadowLine Then
  212.         DrawLine UserControl.hdc, 0, ch - 1, cw - 1, ch - 1, Shadow
  213.         DrawLine UserControl.hdc, cw - 1, 0, cw - 1, ch - 1, Shadow
  214.     End If
  215.     
  216.     
  217.     DrawLine UserControl.hdc, xONOFF + 2, 2, xONOFF + ((wONOFF \ 2)), 2, RGB(50, 100, 200)
  218.     DrawLine UserControl.hdc, xONOFF + ((wONOFF \ 2)) - 1, 2, xONOFF + ((wONOFF \ 2)) - 1, ch - 2, RGB(117, 173, 255)
  219.  
  220.     SetTextColor UserControl.hdc, vbWhite
  221.     TextOut UserControl.hdc, xONOFF + 3, 2, "ON", 2
  222.     
  223.     OutputCaption
  224.     
  225.     UserControl.Refresh
  226.  
  227. End Sub
  228. Sub OutputCaption()
  229.     SetTextColor UserControl.hdc, vbWhite
  230.     TextOut UserControl.hdc, 3, 3, mCaption, Len(mCaption)
  231.     SetTextColor UserControl.hdc, RGB(50, 50, 50)
  232.     TextOut UserControl.hdc, 3, 2, mCaption, Len(mCaption)
  233. End Sub
  234. Sub DrawControl()
  235.     If mCurrentState Then
  236.         DrawControlON
  237.     Else
  238.         DrawControlOFF
  239.     End If
  240. End Sub
  241. Sub DrawControlOFF()
  242.     If mBackStyle = 1 Then
  243.     Gradient UserControl.hdc, 0, 0, cw, ch / 2, HiLite, HiLite2, True
  244.     Gradient UserControl.hdc, 0, ch / 2, cw, ch, HiLite, LoLite, True
  245.     Else
  246.     Gradient UserControl.hdc, 0, 0, cw, ch, vbWhite, HiLite, True
  247.     End If
  248.     
  249.     If mShadowLine Then
  250.         DrawLine UserControl.hdc, 0, ch - 1, cw - 1, ch - 1, Shadow
  251.         DrawLine UserControl.hdc, cw - 1, 0, cw - 1, ch - 1, Shadow
  252.     End If
  253.  
  254.  
  255.     SetTextColor UserControl.hdc, vbWhite
  256.     TextOut UserControl.hdc, cw - 26, 3, "OFF", 3
  257.     
  258.     SetTextColor UserControl.hdc, RGB(50, 50, 50)
  259.     TextOut UserControl.hdc, cw - 26, 2, "OFF", 3
  260.     
  261.     OutputCaption
  262.  
  263.     UserControl.Refresh
  264.  
  265. End Sub
  266.  
  267.