如何在64位Access 365中将HTML格式字符串复制到剪贴板？

你的代码在64位Access中失效的核心原因是指针类型不匹配和内存分配参数错误，以下是具体修复方案：

关键问题分析 #

1. 64位指针类型错误：原来用Long存储内存句柄和指针，64位系统下指针长度是8字节，Long仅能存储4字节，导致GlobalLock返回的指针被截断，最终返回0。
2. GlobalAlloc参数不正确：剪贴板要求内存块必须是可移动的（GMEM_MOVEABLE标志），你传入的0不满足该要求，导致内存块无法被锁定。
3. 字符串字节数计算错误：VBA字符串是Unicode编码，Len()返回字符数，而内存分配需要按字节数计算，直接用Len(sData)会导致内存不足。
4. EmptyClipboard调用时机错误：应该在分配内存前清空剪贴板，避免残留数据干扰后续操作。

修复后的完整代码 #

Option Explicit

' 64位适配的API声明，使用LongPtr处理指针，替换为Unicode版本API
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatW" (ByVal lpString As String) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cbLength As LongPtr)
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpData As LongPtr) As Long

' 剪贴板HTML格式描述头
Private Const m_sDescription = _
                  "Version:1.0" & vbCrLf & _
                  "StartHTML:aaaaaaaaaa" & vbCrLf & _
                  "EndHTML:bbbbbbbbbb" & vbCrLf & _
                  "StartFragment:cccccccccc" & vbCrLf & _
                  "EndFragment:dddddddddd" & vbCrLf

' 内存分配标志：可移动+初始化
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40

Private m_cfHTMLClipFormat As Long

Function RegisterCF() As Long
   ' 注册HTML剪贴板格式
   If m_cfHTMLClipFormat = 0 Then
      m_cfHTMLClipFormat = RegisterClipboardFormat("HTML Format")
   End If
   RegisterCF = m_cfHTMLClipFormat
End Function

Public Sub PutHTMLClipboard(sHtmlFragment As String, _
   Optional sContextStart As String = "<HTML><BODY>", _
   Optional sContextEnd As String = "</BODY></HTML>")

   Dim sData As String
   Dim hMemHandle As LongPtr, lpData As LongPtr
   Dim byteLength As LongPtr

   If RegisterCF = 0 Then Exit Sub

   ' 拼接HTML片段的前后标记
   sContextStart = sContextStart & "<!--StartFragment -->"
   sContextEnd = "<!--EndFragment -->" & sContextEnd

   ' 构建完整的剪贴板HTML数据，替换偏移量占位符
   sData = m_sDescription & sContextStart & sHtmlFragment & sContextEnd
   sData = Replace(sData, "aaaaaaaaaa", Format(Len(m_sDescription), "0000000000"))
   sData = Replace(sData, "bbbbbbbbbb", Format(Len(sData), "0000000000"))
   sData = Replace(sData, "cccccccccc", Format(Len(m_sDescription & sContextStart), "0000000000"))
   sData = Replace(sData, "dddddddddd", Format(Len(m_sDescription & sContextStart & sHtmlFragment), "0000000000"))

   ' 打开剪贴板并操作
   If CBool(OpenClipboard(0)) Then
      ' 先清空剪贴板
      EmptyClipboard

      ' 计算Unicode字符串的字节数（含双字节终止符）
      byteLength = LenB(sData) + 2

      ' 分配可移动的初始化内存块
      hMemHandle = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, byteLength)

      If CBool(hMemHandle) Then
         lpData = GlobalLock(hMemHandle)
         If lpData <> 0 Then
            ' 将Unicode字符串复制到内存块
            CopyMemory ByVal lpData, ByVal sData, LenB(sData)
            ' 添加双字节终止符
            CopyMemory ByVal (lpData + LenB(sData)), 0&, 2
            GlobalUnlock hMemHandle

            ' 将内存块写入剪贴板
            SetClipboardData m_cfHTMLClipFormat, hMemHandle
         End If
      End If

      CloseClipboard
   End If
End Sub

核心修改说明 #

• 指针类型适配：所有内存句柄（hMemHandle）和指针（lpData）改用LongPtr类型，兼容64位系统的8字节指针长度。
• 内存分配规则修正：使用GMEM_MOVEABLE | GMEM_ZEROINIT标志，确保内存块符合剪贴板的可移动要求。
• 字符串字节数计算：用LenB()获取Unicode字符串的实际字节数，分配足够内存并添加双字节终止符，避免字符串截断。
• API版本优化：将RegisterClipboardFormatA改为RegisterClipboardFormatW（Unicode版本），避免编码转换导致的错误。
• 操作流程调整：打开剪贴板后立即调用EmptyClipboard，确保剪贴板状态干净，避免残留数据干扰。

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