![](/img/trans.png)
[英]Put text to clipboard in the background process on locked Windows 10 machine
[英]Text To Clipboard in VBA Windows 10 Issue
我有一個函數,用於將字符串發送到 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,現在當我運行這個功能時,它會吃掉我剪貼板中的所有東西,並用一些垃圾字符替換它。 根據我將它們粘貼到的應用程序,我會得到關於這些字符是什么的不同結果:
我從 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
最后,我通過 遠程桌面連接管理器在另一台 Windows 7 機器上運行了前兩個功能,它成功運行並成功更改了我的 Windows 10 機器上的剪貼板。
所以我不確定升級到 Windows 10 是否弄亂了這些庫或剪貼板是否有所不同。 有什么辦法可以讓我重新工作嗎? 也許其他使用 Windows 10 和 Office 的人根本不會遇到這個問題,而這只是我的機器?
感謝我的問題下的評論,我發現錯誤是將我的變量聲明為 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
有同樣的問題 Windows 10 x64 和 Office Excel 2016 x64。
最后,我能夠將 Cell 的字符串值復制到 Windows API 剪貼板 :)
代碼:
Option Explicit
#If VBA7 Then
Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As LongPtr
Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As LongPtr
Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function SetClipboardData Lib "user32.dll" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As LongPtr, ByVal dwBytes As LongPtr) As LongPtr
Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr
#Else
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
#End If
Public Sub SetClipboard(sUniText As String)
#If Win64 Then
Dim iStrPtr As LongPtr
Dim iLen As LongPtr
Dim iLock As LongPtr
#Else
Dim iStrPtr As Long
Dim iLen As Long
Dim iLock As Long
#End If
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
改進了@Unicco 的答案,它很好地支持 Unicode。
Option Explicit
#If VBA7 Then
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
#Else
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
#End If
Public Sub SetClipboard(sUniText As String)
#If VBA7 Then
Dim iStrPtr As LongPtr
Dim iLock As LongPtr
#Else
Dim iStrPtr As Long
Dim iLock As Long
#End If
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 + GMEM_ZEROINIT, iLen)
iLock = GlobalLock(iStrPtr)
lstrcpy iLock, StrPtr(sUniText)
GlobalUnlock iStrPtr
SetClipboardData CF_UNICODETEXT, iStrPtr
CloseClipboard
End Sub
Public Function GetClipboard() As String
#If VBA7 Then
Dim iStrPtr As LongPtr
Dim iLock As LongPtr
#Else
Dim iStrPtr As Long
Dim iLock As Long
#End If
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
這些答案對我不起作用,我認為它們有點矯枉過正。
以下代碼適用於 64 位 Windows 10 和 64 位 Office Excel 2016
用法:
Call SetClipboard("Clipboard this text")
將下面的代碼插入一些 VBA 模塊
Option Explicit
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Public Sub SetClipboard(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
End Function
來源: https : //msdn.microsoft.com/en-us/library/office/ff192913.aspx
由 Chris Macro 官方開發
一個其他的解決辦法在這里通過Excel的英雄建議。 這是一個不使用 MS Forms 和 Win32 API 的解決方案。 相反,它使用 Microsoft HTML 對象庫
對我很有用。
在reddit上找到這個答案,以防萬一有人需要幫助。
Option Explicit
Private Sub CopyCellContents()
Dim objData As New DataObject
Dim strTemp As String
strTemp = ActiveSheet.Range("E23").Value
strTemp = Replace(strTemp, Chr(10), vbCrLf)
objData.SetText strTemp
objData.PutInClipboard
End Sub
Win10破解了MSForms.DataObject; 這就是適用於 Win7/32 或 Win7/64 的方法現在不起作用的原因。 感謝 Khang Huynh,為原始宏提供了一個簡單而優雅的 mod。
我建議進行一些調整:
Option Explicit
Private Sub CopyCellContents()
' dimension our vars
Dim objData As New DataObject
' set the contents of the active cell as our data object, removing extraneous spaces and linebreaks
with objData
.SetText Trim(ActiveCell.Text)
' write it to the Clipboard
.PutInClipboard
' just for fun
Application.StatusBar = .GetText
End With
' clean up memory by not leaving object handles open
Set objData = Nothing
End Sub
搬到新機器后,我遇到了類似的問題,但通過重新指向 microsoft forms dll 解決了這個問題。 數據對象對象(以及一些人在底部發布的簡化簡短代碼)仍然可以工作。
轉到引用並添加 microsoft forms 2.0 對象庫引用。 如果未顯示,請單擊瀏覽並選擇 \\system32 文件夾中的 fm20.dll。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.