VBA 从形状运行宏和屏幕提示（或工具提示）。我无法获取我发现有效的代码

Question

我使用自定义按钮（形状）作为按钮，我想使用我找到的这段代码，但我无法让它正常工作，我不知道为什么。目标是向形状和宏添加屏幕提示。通常这是行不通的。只有其中之一有效，但不能同时有效。

--- 请不要要求我插入 Activex 控件。我知道鼠标移动事件。我确实尝试过这种方法，它有效，但它非常故障......

如果有人可以帮助我理解我做错了什么，那么附加的方法将是完美的。我在论坛中找到了这个方法，并且给作者“Jaafar Tribak”发了消息，但我还没有收到他的回复。所以我希望其他比我更了解编码的人能够真正解释为什么我无法让它工作。这是我从中获取代码的地方。https://www.mrexcel.com/board/threads/tooltip-and-macro-on-a-shape-in​​-excel-vba.442147/page-3#post-5524771

我理解它是这样操作的：通常，如果将屏幕提示添加到带有宏的形状中，则屏幕提示将起作用，但宏不会，因为超链接优先于单击事件，因此宏永远不会触发。此代码将屏幕提示置于命令栏事件中，并允许单击按钮来触发宏。使用我的代码，屏幕提示确实显示，但按钮单击事件不会触发，或者无论如何也不会启动我的宏。

这是代码，所有这些都与工作簿模块有关。

    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

---

Answer 1

您可以考虑使用使用超链接调用宏的方法，而不是为形状的 onAction 分配单独的宏。

这是一个简单的例子：

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
'**************************************************