文章/答案/技术大牛

发布

社区首页 >问答首页 >VBA运行宏和屏幕提示(或工具提示)从形状。我找不到我找到的代码

问VBA运行宏和屏幕提示(或工具提示)从形状。我找不到我找到的代码
EN

Stack Overflow用户

提问于 2020-07-23 16:19:12

回答 1查看 1.7K关注 0票数 1

我使用自定义按钮(形状)作为按钮，我想使用我找到的这段代码，但我无法让它正确工作，我不知道为什么。目标是向形状和宏中添加屏幕提示。通常情况下，这是行不通的。只有一种或另一种会起作用，但两者都不起作用。

-请不要让我插入Activex控件。我知道鼠标移动事件。我确实试过这样做，但效果很差.--

如果有人能帮助我理解我做错了什么，那么附加的方法将是完美的。我在一个论坛上发现了这种方法，我给提交人"Jaafar Tribak“发了短信，但我没有收到他的回信。因此，我希望其他比我更了解编码的人能够真正解释为什么我不能让它发挥作用。这是我得到密码的地方。https://www.mrexcel.com/board/threads/tooltip-and-macro-on-a-shape-in-excel-vba.442147/page-3#post-5524771

我理解这样操作:通常情况下，如果screentip被添加到带有宏的形状中，screentip会工作，但是宏不会工作，因为超链接优先于click事件，因此宏永远不会触发。此代码将屏幕提示放到命令栏事件中，并允许单击按钮触发宏。使用我的代码，屏幕提示显示，但按钮单击事件没有触发或它没有启动我的宏无论如何。

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

    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

tooltip

excel

vba

hyperlink

回答 1

Stack Overflow用户

发布于 2020-07-23 16:41:58

您可以考虑使用一种方法，使用超链接来调用宏，而不是将单独的宏分配给形状的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
'**************************************************

票数 5

页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持

原文链接：

https://stackoverflow.com/questions/63058747

复制

相似问题

问VBA运行宏和屏幕提示(或工具提示)从形状。我找不到我找到的代码
EN

回答 1

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问VBA运行宏和屏幕提示(或工具提示)从形状。我找不到我找到的代码EN

回答 1

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问VBA运行宏和屏幕提示(或工具提示)从形状。我找不到我找到的代码
EN