问题
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