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

Question

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

我有一个函数，用于将字符串发送到 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

Run Code Online (Sandbox Code Playgroud)

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

VBA 编辑器：??
微软字：?? （被盒子包围）
Notepad++：xEF xBF xBF xEF xBF xBF（黑框包围的白色文本）

我从 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

Run Code Online (Sandbox Code Playgroud)

我确实让这个方法起作用了，但是窗口弹出了一秒钟，它在最后放了一个新行字符，这并不完全理想，而且它需要与 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

Run Code Online (Sandbox Code Playgroud)

最后，我通过远程桌面连接管理器在另一台 Windows 7 机器上运行了前两个功能，它成功运行并成功更改了我的 Windows 10 机器上的剪贴板。

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

Answer 1

Loc*_*min 5

感谢我的问题下的评论，我发现错误是将我的变量声明为 Long 而不是 LongPtr。如果我的第一种方法“TextToClipboard”由于我的 office 实例是 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

Run Code Online (Sandbox Code Playgroud)

没有立即编译，但我在以下内容中发现了一个额外的逗号： Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat, As Long, ByVal hMem As Long) As Long 就在 wFormat 之后。把它拿出来，一切都很好 - 主要节省时间 - 谢谢 (2认同)

归档时间：	9 年，7 月前
查看次数：	15644 次
最近记录：	4 年，3 月前