Tooltip and Macro on a shape in Excel, VBA

X

xlsat

New Member
Joined
Jun 25, 2009
Messages
34
I am trying to attach a tooltip (through hyperlink route) and a macro to an existing shape. The code is something like this -

Code: 
Sub testtooltip()
    Dim myDocument As Worksheet
    Dim shp As Shape
    Dim strTooltip As String, strMacroName As String
    
    Set myDocument = Sheets("MyDashboard")
    
    strTooltip = "setting this tooltip - "
    strMacroName = "'" & ActiveWorkbook.Name & "'" & "!" & "RefreshDashboard"
    
    With myDocument
        Set shp = .Shapes("shp_button_refresh")
        
        .Hyperlinks.Add Anchor:=shp, Address:="", ScreenTip:=strTooltip
       shp.OnAction = strMacroName
    End With

End Sub
I am calling this Sub on Workbook_Open. As I see, the tooltip gets assigned to the shape without any problem and also, the Macro name too seems to get assigned. BUT, on click of the shape, nothing happens, meaning, the assigned macro never gets called. If I comment out the tooltip assigning line, then macro gets called!!!

I did see similar macro not getting called problem being posted in a few places, but none of them seemed to provide a proper answer Help please?

Note: My Excel version is 2007.
P.S: I had submitted this as a response to another old thread. Posting it in a new thread realizing that the old one may not surface at all...
 
Last edited:
Sort by date Sort by votes
Workbook Demo upon someone's request

Updtae code in the ThisWorkbook Module:
Code: 
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_Activate()
    Call AddToolTipToShape(Shp:=ActiveSheet.Shapes(1), ScreenTip:="This is tooltip for shape 1")
    Call AddToolTipToShape(Shp:=ActiveSheet.Shapes(2), ScreenTip:="Hello from shape 2")
    Call AddToolTipToShape(Shp:=ActiveSheet.Shapes(3), ScreenTip:="bla bla bla ...")
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
    
    If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
    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
 
Last edited:
Upvote 0

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Thanks Jaafar for the interesting solution, however I got errors whenever in the spreadsheet are present data validation cells. As as activated (dropdown list) I get this error:"Run-time error '1004':Unable to get the OnAction property of the DropDown class"Any suggestion on how to fix it?ThanksMarco
 
Upvote 0
@Marco Lorenzi

Hi Marco and welcome to the forum.

I am afraid it would be difficult for me to figure out the issue you are having as it is working for me just fine and i do have a cell with a DV list on the same sheet as the shapes.

If you could upload an example of your workbook to some file hosting site like box.net or some other site and post a link here so I could take a look.

Regards.
 
Last edited:
Upvote 0
Jaafar Tribak said:
...
Click to expand...

I've managed to make use of the code and see where it errors. It happens within 'Private Sub cmb_OnUpdate()', whereas when a drop-down exists in the sheet, this will fail to execute:

" If ActiveWindow.RangeFromPoint(tPt.x, tPt.y).OnAction <> "" Then "

There's no OnAction property for DropDown classes, exactly as the error instructs. I guess the command bar update is triggered for drop-down validation fields as well.

BR,
Sun
 
Upvote 0
The error occurs when you click the validation list's drop-down arrow.
 
Upvote 0
sunbeam906 said:
The error occurs when you click the validation list's drop-down arrow.
Click to expand...

Yes. I could reproduce the issue with the Data Validation drop-down... Thanks for testing and letting me know.

Here is an updated workbook example in which I have included a DV list for testing purposes.

And here is the amended code to which I have also added a couple extra defensive layers should any unhandled error occur or an unexpected vba loss of state.

In the ThisWorkbook Module:
VBA Code: 
Option Explicit

Private WithEvents cmb As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

#If 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
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If


Private Sub Workbook_Activate()
    If cmb Is Nothing Then
        Call CleanUp
        Call SetUpShapes
    End If
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If cmb Is Nothing Then
        Call CleanUp
        Call SetUpShapes
    End If
End Sub

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

Private Sub SetUpShapes()
    Call AddToolTipToShape(Shp:=ActiveSheet.Shapes(1), ScreenTip:="This is tooltip for shape 1")
    Call AddToolTipToShape(Shp:=ActiveSheet.Shapes(2), ScreenTip:="Hello from shape 2")
    Call AddToolTipToShape(Shp:=ActiveSheet.Shapes(3), ScreenTip:="bla bla bla ...")
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
    On Error GoTo errHandler
    If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
    GetCursorPos tPt
    If InStr(1, "RangeNothingDropDown", 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
    Exit Sub
errHandler:
    Call CleanUp
    Call SetUpShapes
End Sub
 
Last edited:
Upvote 0
Please dismiss the above code because it doesn't take into account if the workbook has more than one worksheet plus I wrongly used ActiveSheet to refer to the shapes which I shouldn't have.

I have added a shape to Sheet2 to show that the code now works for shapes accross multiple worksheets.

Updated Workbook example

Here is the correct code :
In the ThisWorkbook Module:
VBA Code: 
Option Explicit

Private WithEvents cmb As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

#If 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
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If


Private Sub Workbook_Activate()
    If cmb Is Nothing Then
        Call CleanUp
        Call SetUpShapes
    End If
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If cmb Is Nothing Then
        Call CleanUp
        Call SetUpShapes
    End If
End Sub

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

Private Sub SetUpShapes()
    Call AddToolTipToShape(Shp:=Sheet1.Shapes("Shape1"), ScreenTip:="This is tooltip for shape 1")
    Call AddToolTipToShape(Shp:=Sheet1.Shapes("Shape2"), ScreenTip:="Hello from shape 2")
    Call AddToolTipToShape(Shp:=Sheet1.Shapes("Shape3"), ScreenTip:="bla bla bla ...")
    Call AddToolTipToShape(Shp:=Sheet2.Shapes("Shape1"), ScreenTip:="Shape1 in Sheet2") '<=== Shape In Sheet2
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

Private 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
    On Error GoTo errHandler
    If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
    GetCursorPos tPt
    If InStr(1, "RangeNothingDropDown", 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
    Exit Sub
errHandler:
    Call CleanUp
    Call SetUpShapes
End Sub
 
Upvote 0
As far as I can tell, and correct me if I'm wrong, if you set yourself the tool-tips manually through some macro..
VBA Code: 
Private Sub TestToolTip()
    ActiveSheet.Shapes.Range(Array("Group 6")).Select
    ActiveSheet.Hyperlinks.Add _
        Anchor:=Selection.ShapeRange.Item(1), _
        Address:="", _
        ScreenTip:="Sorts the table A-Z based on Physical Server Name first, then Virtual Server Name."
End Sub

..whereas, in this case, I'm applying that tool-tip to Group 6 shape (contains 2 Pictures with preset macros), then all I need are these in ThisWorkbook:
VBA Code: 
Private WithEvents cmb As CommandBars

Private Sub Workbook_Open()
    Set cmb = Application.CommandBars
End Sub

Private Sub cmb_OnUpdate()
    Dim tPt As POINTAPI
    If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
    GetCursorPos tPt
    If InStr(1, "RangeNothingDropDown", 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
Am not entirely sure if there would be any other CommandBars events where I'd get an error, hence why I removed the error handler. Actually I'll just set a On Error Resume Next, as the elements I have aren't that mixed to require special handling.

Let me know what you think :)

Best regards,
Sun
 
Upvote 0
@sunbeam906

What you have done is essentially the same as what my code does in a more dynamic way.

A runtime error will occur in the cmb_OnUpdate event routine if the unknown object currently under the mouse pointer doesn't expose a "OnAction" Property or when its OnAction Property is not set

Adding On Error Resume Next at the start of the event code (although not a good coding practice) would prevent such unexpected code interruption (a case in point is the DV DropDown) .... I think that In our particular scenario, absorbing these potential errors (via On Error Resume\GoTo ) before they happen shoud be fine.
 
Upvote 0
Found another issue.

If you have 2 Pictures, one visible, one hidden and a macro that executes when you click on the visible picture that does this:

VBA Code: 
Private Sub ShowHideInfoBox()

    Dim b As Boolean: b = ActiveSheet.Shapes("imgInfoOff").Visible 'True
    
    Application.Cursor = xlWait
    With ActiveSheet
        .Shapes("imgInfoOff").Visible = Not b
        .Shapes("Group1").Visible = b
        .Shapes("imgInfoOn").Visible = b
    End With
    Application.Cursor = xlDefault
    
End Sub

What will happen is the macro will be executed twice: first when you click the Picture object and a second time in the cmb_OnUpdate function. Now.. since I have a Boolean there that reads the Picture's visibility state, the effect visually is the pop-up opens and closes fast (first run it opens the info text box, second run it will close it). In short, intermittent behavior.

Anything that can be done about it to prevent running a macro 2 times?

zaRbhPR.png


Clicking on the button Picture would do this:

d5yxYfy.png


That's the standard behavior.

Now.. when I click it.. this happens:

kNLsni2.gif


Best regards,
Sun
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA support : need to remove extra space
Replies
2
Views
168
sksanjeev786
S
D
  • Question Question
I'm trying to write a macro to remove word art
Replies
4
Views
208
rlv01
R
E
  • Question Question
Filling Modules in a Trapezoid Shape Using Excel VBA
Replies
1
Views
230
Fluff
Fluff
S
  • Solved
VBA Code - Rename copied shape
Replies
1
Views
424
KOKOSEK
KOKOSEK
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
316
Minh Tuan VN
M

Forum statistics

Threads
1,223,719
Messages
6,174,089
Members
452,542
Latest member
Bricklin

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top