Microsoft 365 controltiptext sur bouton control activex

[farid]

bonjour,
je souhaite afficher un texte sur un bouton control activX, j'ai trouvé sur ce site et je remercie Mapomme ces quelques ligne de commande qui fonctionne tres biens sur des boutons dans un userform mais pas avec un bouton control activX , il m'affiche une erreur.J'ai beau chercher mais ca plane pour moi.
je met le fichier en ¨J
par avance merci pour votre contribution.

 

[Rhysand]

Bonjour à tous

mettre le code suivant dans un module standard

Option Explicit

Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Public Function CreerUneEtiquette(shpControl As Object, xInfo As String) As Boolean

Const SM_CXSCREEN = 0
Const COLOR_INFOTEXT = 23
Const COLOR_INFOBK = 24
Const COLOR_WINDOWFRAME = 6

Dim shapeLBL As OLEObject
Dim objLBL As OLEObject

Application.ScreenUpdating = False

For Each objLBL In ActiveSheet.OLEObjects
    If objLBL.Name = "lblfantome" Then objLBL.Delete
Next objLBL

Set shapeLBL = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Label.1")

With shapeLBL
    .Top = shpControl.Top + shpControl.Height - 12
    .Left = shpControl.Left + shpControl.Width - 12
    .Object.Caption = xInfo
    .Object.Font.Size = 11                                  ' changer ici la taille (font texte)
    .Object.BackColor = GetSysColor(COLOR_INFOBK)
    .Object.BackStyle = 1
    .Object.BorderColor = GetSysColor(COLOR_WINDOWFRAME)
    .Object.BorderStyle = 1
    .Object.ForeColor = GetSysColor(COLOR_INFOTEXT)
    .Object.TextAlign = 1
    .Object.AutoSize = False
    .Width = GetSystemMetrics(SM_CXSCREEN)
    .Object.AutoSize = True
    .Width = .Width + 2
    .Height = .Height + 2
    .Name = "lblfantome"
End With

DoEvents
Application.ScreenUpdating = True

' durée totale pendant laquelle l'étiquette restera visible
Application.OnTime Now() + TimeValue("00:00:04"), "SupprimerEtiquette"

End Function

Public Sub SupprimerEtiquette()

Dim shpObject As OLEObject

For Each shpObject In ActiveSheet.OLEObjects
    If shpObject.Name = "lblfantome" Then shpObject.Delete
Next shpObject

End Sub

et maintenant mettez le code suivant dans le module de feuille
changer le texte de l'étiquette est dans ce code, pour les autres controls, c'est aussi changer leur nom dans ce code

Option Explicit

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

Dim objlblfantome As OLEObject
Dim flblfantome As Boolean

For Each objlblfantome In ActiveSheet.OLEObjects
       flblfantome = objlblfantome.Name = "lblfantome"
Next objlblfantome

If Not flblfantome Then
CreerUneEtiquette CommandButton1, "Bonjour à tous" ' (MACRO)
' pour les autres contrôles, modifiez le nom et le texte que vous souhaitez sur l'étiquette
End If

End Sub

et si vous souhaitez modifier le texte qui apparaît dans le contrôle (bouton de commande) par VBA, mettez également le code suivant dans le module de feuille

Private Sub Worksheet_Activate()
'
Dim wsh As Worksheet
Dim shp As Shape
Dim strTime As String

strTime = "Je m'appelle Bouton de commande"

For Each wsh In Application.ThisWorkbook.Worksheets
    If wsh.Name = "Feuil1" Then
        For Each shp In wsh.Shapes
            If shp.Type = msoOLEControlObject Then
                If shp.Name = "CommandButton1" Then
                    shp.OLEFormat.Object.Object.Caption = strTime
                Else
                    ' cancel is true
                End If
            End If
        Next shp
    End If
Next wsh

End Sub

J'espère aider

 

[fanch55]

Salut à tous,
correction du Zorder :

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    ActiveSheet.Shapes("TextBox1").ZOrder msoSendToBack
    Me.TextBox1.Left = Me.CommandButton1.Left + X - Me.TextBox1.Width / 1
    Me.TextBox1.Visible = True
  
End Sub

Cependant, le contrôle des activex est assez dépendant de la performance de l'Excel ( mémoire, Cpu) et évidement de la vitesse de la souris quant au mousemove.
Il y a de fortes chancex qu'Excel ne détecte pas à temps la sortie de la souris de l'activex ...

 

[patricktoulon]

bonsoir a tous
l’idée de Rhysand est séduisante
cependant Api windows et tout ce tointoin pour ça!!! faut pas déconner hein

je met un label dans ma feuille je l'appelle "bubule" ,je l'arrange a mon gout et lui met le autosize a true
je le met a visible false

maintenant dans le module de la feuille je met ceci:

Option Explicit

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
With ActiveSheet.Shapes("bubule")
If .Visible = False Then .Visible = True: showEtiquette CommandButton1, "Bonjour à tous"
End With
End Sub

et dans le module standard je met ceci:

Option Explicit

Public Function showEtiquette(shpControl As Object, xInfo As String) As Boolean
     Application.ScreenUpdating = False
    With ActiveSheet.OLEObjects("bubule")
        .Top = shpControl.Top + shpControl.Height - 12
        .Left = shpControl.Left + shpControl.Width - 12
        .Object.Caption = xInfo
    End With
    DoEvents
    Application.ScreenUpdating = True
    ' durée totale pendant laquelle l'étiquette restera visible
    Application.OnTime Now() + TimeValue("00:00:04"), "hideEtiquette"
End Function

Public Sub hideEtiquette(): ActiveSheet.bubule.Visible = False: End Sub

et bien j'ai le même résultat

 

[farid]

Bonsoir fanch55,patricktoulon;Rhysand
Patricktoulon, je n'arrive pas a faire fonctionner en suivant tes instructions j'ai un beug.Je met le fichier en copie pour que tu puisse voir par toi même.
Effectivement fanch55, le message ne disparait pas .
Merci Rhysand, ta version fonctionne, cependant je souhaite personnalisé l'étiquette.
merci


,

 

[farid]

Bonsoir Fanc55,
je viens de réessayé ta solution, il fonctionne bien sauf qu'il faut pointer la souris sur le textbox pour le faire disparaitre , je te met le fichier en PJ pour un apercu.
merci par avance

 

[patricktoulon]

Bonsoir fanch55,patricktoulon;Rhysand
Patricktoulon, je n'arrive pas a faire fonctionner en suivant tes instructions j'ai un beug.Je met le fichier en copie pour que tu puisse voir par toi même.
Effectivement fanch55, le message ne disparait pas .
Merci Rhysand, ta version fonctionne, cependant je souhaite personnalisé l'étiquette.
merci


,

ma fois c'est normal que ça ne fonctionne pas c'est un textbox que tu a mis c'est pas un label

avec un textbox c'est
.Object.Value = xInfo

 

[patricktoulon]

tiens et celle ci elle te plait