VBA 从形状运行宏和屏幕提示（或工具提示）。我无法获得我发现工作的代码
Posted
技术标签:
【中文标题】VBA 从形状运行宏和屏幕提示（或工具提示）。我无法获得我发现工作的代码【英文标题】：VBA Run Macro and Screen Tip (or Tool Tip) From Shape. I cannot get the code I found to work 【发布时间】：2020-11-13 10:40:18 【问题描述】：我使用自定义按钮（形状）作为按钮，我想使用我找到的这段代码，但我无法让它正常工作，我不知道为什么。目标是向形状和宏添加屏幕提示。通常这不起作用。只有一个或另一个可以工作，但不能同时工作。
--- 请不要让我插入 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
【问题讨论】：
【参考方案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
'**************************************************
【讨论】：
@蒂姆·威廉姆斯。这看起来会奏效。当我单击按钮运行宏时，我已经加载了您的代码，但出现错误 - “引用无效” 我插入了宏名称以替换您的 Test1 和 Test2 函数所在的位置。我将此代码放在标准模块中，我应该在工作簿模块“工作表激活”事件或任何事件更改中使用它，或者您将代码放在哪里？ 超链接调用的方法必须是函数，并且它们需要返回链接导航到的目标：我使用（例如）设置Test1 = Selection，这对我来说很好。所有发布的代码都在一个常规代码模块中。
谢谢。我现在遇到的问题可能是由于我的宏是 subs 而不是函数。我不知道我的潜艇是否可以转换，但我希望他们可以，因为我真的很想使用你提供的这段代码。我发布了另一个问题，试图获得一些帮助，将我的潜艇转换为函数here。您介意看看这些 subs 是否可以转换为函数吗？
大多数功能都有效。即使使用 Set FunctionName = Selection 的某些功能也只会显示工具提示，但不会触发宏。不知道为什么。
也许将您的完整代码作为一个新问题发布，并附上此问题的链接？以上是关于VBA 从形状运行宏和屏幕提示（或工具提示）。我无法获得我发现工作的代码的主要内容，如果未能解决你的问题，请参考以下文章