Microsoft 365 controltiptext sur bouton control activex

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

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

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

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

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

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