Ressources EXCEL

Ls BO manuelles sont adaptées pour des applications utilitaires (convertir en majuscules,minuscules,...)
qui doivent être tj disponibles quelquesoit le classeur ouvert (Pour le transport de l'appli sur un autre
poste, il ne faut pas oublier de les associer au classeur).
En revanche, pour les BO associées à une applications, il est préférable de les construire
au chargement et détruire à

la fermeture. On évite ainsi:

Création d’une barre d’outils manuellement

Pour que la barre ne soit ouverte que pour un classeur :

Sub auto_open()
Application.CommandBars("jb-BarreMajuscules").Visible = True
End Sub

Sub auto_close()
Application.CommandBars("jb-BarreMajuscules").Visible = False
End Sub

Pour attacher une BO à un classeur (transport sur un autre poste) :

Ajouter une commande à un menu

On ajoute la commande Majuscules au menu Outils

MenuBars(xlWorksheet).Menus("Outils").MenuItems.Add Caption:="Majuscule", OnAction:="Majuscule"
On Error Resume Next
MenuBars(xlWorksheet).Menus("Outils").MenuItems("Majuscule").Delete

Ajouter un menu à une barre d’outils existante

On ajoute un menu Conversion à la barre XlWorkSheet

Sub auto_open()
'ajouter le menu Conversion avant le menu Outils
MenuBars(xlWorksheet).Menus.Add Caption:="&Conversion", Before:=6
'ajouter les commandes au menu Conversion
With MenuBars(xlWorksheet).Menus("Conversion").MenuItems
.Add Caption:="Ma&juscule", OnAction:="Majuscule"
.Add Caption:="Mi&nuscule", OnAction:="Minuscule"
.Add Caption:="&Nom Propre", OnAction:="NomPropre"
.Add Caption:="&Euros", OnAction:="ConversionEuros"
.Add Caption:="&Francs", OnAction:="ConversionFrancs"
End With
End Sub

Sub auto_close()
For Each M In MenuBars(xlWorksheet).Menus
If M.Caption = "&Conversion" Then M.Delete
Next
End Sub

Sub Majuscule()
For Each c In Selection
c.Value = UCase(c.Value)
Next c
End Sub

Ajouter un menu avec sous-menus

Sub CréeNouveauMenu()
Dim NouveauMenu As CommandBarPopup
Dim MenuElément As CommandBarControl
Dim SousMenuElément As CommandBarButton
SupMenu
Set NouveauMenu = CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup, Temporary:=True, Before:=5)
NouveauMenu.Caption = "&Menu1"
'----
Set MenuElément = NouveauMenu.Controls.Add(Type:=msoControlButton)
MenuElément.Caption = "Commande1"
MenuElément.OnAction = "Macro1"
Set MenuElément = NouveauMenu.Controls.Add(Type:=msoControlPopup)
MenuElément.Caption = "Commande2"
MenuElément.BeginGroup = True
'---- sous menu
Set SousMenuElément = MenuElément.Controls.Add(Type:=msoControlButton)
SousMenuElément.Caption = "Sous-commande1"
SousMenuElément.OnAction = "Macro1"
Set SousMenuElément = MenuElément.Controls.Add(Type:=msoControlButton)
SousMenuElément.Caption = "Sous-commande2"
SousMenuElément.OnAction = "Macro1"
End Sub

Sub SupMenu()
On Error Resume Next
CommandBars("Worksheet Menu Bar").Controls("Menu1").Delete
End Sub

Sub Macro1()
MsgBox "Macro1"
End Sub

Sur Excel 2007, le menu se situe dans l'onglet Compléments

Créer une nouvelle barre de menus

Sub auto_open()
Dim MaBarre As CommandBar
'---- Création barre
On Error Resume Next
Set MaBarre = CommandBars.Add(Name:="NouvelleBarre", MenuBar:=True, Temporary:=True)
MaBarre.Visible = True
MenuBars("NouvelleBarre").Menus.Add Caption:="&Menu1", Before:=6
With MenuBars("NouvelleBarre").Menus("Menu1").MenuItems
.Add Caption:="Ma&juscule", OnAction:="Majuscule"
.Add Caption:="Mi&nuscule", OnAction:="Minuscule"
End With

MenuBars("NouvelleBarre").Menus.Add Caption:="&Menu2", Before:=6
With MenuBars("NouvelleBarre").Menus("Menu2").MenuItems
.Add Caption:="Euros", OnAction:="Euros"
.Add Caption:="Francs", OnAction:="Francs"
End With

End Sub

Sub auto_close()
CommandBars("NouvelleBarre").Delete
CommandBars("Worksheet Menu Bar").Visible = True
End Sub

Sub Majuscule()
For Each c In Selection
If Not IsNumeric(c.Value) And Not IsDate(c.Value) Then
c.Value = UCase(c.Value)
End If
Next c
End Sub

Barre d’outils avec boutons

BarreBoutons.Xls

Sub auto_open()
Dim barre As CommandBar
Dim bouton As CommandBarControl
On Error Resume Next
Set barre = CommandBars.Add(Name:="BarreBoutons")
barre.Visible = True

Set bouton = CommandBars("BarreBoutons").Controls.Add(Type:=msoControlButton)

bouton.Style = msoButtonIconAndCaption
bouton.TooltipText = "xxx"
bouton.FaceId = 121
bouton.OnAction = "Macro1"
bouton.Caption = "Macro1"

Set bouton = CommandBars("BarreBoutons").Controls.Add(Type:=msoControlButton)
bouton.BeginGroup = True
bouton.Style = msoButtonCaption
'bouton.Width = 100
bouton.OnAction = "Macro2"
bouton.Caption = "Macro2"
End Sub

Sub auto_close()
On Error Resume Next
CommandBars("BarreBoutons").Delete
End Sub

Sub macro1()
MsgBox "Macro1"
End Sub

Sub macro2()
MsgBox "Macro2"
End Sub

Avec image

BarreBoutonsImage

Set bouton = CommandBars("BarreBoutons").Controls.Add(Type:=msoControlButton)
bouton.BeginGroup = True
bouton.TooltipText = "Commentaire2"
Set MonImage = ActiveSheet.Pictures.Insert("c:\mesdoc\droc.jpg")
MonImage.Copy
bouton.PasteFace
MonImage.Delete
bouton.OnAction = "Macro2"

Barre de boutons avec passage de paramètres

BarreBoutonsColoriage.xls

Sub auto_open()
On Error Resume Next
CommandBars.Add ("BarreColoriage")
CommandBars("BarreColoriage").Visible = True
For i = 1 To .Count
Set bouton = CommandBars("BarreColoriage").Controls.Add(Type:=msoControlButton)
bouton.Style = msoButtonCaption
bouton.OnAction = "'Coloriage """ & i & """'"
bouton.Caption = Range("couleurs")(i)
Next i
End Sub

Sub Coloriage(p)
For Each c In Selection
Range("couleurs")(p).Copy c
Next c
End Sub

Sub auto_close()
On Error Resume Next
Application.CommandBars("BarreColoriage").Delete
End Sub

Autre version

BarreColoriage2.xls

Sub auto_open()
On Error Resume Next
Set Barre = CommandBars.Add
Barre.Name = "BarreColoriage"
Barre.Visible = True
Set Menu = Barre.Controls.Add(msoControlComboBox)
For i = 1 To .Count - 1
Menu.AddItem Range("couleurs")(i).Value
Next
Menu.AddItem "Efface"
Menu.OnAction = "Couleur"
Menu.Text = "Sélectionner puis choisir"
End Sub

Sub auto_close()
On Error Resume Next
CommandBars("BarreColoriage").Delete
End Sub

Sub couleur()
choix = CommandBars("BarreColoriage").Controls(1).Text
If choix = "Efface" Then
efface
Else
p = Application.Match(choix, , 0)
For Each c In Selection
c.Value = Range("couleurs")(p).Value
c.Interior.ColorIndex = Range("couleurs")(p).Interior.ColorIndex
Next c
End If
End Sub

Barre d’outils avec comboBox

BarreOutilsCombo.xls

Sub auto_open()
On Error Resume Next
Set Barre = CommandBars.Add
Barre.Name = "BarreColoriage"
Barre.Visible = True
Set Menu = Barre.Controls.Add(msoControlComboBox)
Menu.AddItem "Choix1"
Menu.AddItem "Choix2"
Menu.AddItem "Choix3"
Menu.OnAction = "MaMacro"
Menu.Text = "Sélectionner puis choisir"
End Sub

Sub maMacro()
Application.ScreenUpdating = False
choix = CommandBars("BarreColoriage").Controls(1).Text
Select Case choix
Case "Choix1"
MsgBox "choix1"
Case "Choix2"
MsgBox "choix2"
End Select
End Sub

Sub auto_close()
On Error Resume Next
CommandBars("BarreColoriage").Delete
End Sub

Choix d’une feuille

BarreFeuilles.xls

Sub Auto_open()
On Error Resume Next
Set Barre = CommandBars.Add
Barre.Name = "ChoixFeuille"
Barre.Visible = True
Set Menu = Barre.Controls.Add(msoControlComboBox)
For s = 1 To Sheets.Count
Menu.AddItem Sheets(s).Name
Next s
Menu.OnAction = "MaMacro"
Menu.Text = "Sélectionner puis choisir"
End Sub

Sub auto_close()
On Error Resume Next
CommandBars("ChoixFeuille").Delete
End Sub

Sub maMacro()
Application.ScreenUpdating = False
choix = CommandBars("ChoixFeuille").Controls(1).Text
Sheets(choix).Select
End Sub

Ajouter une commande au menu sur clic-droit

Private Sub Worksheet_Activate()
Set temp = CommandBars("cell").Controls.Add
temp.Caption = "babla"
temp.OnAction = "MaMacro"
temp.FaceId = 120
temp.BeginGroup = True
End Sub

Private Sub Worksheet_Deactivate()
Application.CommandBars("Cell").Reset
End Sub

Popup clic droit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim MaBarre As CommandBar
On Error Resume Next
CommandBars("BarrePopup").Delete
Set MaBarre = Application.CommandBars.Add(Name:="BarrePopup", Position:=msoBarPopup)
Set bouton = CommandBars("BarrePopup").Controls.Add(Type:=msoControlButton)
bouton.OnAction = "Macro1"
bouton.Caption = "Macro1"
Set bouton = CommandBars("BarrePopup").Controls.Add(Type:=msoControlButton)
bouton.OnAction = "Macro2"
bouton.Caption = "Macro2"
MaBarre.ShowPopup
Cancel = True
End Sub

Sub Macro1()
Application.Dialogs(xlDialogPatterns).Show
End Sub

Sub Macro2()
Application.Dialogs(xlDialogActiveCellFont).Show
End Sub

Désactive des commandes du menu

Private Sub Worksheet_Activate()
CommandBars(1).Controls("Edition").Controls("Couper").Enabled = False
CommandBars("cell").Controls("Couper").Enabled = False
Application.OnKey "^{x}", ""
End Sub

Private Sub Worksheet_Deactivate()
CommandBars(1).Controls("Edition").Controls("Couper").Enabled = True
CommandBars("cell").Controls("Couper").Enabled = True
Application.OnKey "^{x}"
End Sub

Sub auto_close()
CommandBars(1).Controls("Edition").Controls("Couper").Enabled = True
Application.CommandBars("cell").Reset
Application.OnKey "^{x}"
End Sub

Affichage des items d'une colonne

Affiche les items d'une colonne sur le clic dans la première cellule vide.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (Target.Column = 2 Or Target.Column = 3) And Target.Count = 1 Then
If Target = "" Then SendKeys "%{down}"
'SendKeys "%{down}"
End If
End Sub

Barre majuscules/minuscules

BarreMajuscules

Sub auto_open()
Dim barre As CommandBar
Dim bouton As CommandBarControl
On Error Resume Next
CommandBars("jb-Majuscules").Delete
Set barre = CommandBars.Add(Name:="jb-Majuscules")
barre.Visible = True

Set bouton = CommandBars("jb-Majuscules").Controls.Add(Type:=msoControlButton)
bouton.BeginGroup = True
bouton.Style = msoButtonCaption
bouton.OnAction = "Majuscules"
bouton.Caption = "Majuscules"

Set bouton = CommandBars("jb-Majuscules").Controls.Add(Type:=msoControlButton)
bouton.BeginGroup = True
bouton.Style = msoButtonCaption
bouton.OnAction = "Minuscules"
bouton.Caption = "Minuscules"

Set bouton = CommandBars("jb-Majuscules").Controls.Add(Type:=msoControlButton)
bouton.BeginGroup = True
bouton.Style = msoButtonCaption
bouton.OnAction = "NomPropre"
bouton.Caption = "NomPropre"
End Sub

Sub majuscules()
For Each c In Selection
If Not c.HasFormula Then
c.Value = UCase(c.Value)
End If
Next c
End Sub

Sub minuscules()
For Each c In Selection
If Not c.HasFormula Then
c.Value = LCase(c.Value)
End If
Next c
End Sub

Sub Nompropre()
For Each c In Selection
If Not c.HasFormula Then
c.Value = Application.Proper(c.Value)
End If
Next c
End Sub

Barre d'outils utilitaire utilisable de tous les classeurs Excel2000+

-Barre Utilitaires -

-Majuscule,minuscule,nompropre transforment en majuscules, minuscules, nompropre le champ sélectionné
-Nompropre2 convertit les noms propres et les adresses
-Sup dble espace supprime les doubles espaces
-Transforme point convertit des nombres avec . (importation de fichiers texte des ordinateurs centraux)
-Sommaire crée un sommaire des onglets du classeur actif (avec liens HyperTexte vers les onglets)
-Tri onglets tri les onglets dans l'ordre alpabétique
-Calendrier2 permet de saisir des dates avec un calendrier (Cliquer sur la première date puis la seconde et ok)
-Affiche formule affiche la formule de la cellule active dans un commenataire
-Noms de champs affiche les noms de champ de la page active dans des commentaires
-Quadrillage crée un quadrillage

-pour que la feuille de ce classeur ne soit plus visible, sauvegardez le classeur à sa fermeture. fenêtre/afficher permet de la faire apparaître.
-Le code a été masqué de façon à ne pas perturber l'utilisateur lorsque ce classeur est chargé. Le mot de passe du code est jacques

Si le classeur jb-barreUtilitaires.xls est déplacé, l'ouvrir à nouveau pour que la barre jb-barreUtilitaires soit à nouveau créée.