5

I have a function that I use to send a string to the windows clipboard:

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

I recently upgraded my machine to Windows 10 and now when I run this function it eats everything in my clipboard and replaces it with a few garbage characters. I get different results on what these characters are depending on the application I paste them into:

  1. VBA Editor: ??
  2. Microsoft Word: ?? (surrounded by boxes)
  3. Notepad++: xEF xBF xBF xEF xBF xBF (white text surrounded by black boxes)

I took code from MSDN to use the Windows API (I made my functions PtrSafe as you'll see below) and the "GlobalUnlock" function returns '1' so I guess it can't allocate the memory correctly.

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

I did get this method to work, but the window pops up for a second and it puts a new line character at the end which isn't exactly ideal, plus it would require having a connection with Excel for the wait function. Not terrible either I guess. 

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

Finally, I ran first two functions on another Windows 7 machine via Remote Desktop Connection Manager and it successfully ran and changed the clipboard on my Windows 10 machine successfully.

So I'm not sure if doing the upgrade to Windows 10 messed with these libraries or the clipboard is different somehow. Is there any way for me to get these working again? Maybe someone else with Windows 10 and Office won't have the issue at all and it's just my machine?

Improve this question
8
  • 2
    Functions declared as PtrSafe should use LongPtr for pointers and handles, not Longs. hmem and hwnd would be examples. Commented Feb 15, 2016 at 18:56
  • @GSerg beat me to it there, but also your conditional complication is only checking for VBA7 - are you actually using 32-bit or 64-bit? I would use the Win64 constant also to be sure Commented Feb 15, 2016 at 22:14
  • @GSerg Thank you, that was the problem. I'm sure you are aware that implicitly converting a LongPtr to Long causes a type mismatch in the ClipBoard_SetData method. I'm thinking the best thing to do is declare each variable as Variants, if you have any ideas on that I'd love to hear it. Thanks for the help! If you submit this as an answer I'll mark it as what solved my issue unless it would be more proper for me to submit the answer myself. Thanks again! Commented Feb 16, 2016 at 13:31
  • @MacroMan Thanks for the tip on Win64! I am using Office 2016, 64-bit. The computer I moved from was actually running Office 2013 32-bit before so that could also account for why I hadn't had issues until now. I had taken that conditional from another post but I always kind of wondered if that was most correct or not. Also if you see my question to GSerg about making the variables Variants or not I'd love to get your opinion on that too. Commented Feb 16, 2016 at 13:36
  • @LockeGarmin If you use the Win64 constant then you can ensure that LongPtr is only used when running on a 64-bit version, which should prevent any errors as there is no conversion to Long required. I doubt you are using VBA6 so I would suggest replacing VBA7 with Win64 and see if that helps. Commented Feb 16, 2016 at 13:39

8 Answers 8

Reset to default
6

Thanks to the comments under my question I figured out the error was declaring my variables as Long instead of LongPtr. It's still not 100% clear if my first method "TextToClipboard" is failing because of my office instance being 64-bit, but the second method seems to overcome that fine. If anyone else is interested here is the code I modified to read and write to the clipboard that shouldn't be affected by 64 or 32-bit versions of office. My modifications also included getting all of the text even if it's longer than 4096 characters.

For context I'm putting this in a module called 'mClipboard' so that when I call these methods I use '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
Improve this answer
Sign up to request clarification or add additional context in comments.

1 Comment

DIdn't compile right away but I found a extra comma in the: Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat, As Long, ByVal hMem As Long) As Long right after the wFormat. Took that out and all works great - major timesaver - thanks
3

Had same issue Windows 10 x64 and Office Excel 2016 x64.

Finally I was able to copy Cell's string value to Windows API Clipboard :)

Code:

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
Improve this answer

Comments

3

Refined @Unicco's answer, which supports Unicode well.

  • Declare
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
  • SetClipboard
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
  • GetClipboard
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
Improve this answer

1 Comment

I do confirm that this porting from MS 32bits to 64 bits that Steven Yang implemented is fully functional; I had the same issue with MSForms.DataObject at WIndows 10 64bits and Word & Outlook, both 64 bits.
1

These answers dosen't work for me, and I think they are kinda overkill.

The following code works @ 64-bit Windows 10 & 64-bit Office Excel 2016

Usage:

Call SetClipboard("Clipboard this text")

Insert below code to some VBA-module

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

Source: https://msdn.microsoft.com/en-us/library/office/ff192913.aspx

Officially developed by Chris Macro

Improve this answer

2 Comments

your code did not work at 64bit, it will need ptrsafe keyword
Unicco, @EricK. is right; yours only function at 32 bit; it will not even compile at 64 bits; remove it before someone negatives it.
1

A other solution here is proposed by Excel Hero. It is a solution that does not use MS Forms nor the Win32 API. Instead it uses the Microsoft HTML Object Library

Works great for me.

Improve this answer

Comments

0

Found this answer on reddit just in case someone needs help.

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
Improve this answer

Comments

0

Win10 broke MSForms.DataObject; that's why the approach that works on Win7/32 or Win7/64 don't work now. Thank you, Khang Huynh, for a simple and elegant mod to the original macro.

I suggest a couple of tweaks:

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
Improve this answer

Comments

0

I was having similar problems after moving to a new machine but it was solved by repointing to the microsoft forms dll. the data objects object (and simplified brief code posted by a few people towards the bottom here) will still work.

Go to references and add the microsoft forms 2.0 object library reference. if it is not shown click browse and select fm20.dll in the \system32 folder.

Improve this answer

Comments

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.