Microsoft 365 Création d'un nouvel onglet du ruban en vba et y attacher 4 macros complémentaires (MAC et PC)

RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Bonjour,

j'ai beau chercher partout mais je ne trouve de solution pour le moment …

Comme l'onglet "Acceuil" qui existe dans le ruban, je cherche à pourvoir créer par vba un nouvel onglet "TOTO" et y insérer 4 macros, provenant d'un complément Excel d'un fichier xlam déjà insérer par macro :
VB: 
Sub Add_AddIn() 'version Mac (peut être PC aussi pouvez vous confirmer SVP)
Dim addInPath As String
    addInPath = "MonChemin/TEST.xlam"
    AddIns.Add addInPath
    AddIns("TEST").Installed = True '
End Sub
Le but est de pourvoir faire une automatisation d'installation sur plusieurs utilisateurs Mac et PC

merci d'avance pour vos réponses

Ryu
 
Trier par date Trier par votes
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
1719959877095.png
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
la fonction doit se presenter comme ça
VB: 
function Admissibleelement(child,par)
select case child.tagname
case "tab"
" tabs " like "* " & par.tagname

case "goup"
" tab " like "* " & par.tagname


case "box"
" group " like "* " & par.tagname

case " button "
" group menu dropdown box buttongroup " like "* " & par.tagname


'etc..

end select
end function
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Hi Patrick

J'ai vérifié le Dir pour le fichier Rel invisible, c'est OK :
VB: 
Sub CheckFileHide()
Dim MyFileRel As String
    MyFileRel = "Chemin_Du_Dossier_Rels" & Application.PathSeparator & ".rels"
    requestFileAccess MyFileRel
    
    If FindFileHide(MyFileRel) Then
        MsgBox "OK"
    End If
    
End Sub

Function FindFileHide(FilenameHide As String) As Boolean
  FindFileHide = Dir(FilenameHide, vbDirectory + vbHidden) <> ""
End Function


Sub requestFileAccess(Fichier As String)
Dim fileAccessGranted As Boolean, filePermissionCandidates
    filePermissionCandidates = Array(Fichier)
    fileAccessGranted = GrantAccessToMultipleFiles(filePermissionCandidates)
End Sub

Puis j'ai testé l'écriture cela semble OK aussi :
VB: 
Sub LaunchWriteRel()
Dim FilePathRel As String
      FilePathRel = "Chemin_Du_Dossier_Rels" & Application.PathSeparator & ".rels"
      WriteRel FilePathRel
End Sub

Function WriteRel(PathOfRel As String)
Dim Channel As Long, AddToRel As String, OldRel As String, TbRel, i As Integer, NewRel As String

    AddToRel = "<Relationship Id=""custo2007"" Type=""http://schemas.microsoft.com/office/2006/relationships/ui/extensibility"" Target=""customUI/customUI.xml""/>" & vbCr & _
                        "<Relationship Id=""custo14"" Type=""http://schemas.microsoft.com/office/2007/relationships/ui/extensibility"" Target=""customUI/customUI14.xml""/>"

    Channel = FreeFile
    Open PathOfRel For Input As Channel
    OldRel = Input(LOF(Channel), Channel):      Close Channel
    
    TbRel = Split(OldRel, ">")
    For i = LBound(TbRel) + 1 To UBound(TbRel) - 1
        If i = 1 Then
            NewRel = TbRel(0) & ">" & vbCr & TbRel(i) & ">" & vbCr & AddToRel
        Else
            NewRel = NewRel & vbCr & TbRel(i) & ">"
        End If
    Next

    Open PathOfRel For Output As Channel
    Print #Channel, NewRel:     Close Channel

End Function
 

Pièces jointes

  • Fichier rels via macro.zip
    1 KB · Affichages: 0
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Petite simplification de la fonction
VB: 
Function WriteRel(PathOfRel As String)
Dim Channel As Long, AddToRel As String, OldRel As String, TbRel, i As Integer, NewRel As String

    AddToRel = "<Relationship Id=""custo2007"" Type=""http://schemas.microsoft.com/office/2006/relationships/ui/extensibility"" Target=""customUI/customUI.xml""/>" & vbCr & _
                        "<Relationship Id=""custo14"" Type=""http://schemas.microsoft.com/office/2007/relationships/ui/extensibility"" Target=""customUI/customUI14.xml""/>"

    Channel = FreeFile
    Open PathOfRel For Input As Channel
    OldRel = Input(LOF(Channel), Channel):      Close Channel
    
    TbRel = Split(OldRel, ">")
    NewRel = TbRel(0) & ">" & vbCr & TbRel(1) & ">" & vbCr & AddToRel
    For i = LBound(TbRel) + 2 To UBound(TbRel) - 1
        NewRel = NewRel & vbCr & TbRel(i) & ">"
    Next

    Open PathOfRel For Output As Channel
    Print #Channel, NewRel:     Close Channel

End Function
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Autres modifications pour vérifier si la modification du rels à déjà été faites :
VB: 
Sub LaunchWriteRel()
Dim FilePathRel As String
      FilePathRel = "Chemin_Du_Dossier_Rels" & Application.PathSeparator & ".rels"
      WriteRel FilePathRel
End Sub

Function WriteRel(PathOfRel As String)
Dim Channel As Long, AddToRel As String, OldRel As String, TbRel, i As Integer, NewRel As String

    AddToRel = "<Relationship Id=""custo2007"" Type=""http://schemas.microsoft.com/office/2006/relationships/ui/extensibility"" Target=""customUI/customUI.xml""/>" & vbCr & _
                        "<Relationship Id=""custo14"" Type=""http://schemas.microsoft.com/office/2007/relationships/ui/extensibility"" Target=""customUI/customUI14.xml""/>"

    Channel = FreeFile
    Open PathOfRel For Input As Channel
    OldRel = Input(LOF(Channel), Channel):      Close Channel
 
    If Not OldRel Like "*custo2007*custo14*" Then
        TbRel = Split(OldRel, ">")
        NewRel = TbRel(0) & ">" & vbCr & TbRel(1) & ">" & vbCr & AddToRel
        For i = LBound(TbRel) + 2 To UBound(TbRel) - 1
            NewRel = NewRel & vbCr & TbRel(i) & ">"
        Next
     
        Open PathOfRel For Output As Channel
        Print #Channel, NewRel:     Close Channel
     
        MsgBox "Le fichier Rels est modifié"
    Else
        MsgBox "Rels déjà créé"
    End If
End Function
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
Et un autre code again :
VB: 
Function AdmissibleElement(child, par)
    Select Case child.tagName
        Case "tabs"
        if " ribbon "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "tab"
            if " tabs "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "group"
            if " tab "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "box"
            if " group "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "buttonGroup"
            if " group "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "menu"
            if " group box menu splitButton "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "dynamicMenu"
            if " group "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "button"
            if " group box buttonGroup dropDown menu "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "splitButton"
            if " group box buttongroup "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "checkBox"
            if " group box "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "comboBox"
            if " group "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "dropDown"
            if " group "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "gallery"
            if " group "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "item"
            if " gallery comboBox dropDown "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "labelControl"
            if " group "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "separator"
            if " group "  like "* " & par.tagName & " *" then Yxxxxxx

        Case "menuSeparator"
            if " menu "  like "* " & par.tagName & " *" then Yxxxxxx
     
     
        Case Else
 
    End Select
End Function

GetParentElem corrigé :
VB: 
Public Sub Class_Initialize()
    Set GetParentElem = New Collection
  
    GetParentElem.Add "  ", "customUI"
    GetParentElem.Add " customUI ", "ribbon"
    GetParentElem.Add " ribbon ", "tabs"
    GetParentElem.Add " tabs ", "tab"
    GetParentElem.Add " tab ", "group"
    GetParentElem.Add " group ", "box"
    GetParentElem.Add " group ", "buttonGroup"
    GetParentElem.Add " group box menu splitButton ", "menu"
    GetParentElem.Add " group ", "dynamicMenu"
    GetParentElem.Add " group box buttonGroup dropDown menu ", "button"
    GetParentElem.Add " group box buttongroup ", "splitButton"
    GetParentElem.Add " group box ", "checkBox"
    GetParentElem.Add " group ", "comboBox"
    GetParentElem.Add " group ", "dropDown"
    GetParentElem.Add " group ", "gallery"
    GetParentElem.Add " gallery comboBox dropDown ", "item"
    GetParentElem.Add " group ", "labelControl"
    GetParentElem.Add " group ", "separator"
    GetParentElem.Add " menu ", "menuSeparator"

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
pour la fonction admissibleelement c'est bon je l'avais faite déjà
j'en avais trop besoins pour tester le moteur
VB: 
Public Function AdmissibleElement(tagname, par As ElementXml)
     Dim C As Boolean
    Select Case tagname
        Case "customUI": C = True
        Case "ribbon": C = True
        Case "button": C = " group box buttonGroup dropDown menu " Like "* " & par.tagname & " *"
        Case "group": C = " tab " Like "* " & par.tagname & " *"
        Case "tabs": C = " ribbon " Like "* " & par.tagname & " *"
        Case "tab": C = " tabs " Like "* " & par.tagname & " *"
        Case "box": C = " group " Like "* " & par.tagname & " *"
        Case "buttonGroup": C = " group " Like "* " & par.tagname & " *"
        Case "menu": C = " group box menu splitButton " Like "* " & par.tagname & " *"
        Case "dynamicMenu": C = " group " Like "* " & par.tagname & " *"
        Case "splitButton": C = " group box buttongroup " Like "* " & par.tagname & " *"
        Case "checkBox": C = " group box " Like "* " & par.tagname & " *"
        Case "comboBox": C = " group " Like "* " & par.tagname & " *"
        Case "dropDown": C = " group " Like "* " & par.tagname & " *"
        Case "gallery": C = " group " Like "* " & par.tagname & " *"
        Case "item": C = " gallery comboBox dropDown " Like "* " & par.tagname & " *"
        Case "labelControl": C = " group " Like "* " & par.tagname & " *"
        Case "separator": C = " group " Like "* " & par.tagname & " *"
        Case "menuSeparator": C = " menu " Like "* " & par.tagname & " *"
        Case Else: C = False
    End Select
    AdmissibleElement = C
End Function
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
la définitive sera celle là
VB: 
Public Function AdmissibleElement(tagname, par As ElementXml)
    Dim C As Boolean
    Select Case tagname
        Case "customUI": C = DocXml.Childnodes.Count = 0
        Case "ribbon": C = DocXml.Childnodes.Count = 1
        Case "tabs": C = " ribbon " Like "* " & par.tagname & " *"
        Case "tab": C = " tabs " Like "* " & par.tagname & " *"
        Case "group": C = " tab " Like "* " & par.tagname & " *"
        Case "button": C = " group box buttonGroup dropDown menu " Like "* " & par.tagname & " *"
        Case "box": C = " group " Like "* " & par.tagname & " *"
        Case "buttonGroup": C = " group " Like "* " & par.tagname & " *"
        Case "menu": C = " group box menu splitButton " Like "* " & par.tagname & " *"
        Case "dynamicMenu": C = " group " Like "* " & par.tagname & " *"
        Case "splitButton": C = " group box buttongroup " Like "* " & par.tagname & " *"
        Case "checkBox": C = " group box " Like "* " & par.tagname & " *"
        Case "comboBox": C = " group " Like "* " & par.tagname & " *"
        Case "dropDown": C = " group " Like "* " & par.tagname & " *"
        Case "gallery": C = " group " Like "* " & par.tagname & " *"
        Case "item": C = " gallery comboBox dropDown " Like "* " & par.tagname & " *"
        Case "labelControl": C = " group " Like "* " & par.tagname & " *"
        Case "separator": C = " group " Like "* " & par.tagname & " *"
        Case "menuSeparator": C = " menu " Like "* " & par.tagname & " *"
        Case Else: C = False
    End Select
    AdmissibleElement = C
End Function
 
Vote positif 0 Vote négatif
RyuAutodidacte

RyuAutodidacte

XLDnaute Impliqué
patricktoulon à dit:
la définitive sera celle là
VB: 
Public Function AdmissibleElement(tagname, par As ElementXml)
    Dim C As Boolean
    Select Case tagname
        Case "customUI": C = DocXml.Childnodes.Count = 0
        Case "ribbon": C = DocXml.Childnodes.Count = 1
        Case "tabs": C = " ribbon " Like "* " & par.tagname & " *"
        Case "tab": C = " tabs " Like "* " & par.tagname & " *"
        Case "group": C = " tab " Like "* " & par.tagname & " *"
        Case "button": C = " group box buttonGroup dropDown menu " Like "* " & par.tagname & " *"
        Case "box": C = " group " Like "* " & par.tagname & " *"
        Case "buttonGroup": C = " group " Like "* " & par.tagname & " *"
        Case "menu": C = " group box menu splitButton " Like "* " & par.tagname & " *"
        Case "dynamicMenu": C = " group " Like "* " & par.tagname & " *"
        Case "splitButton": C = " group box buttongroup " Like "* " & par.tagname & " *"
        Case "checkBox": C = " group box " Like "* " & par.tagname & " *"
        Case "comboBox": C = " group " Like "* " & par.tagname & " *"
        Case "dropDown": C = " group " Like "* " & par.tagname & " *"
        Case "gallery": C = " group " Like "* " & par.tagname & " *"
        Case "item": C = " gallery comboBox dropDown " Like "* " & par.tagname & " *"
        Case "labelControl": C = " group " Like "* " & par.tagname & " *"
        Case "separator": C = " group " Like "* " & par.tagname & " *"
        Case "menuSeparator": C = " menu " Like "* " & par.tagname & " *"
        Case Else: C = False
    End Select
    AdmissibleElement = C
End Function
Cliquez pour agrandir...
C'est exactement ce que je pensais dernièrement avec mon GetParentElem en Bolean
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
et oui par ce que quand je te l'ai demandé je pensais child /parent
sauf que l'admissibilité doit être testée avant la création
je n'ai donc que le tagname et non le child.tagname

pour le custo 2007 ça m’étonnerait que des mac tournent encore dessus
après c'est pas un truc important dans le sens ou il est facile de faire le replace 2006/01 par 2009/07

par contre j'ai un véritable problème dans l'adaptation du moteur 2024
c'est le tableau des attributs qui n'engrange pas
j'ai beau chercher depuis hier je trouve pas pourquoi
 
Vote positif 0 Vote négatif

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 62 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 124
Messages
2 116 471
Membres
112 753
dernier inscrit
PUARAI29