"Paste" string variable in excel VBA instead of the contents of clipboard? - excel

I have a string variable that contains an HTML table in excel VBA. I know that when this table is stored in the clipboard and I invoke .PasteSpecial, Excel does some nifty preprocessing and fills the cells out in the current sheet the same way as they appear in the table.
However, if I simply set the .Value of a cell/range to the string variable, no such preprocessing takes place and the entire string, HTML tags and all, are dumped into the cell. I want the former result, but I cannot use the clipboard because it is being used by this application elsewhere and there is no guarantee I would not overwrite critical data. It is also being used asynchronously so I cannot simply save the current contents of the clipboard, use the clipboard, and then restore the previous contents of the clipboard.
So, is there any way to get the "pasting preprocessing" to occur when setting the value for a range with a formatted string?

I would still be curious to know the answer if anyone has it, but I decided to just go ahead and abandon the idea of storing the table in a worksheet. Instead I parse the table myself and find the values I need using the InStr function (as they are mostly adjacent key=value pairs), which is not terribly slow for my application.

I can't think of anyway to invoke Excel's preprocessor without the clipboard. For parsing, you may want to check out the Split function. Here's an example.
Sub ParseTable()
Dim sHtmlTable As String
Dim vaTable As Variant
Dim i As Long
Const STDSTART = "<td"
Const STDEND = "</td"
sHtmlTable = "<table border=""1""><tr><td>row 1, cell 1</td><td>row 1, cell 2</td></tr><tr><td>row 2, cell 1</td><td>row 2, cell 2</td></tr></table>"
vaTable = Split(sHtmlTable, ">")
For i = LBound(vaTable) To UBound(vaTable)
If vaTable(i) = STDSTART Then
Debug.Print Replace(vaTable(i + 1), STDEND, "")
End If
Next i
End Sub

This is just a comment (stackeoverflow doesn't let me comment the propper way yet).
You probably could do it the way you want using some API.
A long time ago I played with it (looking for some way to cheat MS Word) and I remember that you could store any content to the clipboard, as long as you enter the right id of the content type (like pure text, formated text, html, etc). After storing the content, you must use the respective API function to paste, again, the right type of content.
I didn't make progress as fast as I expected, and I was short of time, so I abandoned the idea. If you would like to give it a chance, look up MSDN for the API calls (I don't have it here right now, otherwise I would give you right away).
EDIT: I found the code. All the code below should be kept in a module:
' Clipboard functions:
Private Declare Function OpenClipboard Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "USER32" () As Long
Private Declare Function GetClipboardData Lib "USER32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "USER32" (ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "USER32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
' Memory functions:
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Public Function GetClipboardIDForCustomFormat(ByVal sName As String) As Long
Dim wFormat As Long
wFormat = RegisterClipboardFormat(sName & Chr$(0))
If (wFormat > &HC000&) Then
GetClipboardIDForCustomFormat = wFormat
End If
End Function
Public Function GetClipboardDataAsString(ByVal lFormatID As Long) As String
'Public Function GetClipboardDataAsString(ByVal hWndOwner As Long, ByVal lFormatID As Long) As String
Dim bData() As Byte
Dim hMem As Long
Dim lSize As Long
Dim lPtr As Long
' Open the clipboard for access:
If (OpenClipboard(0&)) Then
' If (OpenClipboard(hWndOwner)) Then
' Check if this data format is available:
If (IsClipboardFormatAvailable(lFormatID) <> 0) Then
' Get the memory handle to the data:
hMem = GetClipboardData(lFormatID)
If (hMem <> 0) Then
' Get the size of this memory block:
lSize = GlobalSize(hMem)
If (lSize > 0) Then
' Get a pointer to the memory:
lPtr = GlobalLock(hMem)
If (lPtr <> 0) Then
' Resize the byte array to hold the data:
ReDim bData(0 To lSize - 1) As Byte
' Copy from the pointer into the array:
CopyMemory bData(0), ByVal lPtr, lSize
' Unlock the memory block:
GlobalUnlock hMem
' Now return the data as a string:
GetClipboardDataAsString = StrConv(bData, vbUnicode)
End If
End If
End If
End If
CloseClipboard
End If
End Function

Related

Excel VBA "Origin" Counterpart of "Target" for Copy and Paste Events [duplicate]

If the Clipboard contains an Excel Worksheet Range, you can access that Range's Data with the DataObject Object
Can you also find the actual Source Range (ie Worksheet, Row & Column) of that Data?
Alternatively, can you find the Last Copied Range, which is indicated with a Dashed Outline Border (NOT the Selected Range)?
Preferably using Excel 2003 VBA
This code is being used in Excel 2019 64 bit to get the range of the cells on the clipboard as opposed to the contents of the cells.
fGetClipRange returns a range object for the Excel range that is cut or copied onto the clipboard, including book and sheet. It reads it directly from the clipboard using the "Link" format, and requires the ID number for this format. The ID associated with the registered formats can change, so fGetFormatId finds the current format ID from a format name. Use Application.CutCopyMode to determine whether the cells were cut or copied.
This site was useful for working with the clipboard in VBA: https://social.msdn.microsoft.com/Forums/office/en-US/ee9e0d28-0f1e-467f-8d1d-1a86b2db2878/a-clipboard-object-for-vba-including-microsoft-word?forum=worddev
Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal lngFormat As Long) As LongPtr
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardFormatNameA Lib "user32" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
'2020-02-11 get excel copy or cut range from clipboard
Function fGetClipRange() As Range
Dim strGetClipRange As String 'return range
Dim lptClipData As LongPtr 'pointer to clipboard data
Dim strClipData As String 'clipboard data
Dim intOffset As Integer 'for parsing clipboard data
Dim lngRangeLink As Long 'clipboard format
Const intMaxSize As Integer = 256 'limit for r1c1 to a1 conversion
lngRangeLink = fGetFormatId("Link") 'we need the id number for link format
If OpenClipboard(0&) = 0 Then GoTo conDone 'could not open clipboard
lptClipData = GetClipboardData(lngRangeLink) 'pointer to clipboard data
If IsNull(lptClipData) Then GoTo conDone 'could not allocate memory
lptClipData = GlobalLock(lptClipData) 'lock clipboard memory so we can reference
If IsNull(lptClipData) Then GoTo conDone 'could not lock clipboard memory
intOffset = 0 'start parsing data
strClipData = Space$(intMaxSize) 'initialize string
Call lstrcpy(strClipData, lptClipData + intOffset) 'copy pointer to string
If strClipData = Space$(intMaxSize) Then GoTo conDone 'not excel range on clipboard
strClipData = Mid(strClipData, 1, InStr(1, strClipData, Chr$(0), 0) - 1) 'trim null character
If strClipData <> "Excel" Then GoTo conDone 'not excel range on clipboard
intOffset = intOffset + 1 + Len(strClipData) 'can't retrieve string past null character
strClipData = Space$(intMaxSize) 'reset string
Call lstrcpy(strClipData, lptClipData + intOffset) 'book and sheet next
strClipData = Mid(strClipData, 1, InStr(1, strClipData, Chr$(0), 0) - 1)
strGetClipRange = "'" & strClipData & "'!" 'get book and sheet
intOffset = intOffset + 1 + Len(strClipData) 'next offset
strClipData = Space$(intMaxSize) 'initialize string
Call lstrcpy(strClipData, lptClipData + intOffset) 'range next
strClipData = Mid(strClipData, 1, InStr(1, strClipData, Chr$(0), 0) - 1)
strGetClipRange = strGetClipRange & strClipData 'add range
strGetClipRange = Application.ConvertFormula(strGetClipRange, xlR1C1, xlA1)
Set fGetClipRange = Range(strGetClipRange) 'range needs a1 style
conDone:
Call GlobalUnlock(lptClipData)
Call CloseClipboard
End Function
'2020-02-11 clipboard format id number changes so get it from format name
Function fGetFormatId(strFormatName As String) As Long
Dim lngFormatId As Long
Dim strFormatRet As String
Dim intLength As Integer
If OpenClipboard(0&) = 0 Then Exit Function 'could not open clipboard
intLength = Len(strFormatName) + 3 'we only need a couple extra to make sure there isn't more
lngFormatId = 0 'start at zero
Do
strFormatRet = Space(intLength) 'initialize string
GetClipboardFormatNameA lngFormatId, strFormatRet, intLength 'get the name for the id
strFormatRet = Trim(strFormatRet) 'trim spaces
If strFormatRet <> "" Then 'if something is left
strFormatRet = Left(strFormatRet, Len(strFormatRet) - 1) 'get rid of terminal character
If strFormatRet = strFormatName Then 'if it matches our name
fGetFormatId = lngFormatId 'this is the id number
Exit Do 'done
End If
End If
lngFormatId = EnumClipboardFormats(lngFormatId) 'get the next used id number
Loop Until lngFormatId = 0 'back at zero after last id number
Call CloseClipboard 'close clipboard
End Function
Not directly, no - the clipboard object seems to only contain the values of the cells (though Excel obviously somehow remembers the border):
Sub testClipborard()
Dim test As String
Dim clipboard As MSForms.DataObject
Set clipboard = New MSForms.DataObject
clipboard.GetFromClipboard
test = clipboard.GetText
MsgBox (test)
End Sub
Note you will need a reference to the Microsoft Forms 2.0 Library to get this to run (and if you don't have values in the cells it will also fail).
That being said, you can try something like the following - add this to a module in the VBA editor.
Public NewRange As String
Public OldRange As String
Public SaveRange As String
Public ChangeRange As Boolean
And use the following in a sheet object
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
'save previous selection
OldRange = NewRange
'get current selection
NewRange = Selection.Address
'check if copy mode has been turned off
If Application.CutCopyMode = False Then
ChangeRange = False
End If
'if copy mode has been turned on, save Old Range
If Application.CutCopyMode = 1 And ChangeRange = False Then
'boolean to hold "SaveRange" address til next copy/paste operation
ChangeRange = True
'Save last clipboard contents range address
SaveRange = OldRange
End If
End Sub
It seemingly works, but, it's also probably fairly prone to different bugs as it is attempting to get around the issues with the clipboard. http://www.ozgrid.com/forum/showthread.php?t=66773
I completely rewrote the previous answer because I needed to get other kinds of data into Excel besides ranges. The new code is more versatile, and gets different formats off the clipboard as strings. Extracting the Excel range ends up being much simpler, and I'm also using it for bitmaps and text.
The last routine gets the number for non-built-in formats. The middle routine gets the clipboard contents as a string for the specified format. The first routine parses the Excel range from this string with the split function.
'https://officeaccelerators.wordpress.com/2013/11/27/reading-data-with-format-from-clipboard/
'https://social.msdn.microsoft.com/Forums/sqlserver/en-US/ee9e0d28-0f1e-467f-8d1d-1a86b2db2878/a-clipboard-object-for-vba-including-microsoft-word?forum=worddev
#If VBA7 And Win64 Then
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongLong) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32.dll" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
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 Long
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
#Else
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cbCopy As Long)
#End If
'test routine displays a message box with the marching ants range
'_2022_10_30
Function fTest_GetClipboardRange()
Dim rngClipboard As Range
Set rngClipboard = fGetClipboardRange
If rngClipboard Is Nothing Then
MsgBox ("No Excel range was found on the clipboard.")
ElseIf Application.CutCopyMode = xlCopy Then 'this is always copy because of sheet add
MsgBox (fGetClipboardRange.Address & " has been copied to the clipboard.")
ElseIf Application.CutCopyMode = xlCut Then
MsgBox (fGetClipboardRange.Address & " has been cut to the clipboard.")
End If
End Function
'reads excel copy-paste range from the clipboard and returns range object or nothing if not found
'_2022_03_19
Function fGetClipboardRange() As Range 'get excel copy or cut range from clipboard
Dim strClipboard As String 'raw clipboard data
Dim arrClipboard() As String 'parse into an array
Set fGetClipboardRange = Nothing 'default is nothing
strClipboard = fGetClipboardData("link") 'get the link data string
If strClipboard = "" Then Exit Function 'done if it's empty
arrClipboard = Split(strClipboard, Chr(0)) 'else parse at null characters
If arrClipboard(0) <> "Excel" Then Exit Function 'excel should be first
strClipboard = "'" & arrClipboard(1) & "'!" & arrClipboard(2) 'parse the range from the others
strClipboard = Application.ConvertFormula(strClipboard, xlR1C1, xlA1) 'convert to a1 style
Set fGetClipboardRange = Range(strClipboard) 'range needs a1 style
End Function
'read clipboard for specified format into string or null string
'_2022_03_19
Function fGetClipboardData(strFormatId As String) As String 'read clipboard into string
#If VBA7 And Win64 Then
Dim hMem As LongPtr 'memory handle
Dim lngPointer As LongPtr 'memory pointer
#Else
Dim hMem As Long 'memory handle
Dim lngPointer As Long 'memory pointer
#End If
Dim arrData() As Byte 'clipboard reads into this array
Dim lngSize As Long 'size on clipboard
Dim lngFormatId As Long 'id number, for format name
fGetClipboardData = "" 'default
lngFormatId = fGetClipboardFormat(strFormatId) 'get format
If lngFormatId <= 0 Then Exit Function 'zero if format not found
CloseClipboard 'in case clipboard is open
If CBool(OpenClipboard(0)) Then 'open clipboard
hMem = GetClipboardData(lngFormatId) 'get memory handle
If hMem > 0 Then 'if there's a handle
lngSize = CLng(GlobalSize(hMem)) 'get memory size
If lngSize > 0 Then 'if we know the size
lngPointer = GlobalLock(hMem) 'get memory pointer
If lngPointer > 0 Then 'make sure we have the pointer
ReDim arrData(0 To lngSize - 1) 'size array
CopyMemory arrData(0), ByVal lngPointer, lngSize 'data from pointer to array
fGetClipboardData = StrConv(arrData, vbUnicode) 'convert array to string
End If
GlobalUnlock hMem 'unlock memory
End If
End If
End If
CloseClipboard 'don't leave the clipboard open
End Function
'return format number form format number, format number from format name or 0 for not found
'_2022_03_19
Function fGetClipboardFormat(strFormatId As String) As Long 'verify, or get format number from format name
Dim lngFormatId As Long 'format id number
fGetClipboardFormat = 0 'default false
If IsNumeric(strFormatId) Then 'for format number
lngFormatId = CLng(strFormatId) 'use number for built in format
CloseClipboard 'in case clipboard is already open
If CBool(OpenClipboard(0)) = False Then 'done if can't open clipboard
ElseIf CBool(IsClipboardFormatAvailable(lngFormatId)) = True Then 'true if format number found
fGetClipboardFormat = lngFormatId 'return format number
End If
CloseClipboard 'don't leave the clipboard open
Else
lngFormatId = RegisterClipboardFormat(strFormatId & Chr(0)) 'else get number from format name
If (lngFormatId > &HC000&) Then fGetClipboardFormat = lngFormatId 'if valid return format number
End If
End Function

Run array formula based on selected cell range and copy results to clipboard

I need to do the following:
Highlight a vertical range of cells, perform an array formula on that range, and push the results into my clipboard (preferably by pushing a hotkey).
For reference, here is the array formula: =LEFT(CONCAT("'"&TRIM(UNIQUE(A:A))&"',"),LEN(CONCAT("'"&TRIM(UNIQUE(A:A))&"',"))-1)
The A:A range above needs to dynamically reflect the cells highlighted (almost always a vertical column).
How do I refer to highlighted cells and put them into the array, and push results to the clipboard?
Here's a table and example
Column A
AAA
BBB
CCC
I'd highlight, for instance, cells A2:A4, press the macro button to run the formula
=LEFT(CONCAT("'"&TRIM(UNIQUE(A2:A4))&"',"),LEN(CONCAT("'"&TRIM(UNIQUE(A2:A4))&"',"))-1)
and copy the following text to the clipboard
'AAA','BBB','CCC'
Here's how I do this type of thing.
You can set the clipboard text using the Win API: it's also possible using DataObject but that seems pretty unreliable on Win10.
Sub tester()
Dim s As String, arr
If TypeName(Selection) = "Range" Then
arr = GetUniques(Selection)
If UBound(arr) = -1 Then Exit Sub 'no values found
s = "'" & Join(arr, "','") & "'"
'Debug.Print s
SetClipboard s 'set to clipboard: see below
End If
End Sub
Function GetUniques(rng As Range) 'as array
Dim c As Range, dict, v
Set dict = CreateObject("scripting.dictionary")
For Each c In rng.Cells
v = Trim(c.Value)
If Len(v) > 0 Then dict(v) = 0
Next c
GetUniques = dict.Keys
End Function
There may be some additions you'd need to make if your input lists are very large, depending on your database flavor. Eg. IN lists for Oracle are restricted to 1000 or fewer items so you need to use something like col IN([first 1000 items]) OR col IN([rest of items])
Edit - full Win API code for setting clipboard. Put this in a separate module. Will need adjustments if you're running 64-bit Excel.
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

HeapFree is crashing

Summary:
I have VBA code that collects lots of info and writes it out into one or more worksheets. To improve perf writing lots of info into sheets, I created a class that acts kind of like a buffered copy/paste stream: the caller sends it CSV format strings which it buffers in memory until the buffer is full; when full, it pastes into a sheet, clears the buffer and continues.
Initially, I used Global memory, but then saw on MSDN a recommendation to use Heap rather than Global or Local due to less overhead. So now I'm using Heap.
I'm in the process of adapting everything for 64-bit Office. After doing all the PtrSafe stuff, I can run the code. But now Excel crashes when HeapFree() is called.
Question: Why is it crashing, and what do I need to change to avoid it?
Details:
I've come up with the following that is a minimized sample that repro's the crash: there's a module with a sub I can run for the repro, and the class. This doesn't do the buffering; every call to .SendText will put the text on the clipboard and paste into the active cell.
First the module. This has the following declare statements
' memory APIs
Public Const HEAP_ZERO_MEMORY = &H8
Declare PtrSafe Function GetProcessHeap Lib "kernel32" () As LongPtr 'returns HANDLE
Declare PtrSafe Function HeapAlloc Lib "kernel32" (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal dwBytes As LongPtr) As LongPtr 'returns HANDLE
Declare PtrSafe Function HeapFree Lib "kernel32" (ByVal hHeap As LongPtr, ByVal dwFlags As Long, lpMem As Any) As Long 'returns BOOL
Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpDestString As Any, ByVal lpSrcString As Any) As LongPtr 'returns HANDLE
' clipboard APIs
Public Const CF_UNICODETEXT = 13
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long 'returns BOOL
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long 'returns BOOL
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long 'returns BOOL
Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr 'returns HANDLE
Then the sub:
Private Sub TestMemoryBugRepro()
Dim s As String
Dim clip As clsHeapBugRepro
s = Chr(34) & "a" & vbLf & "b" & Chr(34) & ",c" & vbCrLf & "d" & vbTab & ",e" & vbCrLf
Set clip = New clsHeapBugRepro
clip.Initialize &H100
clip.SendText s
'Crash happens during the following
Set clip = Nothing
End Sub
Now the class. The crash occurs during Class_Terminate() when HeapFree is called.
Option Explicit
Private m_hHeap As LongPtr 'handle to the process heap
Private m_hMem As LongPtr 'handle to memory
Private m_pMem As LongPtr 'pointer to locked memory
Private m_cbMem As Long 'size of the memory buffer
Private m_BytesWritten As Long '
'**************************************
' Event procedures
Private Sub Class_Initialize()
m_hHeap = GetProcessHeap()
End Sub
Private Sub Class_Terminate()
If m_hMem <> 0 And m_hHeap <> 0 Then
HeapFree m_hHeap, 0, m_hMem 'CRASH OCCURS HERE
End If
End Sub
'**************************************
' Public methods
Public Function Initialize(Optional bufferSize As Long = &H8000) As Boolean
Initialize = False
m_BytesWritten = 0
If m_hHeap <> 0 Then
m_cbMem = bufferSize
m_hMem = HeapAlloc(m_hHeap, (HEAP_ZERO_MEMORY), m_cbMem)
End If
If m_hMem <> 0 Then Initialize = True
End Function
Public Function SendText(text As String) As Boolean
Dim nStrLen As Long
nStrLen = LenB(text) + 2&
Debug.Assert nStrLen < (m_cbMem + m_BytesWritten)
m_pMem = m_hMem 'in lieu of locking heap memory
lstrcpy m_pMem, StrPtr(text)
m_pMem = 0 'in lieu of unlocking heap memory
m_BytesWritten = m_BytesWritten + nStrLen
DoEvents
OpenClipboard 0&
EmptyClipboard
SetClipboardData CF_UNICODETEXT, m_hMem
CloseClipboard
ActiveCell.PasteSpecial
DoEvents
SendText = True
End Function
There's an issue in how you're calling HeapFree, but your real issue is that you shouldn't be using HeapAlloc/HeapFree at all.
Memory allocated by HeapAlloc is not movable, whereas SetClipboardData requires it to be moveable.
Another consideration is that SetClipboardData transfers the ownership of the memory to the system, which means you should not free it yourself. (The application may not write to or free the data once ownership has been transferred to the system.)
So, I would try to rewrite your logic using GlobalAlloc, not HeapAlloc, and don't try to free memory after it is put on the clipboard.
Now, there was an issue in how you were calling HeapFree, if you were going to use it. HeapFree wants the pointer returned by HeapAlloc.
You were instead passing a pointer to that pointer, because you declared the third argument of HeapFree As Any, which means ByRef As Any.
Either redeclare the argument ByVal As LongPtr / ByVal As Any, e.g.:
Declare PtrSafe Function HeapFree Lib "kernel32" (ByVal hHeap As LongPtr, _
ByVal dwFlags As Long,
ByVal lpMem As LongPtr) As Long 'returns BOOL
or specify ByVal when calling it:
HeapFree m_hHeap, 0, ByVal m_hMem

How to copy only plain text of cells in Excel?

I am designing an Excel worksheet where the user will click a command button which copies a predetermined range of cells. The user would then paste the contents into a web app using Firefox or IE. The design of the web app is out of my control and currently the text boxes that are used for data input are rich text inputs. This causes the text to look odd and formatted like Excel when the user pastes into them.
Is there a way in Excel using VBA to copy only the plain text of the cells that are selected? No formatting, no tabling or cell borders, just the text and nothing else. My current workaround macro is copying the cells, opening Notepad, pasting into Notepad, and then copying from Notepad to get the plain text. This is highly undesirable and I'm hoping there's a way to do this within Excel itself. Please let me know, thanks!
Something like this?
Sheet1.Cells(1, 1).Copy
Sheet1.Cells(1, 2).PasteSpecial xlPasteValues
Or
selection.Copy
Sheet1.Cells(1,2).Activate
Selection.PasteSpecial xlPasteValues
Copy copies the entire part, but we can control what is pasted.
Same applies to Range objects as well.
EDIT
AFAIK, there is no straighforward way to copy only the text of a range without assigning it to a VBA object (variable, array, etc.). There is a trick that works for a single cell and for numbers and text only (no formulas):
Sub test()
Cells(1, 1).Select
Application.SendKeys "{F2}"
Application.SendKeys "+^L"
Application.SendKeys "^C"
Cells(1, 3).Select
Application.SendKeys "^V"
End Sub
but most developers avoid SendKeys because it can be unstable and unpredictable. For example, the code above works only when the macro is executed from excel, not from VBA. When run from VBA, SendKeys opens the object browser, which is what F2 does when pressed at the VBA view :) Also, for a full range, you will have to loop over the cells, copy them one by one and paste them one by one to the application. Now that I think better, I think this is an overkill..
Using arrays is probably better. This one is my favorite reference on how you pass ranges to vba arrays and back:
http://www.cpearson.com/excel/ArraysAndRanges.aspx
Personally, I would avoid SendKeys and use arrays. It should be possible to pass the data from the VBA array to the application, but hard to say without knowing more about the application..
Actually, the best way to do this is to copy the cells and paste into a notepad. Notepad won't recognize the cells. You can then copy the text back into whatever cell you want. This works for copying text from multiple cells into a single cell.
If you're dealing with a lot of cells to be copied, the selection.copy method will be extremely slow. (I experienced that when running a macro on 200 000 records).
A 100 times more performant way is to directly assign the value of one cell to another. Example from my code:
With errlogSheet
'Copy all data from the current row
reworkedErrorSheet.Range("A" & reworkedRow).Value = .Range("A" & currentRow).Value
reworkedErrorSheet.Range("B" & reworkedRow).Value = .Range("B" & currentRow).Value
reworkedErrorSheet.Range("C" & reworkedRow).Value = .Range("C" & currentRow).Value
reworkedErrorSheet.Range("D" & reworkedRow).Value = .Range("D" & currentRow).Value
reworkedErrorSheet.Range("E" & reworkedRow).Value = .Range("E" & currentRow).Value
Try this to copy whatever cell you have selected:
Sub CopyTheCell()
Dim TheText As String
TheText = Selection
ToClipboard TheText
End Sub
Function ToClipboard(Optional StoreText As String) As String
'PURPOSE: Read/Write to Clipboard
'Source: ExcelHero.com (Daniel Ferry)
Dim x As Variant
'Store as variant for 64-bit VBA support
x = StoreText
'Create HTMLFile Object
With CreateObject("htmlfile")
With .parentWindow.clipboardData
Select Case True
Case Len(StoreText)
'Write to the clipboard
.setData "text", x
Case Else
'Read from the clipboard (no variable passed through)
Clipboard = .GetData("text")
End Select
End With
End With
End Function
This can be easily solved without bothering with VBA.
The user can paste the contents of the clipboard by Ctrl + Shift + V instead of more usual Ctrl + V (pasting as formatted).
Ctrl + Shift + V pastes the clipboard content as plain text.
In Excel 2013 you can do this with shortcuts.
Press Ctrl + Alt + V to open the paste special window.
Now you can click the values radio button or just press V if your Excel is in English.
If you don't use Excel in English you can see which button can be pressed to select the wanted option by looking at the underlining of the single letters.
Finaly press Enter to paste your copied selection.
In Excel, highlight the cell in question.
Hit F2.
CTRL+Shift+Home. (This highlights the cell’s entire contents.)
CTRL+C.
Go to destination application.
CTRL+V.
It looks like a lot of steps, but when you actually do it, it’s much quicker than using the ribbons to accomplish the same.
If you need to copy multiple cells into an application bereft of the Paste Special… facility, then do a regular copy and paste from Excel into Notepad, and then do a copy and paste from Notepad to the destination. Cumbersome, but it works.
To accomplish this, I will copy the selected cells to clipboard, save the clipboard to a text variable, and then copy this text back to clipboard.
Copy the following into a new module and then run the last sub:
'Handle 64-bit and 32-bit Office
#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
#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
#End If
Const GHND = &H42
Const CF_TEXT = 1
Const MAXSIZE = 4096
Function ClipBoard_SetData(MyString As String)
'PURPOSE: API function to copy text to clipboard
'SOURCE: www.msdn.microsoft.com/en-us/library/office/ff192913.aspx
'Link: https://www.thespreadsheetguru.com/blog/2015/1/13/how-to-use-vba-code-to-copy-text-to-the-clipboard
#If VBA7 Then
Dim hGlobalMemory As LongPtr, lpGlobalMemory As LongPtr
Dim hClipMemory As LongPtr, x As LongPtr
#Else
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, x As Long
#End If
'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 Function
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 Function
Function ClipBoard_GetData() As String
' Return the data in clipboard as text
' Source: https://learn.microsoft.com/en-us/office/vba/access/concepts/windows-api/retrieve-information-from-the-clipboard
#If VBA7 Then
Dim lpGlobalMemory As LongPtr, hClipMemory As LongPtr
Dim lpClipMemory As LongPtr
Dim RetVal As LongPtr
#Else
Dim lpGlobalMemory As Long, hClipMemory As Long
Dim lpClipMemory As Long
Dim RetVal As Long
#End If
Dim MyString As String
If OpenClipboard(0&) = 0 Then
MsgBox "Cannot open Clipboard. Another app. may have it open"
Exit Function
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 OutOfHere
End If
' Lock Clipboard memory so we can reference
' the actual data string.
lpClipMemory = GlobalLock(hClipMemory)
If Not IsNull(lpClipMemory) Then
If lpClipMemory <> 0 Then
MyString = Space$(MAXSIZE)
RetVal = lstrcpy(MyString, lpClipMemory)
RetVal = GlobalUnlock(hClipMemory)
' Peel off the null terminating character.
MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
Else
MsgBox "Clipboard is empty!"
End If
Else
MsgBox "Could not lock memory to copy string from."
End If
OutOfHere:
RetVal = CloseClipboard()
ClipBoard_GetData = MyString
End Function
Sub CopySelectedCellsAsText()
' Copy selected cells to clipboard, save the clipboard to a text variable,
' and then copy this text back to clipboard
If TypeName(Selection) <> "Range" Then Exit Sub
Selection.Copy
Dim strSelection As String
strSelection = ClipBoard_GetData
Application.CutCopyMode = False
ClipBoard_SetData strSelection
End Sub
This copied only text values from a date column, for me
Worksheets("Shee1").Cells(2, "A").Text

Office 2013 Excel .PutInClipboard is Different?

I've used a routine for years to put a plain text string into the clipboard that I can paste into another program such as:
targetData.SetText "This is a plain text string"
targetData.PutInClipboard
When I use this in Excel Office 2013 the data isn't in the clipboard and therefore I can't paste it. This never happened in prior versions.
Under closer inspection I've found that the string does go to the clipboard but as "System String" but not as "Text" or "Unicode Text".
BUT... about 10% of the time it acutally works as it should putting the string into the clipboard as "Text".
Any ideas??
user2140261's comment is the correct solution:
How to: Send Information to the Clipboard
(The following is just copied from the above link)
If you need to copy the contents of the active control on a form or report to the Clipboard, you only need this code:
Private Sub cmdCopy_Click()
Me!txtNotes.SetFocus
DoCmd.RunCommand acCmdCopy
End Sub
However, this the replacement you need for your old routine:
1. Create a module, name it "WinAPI" or something, put this code in it:
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
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
2. In the module where your old routine is defined, replace your old routine with this code:
Function 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 Function
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 Function
3. Then, call it like this:
' doesn't work on Windows 8: targetData.SetText "This is a plain text string"
'doesn't work on Windows 8: targetData.PutInClipboard
ClipBoard_SetData ("This is a plain text string")
You should add "Microsoft forms 2.0 object library" to your references then you can use this feature.
you can do this by going to Excel/developer/Visual basic(or your VBE module) and in the tools/references select browse and then in your system32 folder search for "FM20.DLL" file and then by selecting this file at the end of the references list "Microsoft forms 2.0 object library" will be appeared. Activate that . Now things are as good as old times ;)

Resources