Related
I want to run a macro which will take a screenshot of webpage (one of the multiple tabs in the browser )open in another window and save the screenshot as png file to a folder (path and filename specified in a cell in excel sheet).
I searched for the same on google and got the code to change the active window and take the screenshot. But the below code will paste the screenshot in the active sheet. Instead I want to save it as a png or jpg file to a specific folder with a specific file name as given in excel sheet from where the program is triggered. So everytime the screenshot is triggered it will have a different file name picked from the active excel cell with some constant prefix.
Option explicit
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_SNAPSHOT = &H2C
Sub PrintScreen()
appactivate("Microsoft Word",wait)
keybd_event VK_SNAPSHOT, 1, 0, 0
ActiveSheet.Paste
end sub
This answer assumes that the browser you are using is Chrome ... change the relevant text in the call to AppActivate to be the relevant text for the browser you are using. Also assumed is the filename in the ActiveCell is just the file name (not including the file extension).
You will need to set the PREFIX text to the folder you want to save the file in. This can include a prefix for the filename itself if you want, but if just a folder, must end with a trailing backslash.
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = &H2
Private Const PREFIX As String = "<My folder>\"
Sub PrintScreen()
' grab filename
Dim fileName As String
fileName = ActiveCell.Value
' activate, for example, Chrome ... this will only work if Chrome is already in
' a 'normal' or 'maximized' window (ie not 'minimized')
AppActivate "Chrome", False
' take screenshot
keybd_event VK_SNAPSHOT, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
' wait for screenshot
Dim t As Single
t = Timer + 0.1
Do While Timer < t
DoEvents
Loop
' paste screenshot to sheet and grab it ... the active sheet must be
' a Worksheet for this to work
ActiveSheet.Paste
Dim shp As Shape
Set shp = Selection.ShapeRange(1)
' save as file ... PNG in this case
If ExportPicture(shp, PREFIX & fileName & ".png", "png") Then
' do success stuff!
Debug.Print "Success"
Else
' do failed stuff!
Debug.Print "Failed"
End If
' optionally, if required, delete the screenshot
shp.Delete
End Sub
' Export Shape, as a picture, to a file
Function ExportPicture(shp As Shape, sFile As String, sFilter As String) As Boolean
On Error GoTo errExit
Dim ch As ChartObject
Set ch = shp.Parent.ChartObjects.Add(0, 0, shp.Width, shp.Height)
ch.Activate
ch.ShapeRange.Fill.Visible = msoFalse ' to allow transparency if PNG
ch.ShapeRange.Line.Visible = msoFalse
ch.Chart.Paste
ch.Chart.Export sFile, sFilter
ExportPicture = True
errExit:
If Not ch Is Nothing Then ch.Delete
End Function
This function takes a screenshot and saves as a bmp file
'***********************************************************************************************
' * Please leave any Trademarks or Credits in place.
' *
' * ACKNOWLEDGEMENT TO CONTRIBUTORS :
' * STEPHEN BULLEN, 15 November 1998 - Original PastPicture code
' * G HUDSON, 5 April 2010 - Pause Function
' * LUTZ GENTKOW, 23 July 2011 - Alt + PrtScrn
' * PAUL FRANCIS, 11 April 2013 - Putting all pieces together, bridging the 32 bit and 64 bit version.
' * CHRIS O, 12 April 2013 - Code suggestion to work on older versions of Access.
' *
' * DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
' * This object is then saved to a location on the disc. Please note, this
' * can also be assigned to (for example) and Image control on a userform.
' *
' * The code requires a reference to the "OLE Automation" type library.
' *
' * The code in this module has been derived from a number of sources
' * discovered on MSDN, Access World Forum, VBForums.
' *
' * To use it, just copy this module into your project, then you can use:
' * SaveClip2Bit("C:\Pics\Sample.bmp")
' * to save this to a location on the Disc.
' * (Or)
' * Set ImageControl.Image = PastePicture
' * to paste a picture of whatever is on the clipboard into a standard image control.
' *
' * PROCEDURES:
' * PastePicture : The entry point for 'Setting' the Image
' * CreatePicture : Private function to convert a bitmap or metafile handle to an OLE reference
' * fnOLEError : Get the error text for an OLE error code
' * SaveClip2Bit : The entry point for 'Saving' the Image, calls for PastePicture
' * AltPrintScreen: Performs the automation of Alt + PrtScrn, for getting the Active Window.
' * Pause : Makes the program wait, to make sure proper screen capture takes place.
'**************************************************************************************************
Option Explicit
Option Compare Text
'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'Windows API Function Declarations
#If Win64 = 1 And VBA7 = 1 Then
'Does the clipboard contain a bitmap/metafile?
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'Uses the Keyboard simulation
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'Uses the Keyboard simulation
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If
'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
' Subroutine : AltPrintScreen
' Purpose : Capture the Active window, and places on the Clipboard.
Sub AltPrintScreen()
keybd_event VK_MENU, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
End Sub
Sub PrintScreen()
keybd_event VK_SNAPSHOT, 1, 0, 0
End Sub
' Subroutine : PastePicture
' Purpose : Get a Picture object showing whatever's on the clipboard.
Function PastePicture() As IPicture
'Some pointers
Dim h As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
'Check if the clipboard contains the required format
If IsClipboardFormatAvailable(CF_BITMAP) Then
'Get access to the clipboard
h = OpenClipboard(0&)
If h > 0 Then
'Get a handle to the image data
hPtr = GetClipboardData(CF_BITMAP)
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
'Release the clipboard to other programs
h = CloseClipboard
'If we got a handle to the image, convert it into a Picture object and return it
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, CF_BITMAP)
End If
End If
End Function
' Subroutine : CreatePicture
' Purpose : Converts a image (and palette) handle into a Picture object.
' NOTE : Requires a reference to the "OLE Automation" type library
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
' IPicture requires a reference to "OLE Automation"
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
'OLE Picture types
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
' Create the Interface GUID (for the IPicture interface)
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Fill uPicInfo with necessary parts.
With uPicInfo
.Size = Len(uPicInfo) ' Length of structure.
.Type = PICTYPE_BITMAP ' Type of Picture
.hPic = hPic ' Handle to image.
.hPal = hPal ' Handle to palette (if bitmap).
End With
' Create the Picture object.
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
' If an error occurred, show the description
If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
' Return the new Picture object.
Set CreatePicture = IPic
End Function
' Subroutine : fnOLEError
' Purpose : Gets the message text for standard OLE errors
Private Function fnOLEError(lErrNum As Long) As String
'OLECreatePictureIndirect return values
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Const S_OK = &H0
Select Case lErrNum
Case E_ABORT
fnOLEError = " Aborted"
Case E_ACCESSDENIED
fnOLEError = " Access Denied"
Case E_FAIL
fnOLEError = " General Failure"
Case E_HANDLE
fnOLEError = " Bad/Missing Handle"
Case E_INVALIDARG
fnOLEError = " Invalid Argument"
Case E_NOINTERFACE
fnOLEError = " No Interface"
Case E_NOTIMPL
fnOLEError = " Not Implemented"
Case E_OUTOFMEMORY
fnOLEError = " Out of Memory"
Case E_POINTER
fnOLEError = " Invalid Pointer"
Case E_UNEXPECTED
fnOLEError = " Unknown Error"
Case S_OK
fnOLEError = " Success!"
End Select
End Function
' Routine : SaveClip2Bit
' Purpose : Saves Picture object to desired location.
' Arguments : Path to save the file
Public Sub SaveClip2Bit(savePath As String)
On Error GoTo errHandler:
AltPrintScreen
Pause (3)
SavePicture PastePicture, savePath
errExit:
Exit Sub
errHandler:
Debug.Print "Save Picture: (" & Err.Number & ") - " & Err.Description
Resume errExit
End Sub
' Routine : Pause
' Purpose : Gives a short interval for proper image capture.
' Arguments : Seconds to wait.
Public Function Pause(NumberOfSeconds As Variant)
On Error GoTo Err_Pause
Dim PauseTime As Variant, start As Variant
PauseTime = NumberOfSeconds
start = Timer
Do While Timer < start + PauseTime
DoEvents
Loop
Exit_Pause:
Exit Function
Err_Pause:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "Pause()"
Resume Exit_Pause
End Function
Use like this:
SaveClip2Bit "C:\test\test.bmp"
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
I have this lovely little procedure that is supposed to either shut down the window with the Acrobat display or just one document in it. Only the design is of my own making, meaning I don't fully understand the code, but I do know that it works only partially. It will quit Adobe Acrobat in full, regardless of how many documents are displayed but it can't close just one (as the original from which it was transcribed claimed that it could and should).
Private Sub CloseReaderDC(Optional ByVal MailIdx As Integer)
Dim WinId As String
Dim Wnd As LongPtr
If MailIdx Then
WinId = AcrobatWindowID(Mail(MailIdx))
Wnd = FindWindow(vbNullString, WinId)
PostMessage Wnd, WM_CLOSE, 0, ByVal 0&
Else
WinId = AcrobatWindowID
Wnd = FindWindow(WinId, vbNullString)
SendMessage Wnd, WM_CLOSE, 0, ByVal 0&
End If
End Sub
The logic is that the parameter MailIdx identifies a file name which is sufficient to find a top window. If no value is given the app should be shut down. This part works. The other part also works, but only if there is a single document open, in which case not the document is closed but the entire application. I believe this shutdown may be caused by Acrobat Reader itself which doesn't see a reason for staying open with no document to display. I also think that the window handle may not be found if there are several documents because FindWindow finds a top window only and the one I want to close would be the second one. In practice, I tried both, to close the existing before opening another one and after. In the one case the app gets shut down, in the other nothing happens.
I don't know why my tutor uses SendMessage in one case and PostMessage in the other. I also don't know if the window I'm after is a Child Window or how to get a handle on it if it is. Any suggestions?
Edit 11 Jan 2021
I used the following code to test #FaneDuru's solution.
Private Sub Test_CloseReaderDC()
ReDim Mail(2)
Mail(0) = ""
Mail(1) = "File1.PDF"
Mail(2) = "File2.PDF"
CloseReaderDC 1
End Sub
Private Sub CloseReaderDC(Optional ByVal MailIdx As Integer)
' NIC 003 ++ 10 Jan 2021
Dim WinTitle As String
Dim WinCap As String
Dim Wnd As LongPtr
WinTitle = AcrobatWindowID
If MailIdx Then
WinCap = AcrobatWindowID(Mail(MailIdx))
Wnd = FindWindow(vbNullString, WinCap)
Debug.Print Wnd
SendMessage Wnd, WM_CloseClick, 6038, ByVal 0&
Else
Wnd = FindWindow(WinTitle, vbNullString)
Debug.Print Wnd
SendMessage Wnd, WM_CLOSE, 0, ByVal 0&
End If
End Sub
Function AcrobatWindowID(Optional ByVal Wn As String)
' NIC 003 ++ 07 Jan 2021
Dim Fun As Boolean
Fun = CBool(Len(Wn))
If Fun Then Wn = Wn & " - "
AcrobatWindowID = Wn & Split("AcrobatSDIWindow,Adobe Acrobat Reader DC", ",")(Abs(Fun))
End Function
The code worked perfectly for both 1 or 2 files, not closing the app until called with a parameter of 0. But on second try it failed to find the window and therefore took no action.
I started Acrobat and selected the 2 previously opened files from its File>Open menu. File1 was in the first tab, File2 in the second, active. Then I attempted to delete File1 which failed. Then I called the code with 2 as parameter which closed the top file. Thereafter the code found the window for File1 and closed it.
I don't think the apparent rule is followed consistently, however. How the files were opened seems to make a difference. In my project the files are opened by hyperlink, one at a time. My above test therefore is not indicative of how FaneDuru's suggestion will work in my project but it proves that the solution works.
You did not say anything about my comment regarding closing the active document by programmatically pressing the File menu "Close File" control...
This way of closing does not make Acrobat application quitting. It stay open, even if only a document was open in the moment of running the code.
So, test the next code line, please. You need the Acrobat Reader DC handler and the necessary arguments, like following:
Const WM_CloseClick = &H111
SendMessage Wnd, WM_CloseClick, 6038, ByVal 0&
6038 is the 'Close File' File menu control ID.
I could determine it using the next function:
Private Function findControlID(mainWHwnd As LongPtr, ctlNo As Long) As Long
Dim aMenu As LongPtr, sMenu As LongPtr
aMenu = GetMenu(mainWHwnd): Debug.Print "Main menu = " & Hex(aMenu)
sMenu = GetSubMenu(aMenu, 0&): Debug.Print "File menu = " & Hex(sMenu)
mCount = GetMenuItemCount(sMenu): Debug.Print "File menu no of controls: " & mCount 'check if it is 28
findControlID = GetMenuItemID(sMenu, ctlNo - 1) 'Menu controls are counted starting from 0
End Function
The above function was called in this way:
Sub testFindCloseControlID()
Dim Wnd As LongPtr
'Wnd = findWindowByPartialTitle("Adobe Acrobat Reader DC") 'you will obtain it in your way
Debug.Print findControlID(Wnd, 15) '15 means the fiftheenth control of the File menu (0)
End Sub
15 has been obtained counting the horizontal controls separators, too.
In order to find "Adobe Acrobat Reader DC" window handler I used the function mentioned above, but this does not matter too much. You may use your way of determining it...
Please, test the above way and send some comments
Edited:
In order to extract the applications menu(s) captions, I use the next declarations:
Option Explicit
'APIs for identify a window handler
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As Long
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 GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As Long
'____________________________________________________
'Menu related APIs
Private Declare PtrSafe Function GetMenu Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetSubMenu Lib "user32" (ByVal hMenu As LongPtr, ByVal nPos As Long) As LongPtr
Private Declare PtrSafe Function GetMenuItemID Lib "user32" _
(ByVal hMenu As LongPtr, ByVal nPos As Long) As Long
Private Declare PtrSafe Function GetMenuItemCount Lib "user32" (ByVal hMenu As LongPtr) As Long
Private Declare PtrSafe Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As LongPtr, _
ByVal Un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare PtrSafe Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As LongPtr, _
ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
'_____________________________________________________
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As LongPtr
hbmpChecked As LongPtr
hbmpUnchecked As LongPtr
dwItemData As LongPtr
dwTypeData As String
cch As Long
hbmpItem As LongPtr
End Type
Private Const GW_HWNDNEXT = 2
And the next functions/subs:
To find any window knowing only its partial title:
Sub testFindWindByPartTitle()
Debug.Print findWindowByPartialTitle("Notepad")
End Sub
Private Function findWindowByPartialTitle(ByVal sCaption As String, Optional strSecond As String) As LongPtr
Dim lhWndP As LongPtr
Dim sStr As String
findWindowByPartialTitle = CLngPtr(0)
lhWndP = FindWindow(vbNullString, vbNullString) 'PARENT WINDOW
Do While lhWndP <> 0
sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, sStr, Len(sStr)
If Len(sStr) > 0 Then sStr = left$(sStr, Len(sStr) - 1)
If InStr(1, sStr, sCaption) > 0 And _
IIf(strSecond <> "", InStr(1, sStr, strSecond) > 0, 1 = 1) Then
findWindowByPartialTitle = lhWndP
Exit Do
End If
lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
Loop
End Function
A version of extract the necessary ID by control caption, but it works only for Notepad:
Private Sub TestfindMenuItemsByCaption()
Const NotePApp As String = "Notepad"
Debug.Print findMenuIDByString(NotePApp, "Save") 'it does work
Const pdfApp As String = "Adobe Acrobat Reader DC"
Debug.Print findMenuIDByString(pdfApp, "Close") 'it does not work
End Sub
Private Function findMenuIDByString(pdfApp As String, searchString As String) As Long
Dim mainWHwnd As LongPtr, aMenu As LongPtr, mCount As Long
Dim LookFor As Long, sMenu As LongPtr, sCount As Long
Dim LookSub As Long, sID As Long, sString As String
mainWHwnd = findWindowByPartialTitle(pdfApp)
aMenu = GetMenu(mainWHwnd): Debug.Print "Main menu = " & Hex(aMenu)
sMenu = GetSubMenu(aMenu, 0): Debug.Print "File menu = " & Hex(sMenu)
sCount& = GetMenuItemCount(sMenu)
For LookSub& = 0 To sCount& - 1
sID& = GetMenuItemID(sMenu, LookSub&): Debug.Print "ID = " & sID: 'Stop
sString$ = String$(100, " ")
Call GetMenuString(sMenu, sID&, sString$, 100&, 1&) ' 1&)
Debug.Print sString$ ': Stop
If InStr(LCase(sString$), LCase(searchString$)) Then
findMenuIDByString = sID
Exit Function
End If
Next LookSub&
End Function
And a second version, unfortunately working exactly in the same way. I mean, returning the ID only for Notepad:
Private Sub TestfindMenuItemsByCaptionBis()
Const NotePApp As String = "Notepad"
Debug.Print findMenuItemIDByCaption(NotePApp, "Save")
Const pdfApp As String = "Adobe Acrobat Reader DC"
Debug.Print findMenuItemIDByCaption(pdfApp, "Close")
End Sub
Private Function findMenuItemIDByCaption(strApp As String, strCaption As String)
Dim appHwnd As LongPtr, hMenu As LongPtr, fMenu As LongPtr, i As Long
Dim retval As Long, mii As MENUITEMINFO 'mii receives information about each item
Const WM_SaveClick = &H111, MIIM_STATE = &H1, MIIM_STRING = &H40&, MIIM_ID = &H2&, MIIM_CHECKMARKS = &H8&
Const MIIM_SUBMENU = &H4&, MIIM_TYPE = &H10, MIIM_FTYPE = &H100&, MIIM_DATA = &H20&
appHwnd = findWindowByPartialTitle(strApp)
If appHwnd = 0 Then MsgBox "No application window found...": Exit Function
hMenu = GetMenu(appHwnd) 'application window Menu
fMenu = GetSubMenu(hMenu, 0) 'app window 'File' Submenu
For i = 0 To GetMenuItemCount(fMenu)
With mii
.cbSize = Len(mii)
.fMask = MIIM_STATE Or MIIM_SUBMENU Or MIIM_TYPE
.dwTypeData = space(256)
.cch = 256
retval = GetMenuItemInfo(fMenu, i, 1, mii) '2 = the third menu item
Debug.Print left(.dwTypeData, .cch)
If InStr(left(.dwTypeData, .cch), strCaption) > 0 Then
findMenuItemIDByCaption = GetMenuItemID(fMenu, i): Exit Function
End If
End With
Next i
End Function
I tried all constants as I could find, but not success... If we would find a way, a subroutine could also read the recent files list and activate the needed one, if is not the active one is the necessary one.
Goal
Have an Excel file with a "Search" button that opens a custom program. This program is used for researches. If the program is already opened when the user clicks on the button, make it popup and focus on that given program.
Current Situation
Here's the code I'm trying to use to make it work:
Search Button
Private Sub btnSearch_Click()
Dim x As Variant
Dim Path As String
If Not IsAppRunning("Word.Application") Then
Path = "C:\Tmp\MyProgram.exe"
x = Shell(Path, vbNormalFocus)
End If
End Sub
IsAppRunning()
Function IsAppRunning(ByVal sAppName) As Boolean
Dim oApp As Object
On Error Resume Next
Set oApp = GetObject(, sAppName)
If Not oApp Is Nothing Then
Set oApp = Nothing
IsAppRunning = True
End If
End Function
This code will work only when I put "Word.Application" as the executable. If I try to put "MyProgram.Application" the function will never see the program is running. How can I find that "MyProgram.exe" is currently opened?
Further more, I'd need to put the focus on it...
You can check this more directly by getting a list of open processes.
This will search based on the process name, returning true/false as appropriate.
Sub exampleIsProcessRunning()
Debug.Print IsProcessRunning("MyProgram.EXE")
Debug.Print IsProcessRunning("NOT RUNNING.EXE")
End Sub
Function IsProcessRunning(process As String)
Dim objList As Object
Set objList = GetObject("winmgmts:") _
.ExecQuery("select * from win32_process where name='" & process & "'")
IsProcessRunning = objList.Count > 0
End Function
Here's how I brought the search window to front:
Private Const SW_RESTORE = 9
Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Sub btnSearch_Click()
Dim x As Variant
Dim Path As String
If IsProcessRunning("MyProgram.exe") = False Then
Path = "C:\Tmp\MyProgram.exe"
x = Shell(Path, vbNormalFocus)
Else
Dim THandle As Long
THandle = FindWindow(vbEmpty, "Window / Form Text")
Dim iret As Long
iret = BringWindowToTop(THandle)
Call ShowWindow(THandle, SW_RESTORE)
End If
End Sub
Now if the window was minimized and the user clicks the search button again, the window will simply pop up.
Just want to point out that the Window Text may change when documents are open in the application instance.
For example, I was trying to bring CorelDRAW to focus and everything would work fine so long as there wasn't a document open in Corel, if there was, I would need to pass the complete name to FindWindow() including the open document.
So, instead of just:
FindWindow("CorelDRAW 2020 (64-Bit)")
It would have to be:
FindWindow("CorelDRAW 2020 (64-Bit) - C:\CompletePath\FileName.cdr")
As that is what would be returned from GetWindowText()
Obviously this is an issue as you don't know what document a user will have open in the application, so for anyone else who may be coming here, years later, who may be experiencing the same issue, here's what I did.
Option Explicit
Private Module
Private Const EXE_NAME As String = "CorelDRW.exe"
Private Const WINDOW_TEXT As String = "CorelDRAW 2020" ' This is common with all opened documents
Private Const GW_HWNDNEXT = 2
Private Const SW_RESTORE = 9
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Sub FocusIfRunning(parAppName as String, parWindowText as String)
Dim oProcs As Object
Dim lWindowHandle As Long
Dim sWindowText As String
Dim sBuffer As String
' Create WMI object and execute a WQL query statement to find if your application
' is a running process. The query will return an SWbemObjectSet.
Set oProcs = GetObject("winmgmts:").ExecQuery("SELECT * FROM win32_process WHERE " & _
"name = '" & parAppName & "'")
' The Count property of the SWbemObjectSet will be > 0 if there were
' matches to your query.
If oProcs.Count > 0 Then
' Go through all the handles checking if the start of the GetWindowText()
' result matches your WindowText pre-file name.
' GetWindowText() needs a buffer, that's what the Space(255) is.
lWindowHandle = FindWindow(vbEmpty, vbEmpty)
Do While lWindowHandle
sBuffer = Space(255)
sWindowText = Left(sBuffer, GetWindowText(lWindowHandle, sBuffer, 255))
If Mid(sWindowText, 1, Len(parWindowText)) Like parWindowText Then Exit Do
' Get the next handle. Will return 0 when there are no more.
lWindowHandle = GetWindow(lWindowHandle, GW_HWNDNEXT)
Loop
Call ShowWindow(lWindowHandle , SW_RESTORE)
End If
End Sub
Private Sub btnFocusWindow_Click()
Call FocusIfRunning(EXE_NAME, WINDOW_TEXT)
End Sub
Hopefully somebody gets use from this and doesn't have to spend the time on it I did.
Just wanted to say thank you for this solution. Only just started playing around with code and wanted to automate my job a bit. This code will paste current selection in excel sheet into an already open application with as single click. Will make my life so much easier!!
Thanks for sharing
Public Const SW_RESTORE = 9
Public Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Sub updatepart()
'
' updatepart Macro
' copies current selection
' finds and focuses on all ready running Notepad application called Test
' pastes value into Notepad document
' Keyboard Shortcut: Ctrl+u
'
Dim data As Range
Set data = Application.Selection
If data.Count <> 1 Then
MsgBox "Selection is too large"
Exit Sub
End If
Selection.Copy
If IsProcessRunning("Notepad.EXE") = False Then
MsgBox "Notepad is down"
Else
Dim THandle As Long
THandle = FindWindow(vbEmpty, "Test - Notepad")
Dim iret As Long
iret = BringWindowToTop(THandle)
Call ShowWindow(THandle, SW_RESTORE)
End If
waittime (500)
'Call SendKeys("{F7}")
Call SendKeys("^v", True) '{F12}
Call SendKeys("{ENTER}")
End Sub
Function waittime(ByVal milliseconds As Double)
Application.Wait (Now() + milliseconds / 24 / 60 / 60 / 1000)
End Function
Function IsProcessRunning(process As String)
Dim objList As Object
Set objList = GetObject("winmgmts:") _
.ExecQuery("select * from win32_process where name='" & process & "'")
If objList.Count > 0 Then
IsProcessRunning = True
Else
IsProcessRunning = False
End If
End 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