Soyez le premier à donner votre avis sur cette source.
Snippet vu 7 891 fois - Téléchargée 82 fois
Option Explicit ' **************************************************************************** ' *** CONTROLE IconLabel ******************************************* v1.00 *** ' **************************************************************************** ' *** DESCRIPTION: *** ' ***----------------------------------------------------------------------*** ' *** Label avec icône (comme dans Outlook). *** ' **************************************************************************** ' *** PROPRIETES: *** ' ***----------------------------------------------------------------------*** ' *** [RW] BackColor *** ' *** [RW] BorderSize *** ' *** [RW] Caption *** ' *** [RW] CaptionAlignment *** ' *** [RW] Enabled *** ' *** [RW] Font *** ' *** [RW] ForeColor *** ' *** [RW] Icon *** ' *** [RW] IconAlignment *** ' *** [RW] IconStretch *** ' **************************************************************************** ' *** EVENEMENTS: *** ' ***----------------------------------------------------------------------*** ' *** -= C'est un label ... =- *** ' **************************************************************************** ' *** 1.00: Première version. *** ' **************************************************************************** ' *** (c) 2000 FlyKiller. All Rights Reserved. Can Be Distributed Freely. *** ' **************************************************************************** Private Const P_BC As String = "BackColor" Private Const P_BS As String = "BorderSize" Private Const P_C As String = "Caption" Private Const P_CA As String = "CaptionAlignment" Private Const P_F As String = "Font" Private Const P_FC As String = "ForeColor" Private Const P_I As String = "Icon" Private Const P_IA As String = "IconAlignment" Private Const P_IS As String = "IconStretch" Public Enum ilIconAlignments iliaLeft = 0 iliaRight = 1 End Enum Public Enum ilCaptionAlignments ilcaLeft = 0 ilcaCenter = 1 ilcaRight = 2 End Enum Private mBS As Integer ' Propriété BorderSize Private mC As String ' Propriété Caption Private mCA As ilCaptionAlignments ' Propriété CaptionAlignment Private mI As IPictureDisp ' Propriété Icon Private mIA As ilIconAlignments ' Propriété IconAlignment Private mIS As Boolean ' Propriété IconStretch ' **************************************************************************** ' *** PROPRIETE BackColor **************************************************** ' **************************************************************************** Public Property Get BackColor() As OLE_COLOR BackColor = UserControl.BackColor End Property Public Property Let BackColor(ByVal RHS As OLE_COLOR) UserControl.BackColor = RHS UserControl.PropertyChanged P_BC UserControl.Refresh End Property ' **************************************************************************** ' *** PROPRIETE BorderSize *************************************************** ' **************************************************************************** Public Property Get BorderSize() As Integer BorderSize = mBS End Property Public Property Let BorderSize(ByVal RHS As Integer) mBS = RHS UserControl.PropertyChanged P_BS UserControl.Refresh End Property ' **************************************************************************** ' *** PROPRIETE Caption ****************************************************** ' **************************************************************************** Public Property Get Caption() As String Caption = mC End Property Public Property Let Caption(ByVal RHS As String) mC = RHS UserControl.PropertyChanged P_C UserControl.Refresh End Property ' **************************************************************************** ' *** PROPRIETE CaptionAlignment ********************************************* ' **************************************************************************** Public Property Get CaptionAlignment() As ilCaptionAlignments CaptionAlignment = mCA End Property Public Property Let CaptionAlignment(ByVal RHS As ilCaptionAlignments) mCA = RHS UserControl.PropertyChanged P_CA UserControl.Refresh End Property ' **************************************************************************** ' *** PROPRIETE Font ********************************************************* ' **************************************************************************** Public Property Get Font() As IFontDisp Set Font = UserControl.Font End Property Public Property Set Font(ByVal RHS As IFontDisp) Set UserControl.Font = RHS UserControl.PropertyChanged P_F UserControl.Refresh End Property ' **************************************************************************** ' *** PROPRIETE ForeColor **************************************************** ' **************************************************************************** Public Property Get ForeColor() As OLE_COLOR ForeColor = UserControl.ForeColor End Property Public Property Let ForeColor(ByVal RHS As OLE_COLOR) UserControl.ForeColor = RHS UserControl.PropertyChanged P_FC UserControl.Refresh End Property ' **************************************************************************** ' *** PROPRIETE Icon ********************************************************* ' **************************************************************************** Public Property Get Icon() As IPictureDisp Set Icon = mI End Property Public Property Set Icon(ByVal RHS As IPictureDisp) Set mI = RHS UserControl.PropertyChanged P_I UserControl.Refresh End Property ' **************************************************************************** ' *** PROPRIETE IconAlignment ************************************************ ' **************************************************************************** Public Property Get IconAlignment() As ilIconAlignments IconAlignment = mIA End Property Public Property Let IconAlignment(ByVal RHS As ilIconAlignments) mIA = RHS UserControl.PropertyChanged P_IA UserControl.Refresh End Property ' **************************************************************************** ' *** PROPRIETE IconStretch ************************************************** ' **************************************************************************** Public Property Get IconStretch() As Boolean IconStretch = mIS End Property Public Property Let IconStretch(ByVal RHS As Boolean) mIS = RHS UserControl.PropertyChanged P_IS UserControl.Refresh End Property ' **************************************************************************** ' *** SUB InitProperties ***************************************************** ' **************************************************************************** Private Sub UserControl_InitProperties() ' UserControl.BackColor = .ReadProperty(P_BC, UserControl.BackColor) mBS = 2 mC = "" mCA = ilCaptionAlignments.ilcaLeft ' Set UserControl.Font = .ReadProperty(P_F, UserControl.Font) ' UserControl.ForeColor = .ReadProperty(P_FC, UserControl.ForeColor) Set mI = Nothing mIA = ilIconAlignments.iliaLeft mIS = True End Sub ' **************************************************************************** ' *** SUB Paint ************************************************************** ' **************************************************************************** Private Sub UserControl_Paint() Dim SH As Single ' UserControl - ScaleHeight Dim SW As Single ' UserControl - ScaleWidth Dim IL As Single ' Icon - Left Dim IT As Single ' Icon - Top Dim IW As Single ' Icon - Width Dim IH As Single ' Icon - Height Dim ZF As Single ' Zoom Factor: si IH < UC.ScaleHeight + (MBS*2) Dim CL As Single ' Caption - Left Dim CT As Single ' Caption - Top Dim CW As Single ' Caption - Width Dim CH As Single ' Caption - Height With UserControl SH = .ScaleHeight SW = .ScaleWidth ' ========================================================================== ' === Dessiner l'icône ===================================================== ' ========================================================================== If Not (mI Is Nothing) Then IW = .ScaleX(mI.Width, vbHimetric, .ScaleMode) IH = .ScaleY(mI.Height, vbHimetric, .ScaleMode) If ((SH - (mBS * 2)) < IH) And (mIS = True) Then ZF = (SH - (mBS * 2)) / IH IH = IH * ZF IW = IW * ZF IT = mBS Else IT = (SH - IH) / 2 End If If mIA = iliaLeft Then IL = mBS Else IL = SW - (IW + mBS) End If .PaintPicture mI, IL, IT, IW, IH End If ' ======================================================================== ' === Dessiner le texte ================================================== ' ======================================================================== If Len(mC) > 0 Then CW = .TextWidth(mC) CH = .TextHeight(mC) CT = (SH - CH) / 2 If mCA = ilcaLeft Then If mIA = iliaLeft Then CL = IL + IW + mBS Else CL = mBS End If ElseIf mCA = ilcaCenter Then CL = (SW - CW) / 2 Else If mIA = iliaRight Then CL = SW - (IW + CW + mBS * 2) Else CL = SW - (CW + mBS) End If End If .CurrentX = CL .CurrentY = CT Print mC End If End With End Sub ' **************************************************************************** ' *** SUB ReadProperties ***************************************************** ' **************************************************************************** Private Sub UserControl_ReadProperties(PropBag As PropertyBag) With PropBag UserControl.BackColor = .ReadProperty(P_BC, UserControl.BackColor) mBS = .ReadProperty(P_BS, 2) mC = .ReadProperty(P_C, "") mCA = .ReadProperty(P_CA, ilCaptionAlignments.ilcaLeft) Set UserControl.Font = .ReadProperty(P_F, UserControl.Font) UserControl.ForeColor = .ReadProperty(P_FC, UserControl.ForeColor) Set mI = .ReadProperty(P_I, Nothing) mIA = .ReadProperty(P_IA, ilIconAlignments.iliaLeft) mIS = .ReadProperty(P_IS, True) End With End Sub ' **************************************************************************** ' *** SUB WriteProperties **************************************************** ' **************************************************************************** Private Sub UserControl_WriteProperties(PropBag As PropertyBag) With PropBag .WriteProperty P_BC, UserControl.BackColor .WriteProperty P_BS, mBS .WriteProperty P_C, mC .WriteProperty P_CA, mCA .WriteProperty P_F, UserControl.Font .WriteProperty P_FC, UserControl.ForeColor .WriteProperty P_I, mI .WriteProperty P_IA, mIA .WriteProperty P_IS, mIS End With End Sub
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.