XL 2013 customui copymemory qui fait encore des siennes

[patricktoulon]

Bonsoir à tous
j'aimerais bien trouver ce qui ne va pas dans ma fonction de récupération du ruban là ca me crasch excel

'callback created by [[''creatorRibbonX'']]
'[createRibbonX Application] created by (''patricktoulon'')
'Version 2024 5.2
'POUR MEMO 4 fonctions importantes à connaitre pour les controls dynamiques
'L 'objet IRibbonUI possède 4 méthodes :
'1° myribbon.Invalidate() qui actualise en une seule fois tous les contrôles personnalisés du classeur.
'2° myribbon.InvalidateControl("Id du control") qui actualise un contrôle particulier (ControlID correspond à l'identificateur unique du contrôle).
'3° myRibbon.ActivateTab ("id de l'onglet à activer")qui active l'onglet désigné par son ID dans les parenthèses
'4° myRibbonInvalidateControlMso ("Id de l'element"(onglet/group/control) )qui actualise l'element désigné par son ID dans les parenthèses



'Nom du projet:[C:\Users\patricktoulon\Desktop\CreatorRibbonX V4.9 et V5.0\creatorRibbonX 4.9.9.X\Project_switch_onglet_developer_visible\exemple.xml]
'créé le:[29/12/2024]

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
  Dim iRibbonPointer As LongPtr
  On Error GoTo erreur
  lRibbonPointer = CLngPtr(Replace(Names("NhRibbon").Value, "=", ""))
  CopyMemory objRibbon, lRibbonPointer, LenB(lRibbonPointer)
  Set GetSavedRibbon = objRibbon
  CopyMemory objRibbon, 0&, LenB(lRibbonPointer)
  Set objRibbon = Nothing
  Exit Function
erreur:
  Err.Clear: MsgBox " L application n'a pas pu recuper le ruban" & vbCrLf & " Vous devez redemarrer l application": On Error GoTo 0: End
  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

'l'event ribbon Load_Image
Public Sub Ribbon_loadImage(imageId As String, ByRef image)
Set image = LoadPicture(ThisWorkbook.Path & "\images\" & imageId)
End Sub

'procedure {getvisible} du tab [idMso :''TabDeveloper'']  []'dans le parent [tabs '' ]
'valeur par defaut
Sub TabBuild_Getvisible(control As IRibbonControl, ByRef returnedVal)
 returnedVal = boolbool
End Sub

'procedure {onAction} du bouton [ID:''button_1'' Label:''onglet developpeur'']'dans le parent [group_0'' Label:''Groupe N° 1'']
Sub onglet_developpeur_Click(control As IRibbonControl)
boolbool = Not boolbool
If myRibbon Is Nothing Then Set myRibbon = GetSavedRibbon
myRibbon.InvalidateControlMso ("TabDeveloper")
End Sub

 

[Rheeem]

Au premier vu CopyMemory à besoin de deux adresses pour la source et la destination donc l'argument 0& est incorrect

Dim Dummy As LongPtr
CopyMemory objRibbon,  Dummy, LenB(lRibbonPointer)

 

[patricktoulon]

bon ben j'ai fini par trouver
en fait il faut variabiliser le lenb(du pointeur) en long et se servir de la variable l'ors de l'appel a l'api copymemory tout simplement

Function GetSavedRibbon() As IRibbonUI
    Dim objRibbon As IRibbonUI
    #If VBA7 Then
        Dim lRibbonPointer As LongPtr
    #Else
        Dim lRibbonPointer As Long
    #End If
    Dim lRibbonSize&, mess$
    On Error GoTo erreur
    lRibbonPointer = CLngPtr(Replace(Names("NhRibbon").Value, "=", ""))
    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

 

[patricktoulon]

bonsoir @Rheeem Merci pour l'intérêt à mon problème
l'address 0& est une address valide (hérité de nos bonnes vielles macro4)
c'est qu'en fait lenb doit demander un laps de temps et en 32 visiblement copymemory n'est pas patiente
là je teste à tout va et je n'ai plus aucun raté
voila une opération rondement menée

 

[patricktoulon]

tiens fait le test
quand tu a le beep c'est que le ribbon a été récupéré sinon tu n'a pas le beep
pour killer le ribbon tu a le bouton
tip top
à retenir en 32 pour vba7 variabiliser le lenB(address pointeur) surtout quand on travaille avec des object COM comme le iribbonUI par exemple
Patrick

 

[Rheeem]

à retenir en 32 pour vba7 variabiliser le lenB(address pointeur) surtout quand on travaille avec des object COM comme le iribbonUI par exemple

Je ne pense pas que tu fournis un argument valide le troisième paramètre de CopyMemory est bien un entier passé par valeur et l'appel direct est donc valide .
Par contre l'instruction de transtypage CLngPtr n'est disponible que dans la version VBA7 et elle est présente dans la partie commune du code

 

[patricktoulon]

je te dis que non chez moi vba 7 32 bits dans office 2013 pro plus
copymemory newobject , address pointer , lenB(address pointer) plante
et j'ai eu la confirmation tout à l'heure sur stackoverflow en cherchant des explications sur ce phénomène un a constaté le même phénomène sur 2016 en 32 bit
en plus des constatations de chatGpt qui explique que la latence de la mémoire en vba 7 est plus importante sur 64 je n'ai pas de retour
tu a raison pour clngPtr il faut que je modifie ça
pour être compatible vba6 2007 à vba7 2010 à 2024
en tout cas un long ça mange pas de pain si ça peut arrêter de me faire tilter excel
moi y en a tré boun content

 

[patricktoulon]

tu met ça dans le module des callbackset tu n' a plus de soucis

Public myRibbon As IRibbonUI ' {Variable pour l'object ribbon}

#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

Function GetSavedRibbon() As IRibbonUI
    'creatorRibbonX ImageMso V 5.2 by patricktoulon
    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

c'est quand même pratique quand on débogue de ne pas être obligé de fermer et rouvrir le classeur
la ligne en commentaire tu la met juste avant un invalidate
terminé

 

[Rheeem]

Essaie de copier l'objet avec interlockedexchange ou une de ses variantes qui sont thread safe empêchant toute autre opération avant la copie, probablement quelque chose qui se déroule en arrière plan qui fait planter l'application

InterlockedExchange function (winnt.h) - Win32 apps

Sets a 32-bit variable to the specified value as an atomic operation.

learn.microsoft.com