VBA to add a screentip to a macro-enabed button

[scotthannaford1973]

Hi all

I am using a shape (Rectangle 9) as a button with a macro assigned to it (ExpandFuture) and I'd like to add a screen-tip for when people hover over the button. So just basic text... but importantly the macro still has to run when the click the button. Have found a few suggestions but none of them work!

 

[Yongle]

Here is a simple method - use a second (invisible) rectangle for the screen tip

I am assuming worksheet already contains "Rectangle 9" with click event which runs ExpandFuture

How to do it
- insert a new Rectangle in the worksheet
- right-click on it \ Send To Back
- right-click on it \ Link \ Screen Tip \ enter your screen tip \ OK
- make it 5mm wider AND 5mm taller than "Rectangle 9"
- move it behind "Rectangle 9" making sure that "Rectangle 9" sits in the middle of new rectangle
- right-click on new rectangle \ Format shape \ Fill \ Set Transparency to 100% and Line to No Line (to make it invisible)
- hold {CTRL} left-click on new rectangle AND also on "Rectangle 9" (make sure BOTH are selected) \ right-click \ Group \ Group
- and TEST

 

[scotthannaford1973]

Here is a simple method - use a second (invisible) rectangle for the screen tip

I am assuming worksheet already contains "Rectangle 9" with click event which runs ExpandFuture

How to do it
- insert a new Rectangle in the worksheet
- right-click on it \ Send To Back
- right-click on it \ Link \ Screen Tip \ enter your screen tip \ OK
- make it 5mm wider AND 5mm taller than "Rectangle 9"
- move it behind "Rectangle 9" making sure that "Rectangle 9" sits in the middle of new rectangle
- right-click on new rectangle \ Format shape \ Fill \ Set Transparency to 100% and Line to No Line (to make it invisible)
- hold {CTRL} left-click on new rectangle AND also on "Rectangle 9" (make sure BOTH are selected) \ right-click \ Group \ Group
- and TEST

Hi - unfortunately that doesn't work; when you hover over the 5mm border (effectively the part of the new rectangle that's not below Rectangle 9) you get the message, but when moving onto Rectangle 9, the message disappears... (I grouped the two shapes, but no joy).

 

[Yongle]

Nothing seems to work for you

 

[Yongle]

It does exactly what it should - make the button smaller and the screen tip will be visible for much longer as user moves cursor towards button.
If you use an active-x object instead of a rectangle it has a hover over event - which does exactly what you want.
If you insist on using a rectangle then you need to compromise on your requirements - shapes do not have a mouse over event

 

[mikerickson]

Shapes do not have tooltips.
And Excel doesn't detect hovering over a shape. Clicking yes, hovering no.

If you replace your rectangle with an ActiveX command button, and add a screen tip shape as Yongle suggested, you could use the Mouse Move event to simulate a hover detection.

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    With ActiveSheet.Shapes(1)
        If X <= 5 Or ((CommandButton1.Width - 5) <= X) Then
            .Visible = False
        ElseIf Y <= 5 Or ((CommandButton1.Height - 5) <= Y) Then
            .Visible = False
        Else
            .Visible = True
        End If
    End With
End Sub

 

[Jaafar Tribak]

How about this :

The code below assumes the shape is Rectangle 9 and it is located in Sheet1 .. Change these as required.

Code in the ThisWorkbook Module:

Option Explicit

Private WithEvents cmb As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Sub Workbook_Open()
    Call AddToolTipToShape(Shp:=Sheet1.Shapes("Rectangle 9"), _
    ScreenTip:="This is tooltip for shape : 'Rectangle 9'" & vbCrLf & vbCrLf & "Click Shape to run Macro.")
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call AddToolTipToShape(Shp:=Sheet1.Shapes("Rectangle 9"), _
    ScreenTip:="This is tooltip for shape : 'Rectangle 9'" & vbCrLf & vbCrLf & "Click Shape to run Macro.")
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call CleanUp
End Sub

Private Sub AddToolTipToShape(ByVal Shp As Shape, ByVal ScreenTip As String)
    On Error Resume Next
    Shp.Parent.Hyperlinks.Add Shp, "", "", ScreenTip:=ScreenTip
    Shp.AlternativeText = Shp.AlternativeText & "-ScreenTip"
    Set cmb = Application.CommandBars
End Sub

Sub CleanUp()
    Dim ws As Worksheet, Shp As Shape
    On Error Resume Next
    For Each ws In Me.Worksheets
        For Each Shp In ws.Shapes
            If InStr(1, Shp.AlternativeText, "-ScreenTip") Then
                Shp.Hyperlink.Delete
                Shp.AlternativeText = Replace(Shp.AlternativeText, "-ScreenTip", "")
            End If
        Next Shp
    Next ws
End Sub

Private Sub cmb_OnUpdate()
    Dim tPt As POINTAPI
    GetCursorPos tPt
    If InStr(1, "RangeNothing", TypeName(ActiveWindow.RangeFromPoint(tPt.x, tPt.y))) = 0 Then
        If ActiveWindow.RangeFromPoint(tPt.x, tPt.y).OnAction <> "" Then
            If GetAsyncKeyState(vbKeyLButton) Then
                Application.Run (ActiveWindow.RangeFromPoint(tPt.x, tPt.y).OnAction)
            End If
        End If
    End If
End Sub

The code should enable the shape to display a ScreenTip when the user hover over it while still permitting to run the associated Macro ExpandFuture

 

[Yongle]

@Jafaar Tribak - nice works well

 

[Jaafar Tribak]

@Jafaar Tribak - nice works well

Thanks Yongle for the feedback

 

[Yongle]

Another tried & tested method
- a minor improvement on my previous suggestion
- compromise this time is using Command Button instead of rectangle
- screen tip is visible whenever mouse hovers over the button (which answers the request made in your reply)

Test in a NEW worksheeet

1. Insert 2 Active-X command buttons
2. Place the button2 over the top of button1
3. Make button2 slightly smaller than button1 (just so that either can be selected)
4. Place it centrally over button1
5. Right-click on button2 \ View Code \ insert the line to run your macro: Call ExpandFuture
6. Hold {CTRL} and select BOTH buttons \ right-click \ Group \ Group
7. Right-click \ Link \ add a screen tip
8. Test


Why Active-X buttons?
- allows a fair amount of control over the "look" of buttons
- Design Mode \ Properties allows you to amend back colour, fore colour etc
- when adding the buttons in your "real" sheet amend the properties BEFORE grouping
- setting button1 Visible property to False renders it hidden when not in Design Mode (if you prefer not to see it sticking out under the other button)