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 ;)
Related
Please Look at the code below and test it:
Private Sub CommandButton1_Click()
MsgBox "This window converted Right to Left!", vbMsgBoxRtlReading
End Sub
This code convert the message window from right to left. As the close button moves to the left of the window. How do I do this for userforms?
(Hope T.M., Mathieu Guindon and ... does not say: "Your question is amiss. Please read the links ....")
Like the picture below (Of course photo is photoshop!):
Simulate Right To Left display as in MsgBox
It'll be necessary to use some API *) functions to get the wanted layout independant from language settings using right to left functionality by default.
Identify the Userform's handle to get access to further API methods
Remove the Userform's title bar
Replace it e.g. with a Label control displaying the caption and give it drag functionality to move the UserForm (here: Label1).
Use another control (here: Label2) to simulate the system escape "x".
*) API - Application Programming Interface
A simple UserForm code example
All you need is to provide for 2 Label controls where Label1 replaces the title bar and receives the UserForm's caption and Label2 simulates the system Escape "x". Furthermore this example uses a Type declaration for easy disposal of the UserForm handle for several event procedures needing it for further API actions.
► Note to 2nd edit as of 10/22 2018
As a window handle is declared as LongPtr in Office 2010 or higher and as Long in versions before, it was necessary to differentiate between the different versions by conditional compile constants (e.g. #If VBA7 Then ... #Else ... #End If; cf. section II. using also the Win64 constant to identify actually installed 64bit Office systems - note that frequently Office is installed as 32bit by default).
Option Explicit ' declaration head of userform code module
#If VBA7 Then ' compile constant for Office 2010 and higher
Private Type TThis ' Type declaratation
frmHandle As LongPtr ' receives form window handle 64bit to identify this userform
End Type
#Else ' older versions
Private Type TThis ' Type declaratation
frmHandle As Long ' receives form window handle 32bit to identify this userform
End Type
#End If
Dim this As TThis ' this - used by all procedures within this module
Private Sub UserForm_Initialize()
' ~~~~~~~~~~~~~~~~~~~~~~~
' [1] get Form Handle
' ~~~~~~~~~~~~~~~~~~~~~~~
this.frmHandle = Identify(Me) ' get UserForm handle via API call (Long)
' ~~~~~~~~~~~~~~~~~~~~~~~
' [2] remove System Title Bar
' ~~~~~~~~~~~~~~~~~~~~~~~
HideTitleBar (this.frmHandle) ' hide title bar via API call
End Sub
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' Purpose: Replaces System Title Bar (after removal via API) and receives dragging functionality
' ~~~~~~~~~~~~~~~~~~~~~~~~~~
' [3] allow to move UserForm
' ~~~~~~~~~~~~~~~~~~~~~~~~~~
If Button = 1 Then DragForm this.frmHandle
End Sub
Private Sub Label2_Click()
' Purpose: Label "x" replaces System Escape (after removal in step [2])and hides UserForm
' ~~~~~~~~~~~~~~~~~
' [4] hide UserForm
' ~~~~~~~~~~~~~~~~~
Me.Hide
End Sub
Private Sub UserForm_Layout()
Me.RightToLeft = True
' Simulated Escape Icon
Me.Label2.Caption = " x"
Me.Label2.BackColor = vbWhite
Me.Label2.Top = 0
Me.Label2.Left = 0
Me.Label2.Width = 18: Me.Label2.Height = 18
' Simulated UserForm Caption
Me.Label1.Caption = Me.Caption
Me.Label1.TextAlign = fmTextAlignRight ' <~~ assign right to left property
Me.Label1.BackColor = vbWhite
Me.Label1.Top = 0: Me.Label1.Left = Me.Label2.Width: Me.Label1.Height = Me.Label2.Height
Me.Label1.Width = Me.Width - Me.Label2.Width - 4
End Sub
II. Separate code module for API functions
a) Declaration head with constants and special API declarations
It's necessary to provide for different application versions as the code declarations differ in some arguments (e.g. PtrSafe). 64 bit declarations start as follows: Private Declare PtrSafe ...
Take also care of the correct declarations via #If, #Else and #End If allowing version dependant compilation.
The prefix &H used in constants stands for hexadecimal values.
Option Explicit
Private Const WM_NCLBUTTONDOWN = &HA1&
Private Const HTCAPTION = 2&
Private Const GWL_STYLE = (-16)
Private Const WS_BORDER = &H800000
Private Const WS_DLGFRAME = &H400000
Private Const WS_CAPTION = WS_BORDER Or WS_DLGFRAME
#If VBA7 Then ' True if you're using Office 2010 or higher
' [0] ReleaseCapture
Private Declare PtrSafe Sub ReleaseCapture Lib "User32" ()
' [1] SendMessage
Private Declare PtrSafe Function SendMessage Lib "User32" _
Alias "SendMessageA" _
(ByVal hWnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, lParam As Any) As LongPtr ' << arg's hWnd, wParam + function type: LongPtr
' [2] FindWindow
Private Declare PtrSafe Function FindWindow Lib "User32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr ' << function type: LongPtr
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Two API functions requiring the Win64 compile constant for 64bit Office installations
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#If Win64 Then ' true if Office explicitly installed as 64bit
' [3a] Note that GetWindowLong has been replaced by GetWindowLongPtr
Private Declare PtrSafe Function GetWindowLongPtr Lib "User32" _
Alias "GetWindowLongPtrA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
' [3b] Note that GetWindowLong has been replaced by GetWindowLongPtr
' Changes an attribute of the specified window.
' The function also sets a value at the specified offset in the extra window memory.
Private Declare PtrSafe Function SetWindowLongPtr Lib "User32" _
Alias "SetWindowLongPtrA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
#Else ' true if Office install defaults 32bit
' [3aa] Note that GetWindowLong has been replaced by GetWindowLongPtr Alias GetWindowLongA !
Private Declare PtrSafe Function GetWindowLongPtr Lib "User32" _
Alias "GetWindowLongA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
' [3bb] Note that GetWindowLong has been replaced by GetWindowLongPtr Alias SetWindowLongA !
Private Declare PtrSafe Function SetWindowLongPtr Lib "User32" _
Alias "SetWindowLongA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
#End If
' [4] DrawMenuBar
Private Declare PtrSafe Function DrawMenuBar Lib "User32" _
(ByVal hWnd As LongPtr) As Long ' << arg hWnd: LongPtr
#Else ' True if you're using Office before 2010 ('97)
Private Declare Sub ReleaseCapture Lib "User32" ()
Private Declare Function SendMessage Lib "User32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindWindow Lib "User32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "User32" _
Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "User32" _
Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "User32" _
(ByVal hWnd As Long) As Long
#End If
b) Following Procedures (after section a)
' ~~~~~~~~~~~~~~~~~~~~~~
' 3 Procedures using API
' ~~~~~~~~~~~~~~~~~~~~~~
#If VBA7 Then ' Office 2010 and higher
Public Function Identify(frm As Object) As LongPtr
' Purpose: [1] return window handle of form
' Note: vbNullString instead of ThunderXFrame (97) and class names of later versions
Identify = FindWindow(vbNullString, frm.Caption)
End Function
Public Sub HideTitleBar(hWnd As LongPtr)
' Purpose: [2] remove Userform title bar
SetWindowLongPtr hWnd, GWL_STYLE, GetWindowLongPtr(hWnd, GWL_STYLE) And Not WS_CAPTION
End Sub
Public Sub ShowTitleBar(hWnd As LongPtr)
' Purpose: show Userform title bar
SetWindowLongPtr hWnd, GWL_STYLE, GetWindowLongPtr(hWnd, GWL_STYLE) Or WS_CAPTION
End Sub
Public Sub DragForm(hWnd As LongPtr)
' Purpose: [3] allow to drag & move userform via control (here via e.g.: Label1)
Call ReleaseCapture
Call SendMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub
#Else ' vers. before Office 2010 (Office '97)
Public Function Identify(frm As Object) As Long
' Purpose: [1] return window handle of form
' Note: vbNullString instead of ThunderXFrame (97) and class names of later versions
Identify = FindWindow(vbNullString, frm.Caption)
End Function
Public Sub HideTitleBar(hWnd As Long)
' Purpose: [2] remove Userform title bar
SetWindowLong hWnd, GWL_STYLE, GetWindowLong(hWnd, GWL_STYLE) And Not WS_CAPTION
End Sub
' Public Sub ShowTitleBar(HWND As Long)
' ' Purpose: show Userform title bar
' SetWindowLong HWND, GWL_STYLE, GetWindowLong(HWND, GWL_STYLE) Or WS_CAPTION
' End Sub
Public Sub DragForm(hWnd As Long)
' Purpose: [3] allow to drag & move userform via control (here via e.g.: Label1)
Call ReleaseCapture
Call SendMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub
#End If
► Caveat: API declarations not tested for actually installed 64 bit systems in Office 2010 or higher. The 2nd Edit as of 10/22 2018 tries to correct several LongPtr declarations (only for pointers to a → handle or → memory location) and using the current Get/SetWindowLongPtr function differentiating explicitly between Win64 and Win32; cf. also edited Type declaration in the UserForm code module's declaration head).
See also Compatibility between 32bit and 64bit Versions of Office 2010 and Office 2010 Help Files: Win32API PtrSafe with 64bit Support
Additional note
UserForms are Windows and can be identified by their window handle.
The API function used for this purpose is FindWindow disposing of two arguments:
1) A string giving the name of the class of the window it needs to find and 2) a string giving the caption of the window (UserForm) it needs to find.
Therefore frequently one distinguishes between version '97 (UserForm class name "ThunderXFrame") and later versions ("ThunderDFrame"):
If Val(Application.Version) < 9 Then
hWnd = FindWindow("ThunderXFrame", frm.Caption) ' if used within Form: Me.Caption
Else ' later versions
hWnd = FindWindow("ThunderDFrame", frm.Caption) ' if used within Form: Me.Caption
End If
However using vbNullString (and unique captions!) instead makes coding much easier:
hWnd = FindWindow(vbNullString, frm.Caption) ' if used within Form: Me.Caption
Recommended further reading
UserForm code modules actually are classes and should be used as such. So I recommend reading M. Guindon's article UserForm1.Show. - Possibly of some interest, as well is Destroy a modeless UserForm instance properly
I have an Excel VBA UDF that performs some expensive calculations. Currently, Excel tries to run the function when the user clicks on the Insert Function dialog (the 'fx' button next to the formula bar), and this causes problems in my code.
Is there a way I can set the function to not calculate when the user has the Insert Function dialog (or the Function Arguments dialog, which is what shows up when the function name is already provided) open? I'd like to have the function only run when the user enters the formula in a cell or refreshes the sheet.
try adding this code to the start of your function:
If (Not Application.CommandBars("Standard").Controls(1).Enabled) Then Exit Function
It will quit your UDF if the function wizard is being used
There is one circumstance in which the "CommandBars" solution provided by Charles Williams fails, falsely indicating that the function wizard is active when it's not.
It happens when you open a comma-separated text file in Excel in which case all open Excel workbooks are recalculated, even if Excel calculation is set to manual. That's quite disruptive if you have workbooks open with slow-to-calculate VBA UDFs that use the CommandBars test to exit early if the Wizard is thought to be active.
Charles further suggests that the Windows API can be used as an alternative approach. I've not been able to find such code elsewhere so here's my attempt to implement Charles' suggestion.
Tested only on English-language 64-bit Excel 365.
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hwnd As LongPtr, ByRef lpdwProcessId As Long) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
Private Const GW_HWNDNEXT = 2
Function FunctionWizardActive() As Boolean
Dim ExcelPID As Long
Dim lhWndP As LongPtr
Dim WindowTitle As String
Dim WindowPID As Long
Const FunctionWizardCaption = "Function Arguments" 'This won't work for non English-language Excel
If TypeName(Application.Caller) = "Range" Then
'The "CommandBars test" below is usually sufficient to determine that the Function Wizard is active,
'but can sometimes give a false positive. Example: When a csv file is opened (via File Open) then all
'active workbooks are calculated (even if calculation is set to manual!) with
'Application.CommandBars("Standard").Controls(1).Enabled being False
'So apply a further test using Windows API to loop over all windows checking for a window with title "Function Arguments", checking also the process id.
If Not Application.CommandBars("Standard").Controls(1).Enabled Then
ExcelPID = GetCurrentProcessId()
lhWndP = FindWindow(vbNullString, vbNullString) 'PARENT WINDOW
Do While lhWndP <> 0
WindowTitle = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, WindowTitle, Len(WindowTitle)
WindowTitle = Left$(WindowTitle, Len(WindowTitle) - 1)
If WindowTitle = FunctionWizardCaption Then
GetWindowThreadProcessId lhWndP, WindowPID
If WindowPID = ExcelPID Then
FunctionWizardActive = True
Exit Function
End If
End If
lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
Loop
End If
End If
End Function
With that function available, you can amend your slow VBA UDFs with the code:
If FunctionWizardActive() Then Exit Function
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
I want to copy the different cells data into a notepad. How do i do that.
Example : values from row3 column B(B3), then from row3 column E(E3).
Thanks in advance.
Using a helper module you could:
Dim cell As Range
Dim concat As String
For Each cell In Range("$B$3,$E$3")
concat = concat & vbCrLf & cell.Value
Next
' Debug.Print concat
Text2Clipboard concat
If instead of Range("$B$3,$E$3") you said Selection you'd end up with all the cells currently selected.
Hint: You can select inidivual cells using Ctrl+LeftMouseButton
You need the following helper definitions somewhere in your VBA project (I suggest a module named like 'Clipboard'):
Declare Function abOpenClipboard Lib "User32" Alias "OpenClipboard" (ByVal Hwnd As Long) As Long
Declare Function abCloseClipboard Lib "User32" Alias "CloseClipboard" () As Long
Declare Function abEmptyClipboard Lib "User32" Alias "EmptyClipboard" () As Long
Declare Function abIsClipboardFormatAvailable Lib "User32" Alias "IsClipboardFormatAvailable" (ByVal wFormat As Long) As Long
Declare Function abSetClipboardData Lib "User32" Alias "SetClipboardData" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function abGetClipboardData Lib "User32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long
Declare Function abGlobalAlloc Lib "Kernel32" Alias "GlobalAlloc" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function abGlobalLock Lib "Kernel32" Alias "GlobalLock" (ByVal hMem As Long) As Long
Declare Function abGlobalUnlock Lib "Kernel32" Alias "GlobalUnlock" (ByVal hMem As Long) As Boolean
Declare Function abLstrcpy Lib "Kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function abGlobalFree Lib "Kernel32" Alias "GlobalFree" (ByVal hMem As Long) As Long
Declare Function abGlobalSize Lib "Kernel32" Alias "GlobalSize" (ByVal hMem As Long) As Long
Const GHND = &H42
Const CF_TEXT = 1
Const APINULL = 0
Function Text2Clipboard(szText As String)
Dim wLen As Integer
Dim hMemory As Long
Dim lpMemory As Long
Dim retval As Variant
Dim wFreeMemory As Boolean
' Get the length, including one extra for a CHR$(0) at the end.
wLen = Len(szText) + 1
szText = szText & Chr$(0)
hMemory = abGlobalAlloc(GHND, wLen + 1)
If hMemory = APINULL Then
MsgBox "Unable to allocate memory."
Exit Function
End If
wFreeMemory = True
lpMemory = abGlobalLock(hMemory)
If lpMemory = APINULL Then
MsgBox "Unable to lock memory."
GoTo T2CB_Free
End If
' Copy our string into the locked memory.
retval = abLstrcpy(lpMemory, szText)
' Don't send clipboard locked memory.
retval = abGlobalUnlock(hMemory)
If abOpenClipboard(0&) = APINULL Then
MsgBox "Unable to open Clipboard. Perhaps some other application is using it."
GoTo T2CB_Free
End If
If abEmptyClipboard() = APINULL Then
MsgBox "Unable to empty the clipboard."
GoTo T2CB_Close
End If
If abSetClipboardData(CF_TEXT, hMemory) = APINULL Then
MsgBox "Unable to set the clipboard data."
GoTo T2CB_Close
End If
wFreeMemory = False
T2CB_Close:
If abCloseClipboard() = APINULL Then
MsgBox "Unable to close the Clipboard."
End If
If wFreeMemory Then GoTo T2CB_Free
Exit Function
T2CB_Free:
If abGlobalFree(hMemory) <> APINULL Then
MsgBox "Unable to free global memory."
End If
End Function
Notes
code 'borrowed' from http://www.everythingaccess.com/tutorials.asp?ID=Copying-data-to-and-from-the-Clipboard-(Acc-95%2B)
tested in Excel 2003 on Windows XP SP3
Write your cell values to a text file, then open it in Notepad or your favourite text editor.
' Write to file.
Open "C:\temp.txt" For Output As #1
Print #1, Range("B3").Value, Range("C4").Value
Print #1, Range("Q981").Value, "hello world!" ' or whatever else
Close #1
' Now open it in notepad.
Shell ("notepad ""C:\temp.txt""")
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