Contrôle label/icône (comme dans outlook)

Commenter

Contenu du snippet

Le titre parle de lui-même je pense. Si toutefois, vous avez des questions n'hésitez pas à me les poser.

Créer un usercontrol et copier le code ci-dessous dans le user control. Bon amusement!

Source / Exemple : 


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

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)