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

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
I'm guessing I can restrict the sheets the cmb_OnUpdate function for.. or control the show/hide toggle with separate True/False Booleans. P.S.: Hate there's no Edit function on this forum :|
 
Upvote 0
Is it possible for you to upload here a simplified workbook example where I can reproduce the problem... To be honest, I am confused about the problem you described.
 
Upvote 0
Sure thing, here you go: mockup.

ThisWorkbook contains the init stuff. mod01_Test contains the show/hide macro. Click the ( i ) button and see what happens; try it a few times, clicking on other cells then again on the button. Don't let it fool you that nothing's wrong :P From testing I got: working from first try to show/hide; working every 2nd click; working with intermittent clicks.

Awaiting your feedback.

BR,
Sun
 
Upvote 0
..then mod it like this and test:

VBA Code: 
Private Sub cmb_OnUpdate()
    Dim tPt As POINTAPI
    On Error Resume Next
    If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
    [COLOR=rgb(226, 80, 65)]If ActiveSheet.CodeName = "Sheet001" Then Exit Sub[/COLOR]
    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
 
Upvote 0
sunbeam906 said:
Sure thing, here you go: mockup.

ThisWorkbook contains the init stuff. mod01_Test contains the show/hide macro. Click the ( i ) button and see what happens; try it a few times, clicking on other cells then again on the button. Don't let it fool you that nothing's wrong :P From testing I got: working from first try to show/hide; working every 2nd click; working with intermittent clicks.

Awaiting your feedback.

BR,
Sun
Click to expand...

Ok- I understand.

The ShowHideInfoBox Macro running twice is the expected behaviour because the imgInfoOff and imgInfoOn don't have an hyperlink attached to them.

The whole idea of the code was to make the OnAction Macro run for shapes that have an hyperlink since shapes whith hyperlinks don't run their OnAction Macro.

So the solution to the problem you are experiencing is easy : Simply exclude\skip the shapes that are not hyperlinked.

The following variation should work :
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 LongPtr
    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()
    Set cmb = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If cmb Is Nothing Then
        Set cmb = Application.CommandBars
    End If
End Sub

Private Function HasHyperlink(ByVal Shp As Shape) As Boolean
    On Error Resume Next
    HasHyperlink = CBool(Shp.Hyperlink.Type)
End Function


Private Sub cmb_OnUpdate()
    Dim tPt As POINTAPI, oObj As Object
    On Error Resume Next
    If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
    Call GetCursorPos(tPt)
    Set oObj = ActiveWindow.RangeFromPoint(tPt.x, tPt.y)
    If InStr(1, "RangeNothingDropDown", TypeName(oObj)) = 0 Then
        If HasHyperlink(oObj) Then
            If oObj.OnAction <> "" Then
                If GetAsyncKeyState(vbKeyLButton) Then
                    Call Application.Run(oObj.OnAction)
                End If
            End If
        End If
    End If
End Sub
 
Last edited:
Upvote 0
Please ignore my previous post because I found a bug in the code after testing.. The HasHyperlink function was wrong and would always evaluate to FALSE.

Here is the correct code:
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 LongPtr
    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()
    Set cmb = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If cmb Is Nothing Then
        Set cmb = Application.CommandBars
    End If
End Sub

Private Function HasHyperlink(ByVal Shp As Object) As Boolean
    On Error Resume Next
     HasHyperlink = Not (Shp.Parent.Shapes(Shp.Name).Hyperlink) Is Nothing
End Function


Private Sub cmb_OnUpdate()

    Dim tPt As POINTAPI, oObj As Object
   
    On Error Resume Next
   
    If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
    Call GetCursorPos(tPt)
    Set oObj = ActiveWindow.RangeFromPoint(tPt.x, tPt.y)

    If InStr(1, "RangeNothingDropDown", TypeName(oObj)) = 0 Then
        If HasHyperlink(oObj) Then
            If oObj.OnAction <> "" Then
                If GetAsyncKeyState(vbKeyLButton) Then
                    Call Application.Run(oObj.OnAction)
                End If
            End If
        End If
    End If

End Sub


This
 
Upvote 0
Can I please get some help with this? I have been messing with this code and I know im close but I cant get it to work right. I have multiple pages with multiple buttons on each page used for navigation and I stumbled on this because I couldn't get the macro and screentip to work together. Even using the code provided My screen tips show up but my macros do not execute. I saw something posted earlier on this forum about there being a problem if an error is generated and I wonder if that is what happened to mine.

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
        Set cmb = Application.CommandBars
    End If
    
End Sub
Private Function HasHyperlink(ByVal Shp As Object) As Boolean
    On Error Resume Next
     HasHyperlink = Not (Shp.Parent.Shapes(Shp.Name).Hyperlink) Is Nothing
End Function
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call CleanUp
End Sub
Private Sub SetUpShapes()
    
    Set wbPB = PokerBros
    Dim wsH As Worksheet: Set wsH = wbPB.Worksheets("Home")
    Dim wsPT As Worksheet: Set wsPT = wbPB.Worksheets("Player Tracking")
    Dim wsPD As Worksheet: Set wsPD = wbPB.Worksheets("Player Directory")
    Dim wsAS As Worksheet: Set wsAS = wbPB.Worksheets("Agent Settlement")
    Dim wsAP As Worksheet: Set wsAP = wbPB.Worksheets("Agent Player Data")
    Dim wsRD As Worksheet: Set wsRD = wbPB.Worksheets("Resource Data")
    Dim wsF As Worksheet: Set wsF = wbPB.Worksheets("Files")
    
        Call AddToolTipToShape(Shp:=wsH.Shapes("Admin View"), ScreenTip:="Admin View - Must Have Admin Rights")
        Call AddToolTipToShape(Shp:=wsPT.Shapes("Admin View"), ScreenTip:="Admin View - Must Have Admin Rights")
        Call AddToolTipToShape(Shp:=wsPD.Shapes("Admin View"), ScreenTip:="Admin View - Must Have Admin Rights")
        Call AddToolTipToShape(Shp:=wsAS.Shapes("Admin View"), ScreenTip:="Admin View - Must Have Admin Rights")
        Call AddToolTipToShape(Shp:=wsAP.Shapes("Admin View"), ScreenTip:="Admin View - Must Have Admin Rights")
        Call AddToolTipToShape(Shp:=wsRD.Shapes("Admin View"), ScreenTip:="Admin View - Must Have Admin Rights")
        Call AddToolTipToShape(Shp:=wsF.Shapes("Admin View"), ScreenTip:="Admin View - Must Have Admin Rights")
        
        Call AddToolTipToShape(Shp:=wsH.Shapes("Fullscreen"), ScreenTip:="Fullscreen - View in Fullscreen Mode")
        Call AddToolTipToShape(Shp:=wsPT.Shapes("Fullscreen"), ScreenTip:="Fullscreen - View in Fullscreen Mode")
        Call AddToolTipToShape(Shp:=wsPD.Shapes("Fullscreen"), ScreenTip:="Fullscreen - View in Fullscreen Mode")
        Call AddToolTipToShape(Shp:=wsAS.Shapes("Fullscreen"), ScreenTip:="Fullscreen - View in Fullscreen Mode")
        Call AddToolTipToShape(Shp:=wsAP.Shapes("Fullscreen"), ScreenTip:="Fullscreen - View in Fullscreen Mode")
        Call AddToolTipToShape(Shp:=wsRD.Shapes("Fullscreen"), ScreenTip:="Fullscreen - View in Fullscreen Mode")
        Call AddToolTipToShape(Shp:=wsF.Shapes("Fullscreen"), ScreenTip:="Fullscreen - View in Fullscreen Mode")
        
        Call AddToolTipToShape(Shp:=wsH.Shapes("Player Profile"), ScreenTip:="Player Profile - Player Selection Database")
        Call AddToolTipToShape(Shp:=wsPT.Shapes("Player Profile"), ScreenTip:="Player Profile - Player Selection Database")
        Call AddToolTipToShape(Shp:=wsPD.Shapes("Player Profile"), ScreenTip:="Player Profile - Player Selection Database")
        Call AddToolTipToShape(Shp:=wsAS.Shapes("Player Profile"), ScreenTip:="Player Profile - Player Selection Database")
        Call AddToolTipToShape(Shp:=wsAP.Shapes("Player Profile"), ScreenTip:="Player Profile - Player Selection Database")
        Call AddToolTipToShape(Shp:=wsRD.Shapes("Player Profile"), ScreenTip:="Player Profile - Player Selection Database")
        Call AddToolTipToShape(Shp:=wsF.Shapes("Player Profile"), ScreenTip:="Player Profile - Player Selection Database")
        
        Call AddToolTipToShape(Shp:=wsH.Shapes("SaveAs"), ScreenTip:="Save - Save New File")
        Call AddToolTipToShape(Shp:=wsPT.Shapes("SaveAs"), ScreenTip:="Save - Save New File")
        Call AddToolTipToShape(Shp:=wsPD.Shapes("SaveAs"), ScreenTip:="Save - Save New File")
        Call AddToolTipToShape(Shp:=wsAS.Shapes("SaveAs"), ScreenTip:="Save - Save New File")
        Call AddToolTipToShape(Shp:=wsAP.Shapes("SaveAs"), ScreenTip:="Save - Save New File")
        Call AddToolTipToShape(Shp:=wsRD.Shapes("SaveAs"), ScreenTip:="Save - Save New File")
        Call AddToolTipToShape(Shp:=wsF.Shapes("SaveAs"), ScreenTip:="Save - Save New File")
        
        Call AddToolTipToShape(Shp:=wsPT.Shapes("Home"), ScreenTip:="Home - Go to Homepage")
        Call AddToolTipToShape(Shp:=wsPD.Shapes("Home"), ScreenTip:="Home - Go to Homepage")
        Call AddToolTipToShape(Shp:=wsAS.Shapes("Home"), ScreenTip:="Home - Go to Homepage")
        Call AddToolTipToShape(Shp:=wsAP.Shapes("Home"), ScreenTip:="Home - Go to Homepage")
        Call AddToolTipToShape(Shp:=wsRD.Shapes("Home"), ScreenTip:="Home - Go to Homepage")
        Call AddToolTipToShape(Shp:=wsF.Shapes("Home"), ScreenTip:="Home - Go to Homepage")
        
        Call AddToolTipToShape(Shp:=wsPT.Shapes("ImportPT"), ScreenTip:="Import - Import New Player Tracking")
        
        Call AddToolTipToShape(Shp:=wsPD.Shapes("ImportPD"), ScreenTip:="Import - Import New Directory")

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 Workbook_Open()

    Dim wsH As Worksheet
    Dim CarryOn As Integer
    Set wbPB = PokerBros
    Set wsH = wbPB.ActiveSheet

        CarryOn = MsgBox("Do you want to save a copy of this original file?", vbQuestion + vbYesNo, "Save Copy Recommended")
        If CarryOn = vbYes Then
           Call CopyToNewBook
        End If

        wsH.Activate
        Call GotoHome

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, oObj As Object
    On Error GoTo errHandler
    If Not ActiveWorkbook Is wbPB Then Exit Sub
    GetCursorPos tPt
    Set oObj = ActiveWindow.RangeFromPoint(tPt.x, tPt.y)
     If InStr(1, "RangeNothingDropDown", TypeName(oObj)) = 0 Then
        If HasHyperlink(oObj) Then
            If oObj.OnAction <> "" Then
                If GetAsyncKeyState(vbKeyLButton) Then
                    Call Application.Run(oObj.OnAction)
                End If
            End If
        End If
    End If
    Exit Sub
errHandler:
    Call CleanUp
    Call SetUpShapes
End Sub
 
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