Apprendre la programmation en VBA pour EXCEL par la pratique - Cinquième partie

Dim MémoDonnées As Variant  ' Mémoire pour sauvegarder les valeurs du tableau de données.
Dim MémoAdresse As String   ' Mémoire pour sauvegarder l'adresse de la plage du tableau.
Dim TD As Range             ' Mémoire pour le tableau de données.

' Affecte un tableau de données :
Set TD = Range("Tableau1")

' Mémorise les données du tableau :
MémoDonnées = TD.Value

' Mémorise la plage du tableau :
MémoAdresse = TD.CurrentRegion.Address

... Suite du code ...

' Efface les données existantes et les éventuelles lignes ajoutées :
If TD.ListObject.ListRows.Count > 0 Then TD.ListObject.DataBodyRange.ClearContents

' Redimensionne le tableau à sa taille d'origine :
TD.ListObject.Resize Range(MémoAdresse)

' Restaure les données mémorisées :
TD.ListObject.DataBodyRange.Value = MémoDonnées

Dim TD As Range ' Mémoire pour le tableau de données.

' Affecte un tableau de données :
Set TD = Range("Tableau1")

' Configuration du tri:
If TD.ListObject.DataBodyRange Is Nothing = False Then   ' S'il y a des données.
    With TD.ListObject.Sort
        .SortFields.Clear                        ' Efface les anciens critères.
        .SortFields.Add Key:=TD(0, NumColonne1)  ' NumColonne1 = 1re colonne de tri.
        .SortFields.Add Key:=TD(0, NumColonne2)  ' NumColonne2 = 2e colonne de tri.
        .Header = xlYes                          ' Avec en-tête.
        .Apply                                   ' Exécute le tri.
    End With
End If

'---------------------------------------------------------------------------------------
Public Function SelectTD(TD As Range, StrChamps As String, _
                         Optional ByVal StrSQL As String = "", _
                         Optional MessageSiErreur As Boolean = False, _
                         Optional ByRef NumErr As Long = 0) As DAO.Recordset
'---------------------------------------------------------------------------------------
Dim Db As DAO.Database, Rs As DAO.Recordset

' Gestion des erreurs :
Err.Clear: On Error GoTo Gest_Err

' Requête sur le tableau de données passé en argument (ou la plage avec en-tête)
StrSQL = "SELECT " & IIf(StrChamps > "", StrChamps, "*") & " FROM [" & TD.Parent.Name & "$" _
         & TD.CurrentRegion.Address(False, False, xlA1) & "] " & StrSQL

Set Db = DAO.OpenDatabase(TD.Worksheet.Parent.FullName, False, False, "Excel 8.0;HDR=YES;")
Set Rs = Db.OpenRecordset(StrSQL)

' S'il y a des enregistrements concernés:
If Rs.EOF = False Then
    Rs.MoveFirst            ' Replace le pointeur au début du jeu d'enregistrements.
    Set SelectTD = Rs       ' Retourne les enregistrements.
End If

Gest_Err:
NumErr = Err.Number
If Err.Number <> 0 And MessageSiErreur = True Then _
    MsgBox StrSQL & Chr(10) & Chr(13) & Chr(13) & Err.Number & " : " & Err.Description
Err.Clear
End Function
'---------------------------------------------------------------------------------------

Dim Enr As DAO.Recordset
Dim TD As Range

Set TD = ThisWorkbook.Sheets("Feuil1").Range("T_Personne")
Set Enr = SelectTD(TD, "Nom, Prénom", _
                   "WHERE Age > 18 AND Prénom like 'M*' AND Sexe = 'Masculin' " _
                 & "ORDER BY Nom, Prénom")

If Not Enr Is Nothing Then ' Si un jeu d'enregistrements a été retourné par la requête.
    ThisWorkbook.Sheets("Feuil1").Range("F1").CopyFromRecordset Enr
End If

Dim Enr As DAO.Recordset
Set Enr = SelectTD(Range("T_Personne"), "AVG (Age)", "WHERE Sexe = 'Masculin' ")
Range("F5") = Enr.Fields(0)

Dim Enr As DAO.Recordset
Set Enr = SelectTD(Range("T_Personne"), "Nom", "WHERE Prénom IN('Hugo', 'Margaux')")
If Not Enr Is Nothing Then Range("F1").CopyFromRecordset Enr

Dim Enr As DAO.Recordset
Set Enr = SelectTD(Range("T_Personne"), "Sexe, AVG (Age)", "GROUP BY Sexe ORDER BY AVG (Age)")

If Not Enr Is Nothing Then ThisWorkbook.Sheets("Feuil1").Range("F1").CopyFromRecordset Enr

Dim Enr As DAO.Recordset
Set Enr = SelectTD(Range("T_Personne"), "TOP 3 Nom, prénom, Age", "ORDER BY Age")
If Not Enr Is Nothing Then ThisWorkbook.Sheets("Feuil1").Range("F1").CopyFromRecordset Enr

Dim Enr As DAO.Recordset
Set Enr = SelectTD(Range("T_Personne"), "DISTINCT Sexe", "WHERE Sexe <> '' ORDER BY Sexe")

If Not Enr Is Nothing Then
    While Enr.EOF = False ' Boucle sur les enregistrements sélectionnés.
        Debug.Print Enr.Fields("Sexe").Value ' Affiche la valeur dans l'éditeur.
        Enr.MoveNext ' Passe à l'enregistrement suivant.
    Wend
End If

' Sélectionne tous les enregistrements du champ " Prénom" dans le tableau "T_Personne" :
Dim Enr As DAO.Recordset
Set Enr = SelectTD(Range("T_Personne"), "Prénom") 

' Boucle sur les enregistrements tant que Fin De Fichier (EOF) = Faux :
While Enr.EOF = False  
Enr.Edit                                       ' Passe en mode Modification.
    Enr.Fields(0).Value = Ucase(Enr.Fields(0).Value) ' Modifie la valeur du 1er champ (base 0).
    Enr.Update                                       ' Valide la modification.
    Enr.MoveNext                  ' lit l'enregistrement suivant (EOF = Vrai si plus d'enreg).
Wend                              ' Sortira de la boucle quand tous les enreg seront lus.

Dim Enr As DAO.Recordset
Set Enr = SelectTD(Range("A1"), "CDR, Count(Modele)", _
                  "GROUP BY CDR, Modele HAVING (Modele Like 'GAF*' AND Count(Modele)>=2)")
                                              
If Not Enr Is Nothing Then Sheets("Feuil2").Range("A1").CopyFromRecordset Enr

'---------------------------------------------------------------------------------------
Public Function UpdateTD(TD As Range, StrChamps As String, _
                         StrSQL As String, ParamArray NvValeur() As Variant) As Long
'---------------------------------------------------------------------------------------
Dim Enr As DAO.Recordset, i As Long, NumErr As Long

' Gestion des erreurs :
Err.Clear: On Error GoTo Gest_Err

' Lance la requête de sélection des enregistrements :
Set Enr = SelectTD(TD, StrChamps, StrSQL, True, NumErr)

' Si des enregistrements ont été sélectionnés :
If Not Enr Is Nothing Then
    ' Boucle sur ces enregistrements :
    While Enr.EOF = False
        Enr.Edit ' Passe en mode modification.
        ' Cas particulier des suppressions (recherche un champ au format texte) :
        If NvValeur(0) = "®DeleteTD®" Then
            For i = 0 To Enr.Fields.Count - 1
                If Enr.Fields(i).Type = 10 Then Enr.Fields(i).Value = "®DeleteTD®": Exit For
            Next i
        Else
        ' Boucle sur les champs à mettre à jour :
            For i = LBound(NvValeur()) To UBound(NvValeur())
                Enr.Fields(i).Value = NvValeur(i)
            Next i
        End If
        Enr.Update              ' Valide la modification.
        Enr.MoveNext            ' Passe à l'enregistrement suivant.
        UpdateTD = UpdateTD + 1 ' Compte le nombre d'enregistrements modifiés.
    Wend
End If

Gest_Err:
If Err.Number <> 0 Or NumErr <> 0 Then UpdateTD = -9
Err.Clear
End Function
'---------------------------------------------------------------------------------------

Call UpdateTD(Range("T_Personne"), "Prénom, Age, Sexe", _
                "WHERE Nom = 'CHAPO' AND Prénom = 'Margaux' ", "Hugo", 19, "Masculin")

'---------------------------------------------------------------------------------------
Public Function DeleteTD(TD As Range, StrSQL As String) As Boolean
'---------------------------------------------------------------------------------------
Dim i As Long, ik As Integer, Conversion As Boolean

' Gestion des erreurs :
On Error GoTo Gest_Err

' Marque les enregistrements (le libellé "®DeleteTD®" est assez personnel pour ne pas être
' confondu avec les données de l'utilisateur et ainsi ne pas supprimer des données par erreur) :
If UpdateTD(TD, "*", StrSQL, "®DeleteTD®") > 0 Then

    ' Si TD est une plage alors la transforme en tableau de données:
    If TD.ListObject Is Nothing Then Set TD = ConvertirPlageEnTD(TD, "", ""): Conversion = True

    ' Supprime dans le tableau les lignes marquées et indique que des suppressions sont faites :
    For i = TD.ListObject.ListRows.Count To 1 Step -1
        For ik = 1 To TD.ListObject.HeaderRowRange.Count
            If TD.ListObject.DataBodyRange(i, ik) = "®DeleteTD®" Then
                TD.ListObject.ListRows(i).Delete
                DeleteTD = True
                Exit For
            End If
        Next ik
    Next i
    
    ' Si TD était une plage alors remet la plage d'origine :
    If Conversion = True Then Call ConvertirTDEnPlage(TD)
    
End If

' Fin du traitement :
Gest_Err:
Err.Clear
'-------------------------------------------------------------------------------

Call DeleteTD(Range("T_Personne"), "WHERE Age = 18")

'---------------------------------------------------------------------------------------
Public Function ConvertirPlageEnTD(TD As Range, _
                                   Optional ByRef TDName As String = "", _
                                   Optional ByRef TDStyle As String = "*") As Range
'---------------------------------------------------------------------------------------
On Error GoTo Gest_Err

' Si le TD existe déjà alors le retourne :
If Not TD.ListObject Is Nothing Then Set ConvertirPlageEnTD = TD

' Si TD ne représente qu'une seule cellule alors étend la plage :
If TD.Count = 1 Then Set TD = TD.CurrentRegion

' Création du TD en attribuant le nom passé ou en prenant celui attribué par EXCEL :
If TDName > "" Then
    Sheets(TD.Parent.Name).ListObjects.Add(xlSrcRange, TD, , xlYes).Name = TDName
Else
    Sheets(TD.Parent.Name).ListObjects.Add xlSrcRange, TD, , xlYes
End If

' Modifie le style s'il ne faut pas prendre celui par défaut, ou pas de style si vide :
If TDStyle <> "*" Then _
    Sheets(TD.Parent.Name).ListObjects(TD.ListObject.Name).TableStyle = TDStyle

' Retourne le nom du tableau de données et son style :
TDName = TD.ListObject.Name
TDStyle = Sheets(TD.Parent.Name).ListObjects(TD.ListObject.Name).TableStyle

' Retourne le tableau de données :
Set ConvertirPlageEnTD = TD

' Fin du traitement :
Gest_Err:
Err.Clear

End Function
'---------------------------------------------------------------------------------------

Dim TD As Range
Set TD = ConvertirPlageEnTD(Range("A1"))

'---------------------------------------------------------------------------------------
Public Function ConvertirTDEnPlage(TD As Range) As Boolean
'---------------------------------------------------------------------------------------
Err.Clear: On Error GoTo Gest_Err

Sheets(TD.Parent.Name).ListObjects(TD.ListObject.Name).TableStyle = "" ' Efface le style.
TD.ListObject.Unlist                                                   ' Efface l'objet.

' Fin du traitement :
Gest_Err:
If Err.Number = 0 Then ConvertirTDEnPlage = True
Err.Clear

End Function
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
Public Sub ClearTD(ByRef TD As Range)
'---------------------------------------------------------------------------------------
On Error Resume Next
TD.ListObject.DataBodyRange.ClearContents ' Efface le contenu du tableau de données.
Call ResizeTD(TD)                         ' Redimensionne le tableau de données.
Err.Clear
End Sub

'---------------------------------------------------------------------------------------
Public Function ResizeTD(ByRef TD As Range) As Long
'---------------------------------------------------------------------------------------
Dim TDName As String, SheetName As String, i As Long

' Gestion des erreurs :
Err.Clear: On Error GoTo Gest_err

TDName = TD.ListObject.Name                          ' Mémorise le lien sur le TD.
SheetName = TD.ListObject.Parent.Name                ' Mémorise la feuille du TD.
TD.ListObject.Resize Range(TD.CurrentRegion.Address) ' Redimensionne le TD.

' Ajoute une nouvelle ligne si le tableau de données est vierge :
If TD.ListObject.ListRows.Count = 0 Then
    TD.ListObject.ListRows.Add 1
    ResizeTD = 0
Else
    ResizeTD = TD.ListObject.ListRows.Count ' Retourne le nombre de lignes.
End If

' Cas particulier s'il y a 1 ligne. Vérifier si elle est vide ou non :
If ResizeTD = 1 Then
    ResizeTD = 0
    For i = 1 To TD.Columns.Count
        If TD(1, i) <> "" Then ResizeTD = 1: Exit For
    Next i
End If ' Retourne 0 si la ligne est vierge ou 1 si la ligne est active.

Set TD = ThisWorkbook.Sheets(SheetName).Range(TDName) ' Restaure le lien sur le tableau.

Gest_err:
If Err.Number <> 0 Then ResizeTD = -9
Err.Clear 
End Function
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
Public Function OrderTD(TD As Range, ParamArray StrChamps() As Variant) As Boolean
'---------------------------------------------------------------------------------------
Dim i As Integer, ik As Integer, Ordre As Long
Dim Clé As String

' Gestion des erreurs :
Err.Clear: On Error GoTo Gest_err

' Configuration du tri s'il y a des données dans le tableau :
If TD.ListObject.DataBodyRange Is Nothing = False Then
    With TD.ListObject.Sort
        .SortFields.Clear
        ' Boucle sur la liste des champs passés en argument :
        For i = LBound(StrChamps()) To UBound(StrChamps())
            ' Récupère l'ordre du classement :
            Ordre = xlAscending
            Clé = StrChamps(i)
            If Left(Clé, 1) = ">" Then 
                Clé = Mid(Clé, 2)
            Else
                If Left(Clé, 1) = "<" Then Clé = Mid(Clé, 2): Ordre = xlDescending
            End If
            ' Recherche la colonne de tri qui correspond à l'en-tête :
            For ik = 1 To TD.ListObject.HeaderRowRange.Count
                If TD(0, ik) = Clé Then .SortFields.Add Key:=TD(0, ik), Order:=Ordre
            Next ik
        Next i
        .Header = xlYes
        .Apply
    End With
End If

' Fin du traitement :
Gest_err:
If Err.Number <> 0 Then OrderTD = False
Err.Clear

End Function 
'-------------------------------------------------------------------------------

Call OrderTD(Range("T_Personne"), "Sexe", "<Age")

'---------------------------------------------------------------------------------------
Public Function MAJ_Sauvegardes(ByVal StrFeuille As String, ByVal Valeur As String, _
                                Optional Plage As Range) As String
'---------------------------------------------------------------------------------------
Dim StrDate As String, NvLigne As Long

' Gestion des erreurs :
Err.Clear: On Error GoTo Gest_err

' Définition de la date de la sauvegarde :
StrDate = "{" & Now & "}"

' 1re étape, création du fichier de sauvegarde dans le répertoire "\Sauvegardes_Sentinelle\".
' Le nom du fichier est la date du traitement sans les espaces et les barres obliques.
' Retourne une chaîne vide si pas d'erreur ou le code erreur et libellé :
MAJ_Sauvegardes = CréationSauvegardes(ThisWorkbook.Path & "\Sauvegardes_Sentinelle\", _
                                      DateControleEnFichier(StrDate) & ".xlsm", _
                                      StrFeuille, Plage)

' 2e étape (si pas d'erreur à l'étape 1) mise à jour du tableau des données "T_Sauvegardes" :
If MAJ_Sauvegardes = "" Then

    ' Corrige le nom de la feuille pour la mettre au format T_Sauvegardes :
    StrFeuille = "{" & StrFeuille & "}"     ' Nom de la feuille + plage de sélection.
    
    ' Si l'enregistrement existe déjà alors fait sa mise à jour, sinon sa création :
    Dim TD As Range
    Set TD = ThisWorkbook.Sheets("Sauvegardes").Range("T_Sauvegardes")
    
If UpdateTD(TD, "[Date de la sauvegarde], Valeur", _
                    "WHERE [Chemin]='" & ActiveWorkbook.Path & "'" _
                    & " AND [Classeur]='{" & ActiveWorkbook.Name & "}'" _
                    & " AND [Feuille] like '" & StrFeuille & "*'", _
                    StrDate, StrValeur) = 0 Then

        NvLigne = ResizeTD(TD) + 1
        ' Enregistre les nouvelles données:
        TD.ListObject.DataBodyRange(NvLigne, 1).Value = ActiveWorkbook.Path
        TD.ListObject.DataBodyRange(NvLigne, 2).Value = "{" & ActiveWorkbook.Name & "}"
        TD.ListObject.DataBodyRange(NvLigne, 3).Value = StrFeuille
        TD.ListObject.DataBodyRange(NvLigne, 4).Value = StrDate
        TD.ListObject.DataBodyRange(NvLigne, 5).Value = StrValeur
        TD.ListObject.DataBodyRange(NvLigne, 6).Value = "Oui"
    End If
  
End If

' Fin du traitement:
Gest_err:
If Err.Number <> 0 Then MAJ_Sauvegardes = StrFeuille & Chr(13) & Chr(13) & Chr(10) _
                 & Err.Number & " : " & Err.Description ' Libellé de l'erreur.
                 
' Attente si le traitement fait moins d'une seconde, pour éviter de donner le même nom
' de fichier à deux traitements différents :
While StrDate = "{" & Now & "}": DoEvents: Wend

End Function 
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
Private Function CréationSauvegardes(StrRépertoire As String, StrFichier As String, _
                                     StrFeuille As String, Optional Plage As Range) As String
'---------------------------------------------------------------------------------------
' Création du fichier de sauvegarde StrFichier dans le répertoire StrRépertoire.
' Retourne : "" si aucune erreur dans le traitement, ou le numéro de l'erreur et son libellé.
'---------------------------------------------------------------------------------------
Dim StrDest As String
Dim Wk As Workbook, Ws As Worksheet
Dim NvWk As Workbook, NvWs As Worksheet

' Création du répertoire de sauvegarde :
On Error Resume Next
MkDir StrRépertoire

' Gestion des erreurs :
Err.Clear: On Error GoTo Gest_err

' Mémorise le classeur et la feuille :
Set Wk = ActiveWorkbook
Set Ws = ActiveSheet

' Création d'un nouveau classeur :
Set NvWk = Workbooks.Add

' Copie la plage ou la feuille source dans le nouveau classeur :
If Plage Is Nothing = True Then
    Wk.Sheets(Ws.Name).Copy before:=NvWk.Sheets(1)
Else
    Wk.Sheets(Ws.Name).Range(Plage.Address).Copy _
            Destination:=NvWk.Sheets(1).Range(Plage.Address)
End If

' Création du nom du fichier destination :
StrDest = StrRépertoire & StrFichier

' Enregistrement du classeur au format xlsm (s'il y a des macros, HasVBProject = True):
NvWk.SaveAs StrDest, xlOpenXMLWorkbookMacroEnabled
NvWk.Close False
Set NvWk = Nothing

' Fin du traitement :
Gest_err:
If Err.Number <> 0 Then CréationSauvegardes = StrFeuille & Chr(13) & Chr(13) & Chr(10) _
                 & Err.Number & " : " & Err.Description ' Libellé de l'erreur.

' Éventuellement, force la fermeture du nouveau classeur sans l'enregistrer :
On Error Resume Next
If NvWk Is Nothing = False Then NvWk.Close False
Err.Clear 
End Function
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
Private Sub Workbook_Open()
'---------------------------------------------------------------------------------------
' Evénement déclenché à l'ouverture du classeur.
'---------------------------------------------------------------------------------------
On Error Resume Next
' Boucle sur les fenêtres actives pour masquer la fenêtre de ce classeur :
Dim W As Window
For Each W In Windows
    If W.Caption = ThisWorkbook.Name Then W.Visible = False
Next W

' Lance le menu :
Call MenuSentinelle
End Sub
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Événement déclenché à la fermeture du classeur
'---------------------------------------------------------------------------------------
On Error Resume Next
' Boucle sur les fenêtres actives pour afficher la fenêtre de ce classeur :
Dim W As Window
For Each W In Windows
    If W.Caption = ThisWorkbook.Name Then W.Visible = True
Next W

' Masque les feuilles de l'application sauf la feuille Accueil :
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name = "Accueil" Then Ws.Visible = xlSheetVisible Else Ws.Visible = xlSheetVeryHidden
Next Ws

' Enregistre le classeur :
ThisWorkbook.Close Savechanges:=True
End Sub
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
Public Sub MenuInstaller(Optional Feuille As String = "Menu", _
                         Optional Tableau As String = "T_Menu", _
                         Optional LimiterUneIcone As Long = -1)
'---------------------------------------------------------------------------------------
' Installe le menu de l'application dans l'onglet Compléments du ruban.
' Par défaut le tableau "T_Menu" de la feuille "Menu" est utilisé.
' Si LimiterUneIcone <> -1 alors n'installe que les éléments de cette icône.
'---------------------------------------------------------------------------------------
Dim MyMenuBar, NewMenu, NewPopup, NvCtrl
Dim TD As Range, i As Long

' Charge en mémoire le tableau qui contient les données pour le menu personnel :
On Error Resume Next
Set TD = ThisWorkbook.Sheets(Feuille).Range(Tableau)

' Boucle sur les lignes du tableau :
For i = 1 To TD.ListObject.ListRows.Count

    ' S'il faut limiter l'installation à une icône ou s'il n'y a pas cette limitation :
    If LimiterUneIcone = -1 _
    Or LimiterUneIcone = Val(TD(i, 4).Value) Then
    
        ' Définit le contrôle NvCtrl suivant le type de contrôle du menu :
        Select Case TD(i, 1).Value
        
            Case "Barre de Commande Contextuelle"
                Set MyMenuBar = Application.CommandBars.ActiveMenuBar
                Set NewMenu = MyMenuBar.Controls.Add(Type:=msoControlPopup, Temporary:=True)
                Set NvCtrl = NewMenu
                
            Case "Barre de Commande Bouton"
                Set MyMenuBar = Application.CommandBars.ActiveMenuBar
                Set NewMenu = MyMenuBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
                Set NvCtrl = NewMenu
                
            Case "Menu Contextuel"
                Set NewPopup = NewMenu.CommandBar.Controls.Add(Type:=msoControlPopup)
                Set NvCtrl = NewPopup
    
            Case "Sous Bouton de commande"
                Set NvCtrl = NewPopup.CommandBar.Controls.Add(Type:=msoControlButton)
                
            Case "Bouton de commande"
                Set NvCtrl = NewMenu.CommandBar.Controls.Add(Type:=msoControlButton)
        
        End Select
        
        ' Initialise les propriétés de ce nouveau contrôle :
        With NvCtrl
            .Caption = TD(i, 2).Value         ' Titre
            .TooltipText = TD(i, 3).Value     ' Info bulle
            .FaceId = TD(i, 4).Value          ' icône
            .OnAction = TD(i, 5).Value        ' Macro à lancer
            .BeginGroup = TD(i, 6).Value      ' Nouveau Groupe
            .DescriptionText = TD(i, 7).Value ' Description
            .Style = msoButtonIconAndCaption  ' Style
        End With
        
    End If

Next i
End Sub 
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
Public Sub MenuSupprimer(StrNom As String)
'---------------------------------------------------------------------------------------
' Boucle sur les menus pour supprimer le menu passé en argument qui correspond
' à son nom ou à sa description.
'---------------------------------------------------------------------------------------
Dim Cbar As CommandBar, Ctrl

For Each Cbar In Application.CommandBars
    If Cbar.Visible = True Then
        For Each Ctrl In Cbar.Controls
            If Ctrl.Caption = StrNom Or Ctrl.DescriptionText = StrNom Then Ctrl.Delete
        Next Ctrl
    End If
Next Cbar

End Sub
'---------------------------------------------------------------------------------------

'-------------------------------------------------------------------------------
Dim NumIcone As Long ' Position dans la liste de l'animation.
'-------------------------------------------------------------------------------
Private Sub UserForm_Activate()
'-------------------------------------------------------------------------------
Dim Tps As Double
Dim ListeIcone() As Variant

' Définition de la liste des icônes qui vont former l'animation :
ListeIcone() = Array("54", "55", "56", "123", "56", "55")
NumIcone = UBound(ListeIcone)

' Boucle tant que NumIcone > -1, c'est-à-dire tant que le formulaire n'est pas fermé :
Do

    ' Si 0.3 seconde s'est écoulée :
    If Timer > Tps + 0.3 Then
        Tps = Timer ' Mémorise l'heure actuelle.
        NumIcone = NumIcone + 1 ' Incrémente l'icône dans la liste des icônes.
        If NumIcone > UBound(ListeIcone) Then NumIcone = 0  ' Boucle sur la liste des icônes.
        Call MenuSupprimer("Icone") ' Efface l'icône
        Call MenuInstaller("Menu", "T_Icone", CLng(ListeIcone(NumIcone))) ' Affiche l'icône
    End If

    DoEvents ' Donne la main aux processus en cours.

Loop While NumIcone > -1

' Efface l'icône:
Call MenuSupprimer("Icone")

End Sub

'-------------------------------------------------------------------------------
Private Sub UserForm_Terminate()
'-------------------------------------------------------------------------------
NumIcone = -1 ' Termine la boucle dans UserForm_Activate
End Sub
'-------------------------------------------------------------------------------

'-------------------------------------------------------------------------------
Private Function ADO_ExecuteSQL(TD As Range, StrSQL As String, _
                                Optional MessageSiErreur As Boolean = False, _
                                Optional ByRef NumErr As Long = 0) As ADODB.Recordset
'-------------------------------------------------------------------------------
Dim Cnn As ADODB.Connection
Dim Rs As ADODB.Recordset

' Gestion des erreurs :
Err.Clear: On Error GoTo Gest_Err

' Création d'une connexion :
Set Cnn = New ADODB.Connection
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
         "Data Source=" & TD.Worksheet.Parent.FullName & ";" & _
         "Extended Properties=""Excel 12.0;HDR=Yes"";"

' Exécute une requête SQL sur un jeu d'enregistrements :
Set Rs = New ADODB.Recordset
Rs.Open StrSQL, Cnn, adOpenKeyset, adLockPessimistic, adCmdText

' S'il y a des enregistrements concernés :
If Rs.EOF = False Then
    Rs.MoveFirst              ' Replace le pointeur au début du jeu d'enregistrements.
    Set ADO_ExecuteSQL = Rs   ' Retourne les enregistrements.
End If

' Fin du traitement, libération des mémoires :
Gest_Err:
NumErr = Err.Number
If Err.Number <> 0 And MessageSiErreur = True Then _
    MsgBox StrSQL & Chr(10) & Chr(13) & Chr(13) & Err.Number & " : " & Err.Description

Set Rs = Nothing
Set Cnn = Nothing
Err.Clear

End Function
'-------------------------------------------------------------------------------

'-------------------------------------------------------------------------------
Public Function ADO_SelectTD(TD As Range, StrChamps As String, _
                             Optional ByVal StrSQL As String = "", _
                             Optional MessageSiErreur As Boolean = False, _
                             Optional ByRef NumErr As Long = 0) As ADODB.Recordset
'---------------------------------------------------------------------------------------
' Sélectionne les données d'un tableau de données EXCEL (ou une plage avec en-tête)
' et alimente ADO_SelectTD des enregistrements correspondants à la requête.
' TD : Le tableau des données (ou la plage avec en-tête). Maxi = A1:IU65535
' StrChamps : Liste des champs (ou * ou vide pour tous).
' StrSQL : Requête SQL avec ses conditions.
' MessageSiErreur : Indique s'il faut ou non afficher un message en cas d'erreur.
' NumErr : Alimente le numéro de l'erreur (0 si pas d'erreur).
'---------------------------------------------------------------------------------------
' Retourne : le jeu d'enregistrements sélectionnés.
'---------------------------------------------------------------------------------------
' Gestion des erreurs :
Err.Clear: On Error GoTo Gest_Err

' Requête sur le tableau de données passé en argument (ou la plage avec en-tête)
StrSQL = "SELECT " & IIf(StrChamps > "", StrChamps, "*") & " FROM [" & TD.Parent.Name & "$" _
         & TD.CurrentRegion.Address(False, False, xlA1) & "] " & StrSQL

' S'il y a des enregistrements concernés alors les retourne :
Set ADO_SelectTD = ADO_ExecuteSQL(TD, StrSQL, MessageSiErreur, NumErr)

' Fin du traitement :
Gest_Err:
NumErr = Err.Number + NumErr
If Err.Number <> 0 And MessageSiErreur = True Then _
    MsgBox StrSQL & Chr(10) & Chr(13) & Chr(13) & Err.Number & " : " & Err.Description

Err.Clear
End Function
'-------------------------------------------------------------------------------

'-------------------------------------------------------------------------------
Public Function ADO_UpdateTD(TD As Range, _
                             StrChamps As String, _
                             StrSQL As String, _
                             ParamArray NvValeur() As Variant) As Long
'---------------------------------------------------------------------------------------
' Sélectionne les données d'un tableau de données EXCEL (ou une plage avec en-tête)
' puis les modifie avec les informations contenues dans la liste NvValeur.
' TD : Le tableau des données (ou la plage avec en-tête). Maxi = A1:IU65535
' StrChamps : Liste des champs (ou * ou vide pour tous).
' StrSQL : Requête SQL avec ses conditions.
' NvValeur() : liste des nouvelles valeurs à appliquer aux champs sélectionnés
'---------------------------------------------------------------------------------------
' Retourne : -9 si erreur, >=0 le nombre d'enregistrements mis à jour
'---------------------------------------------------------------------------------------
Dim Enr As ADODB.Recordset, i As Integer, EtatScreenUpdating  As Boolean, NumErr As Long

' Gestion des erreurs :
Err.Clear: On Error GoTo Gest_Err
EtatScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False

' Lance la requête de sélection des enregistrements :
Set Enr = ADO_SelectTD(TD, StrChamps, StrSQL, True, NumErr)

' Si des enregistrements ont été sélectionnés :
If Not Enr Is Nothing Then
    ' Boucle sur ces enregistrements :
    While Enr.EOF = False
        ' Cas particulier des suppressions (recherche un champ au format texte) :
        If NvValeur(0) = "®DeleteTD®" Then
            For i = 0 To Enr.Fields.Count - 1
                If Enr.Fields(i).Type = 202 Then Enr.Fields(i).Value = "®DeleteTD®": Exit For
Autre_Champ:
            Next i
        Else
        ' Boucle sur les champs :
            For i = LBound(NvValeur()) To UBound(NvValeur())
                Enr.Fields(i).Value = NvValeur(i)
            Next i
        End If
        Enr.Update                      ' Valide la modification.
        Enr.MoveNext                    ' Passe à l'enregistrement suivant.
        ADO_UpdateTD = ADO_UpdateTD + 1 ' Compte le nombre d'enregistrements modifiés.
    Wend
End If

' Fin du traitement :
Gest_Err:

' Cas particulier des erreurs lors de la marque "®DeleteTD®" sur des formules :
If Err.Number = -2147217887 Then Err.Clear: Resume Autre_Champ

' Autres cas :
If Err.Number <> 0 Or NumErr <> 0 Then ADO_UpdateTD = -9

Set Enr = Nothing
Err.Clear
Application.ScreenUpdating = EtatScreenUpdating

End Function
'-------------------------------------------------------------------------------

'-------------------------------------------------------------------------------
Public Function ADO_DeleteTD(TD As Range, StrSQL As String) As Boolean
'---------------------------------------------------------------------------------------
' ATTENTION : TD doit contenir au moins un champ texte.
' Sélectionne les données d'un tableau de données EXCEL puis les supprime.
' TD : Le tableau des données (ou la plage avec en-tête). Maxi = A1:IU65535
' StrSQL : Requête SQL avec ses conditions.
'---------------------------------------------------------------------------------------
' Retourne : VRAI si un moins un enregistrement est supprimé.
'---------------------------------------------------------------------------------------
Dim i As Long, ik As Integer, EtatScreenUpdating As Boolean, Conversion As Boolean

' Gestion des erreurs:
On Error GoTo Gest_Err
EtatScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False

' Marque les enregistrements (le libellé "®DeleteTD®" est assez personnel pour ne pas être
' confondu avec les données de l'utilisateur et ainsi ne pas supprimer des données par erreur) :
If ADO_UpdateTD(TD, "*", StrSQL, "®DeleteTD®") > 0 Then

    ' Si TD est une plage alors la transforme en tableau de données :
    If TD.ListObject Is Nothing Then Set TD = ConvertirPlageEnTD(TD, "", ""): Conversion = True
    
   ' Supprime dans le tableau les lignes marquées et indique que des suppressions sont faites :
    For i = TD.ListObject.ListRows.Count To 1 Step -1
        For ik = 1 To TD.ListObject.HeaderRowRange.Count
            If TD.ListObject.DataBodyRange(i, ik) = "®DeleteTD®" Then
                TD.ListObject.ListRows(i).Delete
                ADO_DeleteTD = True
                Exit For
            End If
        Next ik
    Next i
    
    ' Si TD était une plage alors remet la plage d'origine :
    If Conversion = True Then Call ConvertirTDEnPlage(TD)
    
End If

' Fin du traitement :
Gest_Err:
Err.Clear
Application.ScreenUpdating = EtatScreenUpdating

End Function
'-------------------------------------------------------------------------------