Excel 2013 64位VBA：剪贴板API不'；行不通

我过去能够在Excel VBA中使用Windows API调用来设置剪贴板上的文本。但自从升级到64位Office 2013后，我就不能了。下面是一些没有错误的代码，但它也没有在剪贴板上设置任何文本。有人能帮我测试和排除故障吗

将下面的代码粘贴到VBA中的代码模块后，您可以在即时窗口中通过键入

Clipboard\u SetData（“将其复制到剪贴板”）

对其进行测试，并且它应该在剪贴板上设置该文本，您可以将其粘贴到任何其他应用程序中

（我使用的是Windows 8，因此无法使用Microsoft窗体或数据对象来操作剪贴板。它在Windows 8上无法正常工作。）

更新和编辑：下面的代码已经更正，现在可以在64位Excel中正常工作，这要感谢Jason Kurtz下面的回答。如果你觉得这有用，请投票支持他的答案

Option Explicit

'Found 64-bit API declarations here: http://spreadsheet1.com/uploads/3/0/6/6/3066620/win32api_ptrsafe.txt
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr

Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096

Sub ClipBoard_SetData(MyString As String)
'32-bit code by Microsoft: http://msdn.microsoft.com/en-us/library/office/ff192913.aspx
    Dim hGlobalMemory As LongPtr, lpGlobalMemory As LongPtr
    Dim hClipMemory As LongPtr, X As Long

    ' Allocate moveable global memory.
    hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)

    ' Lock the block to get a far pointer to this memory.
    lpGlobalMemory = GlobalLock(hGlobalMemory)

    ' Copy the string to this global memory.
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)

    ' Unlock the memory.
    If GlobalUnlock(hGlobalMemory) <> 0 Then
       MsgBox "Could not unlock memory location. Copy aborted."
       'Debug.Print "GlobalFree returned: " & CStr(GlobalFree(hGlobalMemory))
       GoTo OutOfHere
    End If

    ' Open the Clipboard to copy data to.
    If OpenClipboard(0&) = 0 Then
       MsgBox "Could not open the Clipboard. Copy aborted."
       Exit Sub
    End If

    ' Clear the Clipboard.
    X = EmptyClipboard()

    ' Copy the data to the Clipboard.
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)

OutOfHere:
    If CloseClipboard() = 0 Then
       MsgBox "Could not close Clipboard."
    End If
End Sub

选项显式
'在此处找到64位API声明：http://spreadsheet1.com/uploads/3/0/6/6/3066620/win32api_ptrsafe.txt
私有声明PtrSafe函数GlobalAlloc Lib“kernel32”（ByVal wFlags为Long，ByVal dwBytes为LongPtr）为LongPtr
私有将PtrSafe函数GlobalFree Lib“kernel32”（ByVal hMem作为LongPtr）声明为LongPtr
私有将PtrSafe函数GlobalLock Lib“kernel32”（ByVal hMem作为LongPtr）声明为LongPtr
私有声明PtrSafe函数GlobalSize Lib“kernel32”（ByVal hMem作为LongPtr）作为LongPtr
私有声明PtrSafe函数GlobalUnlock Lib“kernel32”（ByVal hMem作为LongPtr）为Long
私有声明PtrSafe函数OpenClipboard Lib“user32”（ByVal hwnd作为LongPtr）作为Long
私有声明PtrSafe函数CloseClipboard Lib“user32”（长度为
私有声明PtrSafe函数emptycipboard Lib“user32”（长度为
私有声明PtrSafe函数SetClipboardData Lib“user32”（ByVal wFormat为Long，ByVal hMem为LongPtr）为LongPtr
私有声明PtrSafe函数GetClipboardData Lib“user32”（ByVal wFormat As Long）为LongPtr
私有将PtrSafe函数lstrcpy Lib“kernel32”（ByVal lpString1作为任意项，ByVal lpString2作为任意项）声明为LongPtr
私有常量GMEM_MOVEABLE=&H2
私有常量GMEM_zeronit=&H40
Private Const GHND=（GMEM_MOVEABLE或GMEM_zeronit）
公共常数CF_TEXT=1
公共常量MAXSIZE=4096
子剪贴板_SetData（MyString作为字符串）
“Microsoft提供的32位代码：http://msdn.microsoft.com/en-us/library/office/ff192913.aspx
Dim hGlobalMemory作为LongPtr，lpGlobalMemory作为LongPtr
Dim hClipMemory作为LongPtr，X作为Long
'分配可移动全局内存。
hGlobalMemory=GlobalAlloc（GHND，Len（MyString）+1）
'锁定块以获取指向此内存的远指针。
lpGlobalMemory=GlobalLock（hGlobalMemory）
'将字符串复制到此全局内存。
lpGlobalMemory=lstrcpy（lpGlobalMemory，MyString）
'解锁内存。
如果GlobalUnlock（hGlobalMemory）为0，则
MsgBox“无法解锁内存位置。复制已中止。”
'Debug.Print“GlobalFree返回：”&CStr（GlobalFree（hGlobalMemory））
离开这里
如果结束
'打开剪贴板将数据复制到其中。
如果OpenClipboard（0&）=0，则
MsgBox“无法打开剪贴板。复制已中止。”
出口接头
如果结束
'清除剪贴板。
X=清空电路板（）
'将数据复制到剪贴板。
hClipMemory=SetClipboardData（CF_TEXT，hGlobalMemory）
离开这里：
如果CloseClipboard（）=0，则
MsgBox“无法关闭剪贴板。”
如果结束
端接头

完全按照如下所示使用代码：

除了在声明之后为所有API声明插入PtrSafe

代码本身应该在一个模块中

像这样：

Option Explicit

Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _
   As Long
Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
   As Long
Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
   ByVal dwBytes As Long) As Long
Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _
   As Long
Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
   ByVal lpString2 As Any) As Long
Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat _
   As Long, ByVal hMem As Long) As Long

Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096

Function ClipBoard_SetData(MyString As String)
   Dim hGlobalMemory As Long, lpGlobalMemory As Long
   Dim hClipMemory As Long, X As Long

   ' Allocate moveable global memory.
   '-------------------------------------------
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)

   ' Lock the block to get a far pointer
   ' to this memory.
   lpGlobalMemory = GlobalLock(hGlobalMemory)

   ' Copy the string to this global memory.
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)

   ' Unlock the memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo OutOfHere2
   End If

   ' Open the Clipboard to copy data to.
   If OpenClipboard(0&) = 0 Then
      MsgBox "Could not open the Clipboard. Copy aborted."
      Exit Function
   End If

   ' Clear the Clipboard.
   X = EmptyClipboard()

   ' Copy the data to the Clipboard.
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)

OutOfHere2:

   If CloseClipboard() = 0 Then
      MsgBox "Could not close Clipboard."
   End If

   End Function

选项显式
声明PtrSafe函数GlobalUnlock Lib“kernel32”（ByVal hMem为Long）_
只要
声明PtrSafe函数GlobalLock Lib“kernel32”（ByVal hMem为Long）_
只要
声明PtrSafe函数GlobalAlloc Lib“kernel32”（ByVal wFlags As Long_
ByVal dwBytes的长度）的长度
将PtrSafe函数CloseClipboard Lib“User32”（）声明为
声明PtrSafe函数OpenClipboard Lib“User32”（ByVal hwnd尽可能长）_
只要
将PtrSafe函数EmptyClipboard Lib“User32”（）声明为
声明PtrSafe函数lstrcpy Lib“kernel32”（ByVal lpString1为Any_
ByVal lpString2（如有）长度相同
声明PtrSafe函数SetClipboardData库“User32”（ByVal wFormat_
一样长，再见，嗯，一样长）一样长
公用工程GHND=&H42
公共常数CF_TEXT=1
公共常量MAXSIZE=4096
函数剪贴板_SetData（MyString作为字符串）
Dim hGlobalMemory尽可能长，lpGlobalMemory尽可能长
内存长度为，X长度为
'分配可移动全局内存。
'-------------------------------------------
hGlobalMemory=GlobalAlloc（GHND，Len（MyString）+1）
'锁定块以获取远指针
“为了这段记忆。
lpGlobalMemory=GlobalLock（hGlobalMemory）
'将字符串复制到此全局内存。
lpGlobalMemory=lstrcpy（lpGlobalMemory，MyString）
'解锁内存。
如果GlobalUnlock（hGlobalMemory）为0，则
MsgBox“无法解锁内存位置。复制已中止。”
跳出去
如果结束
'打开剪贴板将数据复制到其中。
如果OpenClipboard（0&）=0，则
MsgBox“无法打开剪贴板。复制已中止。”
退出功能
如果结束
'清除剪贴板。
X=清空电路板（）
'将数据复制到剪贴板。
hClipMemory=SetClipboardData（CF_TEXT，hGlobalMemory）
第2部分：
如果CloseClipboard（）=0，则
MsgBox“无法关闭剪贴板。”
如果结束
端函数

好的，我现在拿到了

您需要更改代码版本中的此行：

Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As String) As LongPtr

为此：

Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr

如果您按原样逐步浏览代码，您将看到在调用lstrcopy时lpGlobalMemory的值会发生变化。当类型更改为“任意”时，值保持不变

在Windows7上为我工作。希望它对你有用

Posti

 'http://stackoverflow.com/questions/14738330/office-2013-excel-putinclipboard-is-different
Option Explicit
#If VBA7 Then
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
    Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
    Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
    Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
    Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
#Else
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function CloseClipboard Lib "User32" () As Long
    Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "User32" () As Long
    Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
#End If

Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096

Function ClipBoard_SetData(MyString As String)
   #If VBA7 Then
      Dim hGlobalMemory As LongPtr, lpGlobalMemory As LongPtr, hClipMemory As LongPtr
   #Else
      Dim hGlobalMemory As Long, lpGlobalMemory As Long, hClipMemory As Long
   #End If
   Dim x As Long
   ' Allocate moveable global memory.
   '-------------------------------------------
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)

   ' Lock the block to get a far pointer
   ' to this memory.
   lpGlobalMemory = GlobalLock(hGlobalMemory)

   ' Copy the string to this global memory.
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)

   ' Unlock the memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted. Please contact 14Fathoms."
      GoTo OutOfHere2
   End If

   ' Open the Clipboard to copy data to.
   If OpenClipboard(0&) = 0 Then
      MsgBox "Could not open the Clipboard. Copy aborted. Please contact 14Fathoms."
      Exit Function
   End If

   ' Clear the Clipboard.
   x = EmptyClipboard()

   ' Copy the data to the Clipboard.
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)

OutOfHere2:

   If CloseClipboard() = 0 Then
      MsgBox "Could not close Clipboard. Please contact 14Fathoms."
   End If

End Function
Sub TestCOPYPASTE()
    Call ClipBoard_SetData("Hello World " & now())
    'Open notepad or in the immediate window and hit control-v
End Sub