Remplaçant pour sstab avec gestion des couleurs

5/5 (35 avis)
Vue 14 250 fois - Téléchargée 1 549 fois
Télécharger le projet
Commenter
Description

Voici un contrôle personnalisé à inclure dans un projet pour remplacer le SSTab de microsoft avec lequel on ne peut pas modifier les couleurs de dessin.
Mise à jour le 16/06/2001 - bug corrigé quand on rapetisse le form si le contrôle est aligné (merci à fabiin d'avoir soulevé le bug :-)

Utilisation :
Copier le code dans un fichier .ctl (ne le faites pas sous VB, le code contient des directives) ou telecharger le fichier zip.
Inclure le fichier ctl (Project - Add UserControl) dans votre projet, et amusez vous bien :-)
Source / Exemple :

VERSION 5.00
Begin VB.UserControl KLBTab 
   Alignable       =   -1  'True
   ClientHeight    =   2190
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3240
   ControlContainer=   -1  'True
   EditAtDesignTime=   -1  'True
   ScaleHeight     =   2190
   ScaleWidth      =   3240
End
Attribute VB_Name = "KLBTab"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'##########################################################################
'#                                                                        #
'#  Contrôle KLBTab                                           V 1.0       #
'#                                                         (02/06/2001)   #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  Code réalisé par Cyril VALLOD                                         #
'#  Pour tout problème, report de bug, questions                          #
'#   ecrire à kroclebo@club-internet.fr                                   #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  Remplaçant du contrôle SSTab de Microsoft                             #
'#  Avec des propriétés étendues permettant de personaliser               #
'#  les couleurs                                                          #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  Les fonctionalités sont à peu près les mêmes que celles du            #
'#  contrôle SSTab, le mode de fonctionnement également                   #
'#  comme par exemple la manière de cacher les contrôles contenus         #
'#  sur les tabs non visible (Left -75000) ou encore la manière de        #
'#  "désactiver" les contrôles contenus dans les tabs non visibles        #
'#  (TabStop=False)                                                       #
'#                                                                        #
'#  ATTENTION : LA propriété Tab du contrôle original a été               #
'#              remplacée ici par CurrentTab (Tab n'est pas               #
'#              utilisable et devient une propriété masquée               #
'#              dans l'environnement de dev VB6 ...)                      #
'#                                                                        #
'#  La manière de sauvegarder les propriétés a également été              #
'#  respectée (ou imitée ? :). Ceci permet de remplacer facilement        #
'#  le contrôle original dans un form par celui-ci en éditant             #
'#  le fichier .frm                                                       #
'#                                                                        #
'#  Note : Une des propriété du contrôle original que je n'ai             #
'#         pas réussi à implémenter ici est le fait de pouvoir            #
'#         changer le tab courant en mode design, cependant j'ai          #
'#         mis le contrôle en mode editable pour pouvoir cliquer          #
'#         sur le bouton droit puis edit pour que cela soit possible      #
'#         si une personne trouve le moyen d'implémenter cette            #
'#         propriété directement, je suis preneur                         #
'#         Le changement de Tab courant peut également se faire           #
'#         en changeant la valeur de CurrentTab en mode design            #
'#                                                                        #
'#  Note2: Beaucoup de procédure et propriétés contiennent des            #
'#         informations de comportement (code caché sur l'environnement   #
'#         de développement). Si vous souhaitez changer l'ordre           #
'#         des procédures ou les copier dans un autre projet              #
'#         je vous conseille donc d'éditer directement le fichier         #
'#         .ctl avec un éditeur de texte.                                 #
'#                                                                        #
'#  Ce contôle est facilement transformable en OCX (Active-X) pour        #
'#  ceux qui le souhaitent. Pour ma part je préfère l'avoir en tant       #
'#  que contrôle personalisé pour pouvoir intervenir dessus au cas où.    #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  Certaines fonctionalités du contrôle SSTab ne sont pas                #
'#  implémentées sur ce contrôle et pourront faire l'objet                #
'#  d'évolutions fututres                                                 #
'#                                                                        #
'#  -TabOrientation pour le moment on est en TOP                          #
'#  -TabsPerRow automatiquement égal à tabs                               #
'#  -TabMaxWidth automatique                                              #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'#  License                                                               #
'#  -------                                                               #
'#                                                                        #
'#  Ce tontrôle est en OpenSource, vous pouvez l'utiliser                 #
'#  librement et le diffuser à volonté.                                   #
'#  Vous pouvez également modifier certaines parties du code              #
'#  mais dans ce cas, je vous engage fortement à inscrire                 #
'#  dans cette entête un descriptif de votre intervention ainsi           #
'#  que le moyen de vous contacter si vous diffusez la version            #
'#  modifiée.                                                             #
'#                                                                        #
'#  La responsabilité de l'auteur ne peut être engagée en cas             #
'#  de disfonctionnement d'un programme utilisant ce contrôle             #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'# Historique                                                             #
'# ----------                                                             #
'#                                                                        #
'# 12/06/2001 - Ajout de la propriété Style                               #
'# 14/06/2001 - Amélioration du tracé du texte en style TabbedDialog      #
'#               (centrage horizontal + vertical avec l'API DrawText)     #
'# 15/06/2001 - Ajout de la propriété WordWrap                            #
'# 16/06/2001 - Bug corrigé quand le contôle est aligné et le form        #
'#               rapetissé - merci à fabiin d'avoir soulevé le bug :-)    #
'#                                                                        #
'#========================================================================#
'#                                                                        #
'# Evolutions à prévoir :                                                 #
'#                                                                        #
'#  -Optimisation de l'affichage (redessiner uniquement les parties       #
'#   utiles par exemple lors d'un changement de CurrentTab)               #
'#                                                                        #
'##########################################################################

Option Explicit

' Un peu d'API juste pour pouvoir déssiner un rectangle de focus propre.
' et dessiner le texte proprement aussi (avec un rectange de clipping)
Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_EXPANDTABS = &H40
Private Const DT_INTERNAL = &H1000
Private Const DT_LEFT = &H0
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10
Private Const DT_EDITCONTROL = &H2000
Private Const DT_PATH_ELLIPSIS = &H4000
Private Const DT_END_ELLIPSIS = &H8000
Private Const DT_MODIFYSTRING = &H10000
Private Const DT_RTLREADING = &H20000
Private Const DT_WORD_ELLIPSIS = &H40000

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Private Type DRAWTEXTPARAMS
  cbSize As Long
  iTabLength As Long
  iLeftMargin As Long
  iRightMargin As Long
  uiLengthDrawn As Long
End Type
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, lpDrawTextParams As DRAWTEXTPARAMS) As Long

Private Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As Long
Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal wOptions As Long, lpRect As RECT, ByVal lpString As String, ByVal nCount As Long, ByVal lpDx As Long) As Long
Private Const ETO_CLIPPED = 4
Private Const ETO_OPAQUE = 2
Private Const TA_BASELINE = 24
Private Const TA_BOTTOM = 8
Private Const TA_CENTER = 6
Private Const TA_LEFT = 0
Private Const TA_NOUPDATECP = 0
Private Const TA_RIGHT = 2
Private Const TA_TOP = 0
Private Const TA_UPDATECP = 1
Private Const TA_MASK = (TA_BASELINE + TA_CENTER + TA_UPDATECP)
Private Const VTA_CENTER = TA_CENTER
Private Const VTA_BASELINE = TA_BASELINE

'==========================================================================
'
'  Structures de données
'
'==========================================================================
Public Enum KTStyle
  ssStyleTabbedDialog = 0
  ssStylePropertyPage = 1
End Enum
' Les contrôles contenus sont identifiés par un ID
' composé du nom et de l'éventuel Index
' sous la forme nom(index)
' La propriété TabStop est mémorisée pour que l'on
' puisse jouer avec
Private Type KLBContainedControl
  ControlID As String
  ControlTabStop As Boolean
End Type

' Structure d'un Tab avec son Caption, le nombre de contrôles qu'il
' contient et pour chaque contrôle sa description (tableau dynamique)
' ainsi que le rectangle de la zone clickable pour activer le Tab
Private Type KLBTabDef
  Caption As String
  NbContainedControls As Integer
  KLBContainedControls() As KLBContainedControl
  ClickRect As RECT
End Type

'==========================================================================
'
'  Propriétés par défaut
'
'==========================================================================
Const m_def_CurrentTab = 0
Const m_def_Tabs = 3
Const m_def_Caption = "KLBTab"
Const m_def_TabHeight = 25
Const m_def_HighlightColor3D = &HFFFFFF
Const m_def_LowlightColor3D = &H808080
Const m_def_TextColor = &H0&
Const m_def_SelectedTextColor = &H0&
Const m_def_TabColor = &HBBC5CB
Const m_def_SelectedTabColor = &HC8D0D4
Const m_def_DarkColor3D = &H0&
Const m_def_ShowFocusRect = True
Const m_def_Style = 0
Const m_def_WordWrap = True

'==========================================================================
'
'  Variables de stockage des propriétés et variables globales
'
'==========================================================================
Dim m_CurrentTab As Integer
Dim m_Tabs As Integer
Dim m_Caption As String
Dim m_TabHeight As Integer
Dim m_HighlightColor3D As OLE_COLOR
Dim m_LowlightColor3D As OLE_COLOR
Dim m_TextColor As OLE_COLOR
Dim m_SelectedTextColor As OLE_COLOR
Dim m_TabColor As OLE_COLOR
Dim m_SelectedTabColor As OLE_COLOR
Dim m_DarkColor3D As OLE_COLOR
Dim m_ShowFocusRect As Boolean
Dim m_Style As KTStyle
Dim m_WordWrap As Boolean
Private WithEvents m_Font As StdFont
Attribute m_Font.VB_VarHelpID = -1
Dim m_Focus As Boolean
Dim KLBTabDefs() As KLBTabDef
Dim m_IsControlsInitialized As Boolean
'==========================================================================
'
'  Déclaration des évennements
'
'==========================================================================
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Attribute Click.VB_UserMemId = -600
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Attribute DblClick.VB_UserMemId = -601
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyDown
Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
Event KeyPress(KeyAscii As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyPress
Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
Attribute KeyPress.VB_UserMemId = -603
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyUp
Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
Attribute KeyUp.VB_UserMemId = -604
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Attribute MouseDown.VB_UserMemId = -605
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Attribute MouseMove.VB_UserMemId = -606
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
Attribute MouseUp.VB_UserMemId = -607
Event ReadProperties(PropBag As PropertyBag) 'MappingInfo=UserControl,UserControl,-1,ReadProperties
Attribute ReadProperties.VB_Description = "Occurs when a user control or user document is asked to read its data from a file."
Event Resize() 'MappingInfo=UserControl,UserControl,-1,Resize
Attribute Resize.VB_Description = "Occurs when a form is first displayed or the size of an object changes."
Event WriteProperties(PropBag As PropertyBag) 'MappingInfo=UserControl,UserControl,-1,WriteProperties
Attribute WriteProperties.VB_Description = "Occurs when a user control or user document is asked to write its data to a file."

'==========================================================================
'
'  Mapping des évennements
'
'==========================================================================

Private Sub UserControl_Click()
  RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
  RaiseEvent DblClick
End Sub

Private Sub UserControl_GotFocus()
  m_Focus = True
  DrawTab m_CurrentTab
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  Dim n As Integer, m As Integer
  ' Gestion du changement de TAB sur Ctrl-Tab ou Ctrl-Shift-Tab
  If KeyCode = 9 And (Shift = 2 Or Shift = 3) Then
    n = m_CurrentTab
    m = m_Tabs
    If Shift = 2 Then n = n + 1
    If Shift = 3 Then n = n - 1
    If n > (m - 1) Then n = 0
    If n < 0 Then n = m - 1
    CurrentTab = n
    Refresh
  End If
  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_LostFocus()
  m_Focus = False
  DrawTab m_CurrentTab
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  Dim x1 As Long, y1 As Long
  Dim x2 As Long, y2 As Long
  Dim xm As Long, ym As Long
  'Dim w As Long
  Dim OldScale As Integer
  Dim i As Integer
  
  ' Regardons si l'on a cliqué sur un Tab
  
  xm = x / Screen.TwipsPerPixelX
  ym = y / Screen.TwipsPerPixelY
  
  ' Sauvegarde du scale mode
  OldScale = UserControl.ScaleMode
  ' On passe en scale mode pixel
  UserControl.ScaleMode = 3
  ' Testons chaque tab
  For i = 0 To m_Tabs - 1
    x1 = KLBTabDefs(i).ClickRect.Left
    y1 = KLBTabDefs(i).ClickRect.Top
    x2 = KLBTabDefs(i).ClickRect.Right
    y2 = KLBTabDefs(i).ClickRect.Bottom

    If xm >= x1 And xm <= x2 And ym >= y1 And ym <= y2 Then
      ' Si on a cliqué sur un autre Tab que le courant, on change
      If i <> m_CurrentTab Then
        CurrentTab = i
        Refresh
      End If
      Exit For
    End If
  Next
  
  UserControl.ScaleMode = OldScale
  
  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
  ' Régler le problème du resize quand le contrôle est aligné
  ' (En agrandissant le form ca marche mais pas en rapetissant)
  ' on force donc le contrôle à se redéssiner
  Refresh
End Sub

'==========================================================================
'
'  Evennements gérés en interne
'
'==========================================================================

Private Sub UserControl_Initialize()
  Set m_Font = New StdFont
  Set UserControl.Font = m_Font
  m_Focus = False
  m_IsControlsInitialized = False
End Sub

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
  Dim i As Integer
  Set UserControl.Font = Ambient.Font
  m_Tabs = m_def_Tabs
  m_CurrentTab = m_def_CurrentTab
  m_Caption = m_def_Caption
  m_TabHeight = m_def_TabHeight
  m_HighlightColor3D = m_def_HighlightColor3D
  m_LowlightColor3D = m_def_LowlightColor3D
  m_TextColor = m_def_TextColor
  m_SelectedTextColor = m_def_SelectedTextColor
  m_TabColor = m_def_TabColor
  m_SelectedTabColor = m_def_SelectedTabColor
  m_DarkColor3D = m_def_DarkColor3D
  m_ShowFocusRect = m_def_ShowFocusRect
  ReDim KLBTabDefs(m_Tabs - 1)
  For i = 0 To m_Tabs - 1
    KLBTabDefs(i).Caption = m_def_Caption & " " & i + 1
    KLBTabDefs(i).NbContainedControls = 0
    ReDim KLBTabDefs(i).KLBContainedControls(0)
  Next
End Sub

Private Sub UserControl_Paint()
  Dim i As Integer
  Dim j As Integer
  ' Si c'est le premier paint, on en profite pour initialiser les controles
  ' de la zone non visible en mettant leur TabStop à false si on est pas en dev
  If m_IsControlsInitialized = False Then
    If UserControl.Ambient.UserMode Then
      InitTabStopControls
    End If
    m_IsControlsInitialized = True
  End If
  'Cls
  DrawTabBack
  For i = 0 To m_Tabs - 1
    DrawTab i
  Next
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  Dim i As Integer, j As Integer
  Dim nb As Integer, n As Integer
  RaiseEvent ReadProperties(PropBag)
  UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
  UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
  Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
  m_Tabs = PropBag.ReadProperty("Tabs", m_def_Tabs)
  m_CurrentTab = PropBag.ReadProperty("CurrentTab", m_def_CurrentTab)
  If m_CurrentTab < 0 Then m_CurrentTab = 0
  If m_CurrentTab > (m_Tabs - 1) Then m_CurrentTab = m_Tabs - 1
  
  ReDim KLBTabDefs(m_Tabs - 1)
  For i = 0 To m_Tabs - 1
    KLBTabDefs(i).Caption = PropBag.ReadProperty("TabCaption(" & i & ")", m_def_Caption & " " & i + 1)
    nb = PropBag.ReadProperty("Tab(" & i & ").ControlCount", 0)
    KLBTabDefs(i).NbContainedControls = nb
    ReDim KLBTabDefs(i).KLBContainedControls(nb)
    For j = 0 To nb - 1
      KLBTabDefs(i).KLBContainedControls(j).ControlID = PropBag.ReadProperty("Tab(" & i & ").Control(" & j & ")", "")
    Next
  Next
  m_TabHeight = PropBag.ReadProperty("TabHeight", m_def_TabHeight)
  m_HighlightColor3D = PropBag.ReadProperty("HighlightColor3D", m_def_HighlightColor3D)
  m_LowlightColor3D = PropBag.ReadProperty("LowlightColor3D", m_def_LowlightColor3D)
  m_TextColor = PropBag.ReadProperty("TextColor", m_def_TextColor)
  m_SelectedTextColor = PropBag.ReadProperty("SelectedTextColor", m_def_SelectedTextColor)
  m_TabColor = PropBag.ReadProperty("TabColor", m_def_TabColor)
  m_SelectedTabColor = PropBag.ReadProperty("SelectedTabColor", m_def_SelectedTabColor)
  m_DarkColor3D = PropBag.ReadProperty("DarkColor3D", m_def_DarkColor3D)
  m_ShowFocusRect = PropBag.ReadProperty("ShowFocusRect", m_def_ShowFocusRect)
  m_Style = PropBag.ReadProperty("Style", m_def_Style)
  m_WordWrap = PropBag.ReadProperty("WordWrap", m_def_WordWrap)
  Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
  UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  Dim i As Integer, j As Integer
  Dim nb As Integer

  ' Avant de sauvegarder, on mémorise les changements éventuels sur
  ' le tab actif (sans déplacment en zone invisible)
  MemoCurrentTab False

  RaiseEvent WriteProperties(PropBag)
  Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
  Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
  Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
  Call PropBag.WriteProperty("Tabs", m_Tabs, m_def_Tabs)
  Call PropBag.WriteProperty("CurrentTab", m_CurrentTab, m_def_CurrentTab)
  For i = 0 To m_Tabs - 1
    nb = KLBTabDefs(i).NbContainedControls
    Call PropBag.WriteProperty("TabCaption(" & i & ")", KLBTabDefs(i).Caption, m_def_Caption & " " & i + 1)
    Call PropBag.WriteProperty("Tab(" & i & ").ControlCount", nb, 0)
    If nb > 0 Then
      For j = 0 To nb - 1
        Call PropBag.WriteProperty("Tab(" & i & ").Control(" & j & ")", KLBTabDefs(i).KLBContainedControls(j).ControlID, "")
      Next
    End If
  Next
  Call PropBag.WriteProperty("TabHeight", m_TabHeight, m_def_TabHeight)
  Call PropBag.WriteProperty("HighlightColor3D", m_HighlightColor3D, m_def_HighlightColor3D)
  Call PropBag.WriteProperty("LowlightColor3D", m_LowlightColor3D, m_def_LowlightColor3D)
  Call PropBag.WriteProperty("TextColor", m_TextColor, m_def_TextColor)
  Call PropBag.WriteProperty("SelectedTextColor", m_SelectedTextColor, m_def_SelectedTextColor)
  Call PropBag.WriteProperty("TabColor", m_TabColor, m_def_TabColor)
  Call PropBag.WriteProperty("SelectedTabColor", m_SelectedTabColor, m_def_SelectedTabColor)
  Call PropBag.WriteProperty("DarkColor3D", m_DarkColor3D, m_def_DarkColor3D)
  Call PropBag.WriteProperty("ShowFocusRect", m_ShowFocusRect, m_def_ShowFocusRect)
  Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
  Call PropBag.WriteProperty("WordWrap", m_WordWrap, m_def_WordWrap)
  Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
  Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0)
End Sub

'==========================================================================
'
'  Propriétés standards
'
'==========================================================================

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Background color"
Attribute BackColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  UserControl.BackColor() = New_BackColor
  PropertyChanged "BackColor"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
  Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
  UserControl.Enabled() = New_Enabled
  PropertyChanged "Enabled"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
  Set Font = m_Font
End Property

Public Property Set Font(ByVal New_Font As Font)
  ' cf MSDN, le code ci-dessous ainsi que la déclaration de la variable
  ' m_font associée à un evennement pour qu'un changement de font soit
  ' visible immédiatement sur l'environnement de dev
  With m_Font
    .Bold = New_Font.Bold
    .Italic = New_Font.Italic
    .Name = New_Font.Name
    .Size = New_Font.Size
  End With
  PropertyChanged "Font"
End Property

Private Sub m_Font_FontChanged(ByVal PropertyName As String)
  Set UserControl.Font = m_Font
  Refresh
End Sub

'==========================================================================
'
'  Propriétés propres au contrôle
'
'==========================================================================

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,3
Public Property Get Tabs() As Integer
Attribute Tabs.VB_Description = "Number of tabs to display"
Attribute Tabs.VB_ProcData.VB_Invoke_Property = ";Tabs"
  Tabs = m_Tabs
End Property

Public Property Let Tabs(ByVal New_Tabs As Integer)
  Dim i As Integer, j As Integer, k As Integer
  Dim nb As Integer
  On Error Resume Next
  ' Si un ou plusieurs tab ont été supprimés,
  ' On génère une erreur s'il y a des contrôles dedans
  If New_Tabs < m_Tabs Then
    For i = New_Tabs To m_Tabs - 1
      nb = KLBTabDefs(i).NbContainedControls
      If nb > 0 Then
        MsgBox "Impossible de supprimer un Tab contenant des contôles", vbCritical
        Exit Property
      End If
    Next
  End If
  ' Redimensionnement du tableau dynamique de stockage des propriétés des tabs
  ReDim Preserve KLBTabDefs(New_Tabs - 1)
  ' Valeurs par défaut pour les nouveaux captions s'il y en a
  For i = m_Tabs To New_Tabs - 1
    KLBTabDefs(i).Caption = m_def_Caption & " " & i + 1
  Next

  m_Tabs = New_Tabs
  If m_CurrentTab > (m_Tabs - 1) Then m_CurrentTab = m_Tabs - 1
  PropertyChanged "Tabs"
  PropertyChanged "CurrentTab"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,1
Public Property Get CurrentTab() As Integer
Attribute CurrentTab.VB_Description = "Current selected tab"
Attribute CurrentTab.VB_ProcData.VB_Invoke_Property = ";Tabs"
  CurrentTab = m_CurrentTab
End Property

Public Property Let CurrentTab(ByVal New_CurrentTab As Integer)
  Dim ctr As Control, i As Integer
  Dim ControlID As String
  Dim nb As Integer

  ' Mémorisons avant tous les contrôles du tab courant
  ' en déplacant ceux-ci dans la zone non visible
  MemoCurrentTab True
  
  ' Ensuite on change de tab
  m_CurrentTab = New_CurrentTab
  ' Rectifions si jamais c'est un tab innexistant
  If m_CurrentTab < 0 Then m_CurrentTab = 0
  If m_CurrentTab > (m_Tabs - 1) Then m_CurrentTab = m_Tabs - 1
  
  ' Déplacons maintenant les contrôles du nouveau tab actif en zone visible
  ShowCurrentTabControls
  
  PropertyChanged "CurrentTab"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,Tab
Public Property Get Caption() As String
Attribute Caption.VB_Description = "Caption of the curent selected tab"
Attribute Caption.VB_ProcData.VB_Invoke_Property = ";Tabs"
  Caption = KLBTabDefs(m_CurrentTab).Caption
  If Caption = "" Then Caption = m_def_Caption & " " & m_CurrentTab
End Property

Public Property Let Caption(ByVal New_Caption As String)
  KLBTabDefs(m_CurrentTab).Caption = New_Caption
  PropertyChanged "Caption"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,350
Public Property Get TabHeight() As Integer
Attribute TabHeight.VB_Description = "Height of tabs (in pixels)"
Attribute TabHeight.VB_ProcData.VB_Invoke_Property = ";Appearance"
  TabHeight = m_TabHeight
End Property

Public Property Let TabHeight(ByVal New_TabHeight As Integer)
  m_TabHeight = New_TabHeight
  PropertyChanged "TabHeight"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H00FFFFFF&
Public Property Get HighlightColor3D() As OLE_COLOR
Attribute HighlightColor3D.VB_ProcData.VB_Invoke_Property = ";Appearance"
  HighlightColor3D = m_HighlightColor3D
End Property

Public Property Let HighlightColor3D(ByVal New_HighlightColor3D As OLE_COLOR)
  m_HighlightColor3D = New_HighlightColor3D
  PropertyChanged "HighlightColor3D"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H00808080&
Public Property Get LowlightColor3D() As OLE_COLOR
Attribute LowlightColor3D.VB_ProcData.VB_Invoke_Property = ";Appearance"
  LowlightColor3D = m_LowlightColor3D
End Property

Public Property Let LowlightColor3D(ByVal New_LowlightColor3D As OLE_COLOR)
  m_LowlightColor3D = New_LowlightColor3D
  PropertyChanged "LowlightColor3D"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,MouseIcon
Public Property Get MouseIcon() As Picture
Attribute MouseIcon.VB_Description = "Sets a custom mouse icon."
  Set MouseIcon = UserControl.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
  Set UserControl.MouseIcon = New_MouseIcon
  PropertyChanged "MouseIcon"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,MousePointer
Public Property Get MousePointer() As MousePointerConstants
Attribute MousePointer.VB_Description = "Returns/sets the type of mouse pointer displayed when over part of an object."
  MousePointer = UserControl.MousePointer
End Property

Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
  UserControl.MousePointer() = New_MousePointer
  PropertyChanged "MousePointer"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H00000000&
Public Property Get TextColor() As OLE_COLOR
Attribute TextColor.VB_Description = "Text color of non selected tabs"
Attribute TextColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  TextColor = m_TextColor
End Property

Public Property Let TextColor(ByVal New_TextColor As OLE_COLOR)
  m_TextColor = New_TextColor
  PropertyChanged "TextColor"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H00000000&
Public Property Get SelectedTextColor() As OLE_COLOR
Attribute SelectedTextColor.VB_Description = "Text color of the selected tab"
Attribute SelectedTextColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  SelectedTextColor = m_SelectedTextColor
End Property

Public Property Let SelectedTextColor(ByVal New_SelectedTextColor As OLE_COLOR)
  m_SelectedTextColor = New_SelectedTextColor
  PropertyChanged "SelectedTextColor"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H00808080&
Public Property Get TabColor() As OLE_COLOR
Attribute TabColor.VB_Description = "Background color for non selected tabs"
Attribute TabColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  TabColor = m_TabColor
End Property

Public Property Let TabColor(ByVal New_TabColor As OLE_COLOR)
  m_TabColor = New_TabColor
  PropertyChanged "TabColor"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H00C0C0C0&
Public Property Get SelectedTabColor() As OLE_COLOR
Attribute SelectedTabColor.VB_Description = "Background color of the selected tab"
Attribute SelectedTabColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  SelectedTabColor = m_SelectedTabColor
End Property

Public Property Let SelectedTabColor(ByVal New_SelectedTabColor As OLE_COLOR)
  m_SelectedTabColor = New_SelectedTabColor
  PropertyChanged "SelectedTabColor"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H00000000&
Public Property Get DarkColor3D() As OLE_COLOR
Attribute DarkColor3D.VB_ProcData.VB_Invoke_Property = ";Appearance"
  DarkColor3D = m_DarkColor3D
End Property

Public Property Let DarkColor3D(ByVal New_DarkColor3D As OLE_COLOR)
  m_DarkColor3D = New_DarkColor3D
  PropertyChanged "DarkColor3D"
  Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,True
Public Property Get ShowFocusRect() As Boolean
Attribute ShowFocusRect.VB_Description = "Focus rectagngle of current Tab visible (True) or invisible (False)"
Attribute ShowFocusRect.VB_ProcData.VB_Invoke_Property = ";Appearance"
  ShowFocusRect = m_ShowFocusRect
End Property

Public Property Let ShowFocusRect(ByVal New_ShowFocusRect As Boolean)
  m_ShowFocusRect = New_ShowFocusRect
  PropertyChanged "ShowFocusRect"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,True
Public Property Get Style() As KTStyle
Attribute Style.VB_Description = "Style"
Attribute Style.VB_ProcData.VB_Invoke_Property = ";Appearance"
  Style = m_Style
End Property

Public Property Let Style(ByVal New_Style As KTStyle)
  m_Style = New_Style
  PropertyChanged "Style"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,True
Public Property Get WordWrap() As Boolean
Attribute WordWrap.VB_Description = "Determine whether text in the caption of each tab will wrap to ne next line if it is too long."
Attribute WordWrap.VB_ProcData.VB_Invoke_Property = ";Behaviour"
  WordWrap = m_WordWrap
End Property

Public Property Let WordWrap(ByVal New_WordWrap As Boolean)
  m_WordWrap = New_WordWrap
  PropertyChanged "WordWrap"
  Refresh
End Property

'==========================================================================
'
'  Méthodes
'
'==========================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Refresh
Public Sub Refresh()
  UserControl.Refresh
End Sub

'==========================================================================
'
'  Fonctions et procédure internes
'
'==========================================================================
Private Sub DrawTabBack()
  If m_Style = ssStyleTabbedDialog Then
    DrawTabBackTabbed
  Else
    DrawTabBackProperty
  End If
End Sub
Private Sub DrawTabBackProperty()
  Dim x1 As Long, y1 As Long
  Dim x2 As Long, y2 As Long
  Dim OldScale As Integer
  Dim i As Integer, c As Long
  
  ' Sauvegarde du scale mode
  OldScale = UserControl.ScaleMode
  ' On passe en scale mode pixel
  UserControl.ScaleMode = 3
  ' Coordonnées du rectangle d'encadrement
  x1 = 0
  y1 = m_TabHeight - 1
  x2 = UserControl.ScaleWidth - 1
  y2 = UserControl.ScaleHeight - 1
  
  ' Fond
  UserControl.Line (x1, y1)-(x2, y2), m_SelectedTabColor, BF
  ' Bord gauche
  UserControl.Line (x1 + 1, y1)-(x1 + 1, y2 - 1), m_HighlightColor3D, BF
  
  ' Bord bas
  UserControl.Line (x1, y2)-(x2, y2), m_DarkColor3D, BF
  UserControl.Line (x1 + 1, y2 - 1)-(x2 - 1, y2 - 1), m_LowlightColor3D, BF
  
  ' Bord droit
  UserControl.Line (x2, y1)-(x2, y2), m_DarkColor3D, BF
  UserControl.Line (x2 - 1, y1)-(x2 - 1, y2 - 1), m_LowlightColor3D, BF
  
  ' Bord haut
  UserControl.Line (x1 + 1, y1)-(x2 - 1, y1), m_HighlightColor3D, BF
  ' restauration du scale mode
  UserControl.ScaleMode = OldScale
End Sub

Private Sub DrawTabBackTabbed()
  Dim x1 As Long, y1 As Long
  Dim x2 As Long, y2 As Long
  Dim OldScale As Integer
  Dim i As Integer, c As Long
  
  ' Sauvegarde du scale mode
  OldScale = UserControl.ScaleMode
  ' On passe en scale mode pixel
  UserControl.ScaleMode = 3
  ' Coordonnées du rectangle d'encadrement
  x1 = 0
  y1 = m_TabHeight
  x2 = UserControl.ScaleWidth - 1
  y2 = UserControl.ScaleHeight - 1
  
  ' Fond
  UserControl.Line (x1, y1)-(x2, y2), m_SelectedTabColor, BF
  ' Bord gauche
  UserControl.Line (x1, y1)-(x1, y2), m_DarkColor3D, BF
  UserControl.Line (x1 + 1, y1)-(x1 + 1, y2 - 1), m_HighlightColor3D, BF
  UserControl.Line (x1 + 2, y1)-(x1 + 2, y2 - 2), m_HighlightColor3D, BF
  
  ' Bord bas
  UserControl.Line (x1, y2)-(x2, y2), m_DarkColor3D, BF
  UserControl.Line (x1 + 1, y2 - 1)-(x2 - 1, y2 - 1), m_LowlightColor3D, BF
  UserControl.Line (x1 + 2, y2 - 2)-(x2 - 1, y2 - 2), m_LowlightColor3D, BF
  
  ' Bord droit
  UserControl.Line (x2, y1)-(x2, y2), m_DarkColor3D, BF
  UserControl.Line (x2 - 1, y1)-(x2 - 1, y2 - 1), m_LowlightColor3D, BF
  UserControl.Line (x2 - 2, y1)-(x2 - 2, y2 - 1), m_LowlightColor3D, BF
  
  ' restauration du scale mode
  UserControl.ScaleMode = OldScale
End Sub
Private Sub DrawTab(n As Integer)
  If m_Style = ssStyleTabbedDialog Then
    DrawTabTabbed n
  Else
    DrawTabProperty n
  End If
End Sub

Private Sub DrawTabProperty(n As Integer)
' n=[0 .. m_Tabs-1]
  Dim x1 As Long, y1 As Long
  Dim x2 As Long, y2 As Long
  Dim OldScale As Integer
  Dim i As Integer, c As Long
  Dim w As Long, wt As Long, ht As Long
  Dim HighLight As Boolean
  Dim PrevHighLight As Boolean
  Dim NextHighLight As Boolean
  Dim r As RECT
  PrevHighLight = False
  If n = (m_CurrentTab) Then HighLight = True Else HighLight = False
  If m_CurrentTab = n - 1 Then PrevHighLight = True Else PrevHighLight = False
  If m_CurrentTab = n + 1 Then NextHighLight = True Else NextHighLight = False
  ' Sauvegarde du scale mode
  OldScale = UserControl.ScaleMode
  ' On passe en scale mode pixel
  UserControl.ScaleMode = 3
  ' une marge de 7 pixels de chaque coté du caption
  w = UserControl.TextWidth(KLBTabDefs(n).Caption) + 14
  ' marge supplémentaire de 1 pixel de chaque coté pour le tab actif
  If HighLight Then w = w + 2
  If n > 0 Then
    x1 = KLBTabDefs(n - 1).ClickRect.Right + 1
  Else
    x1 = 0
  End If
  y1 = 0
  x2 = x1 + w - 1
  y2 = m_TabHeight - 1
  
  ' Ajustement
  If Not HighLight Then
    y1 = y1 + 3
    y2 = y2 - 1
    If n = 0 Then x1 = x1 + 3
  Else
    If NextHighLight Then x2 = x2 + 2
    y1 = y1 + 1
  End If
  
  ' Sauvegarde de la zone clickable
  KLBTabDefs(n).ClickRect.Left = x1
  KLBTabDefs(n).ClickRect.Right = x2
  KLBTabDefs(n).ClickRect.Top = y1
  KLBTabDefs(n).ClickRect.Bottom = y2
  
  ' Fond
  If HighLight Then c = m_SelectedTabColor Else c = m_TabColor
  UserControl.Line (x1, y1)-(x2, y2), c, BF
  
  ' Gauche / Haut
  If PrevHighLight Then
    UserControl.Line (x1, y1)-(x2 - 2, y1), m_HighlightColor3D, BF
  Else
    UserControl.Line (x1, y1)-(x1 + 1, y1 + 1), UserControl.BackColor, BF
    UserControl.Line (x1, y1 + 2)-(x1, y2), m_HighlightColor3D, BF
    UserControl.Line (x1 + 1, y1 + 1)-(x1 + 1, y1 + 1), m_HighlightColor3D, BF
    If NextHighLight Then
      UserControl.Line (x1 + 2, y1)-(x2 - 2, y1), m_HighlightColor3D, BF
    Else
      UserControl.Line (x1 + 2, y1)-(x2 - 1, y1), m_HighlightColor3D, BF
    End If
  End If
  
  ' Droite
  If NextHighLight Then
    UserControl.Line (x2 - 1, y1)-(x2, y1), m_HighlightColor3D, BF
  Else
    UserControl.Line (x2 - 1, y1)-(x2, y1 + 1), UserControl.BackColor, BF
    UserControl.Line (x2, y1 + 2)-(x2, y2), m_DarkColor3D, BF
    UserControl.Line (x2 - 1, y1 + 1)-(x2 - 1, y1 + 1), m_DarkColor3D, BF
    UserControl.Line (x2 - 1, y1 + 2)-(x2 - 1, y2), m_LowlightColor3D, BF
  End If
  
  
  If HighLight Then
    UserControl.ForeColor = m_SelectedTextColor
  Else
    UserControl.ForeColor = m_TextColor
  End If
  wt = UserControl.TextWidth(KLBTabDefs(n).Caption)
  ht = UserControl.TextHeight(KLBTabDefs(n).Caption)
  UserControl.CurrentX = x1 + ((w - wt) \ 2)
  UserControl.CurrentY = y1 + ((m_TabHeight - ht) \ 2)
  UserControl.Print KLBTabDefs(n).Caption
  ' Rectangle de focus
  If HighLight And m_Focus And m_ShowFocusRect Then
    ' Dessin du cadre de focus avec 2 pixels de marges haut/bas et 4 pixels de marge gauche/droite autour du caption
    wt = wt + 8
    ht = ht + 4
    UserControl.ForeColor = m_SelectedTextColor
    r.Left = x1 + ((w - wt) \ 2)
    r.Top = y1 + ((m_TabHeight - ht) \ 2)
    r.Right = r.Left + wt
    r.Bottom = r.Top + ht
    DrawFocusRect UserControl.hdc, r
  End If
  ' restauration du scale mode
  UserControl.ScaleMode = OldScale
End Sub

Private Sub DrawTabTabbed(n As Integer)
' n=[0 .. m_Tabs-1]
  Dim x1 As Long, y1 As Long
  Dim x2 As Long, y2 As Long
  Dim OldScale As Integer
  Dim i As Integer, c As Long
  Dim w As Long, wt As Long, ht As Long
  Dim HighLight As Boolean
  Dim r As RECT
  Dim dp As DRAWTEXTPARAMS
  Dim fb As Boolean
  Dim s As String
  Dim DT_Def As Long
  
  If n = (m_CurrentTab) Then HighLight = True Else HighLight = False
  ' Sauvegarde du scale mode
  OldScale = UserControl.ScaleMode
  ' On passe en scale mode pixel
  UserControl.ScaleMode = 3
  
  ' Largeur d'un tab
  w = UserControl.ScaleWidth \ m_Tabs
  ' Coordonnées du rectangle d'encadrement
  x1 = n * w
  y1 = 0
  x2 = x1 + w - 1
  y2 = m_TabHeight - 1
  ' Sur le dernier tab, on ajuste la largeur si on est pas sur un compte rond
  If n = (m_Tabs - 1) Then
    x2 = x2 + (UserControl.ScaleWidth - (m_Tabs * w))
  End If
  
  ' Sauvegarde de la zone clickable
  KLBTabDefs(n).ClickRect.Left = x1
  KLBTabDefs(n).ClickRect.Right = x2
  KLBTabDefs(n).ClickRect.Top = y1
  KLBTabDefs(n).ClickRect.Bottom = y2
  
  ' Fond
  If HighLight Then c = m_SelectedTabColor Else c = m_TabColor
  For i = 4 To y2
    UserControl.Line (x1, i)-(x2, i), c, BF
  Next
  
  'Dessin du texte
  fb = UserControl.FontBold
  If HighLight Then
    UserControl.ForeColor = m_SelectedTextColor
    UserControl.FontBold = True
  Else
    UserControl.ForeColor = m_TextColor
  End If
  ' Marge de 3 pixels en horizontal
  KLBTabDefs(n).ClickRect.Left = KLBTabDefs(n).ClickRect.Left + 3
  KLBTabDefs(n).ClickRect.Top = KLBTabDefs(n).ClickRect.Top
  KLBTabDefs(n).ClickRect.Bottom = KLBTabDefs(n).ClickRect.Bottom
  KLBTabDefs(n).ClickRect.Right = KLBTabDefs(n).ClickRect.Right - 3
  
  r.Left = KLBTabDefs(n).ClickRect.Left
  r.Top = KLBTabDefs(n).ClickRect.Top
  r.Right = KLBTabDefs(n).ClickRect.Right
  r.Bottom = KLBTabDefs(n).ClickRect.Bottom
  s = KLBTabDefs(n).Caption
  
  If m_WordWrap Then
    DT_Def = DT_CENTER + DT_VCENTER + DT_WORDBREAK
  Else
    DT_Def = DT_CENTER + DT_VCENTER + DT_SINGLELINE
  End If
  ' La on ne dessine pas vraiment, l'API va nous retourner la hauteur nécessaire pour dessiner le texte
  DrawText UserControl.hdc, s, Len(s), r, DT_Def + DT_CALCRECT + DT_MODIFYSTRING
  
  ' On s'ajuste pour pouvoir centrer verticalement (l'API ne peut centrer qu'en SINGLELINE)
  r.Top = r.Top + (((KLBTabDefs(n).ClickRect.Bottom - KLBTabDefs(n).ClickRect.Top) - (r.Bottom - KLBTabDefs(n).ClickRect.Top)) / 2)
  r.Left = KLBTabDefs(n).ClickRect.Left
  r.Right = KLBTabDefs(n).ClickRect.Right
  r.Bottom = KLBTabDefs(n).ClickRect.Bottom
  ' Et on dessine vraiment le texte cette fois ci
  DrawText UserControl.hdc, s, Len(s), r, DT_Def
  
  ' ligne bas en blanc si non actif
  If Not HighLight Then UserControl.Line (x1, y2 - 1)-(x2, y2), m_HighlightColor3D, BF
  
  ' ligne gauche noire
  UserControl.Line (x1, y1 + 4)-(x1, y2), m_DarkColor3D, BF
  ' ligne blanche juste à coté
  UserControl.Line (x1 + 1, y1 + 4)-(x1 + 1, y2), m_HighlightColor3D, BF
  ' doublée si actif
  If HighLight Then UserControl.Line (x1 + 2, y1 + 4)-(x1 + 2, y2), m_HighlightColor3D, BF
  ' 2 point blanc en bas à gauche si pas premier onglet
  If n > 0 Then UserControl.Line (x1, y2 - 1)-(x1, y2), m_HighlightColor3D, BF
  
  ' coin supérieur gauche
  UserControl.Line (x1 + 1, y1 + 3)-(x1 + 1, y1 + 3), m_DarkColor3D, BF
  UserControl.Line (x1 + 2, y1 + 2)-(x1 + 2, y1 + 2), m_DarkColor3D, BF
  UserControl.Line (x1 + 3, y1 + 1)-(x1 + 3, y1 + 1), m_DarkColor3D, BF
  UserControl.Line (x1 + 2, y1 + 3)-(x1 + 2, y1 + 3), m_HighlightColor3D, BF
  UserControl.Line (x1 + 3, y1 + 2)-(x1 + 3, y1 + 2), m_HighlightColor3D, BF
  UserControl.Line (x1 + 4, y1 + 1)-(x1 + 4, y1 + 1), m_HighlightColor3D, BF
  
  ' Haut (trait noir + trait blanc en dessous)
  UserControl.Line (x1 + 4, y1)-(x2 - 4, y1), m_DarkColor3D, BF
  If HighLight Then
    UserControl.Line (x1 + 4, y1 + 1)-(x2 - 4, y1 + 1), m_HighlightColor3D, BF
    UserControl.Line (x1 + 4, y1 + 2)-(x2 - 5, y1 + 2), m_HighlightColor3D, BF
    UserControl.Line (x1 + 4, y1 + 3)-(x1 + 4, y1 + 3), m_HighlightColor3D, BF
    UserControl.Line (x1 + 4, y1 + 3)-(x1 + 4, y1 + 3), m_HighlightColor3D, BF
    UserControl.Line (x1 + 5, y1 + 3)-(x2 - 5, y1 + 3), m_SelectedTabColor, BF
    UserControl.Line (x1 + 3, y1 + 4)-(x1 + 3, y1 + 4), m_HighlightColor3D, BF
    UserControl.Line (x1 + 3, y1 + 3)-(x1 + 3, y1 + 3), m_HighlightColor3D, BF
    UserControl.Line (x2 - 4, y1 + 2)-(x2 - 4, y1 + 2), m_LowlightColor3D, BF
    UserControl.Line (x2 - 4, y1 + 3)-(x2 - 4, y1 + 3), m_LowlightColor3D, BF
    UserControl.Line (x2 - 3, y1 + 3)-(x2 - 3, y1 + 3), m_LowlightColor3D, BF
    UserControl.Line (x2 - 3, y1 + 4)-(x2 - 3, y1 + 4), m_LowlightColor3D, BF
  Else
    UserControl.Line (x1 + 4, y1 + 1)-(x2 - 5, y1 + 1), m_HighlightColor3D, BF
    UserControl.Line (x1 + 4, y1 + 2)-(x2 - 4, y1 + 2), m_TabColor, BF
    UserControl.Line (x1 + 3, y1 + 3)-(x2 - 3, y1 + 3), m_TabColor, BF
  End If
  
  ' coin supérieur droit
  UserControl.Line (x2 - 3, y1 + 1)-(x2 - 3, y1 + 1), m_DarkColor3D, BF
  UserControl.Line (x2 - 2, y1 + 2)-(x2 - 2, y1 + 2), m_DarkColor3D, BF
  UserControl.Line (x2 - 1, y1 + 3)-(x2 - 1, y1 + 3), m_DarkColor3D, BF
  If Not HighLight Then UserControl.Line (x2 - 4, y1 + 1)-(x2 - 4, y1 + 1), m_LowlightColor3D, BF
  UserControl.Line (x2 - 3, y1 + 2)-(x2 - 3, y1 + 2), m_LowlightColor3D, BF
  UserControl.Line (x2 - 2, y1 + 3)-(x2 - 2, y1 + 3), m_LowlightColor3D, BF
  
  ' Bord droit noir
  If n < (m_Tabs - 1) Then
    If HighLight Then
      UserControl.Line (x2 - 2, y2 - 1)-(x2, y2), m_HighlightColor3D, BF
      UserControl.Line (x2, y1 + 4)-(x2, y2 - 2), m_DarkColor3D, BF
      UserControl.Line (x2 - 1, y1 + 4)-(x2 - 1, y2 - 2), m_LowlightColor3D, BF
    Else
      UserControl.Line (x2, y1 + 4)-(x2, y2 - 3), m_DarkColor3D, BF
      UserControl.Line (x2 - 1, y1 + 4)-(x2 - 1, y2 - 3), m_LowlightColor3D, BF
    End If
  Else
    UserControl.Line (x2, y1 + 4)-(x2, y2), m_DarkColor3D, BF
    UserControl.Line (x2 - 1, y1 + 4)-(x2 - 1, y2), m_LowlightColor3D, BF
  End If
  If HighLight Then
    If n < (m_Tabs - 1) Then
      UserControl.Line (x2 - 2, y1 + 4)-(x2 - 2, y2 - 1), m_LowlightColor3D, BF
    Else
      UserControl.Line (x2 - 2, y1 + 4)-(x2 - 2, y2), m_LowlightColor3D, BF
    End If
  End If
  If Not HighLight And n = (m_Tabs - 1) Then UserControl.Line (x2 - 2, y2)-(x2 - 2, y2), m_LowlightColor3D, BF
  ' séparation noire en bas si non actif
  If Not HighLight Then UserControl.Line (x1, y2 - 2)-(x2, y2 - 2), m_DarkColor3D, BF
  
  wt = UserControl.TextWidth(KLBTabDefs(n).Caption)
  ht = UserControl.TextHeight(KLBTabDefs(n).Caption)
 
  
  ' Rectangle de focus
  If HighLight And m_Focus And m_ShowFocusRect Then
    ' Dessin du cadre de focus avec 2 pixels de marges haut/bas et 3 pixels de marge gauche/droite autour du caption
    wt = wt + 6
    ht = ht + 2
    If wt > (x2 - x1) Then wt = x2 - x1
    UserControl.ForeColor = m_SelectedTextColor
    r.Left = x1 + ((w - wt) \ 2)
    r.Top = y1 + ((m_TabHeight - ht) \ 2)
    r.Right = r.Left + wt
    r.Bottom = r.Top + ht
    DrawFocusRect UserControl.hdc, r
  End If
  UserControl.FontBold = fb
  ' restauration du scale mode
  UserControl.ScaleMode = OldScale
End Sub

Private Function GetControlID(ctr As Control) As String
  Dim s As String, n As Integer
  n = -1
  On Error Resume Next
  s = ctr.Name
  n = ctr.index
  If n >= 0 Then s = s & "(" & n & ")"
  GetControlID = s
End Function

Private Function GetIndexContainedControl(ControlID As String)
  Dim ctr As Control
  Dim cID As String
  Dim i As Integer, nb As Integer
  nb = ContainedControls.Count
  For i = 0 To nb - 1
    Set ctr = ContainedControls(i)
    cID = GetControlID(ctr)
    If ControlID = cID Then
      GetIndexContainedControl = i
      Exit Function
    End If
  Next
  GetIndexContainedControl = -1
End Function

Private Sub MemoCurrentTab(SetInvisible As Boolean)
  Dim n As Integer
  Dim ctr As Control
  Dim l As Long
  
  'on vide le tableau du tab actif
  ReDim KLBTabDefs(m_CurrentTab).KLBContainedControls(0)
  KLBTabDefs(m_CurrentTab).NbContainedControls = 0
  n = 0
  
  On Error Resume Next
  For Each ctr In UserControl.ContainedControls
    ' pour certains contrôles (comme les timers), en mode exécution
    ' la propriété left n'est pas utilisable, pour éviter que le
    ' contrôle se retrouve sur chaque tab actif, on l'ignore tout
    ' bêtement (la 2eme ligne génère une erreur donc l reste à -75000)
    l = -75000
    l = ctr.Left
    If l > -32000 Then
      ' Un contôle dans le tab actif, on mémorise
      n = n + 1
      KLBTabDefs(m_CurrentTab).NbContainedControls = n
      ReDim Preserve KLBTabDefs(m_CurrentTab).KLBContainedControls(n)
      KLBTabDefs(m_CurrentTab).KLBContainedControls(n - 1).ControlID = GetControlID(ctr)
      KLBTabDefs(m_CurrentTab).KLBContainedControls(n - 1).ControlTabStop = ctr.TabStop
      ' Doit on passer les contrôles actif en zone non visible ?
      If SetInvisible Then
        ctr.Left = l - 75000
        If UserControl.Ambient.UserMode Then
          ctr.TabStop = False
        End If
      End If
    End If
  Next
End Sub

Private Sub ShowCurrentTabControls()
  Dim i As Integer
  Dim n As Integer
  Dim idx As Integer
  Dim ctr As Control
  
  n = KLBTabDefs(m_CurrentTab).NbContainedControls
  
  On Error Resume Next
  
  For i = 0 To n - 1
    ' pour chaque contrôle on va chercher son index dans la collection ContainedControls
    idx = GetIndexContainedControl(KLBTabDefs(m_CurrentTab).KLBContainedControls(i).ControlID)
    ' ce qui nous permet d'avoir une référence sur le contrôle
    If idx >= 0 Then
      Set ctr = UserControl.ContainedControls(idx)
      ' Déplacement en zone visible (imitation de la méthode Microsoft pour rester compatible)
      If ctr.Left < -32000 Then ctr.Left = ctr.Left + 75000
      ' Récupération du tabstop mémorisé si on est pas en mode dev
      If UserControl.Ambient.UserMode Then
        ctr.TabStop = KLBTabDefs(m_CurrentTab).KLBContainedControls(i).ControlTabStop
      End If
    End If
  Next
End Sub

Private Sub InitTabStopControls()
  Dim i As Integer, j As Integer
  Dim n As Integer, idx As Integer
  Dim ctr As Control
  
  On Error Resume Next
  
  For i = 0 To m_Tabs - 1
    n = KLBTabDefs(i).NbContainedControls
    For j = 0 To n - 1
      idx = GetIndexContainedControl(KLBTabDefs(i).KLBContainedControls(j).ControlID)
      If idx >= 0 Then
        Set ctr = UserControl.ContainedControls(idx)
        If ctr.Left < -32000 Then
          ' mémorisation du tabstop
          KLBTabDefs(i).KLBContainedControls(j).ControlTabStop = ctr.TabStop
          ctr.TabStop = False
        End If
      End If
    Next
  Next
End Sub
Conclusion :

Attention : la propriété Tab du controle SSTab est remplacée ici par CurrentTab.
La gestion de plusieur lignes d'onglets (TabsPerRow) n'est pas implémentée ni les propriété TabMaxWidth et TabOrientation
Télécharger le projet
Codes Sources

Télécharger
KLBTab.ctl
A voir également

Sstab
Sstab vb6 - Meilleures réponses
Memberinfo.php?id= - Meilleures réponses
Visual Basic / VB.NET : Ajout d'une tab quasi automatique dans un sstab - CodeS SourceS - Guide
Retrouver le numéro de l'onglet d'un sstab se trouvant sous la souris - Codes sources - Visual Basic / VB.NET (Control)
Move sstab - Codes sources - Visual Basic / VB.NET (Divers)
Utilisation du contrôle sstab - Codes sources - Visual Basic / VB.NET (Control)
Visual Basic / VB.NET : Un sstab sans tabctl32.ocx - CodeS SourceS - Guide
Ajouter un commentaire Commentaires
Signaler
cs_Jack
Messages postés: 14008
Date d'inscription: samedi 29 décembre 2001
Statut: Modérateur
Dernière intervention: 28 août 2015
75
Modifié par cs_Jack le 28/10/2014 à 12:54
Même 13 ans après, je découvre encore de belle pépites comme cette source.
Vraiment identique au SSTab classique.
Presque pas de souci avec les objets implantés sur les Tabs.
Bien sûr, des fonctionnalités à ajouter, mais la base est solide.
Bravo.
Signaler
Galactus13
Messages postés: 332
Date d'inscription: lundi 29 septembre 2008
Statut: Membre
Dernière intervention: 10 avril 2020
1
1 juil. 2013 à 13:11
Chapeau, magnifique.
Le seul coté négatif est de devoir faire édition.
Signaler
Polack77
Messages postés: 1098
Date d'inscription: mercredi 22 mars 2006
Statut: Membre
Dernière intervention: 22 octobre 2019
12 janv. 2010 à 15:53
Bonjour,

Déjà merci pour ce control qui m'est BIEN utile (9/10) :)
Il faudrait ajouter un appel à Refresh dans la propriété Let de Style (pour voir changé le style immédiatement dans le design ;) )
Existe t'il une mise à jours incluant l'orientation ?

Bonne année :)
Signaler
KrocLeBo
Messages postés: 18
Date d'inscription: jeudi 7 juin 2001
Statut: Membre
Dernière intervention: 19 avril 2010
30 déc. 2007 à 11:20
Hello Jhon

Tout comme le contrôle original, il faut d'abord rendre actif le tab sur lequel tu veux modifier le caption
KlbTab.CurrentTab = 1
KlbTab.Caption = "onglet2"

@ bientôt
Signaler
john_pet
Messages postés: 8
Date d'inscription: mardi 23 décembre 2003
Statut: Membre
Dernière intervention: 22 septembre 2009
29 déc. 2007 à 22:18
Petite question

comment changer le nom d'un onglet par programmation
du genre
KlbTab.CurrentTab(1).Caption = "onglet2"
qui ne fonctionne pas

mrci
Afficher les 35 commentaires
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.
Remplaçant pour sstab avec gestion des couleurs

Description

Source / Exemple :

Conclusion :

Codes Sources

A voir également

Vous n'êtes pas encore membre ?

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

Du même auteur (KrocLeBo)

Webcaptureimages - capture automatiques d'images

Source / Exemple :

Conclusion :

A voir également

Vous n'êtes pas encore membre ? inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Du même auteur (KrocLeBo)

Webcaptureimages - capture automatiques d'images

Vous n'êtes pas encore membre ?

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