home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / iPhone_sty213964162009.psc / buttn.ctl < prev    next >
Text File  |  2008-12-29  |  14KB  |  386 lines
  1. VERSION 5.00
  2. Begin VB.UserControl UserControl1 
  3.    AutoRedraw      =   -1  'True
  4.    ClientHeight    =   225
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   945
  8.    BeginProperty Font 
  9.       Name            =   "Tahoma"
  10.       Size            =   9
  11.       Charset         =   0
  12.       Weight          =   400
  13.       Underline       =   0   'False
  14.       Italic          =   0   'False
  15.       Strikethrough   =   0   'False
  16.    EndProperty
  17.    ScaleHeight     =   225
  18.    ScaleWidth      =   945
  19. End
  20. Attribute VB_Name = "UserControl1"
  21. Attribute VB_GlobalNameSpace = False
  22. Attribute VB_Creatable = True
  23. Attribute VB_PredeclaredId = False
  24. Attribute VB_Exposed = False
  25. Option Explicit
  26. Private Type POINTAPI
  27.     X As Long
  28.     Y As Long
  29. End Type
  30. Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
  31. 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
  32. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  33. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  34. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  35. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  36. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  37. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  38. Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
  39. 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&)
  40. Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
  41. Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  42. Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
  43. 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
  44. Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  45.  
  46.  
  47. Public Event Click()
  48. Public Event DblClick()
  49.  
  50. Private HiLite&
  51. Private HiLite2&
  52. Private LoLite&
  53. Private Greyed&
  54. Private Shadow&
  55.  
  56. Private mIconDC&
  57. Private mIconW&
  58. Private mIconH&
  59. Private mIconCX&
  60. Private mIconCY&
  61. Private mBackStyle&
  62. Private mDC&
  63. Private mEnabled As Boolean
  64. Private mBitmap&
  65. Private cw&, ch&
  66. Private mCaption$
  67. Private mTextloc%
  68.  
  69. Public Property Let BackStyle(mBS&)
  70. mBackStyle = mBS
  71. PropertyChanged BackStyle
  72. DrawControlUP
  73. End Property
  74. Public Property Get BackStyle() As Long
  75.     BackStyle = mBackStyle
  76. End Property
  77. Public Property Let IconDC(mDC&)
  78.     mIconDC = mDC
  79.     DrawControlUP
  80.     UserControl.Refresh
  81. End Property
  82. Public Property Let IconW(m&)
  83.     mIconW = m
  84.     mIconCX = (((UserControl.Width \ Screen.TwipsPerPixelX) / 2) - (m / 2)) - 1
  85. End Property
  86. Public Property Let IconH(m&)
  87.     mIconH = m
  88.     mIconCY = (((UserControl.Height \ Screen.TwipsPerPixelY) / 2) - (m / 2))
  89. End Property
  90. Public Property Get hwnd() As Long
  91.     hwnd = UserControl.hwnd
  92. End Property
  93. Public Property Let Caption(s$)
  94.     mCaption = s
  95.     PropertyChanged Caption
  96.     
  97.     DrawControlUP
  98. End Property
  99. Public Property Get Caption() As String
  100.     Caption = mCaption
  101. End Property
  102. Public Property Let Enabled(s As Boolean)
  103.     mEnabled = s
  104.     If mEnabled Then
  105.         DrawControlUP
  106.     Else
  107.         DrawControlGreyed
  108.     End If
  109.     
  110.     PropertyChanged Enabled
  111.     
  112. End Property
  113. Public Property Get Enabled() As Boolean
  114.     Enabled = mEnabled
  115. End Property
  116. Public Property Let TextLocation(s As Integer)
  117.     mTextloc = s
  118.     DrawControlUP
  119. End Property
  120. Public Property Get TextLocation() As Integer
  121.     TextLocation = mTextloc
  122. End Property
  123.  
  124. Private Sub SplitRGB(ByVal clr&, r&, G&, B&)
  125.     r = clr And &HFF: G = (clr \ &H100&) And &HFF: B = (clr \ &H10000) And &HFF
  126. End Sub
  127. Private Sub Gradient(dc&, X&, Y&, dx&, dy&, ByVal c1&, ByVal c2&, v As Boolean)
  128. Dim r1&, G1&, B1&, r2&, G2&, B2&, B() As Byte
  129. Dim i&, lR!, lG!, lB!, dR!, dG!, dB!, BI&(9), xx&, yy&, dd&, hRPen&
  130.     If dx = 0 Or dy = 0 Then Exit Sub
  131.     If v Then xx = 1: yy = dy: dd = dy Else xx = dx: yy = 1: dd = dx
  132.     SplitRGB c1, r1, G1, B1: SplitRGB c2, r2, G2, B2: ReDim B(dd * 4 - 1)
  133.     dR = (r2 - r1) / (dd - 1): lR = r1: dG = (G2 - G1) / (dd - 1): lG = G1: dB = (B2 - B1) / (dd - 1): lB = B1
  134.     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
  135.     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
  136. End Sub
  137.  
  138. Sub CreateBitmaps(ByRef dc&, ByRef BM&, dx&, dy&)
  139. Static t1&, t2&
  140.     DeleteDC t1: DeleteDC t2
  141.     t1 = GetDC(0): t2 = GetDC(0)
  142.     dc = CreateCompatibleDC(t1)
  143.     BM = CreateCompatibleBitmap(t2, dx, dy)
  144.     SelectObject dc, BM
  145. End Sub
  146. Sub UnloadContexts(ByRef dc&, ByRef BM&)
  147.     DeleteDC dc
  148.     DeleteObject BM
  149. End Sub
  150. Function textX()
  151.     textX = ((UserControl.Width - UserControl.TextWidth(mCaption)) \ 2) \ Screen.TwipsPerPixelX
  152. End Function
  153. Function textY()
  154.     textY = -1 + (((UserControl.Height - UserControl.TextHeight(mCaption)) \ 2) \ Screen.TwipsPerPixelY)
  155. End Function
  156.  
  157.  
  158. Private Sub UserControl_Click()
  159.     If mEnabled Then RaiseEvent Click
  160. End Sub
  161.  
  162. Private Sub UserControl_DblClick()
  163.     If mEnabled Then
  164.         DrawControlDown
  165.         RaiseEvent DblClick
  166.     End If
  167. End Sub
  168.  
  169. Private Sub UserControl_Initialize()
  170.     CreateBitmaps mDC, mBitmap, cw, ch
  171.     
  172. '    HiLite = RGB(215, 215, 215)
  173. '    HiLite2 = RGB(255, 255, 255)
  174. '    LoLite = RGB(165, 165, 165)
  175. '    Shadow = RGB(150, 150, 150)
  176. '    Greyed = RGB(190, 190, 190)
  177.     
  178.     HiLite = RGB(196, 196, 196)
  179.     HiLite2 = RGB(255, 255, 255)
  180.     LoLite = RGB(150, 150, 150)
  181.     Shadow = RGB(114, 114, 114)
  182.     Greyed = RGB(190, 190, 190)
  183.     
  184.     mBackStyle = 2
  185.     
  186.     
  187. End Sub
  188.  
  189. 'Gray
  190. 'RGB 196
  191. '150
  192. '
  193. 'darker 114
  194. '
  195. 'lcd top (253,254,231) - (214,219,191)
  196.  
  197. Private Sub UserControl_InitProperties()
  198.     mCaption = "Command"
  199.     mEnabled = True
  200.     mBackStyle = 1
  201. End Sub
  202.  
  203. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  204.     If mEnabled Then DrawControlDown
  205. End Sub
  206. Sub DrawControlDown()
  207.     If mBackStyle = 1 Then
  208.         Gradient UserControl.hdc, 0, 0, cw, (ch / 2) + 1, HiLite, HiLite2, True
  209.         Gradient UserControl.hdc, 0, (ch / 2) + 1, cw, ch / 2, HiLite2, HiLite, True
  210.         
  211.         DrawLine UserControl.hdc, 0, 0, cw - 1, 0, Shadow
  212.         DrawLine UserControl.hdc, 0, 0, 0, ch - 1, Shadow
  213.     ElseIf mBackStyle = 2 Then
  214.         Gradient UserControl.hdc, 0, 0, cw, ch, HiLite2, HiLite, True
  215.         
  216.         DrawLine UserControl.hdc, 0, 0, cw - 1, 0, LoLite
  217.         DrawLine UserControl.hdc, 0, 0, 0, ch - 1, LoLite
  218.     ElseIf mBackStyle = 3 Then
  219.         Gradient UserControl.hdc, 0, 0, cw, (ch / 2) + 1, RGB(108, 168, 250), RGB(59, 109, 219), True
  220.         Gradient UserControl.hdc, 0, (ch / 2) + 1, cw, ch / 2, RGB(59, 109, 219), RGB(118, 178, 255), True
  221.         
  222.         DrawLine UserControl.hdc, 0, 0, cw - 1, 0, RGB(39, 89, 199)
  223.         DrawLine UserControl.hdc, 0, 0, 0, ch - 1, RGB(39, 89, 199)
  224.     ElseIf mBackStyle = 4 Then
  225.         Gradient UserControl.hdc, 0, 0, cw, (ch / 2) + 1, RGB(115, 115, 115), 0, True
  226.         Gradient UserControl.hdc, 0, (ch / 2) + 1, cw, ch / 2, 0, RGB(115, 115, 115), True
  227.         
  228.         DrawLine UserControl.hdc, 0, 0, cw - 1, 0, 0
  229.         DrawLine UserControl.hdc, 0, 0, 0, ch - 1, 0
  230.     End If
  231.     
  232.     If mIconDC <> 0 Then
  233.         BitBlt UserControl.hdc, mIconCX + 1, mIconCY + 1, mIconW, mIconH, mIconDC, 0, 0, vbSrcCopy
  234.     Else
  235.         If mBackStyle = 3 Or mBackStyle = 4 Then
  236.             SetTextColor UserControl.hdc, vbWhite
  237.             TextOut UserControl.hdc, textX + 2, textY + 1, mCaption, Len(mCaption)
  238.         Else
  239.         
  240.             SetTextColor UserControl.hdc, RGB(220, 220, 220)
  241.             TextOut UserControl.hdc, textX + 2, textY + 2, mCaption, Len(mCaption)
  242.             SetTextColor UserControl.hdc, 0
  243.             TextOut UserControl.hdc, textX + 2, textY + 1, mCaption, Len(mCaption)
  244.     
  245.         End If
  246.     End If
  247.     UserControl.Refresh
  248. End Sub
  249. Sub DrawControlUP()
  250.     If mBackStyle = 1 Then
  251.         Gradient UserControl.hdc, 0, 0, cw, ch / 2, HiLite, HiLite2, True
  252.         Gradient UserControl.hdc, 0, ch / 2, cw, ch / 2, HiLite, LoLite, True
  253.         
  254.         DrawLine UserControl.hdc, 0, ch - 1, cw, ch - 1, Shadow
  255.         DrawLine UserControl.hdc, cw - 1, 0, cw - 1, ch - 1, Shadow
  256.     ElseIf mBackStyle = 2 Then
  257.         Gradient UserControl.hdc, 0, 0, cw, ch, HiLite2, HiLite, True
  258.     
  259.         DrawLine UserControl.hdc, 0, ch - 1, cw, ch - 1, LoLite
  260.         DrawLine UserControl.hdc, cw - 1, 0, cw - 1, ch - 1, LoLite
  261.     ElseIf mBackStyle = 3 Then
  262.         Gradient UserControl.hdc, 0, 0, cw, ch, RGB(108, 168, 250), RGB(59, 109, 219), True
  263.         Gradient UserControl.hdc, 0, 0, cw, (ch / 2), RGB(59, 109, 219), RGB(118, 178, 255), True
  264.         
  265.         DrawLine UserControl.hdc, 0, ch - 1, cw, ch - 1, RGB(39, 89, 199)
  266.         DrawLine UserControl.hdc, cw - 1, 0, cw - 1, ch - 1, RGB(39, 89, 199)
  267.     ElseIf mBackStyle = 4 Then
  268.         Gradient UserControl.hdc, 0, 0, cw, ch / 2, 0, RGB(115, 115, 115), True
  269.         Gradient UserControl.hdc, 0, ch / 2, cw, (ch / 2) + 1, 0, RGB(50, 50, 50), True
  270.     End If
  271.     If mIconDC <> 0 Then
  272.         BitBlt UserControl.hdc, mIconCX, mIconCY, mIconW, mIconH, mIconDC, 0, 0, vbSrcCopy
  273.     Else
  274.         If mBackStyle = 3 Or mBackStyle = 4 Then
  275.             SetTextColor UserControl.hdc, vbWhite
  276.             TextOut UserControl.hdc, textX, textY, mCaption, Len(mCaption)
  277.         Else
  278.             SetTextColor UserControl.hdc, RGB(220, 220, 220)
  279.             TextOut UserControl.hdc, textX, textY + 1, mCaption, Len(mCaption)
  280.             SetTextColor UserControl.hdc, 0
  281.             TextOut UserControl.hdc, textX, textY, mCaption, Len(mCaption)
  282.         End If
  283.     End If
  284.     
  285.     UserControl.Refresh
  286.  
  287. End Sub
  288. Sub DrawControlGreyed()
  289.     If mBackStyle = 1 Then
  290.         Gradient UserControl.hdc, 0, 0, cw, ch / 2, HiLite, HiLite2, True
  291.         Gradient UserControl.hdc, 0, ch / 2, cw, ch / 2, HiLite, LoLite, True
  292.         
  293.         DrawLine UserControl.hdc, 0, ch - 1, cw, ch - 1, Shadow
  294.         DrawLine UserControl.hdc, cw - 1, 0, cw - 1, ch - 1, Shadow
  295.     ElseIf mBackStyle = 2 Then
  296.         Gradient UserControl.hdc, 0, 0, cw, ch, HiLite2, HiLite, True
  297.     
  298.         DrawLine UserControl.hdc, 0, ch - 1, cw, ch - 1, LoLite
  299.         DrawLine UserControl.hdc, cw - 1, 0, cw - 1, ch - 1, LoLite
  300.     ElseIf mBackStyle = 3 Then
  301.         Gradient UserControl.hdc, 0, 0, cw, ch, RGB(108, 168, 250), RGB(59, 109, 219), True
  302.         Gradient UserControl.hdc, 0, 0, cw, (ch / 2), RGB(59, 109, 219), RGB(118, 178, 255), True
  303.         
  304.         DrawLine UserControl.hdc, 0, ch - 1, cw, ch - 1, RGB(39, 89, 199)
  305.         DrawLine UserControl.hdc, cw - 1, 0, cw - 1, ch - 1, RGB(39, 89, 199)
  306.     ElseIf mBackStyle = 4 Then
  307.         Gradient UserControl.hdc, 0, 0, cw, ch / 2, 0, RGB(115, 115, 115), True
  308.         Gradient UserControl.hdc, 0, ch / 2, cw, (ch / 2) + 1, 0, RGB(50, 50, 50), True
  309.     End If
  310.     
  311.     If mIconDC <> 0 Then
  312.         BitBlt UserControl.hdc, mIconCX, mIconCY, mIconW, mIconH, mIconDC, 0, 0, vbSrcCopy
  313.     Else
  314.         'SetTextColor UserControl.hdc, HiLite
  315.         'TextOut UserControl.hdc, textX + 1, textY + 1, mCaption, Len(mCaption)
  316.         SetTextColor UserControl.hdc, IIf(mBackStyle = 3 Or mBackStyle = 4, HiLite, Shadow)
  317.         TextOut UserControl.hdc, textX, textY, mCaption, Len(mCaption)
  318.     End If
  319.  
  320.     
  321.     UserControl.Refresh
  322.  
  323. End Sub
  324. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  325.     If mEnabled Then DrawControlUP
  326. End Sub
  327. Public Sub Refresh()
  328.     UserControl_Paint
  329. End Sub
  330. Private Sub UserControl_Paint()
  331.     If mEnabled Then
  332.         DrawControlUP
  333.     Else
  334.         DrawControlGreyed
  335.     End If
  336. End Sub
  337.  
  338. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  339.     With PropBag
  340.          mCaption = .ReadProperty("Caption", "Command")
  341.          mEnabled = .ReadProperty("Enabled", True)
  342.          mBackStyle = .ReadProperty("BackStyle", 1)
  343.     End With
  344. End Sub
  345.  
  346.  
  347. Private Sub UserControl_Resize()
  348.  
  349.     UserControl.BackColor = UserControl.ParentControls.Item(0).BackColor
  350.  
  351.     cw = UserControl.Width \ Screen.TwipsPerPixelX
  352.     ch = UserControl.Height \ Screen.TwipsPerPixelY
  353.     If mEnabled Then
  354.         DrawControlUP
  355.     Else
  356.         DrawControlGreyed
  357.     End If
  358. End Sub
  359.  
  360. Private Sub UserControl_Show()
  361.     If mEnabled Then
  362.         DrawControlUP
  363.     Else
  364.         DrawControlGreyed
  365.     End If
  366. End Sub
  367.  
  368. Private Sub UserControl_Terminate()
  369. UnloadContexts mDC, mBitmap
  370. End Sub
  371. Sub DrawLine(ByRef dc&, X1&, Y1&, X2&, Y2&, c&)
  372. Dim p&, Pt As POINTAPI
  373.     p = CreatePen(0, 1, c): DeleteObject SelectObject(dc, p)
  374.     Pt.X = X1: Pt.Y = Y1
  375.     MoveToEx dc, X1, Y1, Pt: LineTo dc, X2, Y2
  376.     DeleteDC p
  377. End Sub
  378.  
  379. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  380.     With PropBag
  381.         .WriteProperty "Caption", mCaption
  382.         .WriteProperty "Enabled", mEnabled
  383.         .WriteProperty "BackStyle", mBackStyle
  384.     End With
  385. End Sub
  386.