Bouton graphique (version 1 alpha)

Commenter

Contenu du snippet

voici un petit controle qui vous permet d'avoir des boutons un peu plus jolis que les standards.

Pour l'utiliser, copier le source et sauver-le avec notepad sous le nom LeNom.ctl

Source / Exemple : 


VERSION 5.00
Begin VB.UserControl FlyButton 
   Alignable       =   -1  'True
   ClientHeight    =   540
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1080
   DefaultCancel   =   -1  'True
   ScaleHeight     =   36
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   72
End
Attribute VB_Name = "SBoButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Enum ControlTypes
  ctCommandButton
  ctProgressBar
End Enum
Private mCB As OLE_COLOR ' Color Back
Private mCL As OLE_COLOR ' Color Light
Private mCS As OLE_COLOR ' Color Shade
Private mCT As OLE_COLOR ' Color Text
Private mBS As Integer ' Border Size
Private mCaption As Variant
Private mPushed As Boolean
Public Event Click()
Public Event DblClick()
Private mCtlT As ControlTypes

' ****************************************************************************
' *** PROPRIETE ControlType **************************************************
' ****************************************************************************
Public Property Get ControlType() As ControlTypes
  ControlType = mCtlT
End Property
Public Property Let ControlType(ByVal RHS As ControlTypes)
  mCtlT = RHS
  If RHS = ctProgressBar Then Caption = 0
  PropertyChanged "ControlType"
  Refresh
End Property

' ****************************************************************************
' *** PROPRIETE Enabled ******************************************************
' ****************************************************************************
Public Property Get Enabled() As Boolean
  Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal RHS As Boolean)
  UserControl.Enabled = RHS
  PropertyChanged "Enabled"
  Refresh
End Property

' ****************************************************************************
' *** PROPRIETE ColorBack ****************************************************
' ****************************************************************************
Public Property Get ColorBack() As OLE_COLOR
  ColorBack = mCB
End Property
Public Property Let ColorBack(ByVal RHS As OLE_COLOR)
  mCB = RHS
  PropertyChanged "ColorBack"
  Refresh
End Property

' ****************************************************************************
' *** PROPRIETE ColorLight ***************************************************
' ****************************************************************************
Public Property Get ColorLight() As OLE_COLOR
  ColorLight = mCL
End Property
Public Property Let ColorLight(ByVal RHS As OLE_COLOR)
  mCL = RHS
  PropertyChanged "ColorLight"
  Refresh
End Property

' ****************************************************************************
' *** PROPRIETE ColorShade ***************************************************
' ****************************************************************************
Public Property Get ColorShade() As OLE_COLOR
  ColorShade = mCS
End Property
Public Property Let ColorShade(ByVal RHS As OLE_COLOR)
  mCS = RHS
  PropertyChanged "ColorShade"
  Refresh
End Property

' ****************************************************************************
' *** PROPRIETE ColorText ****************************************************
' ****************************************************************************
Public Property Get ColorText() As OLE_COLOR
  ColorText = mCT
End Property
Public Property Let ColorText(ByVal RHS As OLE_COLOR)
  mCT = RHS
  PropertyChanged "ColorText"
  Refresh
End Property

' ****************************************************************************
' *** PROPRIETE BorderSize ***************************************************
' ****************************************************************************
' * The real border size is the border size value + 2                        *
' ****************************************************************************
Public Property Get BorderSize() As Integer
  BorderSize = mBS
End Property
Public Property Let BorderSize(ByVal RHS As Integer)
  If RHS < (UserControl.ScaleHeight / 2) Then mBS = RHS
  PropertyChanged "BorderSize"
  Refresh
End Property

' ****************************************************************************
' *** PROPRIETE Caption ******************************************************
' ****************************************************************************
Public Property Get Caption() As Variant
  Caption = mCaption
End Property
Public Property Let Caption(ByVal RHS As Variant)
  If mCtlT = ctProgressBar Then
    If IsNumeric(RHS) = False Then Exit Property
    If (RHS < 0) Or (RHS > 100) Then Exit Property
  End If
  mCaption = RHS
  PropertyChanged "Caption"
  Refresh
End Property

Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
  If mCtlT = ctCommandButton Then RaiseEvent Click
End Sub

Private Sub UserControl_Click()
  If mCtlT = ctCommandButton Then RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
  If mCtlT = ctCommandButton Then RaiseEvent DblClick
End Sub

' ****************************************************************************
' *** PROCEDURE MouseDown ****************************************************
' ****************************************************************************
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If (UserControl.Enabled = True) And (mCtlT = ctCommandButton) Then
    mPushed = True
    Refresh
  End If
End Sub

' ****************************************************************************
' *** PROCEDURE MouseUp ******************************************************
' ****************************************************************************
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If (UserControl.Enabled = True) And (mCtlT = ctCommandButton) Then
    mPushed = False
    Refresh
  End If
End Sub

' ****************************************************************************
' *** PROCEDURE Paint ********************************************************
' ****************************************************************************
Private Sub UserControl_Paint()
Dim CBR As Integer, CBG As Integer, CBB As Integer
Dim ULR As Integer, ULG As Integer, ULB As Integer
Dim dULR As Integer, dULG As Integer, dULB As Integer
Dim DRR As Integer, DRG As Integer, DRB As Integer
Dim dDRR As Integer, dDRG As Integer, dDRB As Integer
Dim X As Integer
Dim HalfWidth As Single, HalfHeight As Single
Dim OrgX As Single, OrgY As Single

  With UserControl
    ' ========================================================================
    ' === Dessin du relief du bouton =========================================
    ' ========================================================================
    ' --- Calculer les Delta des couleurs ------------------------------------
    SplitColor mCB, CBR, CBG, CBB
'    If (mBS = 0) Or (UserControl.Enabled = False) Then
    If (mBS = 0) Then
      SplitColor mCB, ULR, ULG, ULB
      SplitColor mCB, DRR, DRG, DRB
      dULR = 0: dULG = 0: dULB = 0
      dDRR = 0: dDRG = 0: dDRB = 0
    Else
      If mPushed = True Then
        SplitColor mCS, ULR, ULG, ULB
        SplitColor mCL, DRR, DRG, DRB
      Else
        SplitColor mCL, ULR, ULG, ULB
        SplitColor mCS, DRR, DRG, DRB
      End If
      dULR = (CBR - ULR) / mBS: dULG = (CBG - ULG) / mBS: dULB = (CBB - ULB) / mBS
      dDRR = (CBR - DRR) / mBS: dDRG = (CBG - DRG) / mBS: dDRB = (CBB - DRB) / mBS
    End If
    
    ' --- Dessiner le relief -------------------------------------------------
    .BackColor = mCB
    For X = 1 To mBS
      Line (X - 1, X - 1)-(.ScaleWidth - (X - 1), X - 1), RGB(ULR, ULG, ULB)
      Line (X - 1, .ScaleHeight - X)-(X - 1, X - 1), RGB(ULR, ULG, ULB)
      Line (.ScaleWidth - X, .ScaleHeight - X)-(.ScaleWidth - X, (X - 1)), RGB(DRR, DRG, DRB)
      Line (.ScaleWidth - X, .ScaleHeight - X)-(X - 1, .ScaleHeight - X), RGB(DRR, DRG, DRB)
      ULR = ULR + dULR: ULG = ULG + dULG: ULB = ULB + dULB
      DRR = DRR + dDRR: DRG = DRG + dDRG: DRB = DRB + dDRB
    Next
    
    If mCtlT = ctProgressBar Then
      Line (.ScaleWidth * mCaption / 100, 0)-(.ScaleWidth, .ScaleHeight), mCS, BF
    End If
    ' ========================================================================
    ' === Dessin du caption du bouton ========================================
    ' ========================================================================
    If (Len(mCaption) > 0) And (mCtlT = ctCommandButton) Then
      HalfWidth = TextWidth(mCaption) / 2
      HalfHeight = TextHeight(mCaption) / 2
      OrgX = ScaleWidth / 2 - HalfWidth
      OrgY = ScaleHeight / 2 - HalfHeight
      If UserControl.Enabled Then
        UserControl.ForeColor = mCT
      Else
        UserControl.ForeColor = mCS
      End If
      UserControl.CurrentY = OrgY
      If mPushed = False Then
        UserControl.CurrentX = OrgX
      Else
        UserControl.CurrentX = OrgX + ScaleX(1, vbPixels, ScaleMode)
      End If
      Print mCaption
    End If
  End With
End Sub

' ****************************************************************************
' *** PROCEDURE ReadProperties ***********************************************
' ****************************************************************************
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  With PropBag
    mCB = .ReadProperty("ColorBack", &HC0C0C0)
    mCL = .ReadProperty("ColorLight", &HFFFFFF)
    mCS = .ReadProperty("ColorShade", &H808080)
    mCT = .ReadProperty("ColorText", 0)
    mBS = .ReadProperty("BorderSize", 10)
    mCaption = .ReadProperty("Caption", "")
    mCtlT = .ReadProperty("ControlType", ControlTypes.ctCommandButton)
    UserControl.Enabled = .ReadProperty("Enabled", True)
  End With
End Sub

' ****************************************************************************
' *** PROCEDURE InitProperties ***********************************************
' ****************************************************************************
Private Sub UserControl_InitProperties()
  mCB = &HC0C0C0
  mCL = &HFFFFFF
  mCS = &H808080
  mCT = 0
  mBS = 10
  mCaption = ""
  mCtlT = ctCommandButton
  UserControl.Enabled = True
End Sub

' ****************************************************************************
' *** PROCEDURE WriteProperties **********************************************
' ****************************************************************************
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  With PropBag
    .WriteProperty "ColorBack", mCB
    .WriteProperty "ColorLight", mCL
    .WriteProperty "ColorShade", mCS
    .WriteProperty "ColorText", mCT
    .WriteProperty "BorderSize", mBS
    .WriteProperty "Caption", mCaption
    .WriteProperty "ControlType", mCtlT
    .WriteProperty "Enabled", UserControl.Enabled
  End With
End Sub

' ****************************************************************************
' *** PROCEDURE SplitColor ***************************************************
' ****************************************************************************
Private Sub SplitColor(ByVal RGBColor As OLE_COLOR, _
                       ByRef RColor As Integer, _
                       ByRef GColor As Integer, _
                       ByRef BColor As Integer)
  RColor = (RGBColor And &HFF)
  GColor = ((RGBColor \ &H100) And &HFF)
  BColor = ((RGBColor \ &H10000) And &HFF)
End Sub

Conclusion :


La version finale (que j'ai perdue...) permettra à ce bouton de faire office de CommandButton, ProgressBar, CheckButton, OptionButton. Restez donc à l'écoute...

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_FlyKiller)