簡體   English   中英

VBA Windows 10 問題中的文本到剪貼板

[英]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,現在當我運行這個功能時,它會吃掉我剪貼板中的所有東西,並用一些垃圾字符替換它。 根據我將它們粘貼到的應用程序,我會得到關於這些字符是什么的不同結果:

  1. VBA 編輯器:??
  2. 微軟字:?? (被盒子包圍)
  3. 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

我確實讓這個方法起作用了,但是窗口彈出了一秒鍾,它在最后放了一個新行字符,這並不完全理想,而且它需要與 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.

 
粵ICP備18138465號  © 2020-2024 STACKOOM.COM