vba - VBA Windows 10 问题中的文本到剪贴板

Question

我有一个函数用于将字符串发送到 Windows 剪贴板:

Sub TextToClipboard(ByVal Text As String)

  With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") 'FM20.dll (Microsoft Forms 2.0 Object Library)
    .SetText Text
    .PutInClipboard
  End With

End Sub

我最近将我的机器升级到了 Windows 10，现在当我运行此功能时，它会吃掉我剪贴板中的所有内容并用一些垃圾字符替换它。根据我将这些字符粘贴到的应用程序，我会得到不同的结果:

VBA 编辑器:??

微软字:?? (被方框包围)

Notepad++:xEF xBF xBF xEF xBF xBF(黑框包围的白色文本)

我拿了 code from MSDN使用 Windows API(我创建了我的函数 PtrSafe，如下所示)并且“GlobalUnlock”函数返回“1”，所以我猜它无法正确分配内存。

Option Explicit

#If VBA7 Then

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

#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

Sub 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 Sub
   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 Sub

我确实让这种方法起作用，但是窗口会弹出一秒钟，它会在末尾添加一个换行符，这并不完全理想，而且它需要与 Excel 连接以实现等待功能。我想也不可怕。

Sub SetClipboard(Text As String)

  With CreateObject("WScript.Shell").Exec("clip")
    With .stdIn
      .WriteLine Text
      .Close
    End With

    Do While .Status = 0
        Application.Wait 1
    Loop

  End With

End Sub

最后，我通过 Remote Desktop Connection Manager 在另一台 Windows 7 机器上运行了前两个函数。它成功运行并成功更改了我的 Windows 10 机器上的剪贴板。

所以我不确定升级到 Windows 10 是否会弄乱这些库，或者剪贴板是否有所不同。我有什么办法让这些再次工作？也许其他使用 Windows 10 和 Office 的人根本不会遇到这个问题，而这只是我的机器？

Answer 1

感谢我的问题下的评论，我发现错误是将我的变量声明为 Long 而不是 LongPtr。如果我的第一个方法“TextToClipboard”由于我的办公室实例是 64 位而失败，仍然不是 100% 清楚，但第二种方法似乎克服了这个问题。如果其他人对此感兴趣，我修改的代码可以读取和写入剪贴板，该代码不应受 64 位或 32 位版本的 Office 影响。我的修改还包括获取所有文本，即使它超过 4096 个字符。
对于上下文，我将它放在一个名为“mClipboard”的模块中，以便在调用这些方法时使用“mClipboard.GetText”。

Option Explicit

#If VBA7 Then

Private Declare PtrSafe Function GlobalUnlock 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 GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "User32" () As LongPtr
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 lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr

#Else

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

#End If

Public Sub SetText(Text As String)
#If VBA7 Then
Dim hGlobalMemory As LongPtr
Dim lpGlobalMemory As LongPtr
Dim hClipMemory As LongPtr
#Else

Dim hGlobalMemory As Long
Dim lpGlobalMemory As Long
Dim hClipMemory As Long

#End If

Const GHND = &H42
Const CF_TEXT = 1

   ' Allocate moveable global memory.
   '-------------------------------------------
   hGlobalMemory = GlobalAlloc(GHND, Len(Text) + 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, Text)

   ' Unlock the memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo CloseClipboard
   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.
   Call EmptyClipboard

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

CloseClipboard:

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

Public Property Get GetText()
#If VBA7 Then
Dim hClipMemory As LongPtr
Dim lpClipMemory As LongPtr
#Else

Dim hClipMemory As Long
Dim lpClipMemory As Long
#End If

Dim MaximumSize As Long
Dim ClipText As String

Const CF_TEXT = 1

   If OpenClipboard(0&) = 0 Then
      MsgBox "Cannot open Clipboard. Another app. may have it open"
      Exit Property
   End If
          
   ' Obtain the handle to the global memory block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then
      MsgBox "Could not allocate memory"
      GoTo CloseClipboard
   End If
 
   ' Lock Clipboard memory so we can reference the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
 
   If Not IsNull(lpClipMemory) Then
      MaximumSize = 64
      
      Do
        MaximumSize = MaximumSize * 2
        
        ClipText = Space$(MaximumSize)
        Call lstrcpy(ClipText, lpClipMemory)
        Call GlobalUnlock(hClipMemory)
             
      Loop Until ClipText Like "*" & vbNullChar & "*"
      
      ' Peel off the null terminating character.
      ClipText = Left$(ClipText, InStrRev(ClipText, vbNullChar) - 1)
      
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
 
CloseClipboard:
 
   Call CloseClipboard
   GetText = ClipText
 
End Property