'Auteur: patricktoulon
Option Explicit
Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Public Const PaulRouge = "255"
Public Const Jaune = 65535
Public Const Vert = 65280
Public Const Bleu = 15174705
Public Const Violet = 14438496
Public Const Orange = 1338847
Public Const Olive = 2329968
Public Const Rose = 13811710
Public Const Gris = 10395294
Public Const Turquoise = 16645413
Public fichier As String
Public fichier2 As String
'ici on va cré le xml pour ajouter le bouton dans l'onglet"Accueil"("TabHome" en customUI)
Sub CreateRibbon()
Dim DocXmL, CuI, RibbonX, oCreation, BtabS, BtaB, bGrouP, ButtoN
Set DocXmL = CreateObject("Microsoft.XMLDOM") 'creation
Set CuI = DocXmL.appendchild(DocXmL.createelement("customUI")) 'creation de balise cusomUI
'ses attributs
CuI.setattribute "xmlns", "http://schemas.microsoft.com/office/2009/07/customui"
CuI.setattribute "onLoad", "CustomUIOnLoad"
Set oCreation = DocXmL.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8"" standalone=""yes""") 'creation de l'entete du process
DocXmL.InsertBefore oCreation, DocXmL.ChildNodes.Item(0) 'insertion parametre process
Set RibbonX = DocXmL.createelement("ribbon") 'creation de balise "ribbon"
CuI.appendchild (RibbonX)
Set BtabS = DocXmL.createelement("tabs") 'creation de la balise tabs(qui contient tout les tab(onglets du ruban)
RibbonX.appendchild (BtabS)
Set BtaB = DocXmL.createelement("tab"): BtaB.setattribute "idMso", "TabHome" 'creation de balise tab
BtabS.appendchild (BtaB)
'creation de balise "group"
Set bGrouP = DocXmL.createelement("group"): bGrouP.setattribute "id", "gColorPerso": bGrouP.setattribute "label", "Palette Color"
BtaB.appendchild (bGrouP)
'creation de balise button(le bouton)
Set ButtoN = DocXmL.createelement("button"): ButtoN.setattribute "id", "bColorPerso": ButtoN.setattribute "label", "Afficher Palette Color"
ButtoN.setattribute "imageMso", "HappyFace" 'choisir l'icon que l'on veux ici
bGrouP.appendchild (ButtoN)
'les attribut du bouton
ButtoN.setattribute "onAction", ThisWorkbook.FullName & "!afficher_la_palette" 'sa macro associée
ButtoN.setattribute "size", "large" ' style gros bouton
'creation du fichier officeUI
fichier = Environ("LocalAppData") & "\Microsoft\Office\Excel.officeUI"
SaveFormatDocToFileXL DocXmL, fichier
bGrouP.RemoveChild (ButtoN)
Set ButtoN = DocXmL.createelement("button"): ButtoN.setattribute "id", "bColorPerso2": ButtoN.setattribute "label", "Afficher Palette Color"
ButtoN.setattribute "imageMso", "SadFace" 'choisir l'icon que l'on veux ici
bGrouP.appendchild (ButtoN)
'les attribut du bouton
ButtoN.setattribute "onAction", ThisWorkbook.FullName & "!afficher_la_palette" 'sa macro associée
ButtoN.setattribute "size", "large" ' style gros bouton
SaveFormatDocToFileXL DocXmL, fichier
ForcerMajRuban_OfficeUI
'Debug.Print code
End Sub
Sub afficher_la_palette()
Dim barre, ColoRx, Noms, i&, ColorXs, cp&
'on reprend les constantes en array
ColorXs = Array(PaulRouge, Jaune, Vert, Bleu, Violet, Orange, Olive, Rose, Gris, Turquoise)
'on reprend les constante en noms
Noms = Array("PaulRouge", "Jaune", "Vert", "Bleu", "Violet", "Orange", "Olive", "Rose", "Gris", "Turquoise")
'on delete le popup si il existe
On Error Resume Next
CommandBars("colorperso").Delete
On Error GoTo 0
'creation de la barre popup
Set barre = CommandBars.Add("colorperso", msoBarPopup, False, True)
'création des bouton du popup
For i = 0 To UBound(ColorXs)
cp = 0
'Do While IsClipboardFormatAvailable(&H2) <> 0
' cp = cp + 1
' DoEvents
'Loop
'Debug.Print cp & "tours avant de copier"
cp = 0
With Cells(Rows.Count, Columns.Count)
'ColumnWidth = 1.8
.Interior.Color = ColorXs(i)
'DoEvents
.CopyPicture Appearance:=xlScreen, Format:=xlBitmap 'on copie la cellule en picture
End With
'Do While IsClipboardFormatAvailable(&H2) = 0
' DoEvents
'Loop
'Debug.Print cp "tours avant de coller"
With barre.Controls.Add(msoControlButton, 1, , , True)
.Caption = Noms(i) 'on lui donne son texte de caption
'on colorie une cellule loin loin loin avec la couleur index i
.PasteFace 'on colle l'image au bouton
.OnAction = "ChangeColorCell" 'on lui donne sa macro au bouton
.Tag = ColorXs(i) 'on met la couleur dans le tag du bouton
End With
OpenClipboard 0&
EmptyClipboard
CloseClipboard
Next
Cells(Rows.Count, Columns.Count).Interior.Color = xlNone 'on nettoie la cellule qui nous a servir a faire les icons de couleur
barre.ShowPopup 'on affiche le popup
'le menu s'auto detruit
On Error Resume Next
CommandBars("colorperso").Delete
On Error GoTo 0
End Sub
Sub ChangeColorCell()
'Cette ma"cro est appeler par tout les boutons
'on donne la couleur a la cellule a"vec la va"leur du tag du bouton cliqué
Selection.Interior.Color = Val(CommandBars.ActionControl.Tag)
End Sub
'le customui et officeUI travaillent en UTF-8 alors
'fonction pour enregistrer au format UTF-8 avec le MSXML2 transféré dans le adodb stream
' le code est propre et indenté comme tout xml qu'il se doit d'être
Public Sub SaveFormatDocToFileXL(ByVal doc, ByVal FileName As String)
Dim ReaderXml As Object, StreamFormaté As Object, WriterFormat As Object, elem
Set ReaderXml = CreateObject("MSXML2.SAXXMLReader.6.0")
Set StreamFormaté = CreateObject("ADODB.Stream")
Set WriterFormat = CreateObject("MSXML2.MXXMLWriter")
With StreamFormaté
.Open
.Type = 1 'adTypeBinary
With WriterFormat
.omitXMLDeclaration = False
.standalone = True
.byteOrderMark = False 'If not set (even to False) then
'.encoding is ignored.
.Encoding = "utf-8" 'Even if .byteOrderMark = True
'UTF-8 never gets a BOM.
.indent = True
.Output = StreamFormaté
With ReaderXml
Set .contentHandler = WriterFormat
Set .dtdHandler = WriterFormat
Set .errorHandler = WriterFormat
.putProperty "http://xml.org/sax/properties/lexical-handler", WriterFormat
.putProperty "http://xml.org/sax/properties/declaration-handler", WriterFormat
.Parse doc
End With
End With
If Dir(FileName) <> "" Then Kill fichier
.SaveToFile FileName
.Close
End With
Set ReaderXml = Nothing
Set StreamFormaté = Nothing
Set WriterFormat = Nothing
End Sub
'fonction de sauvegarde du fichier officeUI de personnalisation si il existe déjà
' en le renomant en back
Sub sauvegardeofficeUI()
fichier = Environ("LocalAppData") & "\Microsoft\Office\Excel.officeUI"
If Dir(fichier) <> "" Then
Name fichier As Replace(fichier, ".officeUI", ".officeUIBack")
End If
End Sub
Sub ForcerMajRuban_OfficeUI()
End Sub
'exemple du résultat à obtenir
'<?xml version="1.0" encoding="utf-8" standalone="yes"?>
'<customUI onLoad="CustomUIOnLoad" xmlns="http://schemas.microsoft.com/office/2009/07/customui">
' <ribbon>
' <tabs>
' <tab idMso="TabHome">
' <group id="gColorPerso" label="Palette Color">
' <button id="bColorPerso" label="Afficher Palette Color" imageMso="HappyFace" onAction="C:\Users\patricktoulon\Desktop\palette color dynamique perso customUi Mixte commandbars.xlsm!afficher_la_palette" size="large"/>
' </group>
' </tab>
' </tabs>
' </ribbon>
'</customUI>
