logo标签列表

我能获取Excel剪贴板数据的源范围吗？

vbaclipboardexcel-2003clipboarddata
8
如果剪贴板包含Excel工作表范围，您可以使用DataObject对象访问该范围的数据。
您还可以找到该数据的实际源范围（即工作表、行和列）吗？
或者，您能否找到最后复制的范围，其中使用虚线轮廓边框（而不是所选范围）？
最好使用Excel 2003 VBA。
3个回答
4

以下代码用于在 Excel 2019 64 位中获取剪贴板上单元格的区域范围，而不是单元格的内容。

fGetClipRange 返回一个区域对象，该对象包括被剪切或复制到剪贴板上的 Excel 区域、工作簿和工作表。它直接从剪贴板读取数据，采用“Link”格式，并需要该格式的 ID 号。注册格式所关联的 ID 号可能会改变，因此 fGetFormatId 根据格式名称查找当前格式 ID 号。使用 Application.CutCopyMode 来确定单元格是被剪切还是被复制。

这个网站对于在 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
2
另外一种基于“链接”格式的方法在这里也可以找到：https://stackoverflow.com/a/23119068/2981328 - hymced
1
哇，这是我在网上看到的最漂亮的代码之一。除了第一次尝试就完美运行外，您还非常注意每个步骤的正确处理，每个异常的处理，您的变量名称易于理解且有良好的前缀，注释精彩，易于理解和简单的英语，我喜欢您如何通过在侧面放置注释来使代码块连续，您将繁重的过程放入自己的子程序 fGetFormatId 中，而不是让主要过程变得两倍长，难以理解。 - johny why
1
这种方法比“Worksheet_SelectionChange”要不那么显眼得多，因为这种方法不需要每次用户单击工作表时都运行VBA。那样会引来麻烦。 - johny why
1
我为你无畏地使用GoTo而鼓掌:D，我没有看到任何风险，但我还没有研究过它。 - johny why
1
我理解这种复杂性的必要性，但我希望有一个更简单的实现。请注意，你两次使用了 If OpenClipboard(0&) = 0。这是一个条件和一个 API 调用。你能否将 If OpenClipboard(0&) = 0 Then GoTo conDone 更改为 If lngRangeLink = 0 Then GoTo conDone？ - johny why
显示剩余2条评论
2

没有直接的方法可以做到，看起来剪贴板对象只包含单元格的值（虽然Excel显然以某种方式记住了边框）：

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

请注意，您需要引用Microsoft Forms 2.0库才能运行此代码（如果单元格中没有值也会导致失败）。
话虽如此，您可以尝试以下操作 - 将其添加到VBA编辑器中的一个模块。
Public NewRange As String 
Public OldRange As String 
Public SaveRange As String 
Public ChangeRange As Boolean

在表格对象中使用以下内容：
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

看起来似乎可以工作，但是由于试图解决剪贴板问题，它也可能容易出现不同的错误。 http://www.ozgrid.com/forum/showthread.php?t=66773

0

我完全重写了之前的答案，因为我需要将其他类型的数据除了范围之外导入Excel。新代码更加通用，并将剪贴板中的不同格式作为字符串获取。提取Excel范围变得更加简单，我还将其用于位图和文本。

最后一个例程获取非内置格式的数字。中间例程按指定格式将剪贴板内容作为字符串获取。第一个例程使用split函数从此字符串解析Excel范围。

'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
1
我尝试使用这段代码。由于有许多函数，所以我有点困惑，如何使用此代码来获取复制的（虚线边框）范围。例如，如果我想在msgBox或Debug.Print中查看复制的范围，我该如何获取，请帮忙解答？ - Zohir Emon
MsgBox(fGetClipboardRange.Address) - Oddclock
1
嗨@oddClock，感谢您的回复。您能否帮忙发布32位和64位Excel的代码？据我所知，我必须使用#If VBA7 Then（需要添加PtrSafe）... #Else... .#End If。我已经尝试过这种方法，但它不起作用。任何与#win64相关的内容，抱歉我不熟悉代码转换。 - Zohir Emon
嗨，Zohir Emon- 我添加了32位开关，但我没有测试机器。请告诉我这是否适用于您。 - Oddclock
1
我已经测试过了。在32位和64位的Excel中都可以正常工作。你在Excel世界里很厉害。@oddclock - Zohir Emon
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接