XL 2016 [VBA] afficher un userform en Mouse Over d'une forme

F22Raptor · 5 Mai 2021

Bonjour à tous,
J'ai vu des vidéos qui expliquent comment programmer le déclenchement d'une macro sur un Mouse Over d'une forme dans une feuille Excel.
En fait, si j'ai bien compris, il faut superposer à chaque forme un contrôle ActiveX transparent, et c'est lui qui déclenchera le Mouse Over.

C'est pas trop ce qui m'arrange, vu que ma feuille comprend quelques dizaines de formes, et que l'utilisateur peut en créer de nouvelles.
L'idée étant que le passage en Mouse Over de la forme affiche un UF avec les dimensions de la forme, et qui disparaisse quand on ne survole plus la forme.
S'il faut créer un ActiveX superposé à chaque forme, de sa dimension exacte, et le redimensionner quand on redimensionne la forme, ça risque d'être lourd !

Selon vous, sans cette méthode, c'est impossible d'avoir ce résultat ?

Dudu2 · 6 Mai 2021

Bonjour,
Si le but est d'afficher les caractéristiques des Shapes, je peux te proposer ce code home made.
Il y a une petite latence due au minimum du Application.OnTime() mais ce n'est pas très sensible.

A noter que si besoin, le code peut être sorti dans un classeur indépendant pour pouvoir être utilisé sur toute feuille de tout classeur que le code demanderait. Je vais peut-être le faire d'ailleurs comme un "outil à Shape".

Fichier supprimé, voir plus loin.

F22Raptor · 6 Mai 2021

Impressionnant Dudu !
Merci, c'est exactement ça.
J'ai regardé le code : disons que j'ai l'impression de tailler de beaux silex, et qu'un gars d'une tribu d'à côté vient me montrer un processeur Intel ...
Le choc !

Dudu2 · 6 Mai 2021

Voilà la version généraliste qui est indépendante et demande sur quelle feuille de quel classeur on doit faire la manip.

Tip: on peut arrêter l'analyse soit avec ESC soit en revenant sur le classeur indépendant.

Fichier supprimé, voir plus loin.

F22Raptor · 6 Mai 2021

Dudu2 · 6 Mai 2021

Une petite modif mineure pour choper l'Escape aussi lorsque le UserForm des infos est affiché.

patricktoulon · 6 Mai 2021

Bonjour @Dudu2
je te propose mon astuce timer commandbars
qui est plus rapide et qui utilise donc un events commandbars en interne non implémenté
on a donc une boucle VBA non bloquante silencieuse (et non gourmande) pour preuve tu peux même essayer de taper dans les cellules rien ne t’empêche de travailler sur la feuille en meme temps
astuce à la patricktoulon
te reste plus qu'a refaire ton userform

Dudu2 · 6 Mai 2021

Salut @patricktoulon,
Oui je sais que tu as ça en magasin, on en a déjà parlé. Je vais jeter un oeil et tenter une version "CommandBar Timer". Même si en l'occurrence la latence Application.OnTime() n'a pratiquement pas d'incidence pour la fonctionnalité.

Dudu2 · 6 Mai 2021

Voici d'abord ma tentative de rendre ton système plus modulaire pour simplifier l'appel au CommandBars Timer. C'est plus facile à utiliser ensuite avec de simples appels de fonctions indépendantes Start & Stop.

J'ai préféré sortir dans un Module_CommandBarsTimer dédié ce que je pouvais du Module ThisWorkbook pour ne pas mélanger avec ce qu'on peut éventuellement y trouver d'autres traitements liés au classeur.
Hélas on ne peut pas sortir la variable WithEvents ni sa fonction liée.

patricktoulon · 6 Mai 2021

heu.. c'est simple
pur demarrer c'est set cmbrs=application.commandbars
pour l'arreter c'est set cmbrs =nothing
je pige pas ton souci tu laisse cici dans le thiswotkbook

VB:

Option Explicit
Private WithEvents Cmbrs As CommandBars    'creation de l'object commandbars events
#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
#End If

Private Type POINTAPI: X As Long: Y As Long: End Type
Public t
Dim pos As POINTAPI
Dim obj
'evenement commandbars
Private Sub Cmbrs_OnUpdate()
    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
    Ontimer Timer - t
End Sub

et dans un module standard
tu déplace aussi les variable global dans le module standard si il faut

et puis voila

non je pige pas ton soucis

VB:

 Sub go(): t = Timer: Set thisworkbook.Cmbrs = Application.CommandBars: End Sub

 Sub alt(): Set thiswokbook.Cmbrs = Nothing: TimerOnStop Timer - t: End Sub

'pseudo events on timer

Sub Ontimer(Optional TimeElapsed As Double)    'action pendant le timer
    [B1] = Format(Now, "hh:nn:ss")
    On Error GoTo fin
    [B2] = Format((TimeElapsed) / 86400, "hh:mm:ss ") & "0" & Left(Split(TimeElapsed & "000", ",")(1), 2)
    GetCursorPos pos
    [B3] = "x=" & pos.X
    [B4] = "y=" & pos.Y
    Set obj = ActiveWindow.RangeFromPoint(pos.X, pos.Y)
    'MsgBox TypeName(obj)
    Select Case TypeName(obj)
    Case "Range"
        [B5] = "Range " & obj.Address: [C5] = ""
    Case Else
        Select Case True
        Case TypeOf obj Is OLEObject
            [B5] = "OLEObject"
            [C5] = obj.Name

        Case ActiveSheet.Shapes(obj.Name).Type = 1    ' si c'est une shape
            [B5] = "shape"
            [C5] = obj.Name

        Case ActiveSheet.Shapes(obj.Name).Type = 8    ' si c'est un control formulaire
            [B5] = "control formulaire"
            [C5] = obj.Name

        Case ActiveSheet.Shapes(obj.Name).Type = 13    ' si c'est une picture
            [B5] = "picture"
            [C5] = obj.Name
        Case ActiveSheet.Shapes(obj.Name).Type = 24    ' si c'est une picture
            [B5] = TypeName(obj)
            [C5] = obj.Name

        Case TypeName(obj) = "ChartObject"
            [B5] = TypeName(obj)
            [C5] = obj.Name

        End Select

    End Select
fin:
    Err.Clear
End Sub

'pseudo events timer stop
Sub TimerOnStop(Optional TimeElapsed As Double = 0)
[B1:C5].ClearContents
' faire quelque chose ici quand on arrete
End Sub

tu a un pseudo event update dans le quel tu fait ce que tu veux
et un etvant stop pour faire ce que tu veux quand tu arrete voir rien si tu veux pas t'en servir
les deux macro associé au bouton de formilaire demarre et arrete c'est tout
c'est pas compliqué tu n'avais qu'a refaire ton usf avec ta table de correspondance de type d'obj
tu veux que je te le fasse ?

Dudu2 · 6 Mai 2021

Non, je suis en train de le faire en intégrant les 2 méthodes sur simple constante préprocesseur.
On ne peut pas placer la variable Private WithEvents Cmbrs As CommandBars dans un module séparé.
Les variables WithEvents sont spéciales. Donc soit en ThisWorkbook, soit en feuille.

patricktoulon · 6 Mai 2021

re
oui c'est la seule chose c'est normal c'est une classe events pour implémenter l'event update de la barre
tout le reste peut aller dans un module
je te fait une esquisse

Dudu2 · 6 Mai 2021

Non, ça va, merci, j'ai fait mon Module qui me convient parfaitement

Post #9.

patricktoulon · 6 Mai 2021

re
concernant mon timer bars on peut faire très simple
reste plus qu'a remplacer mon select case par ta moulinette type dans le userform
l'userform est non modal

Dudu2 · 6 Mai 2021

Voilà le classeur avec les 2 méthodes de Timer possibles: Application.OnTime() et CommandBars Timer.
Une simple variable préprocesseur permet d'activer l'une ou l'autre:

VB:

'------------------------------------
#Const CommandBarsTimerMethod = True    'True 3 fois par seconde et donc plus réactif mais consomme plus de CPU
                                        'False 1 fois par seconde mais suffisant pour la fonctionnalité
'------------------------------------

Maintenant une amélioration qui permet de déplacer le UserForm s'il gène là où il est, pour voir la feuille et les éventuels objets qu'il cache.

Pour info je n'ai pas utilisé la méthode ActiveWindow.RangeFromPoint(Pos.X, Pos.Y) pour trouver l'objet car elle ne permet pas de détecter des objets superposés. J'ai utilisé une fonction perso IsMouseOverObject().

Fichier supprimé, voir ci-dessous

XL 2016 [VBA] afficher un userform en Mouse Over d'une forme

F22Raptor

XLDnaute Impliqué

Dudu2

XLDnaute Barbatruc

F22Raptor

XLDnaute Impliqué

Dudu2

XLDnaute Barbatruc

F22Raptor

XLDnaute Impliqué

Dudu2

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Pièces jointes

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes

Dudu2

XLDnaute Barbatruc

Discussions similaires