Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

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
 

patricktoulon

XLDnaute Barbatruc
re
VB:
Sub Ouvrir()
Dim QuelFichier
    
    ChDir ThisWorkbook.Path
    QuelFichier = Application.GetOpenFilename(, , "Sélectionnez votre source de données")
    If QuelFichier <> False Then
        Debug.Print QuelFichier 'Workbooks.Open QuelFichier
    Else
        MsgBox "Vous n'avez pas sélectionné de fichier"
    End If
End Sub
 

patricktoulon

XLDnaute Barbatruc
re
VB:
Sub BTOPENPROJECT_Cliquer()
    Dim myfile, x As Long, CsvCod, tbl, At, tblc, elem As ElementXml

    ThisWorkbook.Sheets("param").[h2:h3].ClearContents
    reset

    #If Mac Then
        On Error Resume Next
        MainPath = MacScript("POSIX path of (choose file with prompt ""Sélectionner un ou plusieurs fichiers:"" of type {""xls"",""pdf"",""xlsm"", ""csv""} with multiple selections allowed)")
        'Pour la partie => {""xls"",""pdf"",""xlsm""} mettre les extensions voulues, entourées de doubles guillemets et séparées par une virgule
        'Si on veut tous les fichiers mettre alors la double accolade comme suit => {}
        'Si on veut ne sélectionner qu'un fichier alors retirer => with multiple selections allowed
        If Err.Number > 0 Then MsgBox "Sélection annulée": Exit Sub
        On Error GoTo 0
        myfile = MainPath 'on récupère le tout dans un tableau de base 0 que l'on peut alors traiter
    #Else
        MsgBox "Mettre le code PC ici"
        With Application.FileDialog(msoFileDialogOpen)
            .InitialFileName = ThisWorkbook.Path
            If .Show = -1 Then
                myfile = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
    #End If




    With ThisWorkbook.Sheets("param")
        .[h2] = Mid(myfile, 1, InStrRev(myfile, Application.PathSeparator) - 1)
        .[H3] = Mid(myfile, InStrRev(myfile, Application.PathSeparator) + 1)
    End With
    x = FreeFile: Open myfile For Input As #x: CsvCod = Input$(LOF(x), #x): Close #x
    tbl = Split(CsvCod, vbCr)
    Set DocXml = New ElementXml
    DocXml.Id = "Document"
    At = Split(tbl(0), ";")
    For i = 1 To UBound(tbl)
        If Len(Trim(tbl(i))) > 3 Then
            tblc = Split(tbl(i), ";")
            If Trim(tblc(0)) = "" Then Set leParent = DocXml Else Set leParent = DocXml.getElementById(Id:=Trim(tblc(1)))
            Set MyElement = leParent.AddChildNode(Trim(tblc(2)))
            MyElement.Id = Trim(tblc(3))
            DoEvents
            For C = 4 To UBound(tblc)
                If tblc(C) <> "" Then MyElement.SetAttribute Trim(At(C)), Trim(tblc(C))
            Next
        End If
    Next
    visualAddAll

    Set customUI = DocXml.getElementById(Id:="customUI")
    IndentationShape


End Sub
 

RyuAutodidacte

XLDnaute Impliqué
VB:
Sub GetOpenFileNameMacRibbon() 'RyuAutodidacte 10/07/2024 - GetOpenFilename à ma sauce pour Mac
Dim myLocation As String
    myLocation = ThisWorkbook.Path & Application.PathSeparator
    If Application.OperatingSystem Like "*Macintosh*" Then
        On Error Resume Next
        MainPath = MacScript("POSIX path of (choose file with prompt ""Sélectionner du projet en .csv :"" of type {""csv""} default location " & Chr(34) & myLocation & Chr(34) & ")")
        If Err.Number > 0 Then MsgBox "Sélection annulée": Exit Sub
        On Error GoTo 0
    Else
        MsgBox "Mettre le code PC ici"
    End If
End Sub
 

patricktoulon

XLDnaute Barbatruc
re
VB:
Sub BTOPENPROJECT_Cliquer()
    Dim myfile, x As Long, CsvCod, tbl, At, tblc, elem As ElementXml

    ThisWorkbook.Sheets("param").[h2:h3].ClearContents
    reset

    #If Mac Then
        On Error Resume Next
        Dim myLocation As String
        myLocation = ThisWorkbook.Path & Application.PathSeparator
        myfile = MacScript("POSIX path of (choose file with prompt ""Sélectionner du projet en .csv :"" of type {""csv""} default location " & Chr(34) & myLocation & Chr(34) & ")")
        If Err.Number > 0 Then MsgBox "Sélection annulée": Exit Sub
        On Error GoTo 0
    #Else
        With Application.FileDialog(msoFileDialogOpen)
            .InitialFileName = ThisWorkbook.Path
            If .Show = -1 Then
                myfile = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
    #End If
 

RyuAutodidacte

XLDnaute Impliqué
Franchement c'est pas trop mal, ca prends pas trop de place, c'est assez bien agencé
Peut etre faudrait il mettre un petite icone à coté/pour "Controls", "Attributs" et "Callbacks" pour que l'on voit bien et différencié chaque parties
 
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…