home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD1306512262000.psc / Controls / SBSCoolButton.ctl < prev    next >
Encoding:
Visual Basic user-defined control file  |  2000-11-05  |  15.2 KB  |  521 lines
  1. VERSION 5.00
  2. Begin VB.UserControl SBSCoolButton 
  3.    ClientHeight    =   3600
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   4800
  7.    ScaleHeight     =   3600
  8.    ScaleWidth      =   4800
  9.    ToolboxBitmap   =   "SBSCoolButton.ctx":0000
  10.    Begin VB.Timer tmrHighlight 
  11.       Interval        =   250
  12.       Left            =   1260
  13.       Top             =   1500
  14.    End
  15.    Begin VB.Image picIcon 
  16.       Height          =   255
  17.       Left            =   60
  18.       Stretch         =   -1  'True
  19.       Top             =   60
  20.       Width           =   255
  21.    End
  22.    Begin VB.Label lblCaption 
  23.       Alignment       =   2  'Center
  24.       AutoSize        =   -1  'True
  25.       BackStyle       =   0  'Transparent
  26.       Caption         =   "Label1"
  27.       Height          =   195
  28.       Left            =   360
  29.       TabIndex        =   0
  30.       Top             =   240
  31.       Width           =   480
  32.    End
  33. End
  34. Attribute VB_Name = "SBSCoolButton"
  35. Attribute VB_GlobalNameSpace = False
  36. Attribute VB_Creatable = True
  37. Attribute VB_PredeclaredId = False
  38. Attribute VB_Exposed = False
  39. Option Explicit
  40.  
  41. ' Variables/Tipos/Enumeraciones/Constantes Privados
  42. ' **********************************************
  43.  
  44. Private Enum htWhatToApply
  45.    apyDrawBorder = 1
  46.    apyBackColor = 2
  47.    apyCaption = 4
  48.    apyEnabled = 8
  49.    apyFont = 16
  50.    apyForeColor = 32
  51.    apyButtonIcon = 64
  52.    apyAll = (apyBackColor Or apyCaption Or apyEnabled Or apyFont Or apyForeColor)
  53. End Enum
  54.  
  55. Dim mbHasCapture As Boolean
  56. Dim mpntLabelPos As POINTAPI
  57. Dim mpntOldSize As POINTAPI
  58.  
  59. ' Declaraciones API /Tipos/Constantes
  60. ' ********************************
  61.  
  62. Private Type POINTAPI
  63.         x As Long
  64.         y As Long
  65. End Type
  66.  
  67. Private Type RECT
  68.    Left     As Long
  69.    Top      As Long
  70.    Right    As Long
  71.    Bottom   As Long
  72. End Type
  73.  
  74. Private Const BDR_RAISEDINNER = &H4
  75. Private Const BDR_RAISEDOUTER = &H1
  76. Private Const BDR_SUNKENINNER = &H8
  77. Private Const BDR_SUNKENOUTER = &H2
  78. Private Const BDR_MOUSEOVER = BDR_RAISEDINNER
  79. Private Const BDR_MOUSEDOWN = BDR_SUNKENOUTER
  80.  
  81. Private Const BF_BOTTOM = &H8
  82. Private Const BF_FLAT = &H4000
  83. Private Const BF_LEFT = &H1
  84. Private Const BF_RIGHT = &H4
  85. Private Const BF_TOP = &H2
  86. Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
  87.  
  88.  
  89. Private Declare Function apiDrawEdge Lib "user32" _
  90.                          Alias "DrawEdge" _
  91.                         (ByVal hdc As Long, _
  92.                          ByRef qrc As RECT, _
  93.                          ByVal edge As Long, _
  94.                          ByVal grfFlags As Long) As Long
  95.                                                   
  96. Private Declare Function apiGetCursorPos Lib "user32" _
  97.                          Alias "GetCursorPos" _
  98.                         (lpPoint As POINTAPI) As Long
  99.                          
  100. Private Declare Function apiWindowFromPoint Lib "user32" _
  101.                          Alias "WindowFromPoint" _
  102.                         (ByVal xPoint As Long, _
  103.                          ByVal yPoint As Long) As Long
  104.                          
  105. Private Declare Function apiDrawFocusRect Lib "user32" _
  106.                          Alias "DrawFocusRect" _
  107.                         (ByVal hdc As Long, _
  108.                          lpRect As RECT) As Long
  109.                                                   
  110. ' Propiedades (Variables/Constantes)
  111. ' *******************************
  112.  
  113. Private mProp_AlwaysHighlighted  As Boolean
  114. Private mProp_BackColor          As OLE_COLOR
  115. Private mProp_Caption            As String
  116. Private mProp_Enabled            As Boolean
  117. Private mProp_FocusRect          As Boolean
  118. Private mProp_Font               As StdFont
  119. Private mProp_HoverColor         As OLE_COLOR
  120. Private mProp_ForeColor          As OLE_COLOR
  121.  
  122. Private mprop_ButtonIcon         As StdPicture
  123.  
  124.  
  125.  
  126. Const mDef_AlwaysHighlighted = False
  127. Const mDef_BackColor = vbButtonFace
  128. Const mDef_ForeColor = vbButtonText
  129. Const mDef_Caption = "SBSCoolButton"
  130. Const mDef_Enabled = True
  131. Const mDef_FocusRect = True
  132. Const mDef_Font = Null                             ' Ambient.Font
  133. Const mDef_HoverColor = vbHighlight
  134.  
  135.  
  136. ' Enumeraciones Publicas
  137. ' *******************
  138.  
  139. Public Enum b2kClickReason
  140.    b2kReasonMouse
  141.    b2kReasonAccessKey
  142.    b2kReasonKeyboard
  143. End Enum
  144.  
  145. ' Eventos
  146. ' ******
  147.  
  148. Event Click(ByVal ClickReason As b2kClickReason)
  149.  
  150.  
  151. Private Sub picIcon_Click()
  152.    RaiseEvent Click(b2kReasonMouse)
  153. End Sub
  154.  
  155. Private Sub picIcon_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  156.    UserControl_MouseDown Button, Shift, -1, -1
  157. End Sub
  158.  
  159. Private Sub picIcon_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  160.    UserControl_MouseUp Button, Shift, -1, -1
  161. End Sub
  162.  
  163. Private Sub tmrHighlight_Timer()
  164.    Dim pntCursor As POINTAPI
  165.     
  166.    apiGetCursorPos pntCursor
  167.    If apiWindowFromPoint(pntCursor.x, pntCursor.y) = hwnd Then
  168.       If Not mbHasCapture Then
  169.          Call ApplyProperties(apyDrawBorder)
  170.          lblCaption.ForeColor = mProp_HoverColor
  171.          mbHasCapture = True
  172.       End If
  173.    Else
  174.       If mbHasCapture Then
  175.          Line (0, 0)-(ScaleWidth - 1, ScaleHeight - 1), mProp_BackColor, B
  176.          lblCaption.ForeColor = mProp_ForeColor
  177.          mbHasCapture = False
  178.       End If
  179.    End If
  180. End Sub
  181.  
  182. Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
  183.    RaiseEvent Click(b2kReasonAccessKey)
  184. End Sub
  185.  
  186. Private Sub UserControl_Click()
  187.    RaiseEvent Click(b2kReasonMouse)
  188. End Sub
  189.  
  190. Private Sub UserControl_EnterFocus()
  191.    Dim rctFocus As RECT
  192.    
  193.    If Not mProp_FocusRect Then Exit Sub
  194.    
  195.    rctFocus.Left = 3
  196.    rctFocus.Top = 3
  197.    rctFocus.Right = ScaleWidth - 3
  198.    rctFocus.Bottom = ScaleHeight - 3
  199.    apiDrawFocusRect hdc, rctFocus
  200.    Refresh
  201.       
  202. End Sub
  203.  
  204. Private Sub UserControl_ExitFocus()
  205.    If mProp_FocusRect Then Line (3, 3)-(ScaleWidth - 4, ScaleHeight - 4), mProp_BackColor, B
  206. End Sub
  207.  
  208. Private Sub UserControl_Initialize()
  209.    AutoRedraw = True
  210.    ScaleMode = vbPixels
  211.    lblCaption.Alignment = vbCenter
  212.    lblCaption.AutoSize = True
  213.    lblCaption.BackStyle = vbTransparent
  214.    lblCaption.ForeColor = vbButtonText
  215.    tmrHighlight.Enabled = False
  216.    tmrHighlight.Interval = 1
  217. End Sub
  218.  
  219. Private Sub UserControl_InitProperties()
  220.    Width = 1215
  221.    Height = 375
  222.    
  223.    mProp_AlwaysHighlighted = mDef_AlwaysHighlighted
  224.    mProp_BackColor = mDef_BackColor
  225.    mProp_ForeColor = mDef_ForeColor
  226.    mProp_Caption = mDef_Caption
  227.    mProp_Enabled = mDef_Enabled
  228.    mProp_FocusRect = mDef_FocusRect
  229.    Set mProp_Font = Ambient.Font
  230.    mProp_HoverColor = mDef_HoverColor
  231.    
  232.    Call ApplyProperties(apyAll)
  233. End Sub
  234.  
  235. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  236.    mProp_AlwaysHighlighted = PropBag.ReadProperty("AlwaysHighlighted", mDef_AlwaysHighlighted)
  237.    mProp_BackColor = PropBag.ReadProperty("BackColor", mDef_BackColor)
  238.    mProp_Caption = PropBag.ReadProperty("Caption", mDef_Caption)
  239.    mProp_Enabled = PropBag.ReadProperty("Enabled", mDef_Enabled)
  240.    mProp_FocusRect = PropBag.ReadProperty("FocusRect", mDef_FocusRect)
  241.    Set mProp_Font = PropBag.ReadProperty("Font", Ambient.Font)
  242.    mProp_HoverColor = PropBag.ReadProperty("HoverColor", mDef_HoverColor)
  243.    mProp_ForeColor = PropBag.ReadProperty("ForeColor", mDef_ForeColor)
  244.    Set mprop_ButtonIcon = PropBag.ReadProperty("ButtonIcon", Nothing)
  245.    Call ApplyProperties(apyAll)
  246.    
  247.    If Ambient.UserMode Then
  248.       If mProp_AlwaysHighlighted Then
  249.          Call ApplyProperties(apyDrawBorder)
  250.       Else
  251.          tmrHighlight = True
  252.       End If
  253.    End If
  254. End Sub
  255.  
  256. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  257.    With PropBag
  258.       .WriteProperty "AlwaysHighlighted", mProp_AlwaysHighlighted, mDef_AlwaysHighlighted
  259.       .WriteProperty "BackColor", mProp_BackColor, mDef_BackColor
  260.       .WriteProperty "Caption", mProp_Caption, mDef_Caption
  261.       .WriteProperty "Enabled", mProp_Enabled, mDef_Enabled
  262.       .WriteProperty "FocusRect", mProp_FocusRect, mDef_FocusRect
  263.       .WriteProperty "Font", mProp_Font, Ambient.Font
  264.       .WriteProperty "HoverColor", mProp_HoverColor, mDef_HoverColor
  265.       .WriteProperty "ForeColor", mProp_ForeColor, mDef_ForeColor
  266.       .WriteProperty "ButtonIcon", mprop_ButtonIcon, Nothing
  267.    End With
  268. End Sub
  269.  
  270. Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  271.    If KeyCode = vbKeySpace Or KeyCode = vbKeyReturn Then
  272.       UserControl_MouseDown -2, -2, -2, -2
  273.    End If
  274. End Sub
  275.  
  276. Private Sub UserControl_KeyPress(KeyAscii As Integer)
  277.    If KeyAscii = vbKeySpace Or KeyAscii = vbKeyReturn Then
  278.       RaiseEvent Click(b2kReasonKeyboard)
  279.    End If
  280. End Sub
  281.  
  282. Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
  283.    If KeyCode = vbKeySpace Or KeyCode = vbKeyReturn Then
  284.       UserControl_MouseUp -2, -2, -2, -2
  285.    End If
  286. End Sub
  287.  
  288. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  289.    Dim rctBtn As RECT
  290.    Dim dwRetVal As Long
  291.    
  292.    tmrHighlight.Enabled = False
  293.    lblCaption.Left = mpntLabelPos.x + 1
  294.    lblCaption.Top = mpntLabelPos.y + 1
  295.    Line (0, 0)-(Width, Height), mProp_BackColor, B
  296.    
  297.    rctBtn.Left = 0
  298.    rctBtn.Top = 0
  299.    rctBtn.Right = ScaleWidth
  300.    rctBtn.Bottom = ScaleHeight
  301.    
  302.    dwRetVal = apiDrawEdge(hdc, rctBtn, BDR_MOUSEDOWN, BF_RECT)
  303. End Sub
  304.  
  305. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  306.    Dim pntCursor As POINTAPI
  307.    
  308.    lblCaption.Left = mpntLabelPos.x
  309.    lblCaption.Top = mpntLabelPos.y
  310.    
  311.    apiGetCursorPos pntCursor
  312.    If apiWindowFromPoint(pntCursor.x, pntCursor.y) = hwnd Or mProp_AlwaysHighlighted Then
  313.       Call ApplyProperties(apyDrawBorder)
  314.       mbHasCapture = True
  315.    Else
  316.       Line (0, 0)-(ScaleWidth - 1, ScaleHeight - 1), mProp_BackColor, B
  317.       mbHasCapture = False
  318.    End If
  319.    
  320.    If Not mProp_AlwaysHighlighted Then tmrHighlight.Enabled = True
  321. End Sub
  322.  
  323. Private Sub lblCaption_Click()
  324.    RaiseEvent Click(b2kReasonMouse)
  325. End Sub
  326.  
  327. Private Sub lblCaption_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  328.    UserControl_MouseDown Button, Shift, -1, -1
  329. End Sub
  330.  
  331. Private Sub lblCaption_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  332.    UserControl_MouseUp Button, Shift, -1, -1
  333. End Sub
  334.  
  335. Private Sub UserControl_Resize()
  336.    Dim rctBtn As RECT
  337.    Dim dwRetVal As Long
  338.    Static sbFirstTime As Boolean
  339.    
  340.    If Not sbFirstTime Then
  341.       sbFirstTime = True
  342.    Else
  343.       Cls
  344.    End If
  345.    
  346.    lblCaption.AutoSize = False
  347.    lblCaption.Top = (ScaleHeight / 2) - (lblCaption.Height / 2)
  348.    lblCaption.Left = 1
  349.    lblCaption.Width = ScaleWidth - 2
  350.    
  351.    picIcon.Left = lblCaption.Left + 4
  352.    picIcon.Top = lblCaption.Top - 2
  353.       
  354.    
  355.    If Not Ambient.UserMode Or mProp_AlwaysHighlighted Then
  356.       Call ApplyProperties(apyDrawBorder)
  357.    End If
  358.    
  359.    mpntLabelPos.x = lblCaption.Left
  360.    mpntLabelPos.y = lblCaption.Top
  361.    mpntOldSize.x = ScaleWidth
  362.    mpntOldSize.y = ScaleHeight
  363.    
  364.    
  365. End Sub
  366.  
  367. ' Private Procedures
  368. ' ******************
  369.  
  370. Private Sub ApplyProperties(ByVal apyWhatToApply As htWhatToApply)
  371.    Dim rctBtn As RECT
  372.    Dim dwRetVal As Long
  373.    Dim n As Long
  374.    
  375.    If (apyWhatToApply And apyBackColor) Then UserControl.BackColor = mProp_BackColor
  376.    If (apyWhatToApply And apyForeColor) Then lblCaption.ForeColor = mProp_ForeColor
  377.    If (apyWhatToApply And apyCaption) Then
  378.       lblCaption.Caption = mProp_Caption
  379.       AccessKeys = ""
  380.       For n = Len(mProp_Caption) To 1 Step -1
  381.          If Mid$(mProp_Caption, n, 1) = "&" Then
  382.             If n = 1 Then
  383.                AccessKeys = Mid$(mProp_Caption, n + 1, 1)
  384.             ElseIf Not Mid$(mProp_Caption, n - 1, 1) = "&" Then
  385.                AccessKeys = Mid$(mProp_Caption, n + 1, 1)
  386.                Exit For
  387.             Else
  388.                n = n - 1
  389.             End If
  390.          End If
  391.       Next n
  392.    End If
  393.    
  394.    If (apyWhatToApply And apyFont) Then
  395.       Set UserControl.Font = mProp_Font
  396.       lblCaption.AutoSize = True
  397.       Set lblCaption.Font = mProp_Font
  398.       lblCaption.AutoSize = False
  399.       lblCaption.Top = (ScaleHeight / 2) - (lblCaption.Height / 2)
  400.       lblCaption.Left = 1
  401.       lblCaption.Width = ScaleWidth - 2
  402.       Set picIcon.Picture = mprop_ButtonIcon
  403.    End If
  404.                   
  405.    If (apyWhatToApply And apyEnabled) Then
  406.       If Ambient.UserMode Then
  407.          lblCaption.Enabled = mProp_Enabled
  408.          UserControl.Enabled = mProp_Enabled
  409.       End If
  410.    End If
  411.                   
  412.    If (apyWhatToApply And apyDrawBorder) Then
  413.       Line (0, 0)-(Width, Height), mProp_BackColor, B
  414.       rctBtn.Left = 0
  415.       rctBtn.Top = 0
  416.       rctBtn.Right = ScaleWidth
  417.       rctBtn.Bottom = ScaleHeight
  418.       
  419.       dwRetVal = apiDrawEdge(hdc, rctBtn, BDR_MOUSEOVER, BF_RECT)
  420.    End If
  421. End Sub
  422.  
  423.  
  424. Public Property Get AlwaysHighlighted() As Boolean
  425.    AlwaysHighlighted = mProp_AlwaysHighlighted
  426. End Property
  427.  
  428. Public Property Let AlwaysHighlighted(ByVal bNewValue As Boolean)
  429.    If Ambient.UserMode Then
  430.       Err.Raise 383
  431.    Else
  432.       mProp_AlwaysHighlighted = bNewValue
  433.       PropertyChanged "AlwaysHighlighted"
  434.    End If
  435. End Property
  436.  
  437. Public Property Get BackColor() As OLE_COLOR
  438.    BackColor = mProp_BackColor
  439. End Property
  440.  
  441. Public Property Let BackColor(ByVal oleNewValue As OLE_COLOR)
  442.    mProp_BackColor = oleNewValue
  443.    Call ApplyProperties(apyBackColor Or apyDrawBorder)
  444.    PropertyChanged "BackColor"
  445. End Property
  446.  
  447. Public Property Get ForeColor() As OLE_COLOR
  448.    ForeColor = mProp_ForeColor
  449. End Property
  450.  
  451. Public Property Let ForeColor(ByVal oleNewValue As OLE_COLOR)
  452.    mProp_ForeColor = oleNewValue
  453.    Call ApplyProperties(apyForeColor Or apyDrawBorder)
  454.    PropertyChanged "ForeColor"
  455. End Property
  456.  
  457.  
  458. Public Property Get Caption() As String
  459.    Caption = mProp_Caption
  460. End Property
  461.  
  462. Public Property Let Caption(ByVal sNewValue As String)
  463.    mProp_Caption = sNewValue
  464.    Call ApplyProperties(apyCaption)
  465.    PropertyChanged "Caption"
  466. End Property
  467.  
  468. Public Property Get FocusRect() As Boolean
  469.    FocusRect = mProp_FocusRect
  470. End Property
  471.  
  472. Public Property Let FocusRect(ByVal bNewValue As Boolean)
  473.    If Ambient.UserMode Then
  474.       Err.Raise 383
  475.    Else
  476.       mProp_FocusRect = bNewValue
  477.       PropertyChanged "FocusRect"
  478.    End If
  479. End Property
  480.  
  481. Public Property Get Font() As StdFont
  482.    Set Font = mProp_Font
  483. End Property
  484.  
  485. Public Property Set Font(ByVal fntNewValue As StdFont)
  486.    Set mProp_Font = fntNewValue
  487.    Call ApplyProperties(apyFont)
  488.    PropertyChanged "Font"
  489. End Property
  490.  
  491. Public Property Get Enabled() As Boolean
  492.    Enabled = mProp_Enabled
  493. End Property
  494.  
  495. Public Property Let Enabled(ByVal bNewValue As Boolean)
  496.    mProp_Enabled = bNewValue
  497.    Call ApplyProperties(apyEnabled)
  498.    PropertyChanged "Enabled"
  499. End Property
  500.  
  501. Public Property Get HoverColor() As OLE_COLOR
  502.    HoverColor = mProp_HoverColor
  503. End Property
  504.  
  505. Public Property Let HoverColor(ByVal oleNewValue As OLE_COLOR)
  506.    mProp_HoverColor = oleNewValue
  507.    PropertyChanged "HoverColor"
  508. End Property
  509.  
  510.  
  511. Public Property Get ButtonIcon() As StdPicture
  512.    Set ButtonIcon = mprop_ButtonIcon
  513. End Property
  514.  
  515. Public Property Set ButtonIcon(ByVal stdNewValue As StdPicture)
  516.    Set mprop_ButtonIcon = stdNewValue
  517.    PropertyChanged "ButtonIcon"
  518.    Set picIcon.Picture = mprop_ButtonIcon
  519. End Property
  520.  
  521.