récupération de l'object ribbon en cas de bug dans les macros

Version imprimable

1 pièce(s) jointe(s)

Bonjour à tous
j'ai un petit soucis avec un code de récupération de l'object ruban
le code me fait planter excel
je joins un fichier excel exemple au cas ou

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Option Explicit
 
#If Mac Then
    Private Declare PtrSafe Function CopyMemory_byVar Lib "libc.dylib" Alias "memmove" (ByRef dest As Any, ByRef src As Any, ByVal size As Long) As LongPtr
    Dim lRibbonPointer As LongPtr
#Else
    #If VBA7 Then
        Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef dest As Any, ByVal src As LongPtr, ByVal size As LongPtr)
        Dim lRibbonPointer As LongPtr
    #Else
        Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef dest As Any, ByVal src As Long, ByVal size As Long)
        Dim lRibbonPointer As Long
    #End If
#End If
 
#If VBA7 Then
Function GetRibbon(ByVal lRibbonPointer As LongPtr) As IRibbonUI
#Else
Function GetRibbon(ByVal lRibbonPointer As Long) As IRibbonUI
#End If
    Dim objRibbon As IRibbonUI
    If lRibbonPointer <> 0 Then
        #If Mac Then
            CopyMemory_byVar objRibbon, lRibbonPointer, LenB(lRibbonPointer)
        #Else
            CopyMemory objRibbon, lRibbonPointer, LenB(lRibbonPointer)
        #End If
    End If
    Set GetRibbon = objRibbon
End Function
 
 
Sub SafeRibbon()
    On Error GoTo ErrorHandler
    MsgBox "Tentative de récupération du ruban"
    lRibbonPointer = ThisWorkbook.Sheets(1).Range("a2").Value
    Set myRibbon = GetRibbon(lRibbonPointer)
    If Not myRibbon Is Nothing Then
        myRibbon.Invalidate
    Else
        MsgBox "Erreur : impossible de récupérer l'objet Ribbon."
    End If
    Exit Sub
 
ErrorHandler:
    MsgBox "Erreur : " & Err.Description
End Sub

24/07/2024, 23h04
deedolith

Salut,

J'ai déja essayé un truc comme ça, c'est extrêmement instable.
Ce qui ne m'étonne pas, VBA est un langage haut niveau, qui n'a pas grand chose à carrer des pointeurs qui par définition sont bas niveau. Sans compter que la tambouille interne d'Excel doit également interférer (je pense aux transtypages automatiques).

Rien ne vaut une appli bien architecturée et fail-proof.

Quand au projet qui s'effondre lorsque tu édites quelque chose, je pense que c'est un mal pour un bien, car ca force a fermer / reouvrir le classeur (re-initialisation de l'application dans un état connu).
25/07/2024, 20h24
patmeziere

re

Bonjour deedolith
mon app est relativement bien structuré tu n'a pas compris le contexte
je parle d'autres classeurs éventuellements ouvert qui bugueraient sur une macro ce qui entraine immédiatement le choix fin/deboguage
en cas de deboguage toute variable est détruite et donc celle du ruban aussi

donc il me faut une solution
25/07/2024, 23h43
deedolith

Citation:

Envoyé par patmeziere

je parle d'autres classeurs éventuellements ouvert qui bugueraient sur une macro ce qui entraine immédiatement le choix fin/deboguage

Heu ...

La solution ne serait-elle pas de corriger les anomalies ?
Si tu fais un contournement ou passage en force, les anomalies seront toujours la.
Et (Loi de Murphy oblige), elle sauront te rappeler leur présence au "meilleur" moment.
26/07/2024, 03h12
patmeziere

re

re
corrigé ou pas là n'est pas la question
quand il arrive une erreur je perd mon object ribbon
c'est pas compliqué a comprendre
j'ai besoins de ce sauve conduit c'est tout

visiblement tu réponds sans comprendre le contexte
donc je vais essayer d'expliquer
j'ai un fichier avec un ruban perso avec des control dynamique donc utilisation de myrribon.invalidate
d'autre fichiers sont ouverts qui viennent d'autres membre d'un forum
c'est fichiers parfois contienent des erreurs
la je choisi deboguage pour aller corriger
sauf que le deboguage réinitialise toute variables public ou global module dans tout les classeur
une fois corrigé je voudrais récupérer le ruban (mes outils)
voilà j'espère avoir été plus clair

Après recherches approfondies, je n'ai pas mieux à proposer.

Au risque de me répéter, j'ai déjà essayé cette technique, ca s'est révélé inutilisable tellement c'est instable.
Avec en bonus le risque de corruption du classeur, ca ne vaut pas le coup.

Tu es en train de dire qu'une erreur d'exécution dans 1 classeur fais tomber tous les projets ?
Pas normal, 1 seul projet est supposé s'effondrer (ou alors, il y a des dépendances que tu ne nous dit pas).

Sinon, les bases du debugging ?
Points d'arrêts, instruction Stop, instruction Debug.Print, exécuter en pas à pas, espions ?
Tracking des erreurs qui peut être fait avec une classe très simple ?
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 '// Module de classe: ErrorLogger Option Explicit Private mModuleName as String Private mFunctionName as String Friend Sub Create(ByVal ModuleName As String, ByValFunctionName As String) mModuleName = ModuleName mFunctionName = FunctionName End Sub Private Sub Class_Terminate() If(Err.Number <> 0) Then Debug.Print mModuleName & "." & mFunctionName & " : " & Err.Description End If End Sub
Code:

1 2 3 4 5 6 7 8 9 10 11 '// Module standard: Factory Option Explicit '// Fonction en charge d'instancier un objet de type ErrorLogger Public Function CreateErrorLogger(ByVal ModuleName As String, ByVal FunctionName As String) As ErrorLogger Dim Logger As ErrorLogger Set Logger = New ErrorLogger Logger.Create ModuleName, FunctionName Set CreateErrorLogger = Logger End Function
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 '// Module standard: TestModule Option Explicit Private Const ModuleName As String = "TestModule" Public Sub TestFunction() On Error Goto Error '// Gestionnaire d'erreur à déclarer uniquement pour les fonctions de plus haut niveau Const FunctionName As String = "TestFunction" Dim Logger As ErrorLogger Set Logger = Factory.CreateErrorLogger(ModuleName, FunctionName) SubTest Exit Sub Error: Stop End Sub Private Sub SubTest() Const FunctionName As String = "SubTest" Dim Logger As ErrorLogger Set Logger = Factory.CreateErrorLogger(ModuleName, FunctionName) Dim i As Long i = 10 / 0 End Sub
Lors de la destruction de l'instance de la classe ErrorLogger, si une erreur d'exécution a été levée, cette dernière est affichée dans la fenêtre d'exécution. On a alors connaissance de toute la pile des appels.
On sais quelle fonction à levé quelle erreur.
On sais également si l'erreur se transforme (symptôme d'une seconde erreur d'execution levée sur une première).

Bonjour à tous,
Je ne vois nulle part où tu sauvegardes le ruban, en général c'est dans la Sub de chargement du ruban.
Je n'utilise pas Mac mais pour ma part voici mon code qui ne me pose pose pas de problème.
Pour les déclarations :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
#If VBA7 Then
    Public Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, _
                                                                                    ByRef Source As Any, _
                                                                                    ByVal Length As Long)
#Else
    Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, _
                                                                            ByRef Source As Any, _
                                                                            ByVal Length As Long)
#End If
 
#If VBA7 Then
    Function GetRibbon(ByVal lRibbonPointer As LongPtr) As Object
#Else
    Function GetRibbon(ByVal lRibbonPointer As Long) As Object
#End If
    Dim RibbonTemp As Object
    CopyMemory RibbonTemp, lRibbonPointer, LenB(lRibbonPointer)
    Set GetRibbon = RibbonTemp
    Set RibbonTemp = Nothing
End Function

Pour la sauvegarde du Handle du ruban avec trois exemples selon la gestion des paramètres qui a été choisi les deux premières nécessites des procédures supplémentaires. La troisième sauvegarde le Handle dans un champ nommé (RibbonHandle) d'une feuille sys_Settings.
Il faut décommenter une des trois lignes selon le cas. (Pour les essais la troisième fera l'affaire. Penser à créer le champ nommé sur la feuille sys_Settings)

Code:

1
2
3
4
5
6
7
8
9
10
'@Description "Définit la procédure VBA qui doit être déclenchée lors du chargement du ruban."
Public Sub OnRibbonLoad(Ribbon As IRibbonUI)
    Set mUIRibbon = Ribbon
    mUIRibbon.ActivateTab "tab0"
    ' // Save the Ribbon Handle
'    ExcelProperties.SetProperty "RibbonHandle", CStr(ObjPtr(mUIRibbon)), msoPropertyTypeNumber
'    Settings.SetParams Factory.InitSettingsTab, "RibbonHandle", CStr(ObjPtr(mUIRibbon))
    sys_Settings.Range("RibbonHandle").Value = CStr(ObjPtr(mUIRibbon))
 
End Sub

Maintenant la procédure de récupération du Handle, il faut aussi dé-commenter une ligne selon selon la méthode de sauvegarde sélectionnée.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
'@Description "Récupère le ruban en cas de perte."
Sub RefreshRibbon(Optional ByVal ControlID As String = "")
    If mUIRibbon Is Nothing Then
        #If VBA7 Then
'            Set mUIRibbon = GetRibbon(CLngPtr(ExcelProperties.GetProperty("RibbonHandle")))
'            Set mUIRibbon = GetRibbon(CLngPtr(Settings(Factory.InitSettingsTab, "RibbonHandle")))
            Set mUIRibbon = GetRibbon(CLngPtr(sys_Settings.Range("RibbonHandle").Value))
        #Else
'            Set mUIRibbon = GetRibbon(CLng(ExcelProperties.GetProperty("RibbonHandle")))
'            Set mUIRibbon = GetRibbon(CLng(Settings(Factory.InitSettingsTab, "RibbonHandle")))
            Set mUIRibbon = GetRibbon(CLng(sys_Settings.Range("RibbonHandle").Value))
        #End If
        If ControlID = vbNullString Then
            mUIRibbon.Invalidate
        Else
            mUIRibbon.InvalidateControl ControlID
        End If
    Else
        If ControlID = vbNullString Then
            mUIRibbon.Invalidate
        Else
            mUIRibbon.InvalidateControl ControlID
        End If
    End If
End Sub

Maintenant , tu dois appeller la procédure refreshribbon à chaque fois que tu fait appel à celui-ci :

Code:

1
2
3
4
5
6
 
'...
'...
RefreshRibbon
' Ou pour un contrôle
RefreshRibbon ("Btn_Valider")

Je ne suis que de passage et ne pourrais peut-être pas répondre rapidement aux compléments d'informations.

31/07/2024, 13h19
patmeziere

2 pièce(s) jointe(s)

re

Merci valtraze
ca fonctionne mais au bout de 10 ou 15 fois ça plante excel
je garde ton écriture pour les api
j'ajoute une sub restaureRibbon
et je l'appelle dans les callback des controls sensés agir avec myRibbon.invalidate ( si myRibbon est nothing )

Pièce jointe 657730

merci pour le coup de main
01/08/2024, 10h59
Valtrase

Bonjour,
Je me suis peut-être mal expliqué...

Citation:

j'ajoute une sub restaureRibbon

Nul besoin de créer une procédure restaure ribbon. Vous avez tout ce qu'il faut dans les exemples donnés plus haut.
Vous devez utiliser la procédure RefreshRibbon avec ou pas de contrôle en paramètre. Si pas de contrôle mis en paramètre tout le ruban sera mis à jour, la procédure se charge aussi de vérifier si le Ruban est à Nothing.
Et pour finir, vous avez la possibilité d'utiliser d'autres contrôles pour le ruban vous évitant de la programmation exemple avec les SplitButtons.
01/08/2024, 19h27
patmeziere

1 pièce(s) jointe(s)

re

re
bonjour valtraze
non j'ai très bien compris le truc
mais la sub restaureribbon est apellée a tout moment ou un callback est déclenché
car dans ces callback je modifie des group en changeant des variable qui vont faire des modif avec des getvisible getlabel etc...
en gros je fait des switch group pour ne voir afficher uniquement les groupes dont j'ai besoin
bon la plus part du temps c'est un ribbon.invalidate
Pièce jointe 657795

en fait mon code était bon au depart sauf le longptr en trop dans les déclarations d'api
il faudra que je teste quand même avec office 64 sur Win 64
je renouvelle mes remerciements

re
Bonjour Valtraze
je reviens aujourd'hui pour te dire que j'ai enfin trouvé le poteau rose
a savoir: que ca crasch excel au bout d'un moment 5/15 foispuis la 16 eme crash excel
en fait c'est chatGPT qui m'a donné la solution sans le vouloir

en vba 7 32 bits copymemory manque de patience :mouarf: si je puis m'exprimer ainsi

lle temps que lenB soit correctement dimensionné bye bye copymemory
copymemory newobject , addrress pointer , lenB( pointer size)

ici ca marche
dim pointerSize as long
pointersize=lenB(addresspointer )
copymemory newobject , addresspointer , pointersize
Code:

1 2 3 4 5 6 7 8 9 10 11 12 #If VBA7 Then Function GetRibbon(ByVal lRibbonPointer As LongPtr) As Object #Else Function GetRibbon(ByVal lRibbonPointer As Long) As Object #End If Dim RibbonTemp As Object,RibbonSize as long lRibbonSize =lenB(lRibbonPointer) CopyMemory RibbonTemp, lRibbonPointer, lRibbonSize Set GetRibbon = RibbonTemp CopyMemory RibbonTemp, 0&, lRibbonSize ' Nettoyage Set RibbonTemp = Nothing End Function
et plus de problème
Voila au cas ou si tu repasse par ici
Patrick

30/12/2024, 21h42
Qwazerty

Salut

Je te remercie beaucoup pour ce retour, j'ai un problème similaire sur un fichier avec ruban, je vais pouvoir utiliser ton code pour améliorer son fonctionnement.
Je trouve ce système de switch sur les groupes plutôt intéressant.

Je te souhaite une bonne soirée
Qwaz

2 pièce(s) jointe(s)

re
bonsoir quazerty ça faisait longtemps;)
en fait j'ai fait une fonction entiere qui devrait être compatible de 2007 à 2024
elle gère les erreurs et te dis ou ca coince (eventuellement)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Public myRibbon As IRibbonUI ' {Variable pour l'object ribbon}
Public boolbool As Boolean
 
#If VBA7 Then
    Public Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr)
#Else
    Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
#End If
 
Sub KILLRIBBON()
    Set myRibbon = Nothing
End Sub
Function GetSavedRibbon() As IRibbonUI
    Dim objRibbon As IRibbonUI
    #If VBA7 Then
        Dim lRibbonPointer As LongPtr
    lRibbonPointer = CLngPtr(Replace(Names("NhRibbon").Value, "=", ""))
    #Else
        Dim lRibbonPointer As Long
     lRibbonPointer = CLng(Replace(Names("NhRibbon").Value, "=", ""))
   #End If
    Dim lRibbonSize&, mess$
    On Error GoTo erreur
    If lRibbonPointer = 0 Then mess = "Pointeur invalide (0).": GoTo erreur
    lRibbonSize = LenB(lRibbonPointer)
    If lRibbonSize <= 0 Then mess = "Taille invalide pour le pointeur.": GoTo erreur
    CopyMemory objRibbon, lRibbonPointer, lRibbonSize
    If objRibbon Is Nothing Then mess = "Impossible de recréer l'objet Ribbon.": GoTo erreur
    Set GetSavedRibbon = objRibbon ' Assigner l'objet récupéré à la fonction
    CopyMemory objRibbon, 0&, lRibbonSize ' Nettoyage
    Set objRibbon = Nothing
    Exit Function
erreur:
    MsgBox "Le ruban n'a pas pu être récupéré." & vbCrLf & mess & vbCrLf & _
            "Vous devez redémarrer l'application.", vbCritical, "Erreur"
    On Error GoTo 0
End Function
'**********************************************
'utilisation avant de faire un des 4 invalidate dans vos events dynamique
'If myRibbon is nothing then set myRibbon=GetSavedRibbon
'**********************************************'Callback pour l' event customUI.onLoad
Sub CustomUIOnLoad(ribbon As IRibbonUI)
    Set myRibbon = ribbon
    ActiveWorkbook.Names.Add Name:="NhRibbon", RefersTo:=ObjPtr(myRibbon)
End Sub

mise en application dans un fichier
et si tu a des soucis pour gérer la création de tes rubans j'ai créé un applicatif dans un fichier excel
c'est le CreatorRibonX ImageMso v 4.x.x.x.x.

https://excel-downloads.com/resource...3-v4-9-x.1447/
un exemple aussi de switch group dans un onglet perso selon la feuille active