VBA Run Macro and Screen Tip (or Tool Tip) From Shape. I cannot get the code I found to work

问题

I am using custom buttons (shapes) as buttons and I would like to use this code that I found but I cant get it to work correctly and I dont know why. The goal is to add a screentip to the shape as well as a macro. Normally this doesnt work. Only one or the other will work but not both.

--- Please do not ask me to insert Activex Controls. I am aware Mouse move events. I did try that way and it works but it is very glitchy.---

The attached method would be perfect if anyone can help me understand what I am doing wrong. I found this method in a forum and I have messaged the author "Jaafar Tribak" but I havent heard back from him. So I am hoping someone else that understands coding better than me can actually explain why I cant get this to work. Here is where i got the code from. https://www.mrexcel.com/board/threads/tooltip-and-macro-on-a-shape-in-excel-vba.442147/page-3#post-5524771

I understand it to opertate like this: Normally the if a screentip was added to a shape with a macro the screentip would work but the macro wouldnt because the hyperlink takes precedence with the click event so the macro never triggers. This code puts the screentip to the commandbar event and allows the button click to trigger the macro. with my code the screentip does show but the button click event doesnt trigger or it doesnt start my macro anyway.

This is the code and all of this pertains to the workbook module.

    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
    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, 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

回答1:

You could consider using an approach where you use the hyperlink to call the macro, instead of assigning a separate macro to the onAction of the shape.

Here's a quick example:

Sub Tester()
    'set up some buttons
    With ActiveSheet
        AddMacroAndPopUp .Shapes("Rectangle 1"), "Test1", "popup 1"
        AddMacroAndPopUp .Shapes("Rectangle 2"), "Test2", "popup 2"
    End With
End Sub

'utility sub to configure a shape with a link and some pop-up text
Sub AddMacroAndPopUp(shp As Shape, macroName, txt As String)
    Dim ws As Worksheet
    shp.Parent.Hyperlinks.Add Anchor:=shp, Address:="#" & macroName & "()", ScreenTip:=txt
End Sub

'Example functions called from hyperlinks
'**************************************************
Function Test1()
    Debug.Print "Test1"
    Range("A1") = Now      'do something here
    Set Test1 = Selection  '<< must return a "destination" for the link,
                           '      in this case the clicked shape
End Function

'called from hyperlink
Function Test2()
    Debug.Print "Test2"
    Range("A2") = Now      'do something here
    Set Test2 = Selection
End Function
'**************************************************

来源：https://stackoverflow.com/questions/63058747/vba-run-macro-and-screen-tip-or-tool-tip-from-shape-i-cannot-get-the-code-i-f

标签

excel

vba

hyperlink

tooltip