Soyez le premier à donner votre avis sur cette source.
Vue 14 201 fois - Téléchargée 1 548 fois
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
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.
Le seul coté négatif est de devoir faire édition.
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 :)
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
comment changer le nom d'un onglet par programmation
du genre
KlbTab.CurrentTab(1).Caption = "onglet2"
qui ne fonctionne pas
mrci
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.