L'ocx du futur (multi conteneur, multi utilisation) dans le style du menu outlook ou spybot

Télécharger le projet
Commenter

Description

Ce controle a pour origine le besoin de créer un menu souple, limité par la place et ergonomique.

Il s'inspire du fonctionnement du menu de Spybot ou encore d'Outlook 2000 tout en offrant infiniment plus de souplesse puisqu'il sert de multi-conteneur. Libre à vous de mettre tout ce qui vous passe par la tête (comme un SSTab).

Source / Exemple : 


'##########################################################################
'#                                                                        #
'#  Contrôle  k3moTabs                                     Version 1.0    #
'#  >> kemo@altern.org                                     (30/06/2001)   #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  Description                                                           #
'#  -----------                                                           #
'#                                                                        #
'#  Un contrôle avec système de pseudo multi-conteneurs dans le style     #
'#  SSTab avec une interface proche du menu d'Outlook.                    #
'#                                                                        #
'#  Note : Il est impératif de ne pas toucher à la propriété TAG des      #
'#         contrôles que vous insérez sur le contrôle activeX.            #
'#         Cette propriété est utilisée afin de savoir à quelle tab       #
'#         elle appartient et quelle est sa position.                     #
'#                                                                        #
'#  Note2: Les contrôles windowless (comme les shapes) ne sont pas        #
'#         encore supportés.                                              #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  License                                                               #
'#  -------                                                               #
'#                                                                        #
'#  Ce contrôle est en OpenSource, vous pouvez l'utiliser, le             #
'#  diffuser et le modifier en toute liberté.                             #
'#                                                                        #
'#  La responsabilité de l'auteur ne peut être engagée en cas             #
'#  de disfonctionnement d'un programme utilisant ce contrôle.            #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  Historique                                                            #
'#  ----------                                                            #
'#                                                                        #
'#  30/06/2004 -  Première version officielle                             #
'#  25/06/2004 -  Début du projet                                         #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  Evolutions à prévoir                                                  #
'#  --------------------                                                  #
'#                                                                        #
'#  -Trop nombreuses pour l'instant-                                      #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  Remerciements                                                         #
'#  -------------                                                         #
'#                                                                        #
'#  -Raph 'merci de rien'                                                 #
'#  -CodesSource pour leurs excellents sites                              #
'#  -keh0ps pour son aide                                                 #
'#  -Cyril VALLOD et son KLBTab (www.vbfrance.com/article.aspx?ID=1556)   #
'#                                                                        #
'##########################################################################
Option Explicit
Option Base 1

' Structures --------------------------------------------------------------
Enum EnumState           ' State de la tab
    KTab_MINIMIZED = 0
    KTab_NORMAL = 1
    KTab_MAXIMIZED = 2
End Enum

Private Type tKTab       ' Défini les tabs
    Libelle As String
    State As EnumState
    Top As Integer
    Height As Integer
    Opened As Boolean
    Visible As Boolean
End Type

' Les propriétés -----------------------------------------------------------------
Private KTab() As tKTab                         ' Les KTabs
Private intCurrentTab As Integer                ' La KTab sélectionnée
Private intButtonHeight As Integer              ' La hauteur des boutons
Private bolMaximized As Boolean                 ' Si une des tabs est maximizée
Private bolInitialized As Boolean               ' Si controle initialisé
Private clrButtonBackColor As OLE_COLOR         ' Couleur de fond du bouton
Private clrBackColor As OLE_COLOR               ' Couleur de font du bouton
Private WithEvents fntButtonFont As StdFont     ' Font
Attribute fntButtonFont.VB_VarHelpID = -1

' Les propriétés par défaut ----------------------------------------------------------
Const DefTabs = 1
Const DefCurrentTab = 1             ' La KTab sélectionnée
Const DefButtonHeight = 300         ' La hauteur des boutons
Const DefButtonColor = &H8000000F   ' Couleur de fond du bouton
Const DefBackColor = &H80000005     ' Couleur de fond du bouton
Const DefFontColor = &H80000012     ' Couleur de font du bouton
Const DefTabHeight = 900            ' Hauteur des bouton
Const DefState = KTab_NORMAL        ' Etat de base des bouton

' Les évenements -----------------------------------------------------------------
Event Click()
Event DblClick()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Event ReadProperties(PropBag As PropertyBag)
Event Resize()
Event WriteProperties(PropBag As PropertyBag)
Event Change(Index As Integer, State As EnumState)

' Les accesseurs -----------------------------------------------------------------
Public Property Get ButtonFont() As Font
Attribute ButtonFont.VB_Description = "La police des boutons"
    Set ButtonFont = btnKTab(0).Font
End Property

Public Property Set ButtonFont(ByVal pFont As Font)
    Dim i As Integer
    For i = 0 To Tabs
        Set btnKTab(i).Font = pFont
    Next i
    'PropertyChanged "ButtonFont"
End Property
Public Property Get CurrentTabPic() As Picture
Attribute CurrentTabPic.VB_Description = "L'image du bouton"
    Set CurrentTabPic = btnKTab(CurrentTab).Picture
End Property
Public Property Set CurrentTabPic(pPic As Picture)
    Set btnKTab(CurrentTab).Picture = pPic
    'PropertyChanged "CurrentTabPic"
End Property

Public Property Get CurrentTabPicDown() As Picture
Attribute CurrentTabPicDown.VB_Description = "L'image enfoncée du bouton"
    Set CurrentTabPicDown = btnKTab(CurrentTab).DownPicture
End Property
Public Property Set CurrentTabPicDown(pPic As Picture)
    Set btnKTab(CurrentTab).DownPicture = pPic
    'PropertyChanged "CurrentTabPicDown"
End Property

Public Property Get Tabs() As Integer
Attribute Tabs.VB_Description = "Permet de choisir le nombre de tabs désirées."
    On Error Resume Next
    Tabs = UBound(KTab)
End Property
Public Property Let Tabs(ByVal pIntTabs As Integer)
    Dim intEcart As Integer
    Dim i As Integer
    Dim ctr As Control
    Dim bolExist As Boolean
    intEcart = pIntTabs - Tabs
    If intEcart >= 0 Then
        For i = 1 To intEcart
            addTab "KTab " & Tabs, DefState, DefTabHeight
        Next i
    Else
        For i = -1 To intEcart Step -1
            bolExist = False
            For Each ctr In UserControl.ContainedControls
                If CInt(Left(ctr.Tag, 2)) = Tabs + i Then bolExist = True
            Next
            If bolExist = True Then
                MsgBox "Supprimez d'abord les contrôles associés à la tab " & Tabs + i & ".", vbExclamation, "KTabs"
            Else
                delTab Tabs + i
            End If
        Next i
    End If
    'PropertyChanged "Tabs"
End Property
Public Property Get CurrentTabCaption() As String
Attribute CurrentTabCaption.VB_Description = "Le libellé du bouton"
    If Tabs > 0 And CurrentTab > 0 Then
        CurrentTabCaption = KTab(CurrentTab).Libelle
    Else
        CurrentTabCaption = 0
    End If
End Property
Public Property Let CurrentTabCaption(ByVal pStrCaption As String)
    If Tabs > 0 And CurrentTab > 0 Then
        KTab(CurrentTab).Libelle = pStrCaption
        UserControl.Refresh
    End If
    'PropertyChanged "CurrentTabCaption"
End Property

Public Property Get CurrentTabHeight() As Integer
Attribute CurrentTabHeight.VB_Description = "La hauteur de la tab (désigné par le trait)"
    If Tabs > 0 And CurrentTab > 0 Then
        CurrentTabHeight = KTab(CurrentTab).Height
    Else
        CurrentTabHeight = 0
    End If
End Property
Public Property Let CurrentTabHeight(ByVal pIntHeight As Integer)
    If Tabs > 0 And CurrentTab > 0 Then
        KTab(CurrentTab).Height = pIntHeight
        UserControl.Refresh
    End If
    'PropertyChanged "CurrentTabHeight"
End Property

Public Property Get CurrentTabState() As EnumState
Attribute CurrentTabState.VB_Description = "L'état dans lequel le bouton va apparaitre"
    If Tabs > 0 And CurrentTab > 0 Then
        CurrentTabState = KTab(CurrentTab).State
    Else
        CurrentTabState = 0
    End If
End Property
Public Property Let CurrentTabState(ByVal pIntState As EnumState)
    If Tabs > 0 And CurrentTab > 0 Then
        KTab(CurrentTab).State = pIntState
    End If
    'PropertyChanged "CurrentTabState"
End Property

Public Property Get ButtonColor() As OLE_COLOR
Attribute ButtonColor.VB_Description = "La couleur des boutons"
    ButtonColor = btnKTab(0).BackColor
End Property
Public Property Let ButtonColor(ByVal pColor As OLE_COLOR)
    Dim i As Integer
    For i = 0 To btnKTab.Count - 1
        btnKTab(i).BackColor = pColor
    Next i
    'PropertyChanged "ButtonColor"
End Property

Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "La couleur du fond"
    BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal pColor As OLE_COLOR)
    UserControl.BackColor = pColor
    'PropertyChanged "BackColor"
End Property

Public Property Get CurrentTab() As Integer
Attribute CurrentTab.VB_Description = "Permet de sélectionner une tab à modifier"
    CurrentTab = intCurrentTab
End Property
Public Property Let CurrentTab(ByVal pIntCurrentTab As Integer)
    ' Si > aux tabs
    If Tabs > 0 Then
        If pIntCurrentTab > Tabs Then pIntCurrentTab = Tabs
        If pIntCurrentTab < 1 Then pIntCurrentTab = 1
    Else
        pIntCurrentTab = 0
    End If
    intCurrentTab = pIntCurrentTab
    'PropertyChanged "CurrentTab"
    UserControl.Refresh
End Property

Public Property Get ButtonHeight() As Integer
Attribute ButtonHeight.VB_Description = "La taille des boutons"
    ButtonHeight = intButtonHeight
End Property
Public Property Let ButtonHeight(ByVal pIntButtonHeight As Integer)
    intButtonHeight = pIntButtonHeight
    'PropertyChanged "ButtonHeight"
    UserControl.Refresh
End Property

' Le mapping -----------------------------------------------------------------
Private Sub UserControl_Click()
  RaiseEvent Click
End Sub
Private Sub UserControl_DblClick()
  RaiseEvent DblClick
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyDown(KeyCode, Shift)
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
  RaiseEvent KeyPress(KeyAscii)
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyUp(KeyCode, Shift)
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  RaiseEvent MouseDown(Button, Shift, x, y)
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  RaiseEvent MouseMove(Button, Shift, x, y)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  RaiseEvent MouseUp(Button, Shift, x, y)
End Sub
Private Sub UserControl_Resize()
    RaiseEvent Resize
    UserControl.Refresh
End Sub
Private Sub UserControl_Paint()

    If bolInitialized = True Then
        writeControlsTag    ' Ecrit le tag sur les controls
        calculTabs          ' Calcul top de chaque tab
        afficheTabs         ' Affiche
        afficheControls     ' Affiche les controles
    End If

End Sub

Private Sub UserControl_Initialize()
    btnLostFocus.Left = -1000
    bolInitialized = True
End Sub

Private Sub UserControl_InitProperties()
    Dim i As Integer
    Tabs = DefTabs
    CurrentTab = DefCurrentTab
    ButtonHeight = DefButtonHeight
    For i = 1 To Tabs
        KTab(i).Libelle = "KTab " & i
    Next i
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    Dim i As Integer

    RaiseEvent ReadProperties(PropBag)
    
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    Tabs = PropBag.ReadProperty("Tabs", DefTabs)
    CurrentTab = PropBag.ReadProperty("CurrentTab", DefCurrentTab)
    ButtonHeight = PropBag.ReadProperty("ButtonHeight", DefButtonHeight)
    ButtonColor = PropBag.ReadProperty("ButtonColor", DefButtonColor)
    BackColor = PropBag.ReadProperty("BackColor", DefBackColor)
    For i = 1 To Tabs
        Set btnKTab(i).Font = PropBag.ReadProperty("ButtonFont", Ambient.Font)
        Set btnKTab(i).Picture = PropBag.ReadProperty("btnKTab(" & i & ").Picture", Nothing)
        Set btnKTab(i).DownPicture = PropBag.ReadProperty("btnKTab(" & i & ").DownPicture", Nothing)
        KTab(i).State = PropBag.ReadProperty("KTab(" & i & ").State", DefState)
        KTab(i).Libelle = PropBag.ReadProperty("KTab(" & i & ").Libelle", "KTab " & i)
        KTab(i).Height = PropBag.ReadProperty("KTab(" & i & ").Height", DefTabHeight)
    Next i
    
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  
    Dim i As Integer
  
    RaiseEvent WriteProperties(PropBag)
    
    Call PropBag.WriteProperty("Tabs", Tabs, DefTabs)
    Call PropBag.WriteProperty("CurrentTab", CurrentTab, DefCurrentTab)
    Call PropBag.WriteProperty("ButtonFont", btnKTab(0).Font, Ambient.Font)
    Call PropBag.WriteProperty("ButtonHeight", ButtonHeight, DefButtonHeight)
    Call PropBag.WriteProperty("ButtonColor", ButtonColor, DefButtonColor)
    Call PropBag.WriteProperty("BackColor", BackColor, DefBackColor)
    Call PropBag.WriteProperty("PPicture", UserControl.Picture, "")
    For i = 1 To Tabs
        Call PropBag.WriteProperty("btnKTab(" & i & ").Picture", btnKTab(i).Picture, Nothing)
        Call PropBag.WriteProperty("btnKTab(" & i & ").DownPicture", btnKTab(i).DownPicture, Nothing)
        Call PropBag.WriteProperty("KTab(" & i & ").State", KTab(i).State, DefState)
        Call PropBag.WriteProperty("KTab(" & i & ").Libelle", KTab(i).Libelle, "KTab " & i)
        Call PropBag.WriteProperty("KTab(" & i & ").Height", KTab(i).Height, DefTabHeight)
    Next i

End Sub

' Methodes -----------------------------------------------------------------
Public Sub addTab(ByVal pStrLibelle As String, ByVal pState As EnumState, ByVal pIntHeight As Integer)

    ' Redimensionne le KTableau de KTabs
    ReDim Preserve KTab(Tabs + 1)
    
    ' Défini les propriétés
    With KTab(Tabs)
        .Libelle = pStrLibelle
        .Height = pIntHeight
        .State = pState
    End With
    
    ' Crée le bouton
    Load btnKTab(Tabs)
    
End Sub

Public Sub delTab(ByVal Index As Integer, Optional bolDelControls As Boolean)

    ' Variables
    Dim i As Integer
    Dim ctr As Control
    Dim intCtrIndex As Integer

    ' Supprime les contrôles
    For Each ctr In UserControl.ContainedControls
            
        ' Récupère les valeurs
        intCtrIndex = CInt(Left(ctr.Tag, 2))

        ' Supprime le controle
        If intCtrIndex = Index Then
            If bolDelControls = True Then
                Unload ctr
            Else
                Err.Raise 1000, "delTab", "Supprimez d'abord les contrôles associés au tab " & Index & "."
                Exit Sub
            End If
        End If

    Next

    ' Décale les tabs
    For i = Index + 1 To Tabs
        KTab(i - 1) = KTab(i)
    Next i

    ' Supprime le bouton
    Unload btnKTab(Tabs)

    ' Redimensionne
    ReDim Preserve KTab(Tabs - 1)

End Sub

Sub writeControlsTag()

    ' Variables
    Dim ctr As Control

    ' Mode conception uniquement
    If Not UserControl.Ambient.UserMode Then
        
        ' Passe les controls en revue
        For Each ctr In UserControl.ContainedControls
            
            ' Ecrit l'index
            If ctr.Tag = "" Then ctr.Tag = Right("00" & CStr(CurrentTab), 2)
            
            ' Ecrit le top
            ctr.Tag = Left(ctr.Tag, 2) & ctr.Top
        
        Next
        
    End If

End Sub

Public Sub changeTabState(ByVal Index As Integer)
    
    ' Variables
    Dim i As Integer

    ' Enlève tous les maximisés
    If bolMaximized = True Then
        For i = 1 To Tabs
            If i <> Index And KTab(i).State = KTab_MAXIMIZED Then KTab(i).State = KTab_MINIMIZED
        Next i
        bolMaximized = False
    End If
    
    ' Change l'état du tab
    With KTab(Index)
        Select Case .State
            Case KTab_NORMAL
            .State = KTab_MAXIMIZED
            bolMaximized = True
            Case KTab_MAXIMIZED
            .State = KTab_MINIMIZED
            Case KTab_MINIMIZED
            .State = KTab_NORMAL
        End Select
    End With
    
    ' Rafraichi
    RaiseEvent Change(Index, KTab(Index).State)
    PropertyChanged "CurrentTabState"
    UserControl.Refresh
    
End Sub

Private Sub calculTabs()
' Calcul le top et le visible de chaque tab

    ' Variables
    Dim i As Integer

    ' Si un bouton au moins
    If Tabs > 0 Then
    
        ' Mode execution
        If UserControl.Ambient.UserMode Then
        
            ' Calcul la position de chaque bouton
            For i = 1 To Tabs
                With KTab(i)
                
                    ' Le 1er en haut
                    If i = 1 Then
                        .Top = 0
                    
                    Else
                                                        
                        ' State NORMAL activé si pas de MAXIMIZED
                        If KTab(i - 1).State = KTab_NORMAL And bolMaximized = False Then
                            .Top = KTab(i - 1).Top + ButtonHeight + KTab(i - 1).Height
                            
                            ' Si la tab sort
                            If .Top + ButtonHeight * (Tabs - i + 1) > UserControl.Height Then
                                .Top = UserControl.Height - (ButtonHeight * (Tabs - i + 1)) - 60
                            End If
                            
                        ' Si précédent MAXIMIZED, place le suivant en bas
                        ElseIf KTab(i - 1).State = KTab_MAXIMIZED Then
                            .Top = UserControl.Height - (ButtonHeight * (Tabs - i + 1)) - 60
                        Else
                            .Top = KTab(i - 1).Top + ButtonHeight
                        End If
                        
                    End If
                    .Visible = True
                    
                End With
            Next i
            
            ' Calcul la visibilité du dernier
            If KTab(i - 1).State = KTab_NORMAL And bolMaximized = False Then
                KTab(i - 1).Opened = True
            ElseIf KTab(i - 1).State = KTab_MAXIMIZED Then
                KTab(i - 1).Opened = True
            Else
                KTab(i - 1).Opened = False
            End If
            
        ' Mode conception
        Else
        
            If CurrentTab > 0 Then
        
                ' Met tout le monde à visible = false sauf le sélectionné
                For i = 1 To Tabs
                    If i <> CurrentTab Then
                        KTab(i).Opened = False
                        KTab(i).Visible = False
                    End If
                Next i
                With KTab(CurrentTab)
                    .Top = 0
                    .Opened = True
                    .Visible = True
                End With
            
            End If
        
        End If
        
    End If

End Sub

Private Sub afficheControls()

    ' Variables
    Dim i As Integer
    Dim ctr As Control
    Dim intCtrIndex As Integer
    Dim intCtrTop As Integer
    Dim intEspace As Integer
    
    ' Si un bouton au moins
    If Tabs > 0 Then
    
        ' Passe chaque contrôle
        For Each ctr In UserControl.ContainedControls
        
            ' Récupère les valeurs
            intCtrIndex = CInt(Left(ctr.Tag, 2))
            intCtrTop = CInt(Right(ctr.Tag, Len(ctr.Tag) - 2))

            ' Mode execution
            If UserControl.Ambient.UserMode Then

                ' Calcul l'espace dispo entre les 2 tabs (sauf si dernière, alloue tout l'espace)
                If intCtrIndex < Tabs Then
                    intEspace = KTab(intCtrIndex + 1).Top - KTab(intCtrIndex).Top
                Else
                    intEspace = 32000
                End If
            
            ' Mode conception
            Else
            
                If intCtrIndex = CurrentTab Then
                    intEspace = 32000
                Else
                    intEspace = 0
                End If
            
            End If
            
            ' Si place dispo affiche
            If intCtrTop + ctr.Height < intEspace Then
                
                ' Calcul du left
                If ctr.Left < 0 Then
                    ctr.Left = ctr.Left + 10000
                End If
                
                ' Calcul du top
                ctr.Top = KTab(intCtrIndex).Top + intCtrTop
                
            ' Sinon vire de l'écran
            Else
                
                ' Calcul du left
                If ctr.Left >= 0 Then
                    ctr.Left = ctr.Left - 10000
                End If
            
            End If
                
        Next
        
    End If

End Sub

Private Sub afficheTabs()

    ' Variables
    Dim i As Integer
    Dim intMaxiPos As Integer
        
    ' Affiche les boutons
    For i = 1 To Tabs
        With btnKTab(i)
            .Caption = KTab(i).Libelle
            .Top = KTab(i).Top
            .Width = UserControl.Width - 60
            .Height = ButtonHeight
            .Visible = KTab(i).Visible
        End With
    Next i
    
    ' Si conception, affiche la barre de limite
    If Tabs > 0 And CurrentTab > 0 Then
        With shpLimite
            If Not UserControl.Ambient.UserMode Then
                .X1 = 0
                .Y1 = KTab(CurrentTab).Height + ButtonHeight
                .X2 = UserControl.Width
                .Y2 = .Y1
                .Visible = True
            Else
                .Visible = False
            End If
        End With
    End If
    
End Sub

' Controls
Private Sub btnKTab_Click(Index As Integer)

    btnLostFocus.SetFocus
    changeTabState (Index)
    
End Sub

Conclusion :


Merci de laisser vos commentaires. Cette version est encore surement pas mal buggé mais elle est assez fonctionnelle pour une première version. Je la complèterai très prochainement avec des nouvelles fonctionnalités... et dernier point, soyez indulgent, c'est mon premier ocx :P
Télécharger le projet

Codes Sources

A voir également

Du même auteur (kemo_0ne)