点击超链接复制到剪贴板：现有VBA代码无效求助

嘿，我来帮你搞定这个超链接复制到剪贴板的问题！你用MSForms.DataObject的方法失败，大概率是这个对象在Excel环境里的兼容性问题——哪怕你已经引用了库，不同Office版本或者后台运行场景下它经常掉链子。

先给你分析下现有代码可能的坑：

• 第一段代码用Selection，如果选中的是多个单元格，或者选中区域里的超链接不是第一个，Selection.Hyperlinks(1)可能取不到正确的地址，甚至直接报错（但你说剪贴板为空，可能是没报错但实际没拿到值）；
• 第二段代码虽然加了读取剪贴板的测试，但如果DataObject本身没正确写入，那返回空也正常，这是Forms对象的老毛病了。

给你换个更靠谱的方案——用Windows API直接操作剪贴板，稳定性拉满，兼容32位和64位Excel：

#If VBA7 Then
    Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
    Declare PtrSafe Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
    Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal uFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long
    Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr
#Else
    Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "user32.dll" () As Long
    Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Declare Function CloseClipboard Lib "user32.dll" () As Long
    Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
#End If

Const CF_UNICODETEXT As Long = 13
Const GMEM_MOVEABLE As Long = &H2
Const GMEM_ZEROINIT As Long = &H40

Sub CopyHyperlinkToClipboard()
    Dim linkURL As String
    Dim hGlobal As LongPtr
    Dim lpGlobal As LongPtr
    
    ' 先检查当前单元格有没有超链接，避免报错
    If ActiveCell.Hyperlinks.Count = 0 Then
        MsgBox "当前选中的单元格没有超链接哦！", vbExclamation
        Exit Sub
    End If
    
    ' 获取超链接地址
    linkURL = ActiveCell.Hyperlinks(1).Address
    
    ' 打开系统剪贴板
    If OpenClipboard(0&) = 0 Then
        MsgBox "无法打开剪贴板！", vbCritical
        Exit Sub
    End If
    
    ' 清空剪贴板原有内容
    EmptyClipboard
    
    ' 分配内存存储链接文本（Unicode格式）
    hGlobal = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(linkURL) * 2 + 2)
    If hGlobal = 0 Then
        CloseClipboard
        MsgBox "内存分配失败！", vbCritical
        Exit Sub
    End If
    
    ' 锁定内存并复制文本到内存块
    lpGlobal = GlobalLock(hGlobal)
    lstrcpy lpGlobal, StrPtr(linkURL)
    GlobalUnlock hGlobal
    
    ' 将内存块内容放入剪贴板
    SetClipboardData CF_UNICODETEXT, hGlobal
    
    ' 关闭剪贴板
    CloseClipboard
    
    MsgBox "超链接地址已复制到剪贴板：" & linkURL, vbInformation
End Sub

使用说明： #

1. 把这段代码粘贴到你的VBA模块里；
2. 选中包含超链接的单元格，运行这个宏就行；
3. 代码里加了检查逻辑，会提示你有没有选中带超链接的单元格，避免踩坑。

为什么这个方法比Forms对象靠谱？因为它直接调用Windows系统API操作剪贴板，不依赖Office的Forms库，几乎不会出现“写不进剪贴板”的问题。

内容的提问来源于stack exchange，提问作者João Alves