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

RyuAutodidacte · 11 Mai 2023

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 · 31 Mai 2023

re
le sample avec le bon nom de sub
essaie le sur windows avant

RyuAutodidacte · 17 Août 2024

patricktoulon à dit:

re

VB:

If RunMacScript = "true" Then
            MsgBox "un projet portant ce Nom exite deja"
            Set DocXml = Nothing
           clearvisual
          ThisWorkbook.Sheets("param").[H2:H3] = ""
          Exit Function
        End If

C'est ok

patricktoulon · 17 Août 2024

et même mieux je te laisse le choix
tu "a donc 2 possibilités
1 non on annule
2 oui on écrase

pour Mac

VB:

Function RegMacCSVproject(csvcode)
    Dim Nom As String, folderAllproject As String, x As Long, fold, fich, RunMacScript As String, rewrite&, Q&
    If ThisWorkbook.Sheets("param").[h2] = "" Then
        rewrite = 0
        folderAllproject = ThisWorkbook.Path & Application.PathSeparator & "Mes Projets"
        RunMacScript = AppleScriptTask("myScriptUI.scpt", "CreateFolder", folderAllproject)

        Nom = InputBox("Entrez un nom pour ce projet", "ouverture de nouveau projet", "myproject")
        fold = folderAllproject & Application.PathSeparator & "Projet_" & Nom
        RunMacScript = AppleScriptTask("myScriptUI.scpt", "CreateFolder", fold)

        fich = fold & Application.PathSeparator & Nom & ".csv"
        ThisWorkbook.Sheets("param").[h2] = fold
        ThisWorkbook.Sheets("param").[H3] = Nom & ".csv"

    Else
        rewrite = 2
        With ThisWorkbook.Sheets("param"): fich = .[h2] & Application.PathSeparator & .[H3]: End With
    End If

    If rewrite = 2 Then
        ' Kill fich
        'RunMacScript = AppleScriptTask("myScriptUI.scpt", "DeleteFile", fich)
        RunMacScript = AppleScriptTask("myScriptUI.scpt", "CreateFileContentsUTF8", csvcode & "|" & fich)
    Else
        'If Dir(fich) <> "" Then MsgBox "un projet portant ce Nom exite deja": Exit Function
        RunMacScript = AppleScriptTask("myScriptUI.scpt", "FileExists", fich)
        If RunMacScript = "true" Then
            Q = MsgBox("un projet portant ce Nom existe deja" & vbcrlf & "Voulez vous ecraser l'existant", vbYesNo + vbCritical)
            If Q = vbNo Then
                Set DocXml = Nothing
                clearvisual
                ThisWorkbook.Sheets("param").[H2:H3] = ""
                Exit Function
            Else
                RunMacScript = AppleScriptTask("myScriptUI.scpt", "CreateFileContentsUTF8", csvcode & "|" & fich)
                MsgBox "projet demarre" & vbCrLf & " Toutes modifications sera automatiquement enregistree dans le projet Csv"
            End If
        End If
    End If
End Function

pour win

VB:

Function RegCSVproject(csvcode)
    'patricktoulon
    Dim Nom As String, folderAllproject As String, x As Long, fold, fich, rewrite&, Q&
    If ThisWorkbook.Sheets("param").[h2] = "" Then
        rewrite = 0
        folderAllproject = ThisWorkbook.Path & Application.PathSeparator & "Mes Projets"
        If Dir(folderAllproject, vbDirectory) = "" Then MkDir folderAllproject
        Nom = InputBox("Entrez un nom pour ce projet", "ouverture de nouveau projet", "myproject")
        fold = folderAllproject & Application.PathSeparator & "Projet_" & Nom
        If Dir(fold, vbDirectory) = "" Then: MkDir fold
        fich = fold & Application.PathSeparator & Nom & ".csv"
        ThisWorkbook.Sheets("param").[h2] = fold
        ThisWorkbook.Sheets("param").[H3] = Nom & ".csv"
    Else
        rewrite = 2
        With ThisWorkbook.Sheets("param"): fich = .[h2] & Application.PathSeparator & .[H3]: End With
    End If

    If rewrite = 2 Then
        Kill fich
        SaveFileUTF_8 csvcode, fich
    Else
        If Dir(fich) <> "" Then
            Q = MsgBox("un projet portant ce Nom existe deja" & vbcrlf & "Voulez vous ecraser l'existant", vbYesNo)
            If Q = vbNo Then
                Set DocXml = Nothing
                clearvisual
                ThisWorkbook.Sheets("param").[H2:H3] = ""
                Exit Function
            Else
                SaveFileUTF_8 csvcode, fich
                MsgBox "projet demarre" & vbCrLf & " Toutes modifications sera automatiquement enregistree dans le projet Csv"

            End If
        End If
    End If
End Function

ne pas oublier d'enlever le message d"ans le callback nouveau projet

patricktoulon · 17 Août 2024

hola j'ai fait une erreur on ne peut plus faire de nouveau projet

pour Mac

VB:

Function RegMacCSVproject(csvcode)
    Dim Nom As String, folderAllproject As String, x As Long, fold, fich, RunMacScript As String, rewrite&, Q&
    If ThisWorkbook.Sheets("param").[h2] = "" Then
        rewrite = 0
        folderAllproject = ThisWorkbook.Path & Application.PathSeparator & "Mes Projets"
        RunMacScript = AppleScriptTask("myScriptUI.scpt", "CreateFolder", folderAllproject)

        Nom = InputBox("Entrez un nom pour ce projet", "ouverture de nouveau projet", "myproject")
        fold = folderAllproject & Application.PathSeparator & "Projet_" & Nom
        RunMacScript = AppleScriptTask("myScriptUI.scpt", "CreateFolder", fold)

        fich = fold & Application.PathSeparator & Nom & ".csv"
        ThisWorkbook.Sheets("param").[h2] = fold
        ThisWorkbook.Sheets("param").[H3] = Nom & ".csv"
        RunMacScript = AppleScriptTask("myScriptUI.scpt", "CreateFileContentsUTF8", csvcode & "|" & fich)
        MsgBox "projet demarre" & vbCrLf & " Toutes modifications sera automatiquement enregistree dans le projet Csv"

        Exit Function
    Else
        rewrite = 2
        With ThisWorkbook.Sheets("param"): fich = .[h2] & Application.PathSeparator & .[H3]: End With
    End If

    If rewrite = 2 Then
        ' Kill fich
        'RunMacScript = AppleScriptTask("myScriptUI.scpt", "DeleteFile", fich)
        RunMacScript = AppleScriptTask("myScriptUI.scpt", "CreateFileContentsUTF8", csvcode & "|" & fich)
    Else
        'If Dir(fich) <> "" Then MsgBox "un projet portant ce Nom exite deja": Exit Function
        RunMacScript = AppleScriptTask("myScriptUI.scpt", "FileExists", fich)
        If RunMacScript = "true" Then
            Q = MsgBox("un projet portant ce Nom existe deja" & vbxclf & "Voulez vous ecraser l'existant", vbYesNo + vbCritical)
            If Q = vbNo Then
                Set DocXml = Nothing
                clearvisual
                ThisWorkbook.Sheets("param").[H2:H3] = ""
                Exit Function
            Else
                RunMacScript = AppleScriptTask("myScriptUI.scpt", "CreateFileContentsUTF8", csvcode & "|" & fich)
                MsgBox "projet demarre" & vbCrLf & " Toutes modifications sera automatiquement enregistree dans le projet Csv"
            End If
        End If
    End If
End Function

pour win

Code:

Function RegCSVproject(csvcode)
    'patricktoulon
    Dim Nom As String, folderAllproject As String, x As Long, fold, fich, rewrite&, Q&
    If ThisWorkbook.Sheets("param").[h2] = "" Then
        rewrite = 0
        folderAllproject = ThisWorkbook.Path & Application.PathSeparator & "Mes Projets"
        If Dir(folderAllproject, vbDirectory) = "" Then MkDir folderAllproject
        Nom = InputBox("Entrez un nom pour ce projet", "ouverture de nouveau projet", "myproject")
        fold = folderAllproject & Application.PathSeparator & "Projet_" & Nom
        If Dir(fold, vbDirectory) = "" Then: MkDir fold
        fich = fold & Application.PathSeparator & Nom & ".csv"
        ThisWorkbook.Sheets("param").[h2] = fold
        ThisWorkbook.Sheets("param").[H3] = Nom & ".csv"
        SaveFileUTF_8 csvcode, fich
        MsgBox "projet demarre" & vbCrLf & " Toutes modifications sera automatiquement enregistree dans le projet Csv"
        Exit Function
    Else
        rewrite = 2
        With ThisWorkbook.Sheets("param"): fich = .[h2] & Application.PathSeparator & .[H3]: End With
    End If

    If rewrite = 2 Then
        Kill fich
        SaveFileUTF_8 csvcode, fich
    Else
        If Dir(fich) <> "" Then
            Q = MsgBox("un projet portant ce Nom existe deja" & vbCrLf & "Voulez vous ecraser l'existant", vbYesNo)
            If Q = vbNo Then
                Set DocXml = Nothing
                clearvisual
                ThisWorkbook.Sheets("param").[H2:H3] = ""
                Exit Function
            Else
                SaveFileUTF_8 csvcode, fich
                MsgBox "projet demarre" & vbCrLf & " Toutes modifications sera automatiquement enregistree dans le projet Csv"

            End If
        End If
    End If
End Function

voila cette fois ci on est bon on a les 4 modes
1 crée le nouveau projet
et si mode rewrite avec si fileexiste
2 on n' écrase pas
3 on écrase
si rewrite en cours de route(a chaque changement)
4 on écrase

voila

patricktoulon · 18 Août 2024

patricktoulon · 20 Août 2024

le dossier

RyuAutodidacte · 21 Août 2024

patricktoulon à dit:
le dossier

voilà insérer … bien sur j'ai pas les callbacks car j'ai créé un xlsm vierge … mis en zip

patricktoulon · 21 Août 2024

ok
et donc on gagne quoi avec la méthode insertion?
a ton encore les msgbox d' autorisation sur les dossiers ?

RyuAutodidacte · 21 Août 2024

Hola attention là tu me pose une question sur une version non encore testé
là j'ai fait juste l'insertion direct avec des fonctions script sans passé par vba
pour voir si le fichier était valide avec les images perso

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é

patricktoulon

RyuAutodidacte

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Pièces jointes

RyuAutodidacte

XLDnaute Impliqué

Pièces jointes

patricktoulon

XLDnaute Barbatruc

RyuAutodidacte

XLDnaute Impliqué