将信息发送到剪贴板 - 旧方法失败 - 新方法

Question

https://learn.microsoft.com/en-us/office/vba/access/Concepts/Windows-API/send-information-to-the-clipboard

将代码重新格式化为 ptrsafe，但出现错误：StrPtr(( 实际上是 LongLong- 但在任何一个地方更改它都不会将数据推送到剪贴板......

具有推送功能的 OUTLOOK 和 EXCEL 中的问题。

建议？

Attribute VB_Name = "MyClipboardAPI"
''https://learn.microsoft.com/en-us/office/vba/access/Concepts/Windows-API/send-information-to-the-clipboard
Option Explicit
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Public Sub PushToClipboardAPI(sUniText As String)
Dim iStrPtr As Long
Dim iLen As Long
Dim iLock As Long
Const GMEM_MOVEABLE As Long = &H2
Const GMEM_ZEROINIT As Long = &H40
Const CF_UNICODETEXT As Long = &HD
OpenClipboard 0&
EmptyClipboard
iLen = LenB(sUniText) + 2&
iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
iLock = GlobalLock(iStrPtr)
lstrcpy iLock, StrPtr(sUniText)
GlobalUnlock iStrPtr
SetClipboardData CF_UNICODETEXT, iStrPtr
CloseClipboard
End Sub
Public Function GetClipboard() As String
Dim iStrPtr As Long
Dim iLen As Long
Dim iLock As Long
Dim sUniText As String
Const CF_UNICODETEXT As Long = 13&
OpenClipboard 0&
If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
iStrPtr = GetClipboardData(CF_UNICODETEXT)
If iStrPtr Then
iLock = GlobalLock(iStrPtr)
iLen = GlobalSize(iStrPtr)
sUniText = String$(iLen  2& - 1&, vbNullChar)
lstrcpy StrPtr(sUniText), iLock
GlobalUnlock iStrPtr
End If
GetClipboard = sUniText
End If
CloseClipboard

结束功能

Answer 1

来自： https://social.msdn.microsoft.com/Forums/en-US/48e8c30c-24ee-458e-a873-a4e6e13f5926/dataobject-settext-and-putinclipboard-sequence-puts-invalid-data-hex-63-characters-in-clipboard?forum=isvvba

修改 - 4行代码到longptr类型：

''https://learn.microsoft.com/en-us/office/vba/access/Concepts/Windows-API/send-information-to-the-clipboard
Option Explicit
Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "User32" () As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr

Public Sub PushToClipboardAPI(sUniText As String)
Dim iStrPtr As LongPtr
Dim iLock As LongPtr
Dim iLen As Long
Const GMEM_MOVEABLE As Long = &H2
Const GMEM_ZEROINIT As Long = &H40
Const CF_UNICODETEXT As Long = &HD
OpenClipboard 0&
EmptyClipboard
iLen = LenB(sUniText) + 2&
iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
iLock = GlobalLock(iStrPtr)
Dim spv As LongLong
spv = StrPtr(sUniText)
lstrcpy iLock, spv
GlobalUnlock iStrPtr
SetClipboardData CF_UNICODETEXT, iStrPtr
CloseClipboard
End Sub
Public Function GetClipboard() As String
Dim iStrPtr As LongPtr
Dim iLock As LongPtr
Dim iLen As Long
Dim sUniText As String
Const CF_UNICODETEXT As Long = 13&
OpenClipboard 0&
If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
iStrPtr = GetClipboardData(CF_UNICODETEXT)
If iStrPtr Then
iLock = GlobalLock(iStrPtr)
iLen = GlobalSize(iStrPtr)
sUniText = String$(iLen  2& - 1&, vbNullChar)
lstrcpy StrPtr(sUniText), iLock
GlobalUnlock iStrPtr
End If
GetClipboard = sUniText
End If
CloseClipboard
End Function

Answer 2

我只是在研究参考 Excel/VBA 的 Windows 剪贴板 API 时遇到了这个问题。请注意，上面 Apsis0215 帖子中的函数定义仍然是错误的！它们可能在技术上适用于 Win64，但它们不正确。

首先，OpenClipboard()、EmptyClipboard()、CloseClipboard()、IsClipboardFormatAvailable()、GlobalUnlock()都返回一个BOOL数据类型(最终定义为 32 位的"有符号 int"。他们不是指针！因此，它们不应该用As LongPtr来定义，而应该用As Long来定义，即使在Vba7和/或Win64中也是如此。(顺便说一下，也不是As Boolean，因为 VBA 中的布尔数据类型只有 16 位(。

其次，所有函数中的所有wFormat参数都需要UINT数据类型(32 位"无符号 int"(。因此应该用As Long定义，即使在 Vba7 和/或 Win64 上也是如此！

第三，函数GlobalAlloc()的dwBytes参数具有数据类型SIZE_T，这意味着必须用As LongPtr而不是As Long来声明。函数GlobalSize()的返回数据类型也是如此，这也是数据类型SIZE_T，因此也应该As LongPtr。

请参阅官方 Windows API 参考和 VBA 参考。

Private Declare PtrSafe Function OpenClipboard Lib "USER32.DLL" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "USER32.DLL" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "USER32.DLL" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "USER32.DLL" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "USER32.DLL" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "USER32.DLL" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "KERNEL32.DLL" (ByVal uFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "KERNEL32.DLL" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "KERNEL32.DLL" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function GlobalSize Lib "KERNEL32.DLL" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function lstrcpy Lib "KERNEL32.DLL" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr