如何利用Worksheet_FollowHyperlink事件识别带超链接的形状点击？

问题分析 #

Excel里单元格/文本超链接和形状上的超链接分属不同对象体系：

• 文本超链接点击会触发Worksheet_FollowHyperlink事件
• 形状上的超链接点击仅执行跳转，不会触发该事件，这就是你遇到的核心问题。

可行解决方案（保留ScreenTip的前提下） #

方案1：利用Worksheet_SelectionChange结合超链接目标 #

你的形状超链接都指向A1，点击后会选中A1，可通过以下代码识别点击的形状：

1. 在工作表模块中添加代码：

Private lastRange As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 判断是否跳转到A1
    If Target.Address = "$A$1" Then
        Dim clickedShape As Shape
        Set clickedShape = GetClickedShape()
        
        If Not clickedShape Is Nothing Then
            ' 根据形状名称执行对应操作
            Select Case clickedShape.Name
                Case "RemoveButton"
                    Debug.Print "点击了RemoveButton"
                    ' 此处添加Remove逻辑
                Case "AddButton"
                    Debug.Print "点击了AddButton"
                    ' 此处添加Add逻辑
            End Select
        End If
    End If
    Set lastRange = Target
End Sub

2. 添加标准模块，放入API代码捕获点击的形状：

Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Type POINTAPI
    x As Long
    y As Long
End Type

Function GetClickedShape() As Shape
    Dim p As POINTAPI
    Dim hwnd As LongPtr
    Dim className As String * 256
    Dim ws As Worksheet
    Dim shp As Shape
    
    GetCursorPos p
    hwnd = WindowFromPoint(p.x, p.y)
    GetClassName hwnd, className, 256
    
    If Left(className, 7) = "EXCEL7" Then
        Set ws = ActiveSheet
        For Each shp In ws.Shapes
            ' 根据你的按钮形状类型调整判断条件
            If shp.Type = msoShapeRectangle Or shp.Type = msoShapeRoundedRectangle Then
                If p.x >= shp.Left And p.x <= shp.Left + shp.Width And _
                   p.y >= shp.Top And p.y <= shp.Top + shp.Height Then
                    Set GetClickedShape = shp
                    Exit Function
                End If
            End If
        Next shp
    End If
End Function

方案2：用类模块捕获形状MouseDown事件 #

这种方法更直接，无需依赖跳转目标，同时保留超链接ScreenTip：

1. 插入类模块，命名为ShapeClickHandler，添加代码：

Public WithEvents btnShape As Shape

Private Sub btnShape_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    ' 识别点击的形状并执行操作
    Select Case btnShape.Name
        Case "RemoveButton"
            Debug.Print "点击了RemoveButton"
            ' 执行Remove操作
        Case "AddButton"
            Debug.Print "点击了AddButton"
            ' 执行Add操作
    End Select
    ' 手动触发超链接跳转（事件捕获会拦截自动跳转）
    ThisWorkbook.FollowHyperlink Address:=btnShape.Hyperlink.Address, SubAddress:=btnShape.Hyperlink.SubAddress
End Sub

2. 在工作表模块中添加初始化代码：

Private shapeHandlers As Collection

Private Sub Worksheet_Activate()
    Dim handler As ShapeClickHandler
    Dim shp As Shape
    
    Set shapeHandlers = New Collection
    
    ' 为目标按钮绑定事件监听
    For Each shp In Me.Shapes
        If shp.Name = "RemoveButton" Or shp.Name = "AddButton" Then
            Set handler = New ShapeClickHandler
            Set handler.btnShape = shp
            shapeHandlers.Add handler
        End If
    Next shp
End Sub

Private Sub Worksheet_Deactivate()
    ' 清理事件监听
    Set shapeHandlers = Nothing
End Sub

注意事项 #

• 方案1的API代码兼容64位Excel，32位版本需移除PtrSafe关键字。
• 方案2中必须手动调用FollowHyperlink，否则捕获MouseDown事件后超链接不会自动跳转。

内容的提问来源于stack exchange，提问作者OMG Reptar