Soyez le premier à donner votre avis sur cette source.
Snippet vu 14 726 fois - Téléchargée 87 fois
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
Thanks d'avance Shad20020
Un zip serait plus pratique aussi.
Super quand même !!!
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.