Trucos Formatos propios en el portapapeles

Vamos a ver como utilizar el prtapapeles con formatos de datos propios.
Para ello ponemos en un módulo :

Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MOVEABLE = &H2

Private Declare Sub CopyMemToPtr Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, Source As Any, ByVal Length As Long)
Private Declare Sub CopyMemFromPtr Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function SetClipboardDataAPI Lib "user32" Alias "SetClipboardData" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardDataAPI Lib "user32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long

Dim m_colFormats As Collection

'*******************************************************************************
' Map a Format Name string to a clipboard Type ID
'-------------------------------------------------------------------------------

Private Function FormatID(ByVal FormatName As String) As Long

    ' Modify the FormatName incase the user has specified a number.

    FormatName = "!" & FormatName

    ' Ensure that the collection for mapping FormatNames to clipboard Type IDs
    ' has been instanciated

    If m_colFormats Is Nothing Then Set m_colFormats = New Collection

    ' Retrieve the Type ID for this Format Name

    Dim lng As Long
    On Error GoTo ErrorTrap
    lng = m_colFormats(FormatName)
Continue:
    FormatID = lng
    Exit Function

ErrorTrap:

    ' Whoops! The FormatName has not yet been registered with the clipboard.
    ' Register it, and then continue.

    lng = RegisterClipboardFormat(FormatName)
    m_colFormats.Add lng, FormatName
    Resume Continue
End Function

'*******************************************************************************
'
'-------------------------------------------------------------------------------

'*******************************************************************************
' Write custom data to the clipboard.
'-------------------------------------------------------------------------------

Public Sub SetClipboardData(ByVal FormatName As String, Data As Variant, _
                                            Optional ByVal hWnd As Long)

    If hWnd = 0 Then hWnd = GetDesktopWindow()

    ' Determine clipboard format ID

    Dim lngFormatID As Long
    lngFormatID = FormatID(FormatName)

    If (lngFormatID = 0) Then
        Err.Raise vbObjectError, "modClipBoard::SetClipboardData()", _
            "modClipBoard::SetClipboardData() - Failed to register data type"
        Exit Sub
    Else

        ' Determine the type of data being passed in

        Dim intVarType As Integer
        intVarType = VarType(Data)

        ' Copy the data into an array of bytes

        Dim byt() As Byte
        Dim lngDataLen As Long
        Select Case intVarType
        Case vbString, vbArray, 8209
            byt = Data
        Case vbByte
            Dim b As Byte
            b = Data
            ReDim byt(0 To LenB(b) - 1) As Byte
            CopyMemory byt(0), b, LenB(b)
        Case vbLong
            Dim l As Long
            l = Data
            ReDim byt(0 To LenB(l) - 1) As Byte
            CopyMemory byt(0), l, LenB(l)
        Case vbInteger
            Dim i As Integer
            i = Data
            ReDim byt(0 To LenB(i) - 1) As Byte
            CopyMemory byt(0), i, LenB(i)
        Case vbSingle
            Dim s As Single
            s = Data
            ReDim byt(0 To LenB(s) - 1) As Byte
            CopyMemory byt(0), s, LenB(s)
        Case vbDouble
            Dim d As Double
            d = Data
            ReDim byt(0 To LenB(d) - 1) As Byte
            CopyMemory byt(0), d, LenB(d)
        Case vbCurrency
            Dim c As Currency
            c = Data
            ReDim byt(0 To LenB(c) - 1) As Byte
            CopyMemory byt(0), c, LenB(c)
        Case vbDate
            Dim dte As Date
            dte = Data
            ReDim byt(0 To LenB(dte) - 1) As Byte
            CopyMemory byt(0), dte, LenB(dte)
        Case vbBoolean
            Dim bln As Boolean
            bln = Data
            ReDim byt(0 To LenB(bln) - 1) As Byte
            CopyMemory byt(0), bln, LenB(bln)
        Case Else
            Err.Raise vbObjectError, "modClipBoard::SetClipboardData()", _
                "modClipBoard::SetClipboardData() - Unsupported Data Type"
        End Select

        ' Determine the length of the data

        lngDataLen = UBound(byt) - LBound(byt) + 1

        ' Allocate global memory accordingly

        Dim lngGlobalHandle As Long
        lngGlobalHandle = GlobalAlloc(GMEM_ZEROINIT Or GMEM_MOVEABLE, _
                                                        lngDataLen + 6)
        If lngGlobalHandle = 0 Then
            Err.Raise vbObjectError, "modClipBoard::SetClipboardData()", _
                "modClipBoard::SetClipboardData() - Failed to allocate " & _
                                                "memory in the clipboard"
            Exit Sub
        Else

            Dim lngGlobalPtr As Long
            lngGlobalPtr = GlobalLock(lngGlobalHandle)

            ' Copy the data into the global memory allocated

            CopyMemToPtr lngGlobalPtr, intVarType, 2 ' Data Type
            CopyMemToPtr lngGlobalPtr + 2, lngDataLen, 4 ' Data Length
            CopyMemToPtr lngGlobalPtr + 6, byt(LBound(byt)), lngDataLen ' Data

            ' Insert the data into the clipboard

            Dim lngRet As Long
            If OpenClipboard(hWnd) Then
                lngRet = GlobalUnlock(lngGlobalHandle)
                lngGlobalHandle = SetClipboardDataAPI(lngFormatID, _
                                                        lngGlobalHandle)
                lngRet = CloseClipboard()
            Else
                'Avoid memory leakage If OpenClipboard fails
                lngRet = GlobalFree(lngGlobalHandle)
                Err.Raise vbObjectError, "modClipBoard::SetClipboardData()", _
                    "modClipBoard::SetClipboardData() - Failed to open " & _
                                                            "the clipboard"
            End If
        End If
    End If
End Sub

'*******************************************************************************
' Read custom data from the clipboard.
'-------------------------------------------------------------------------------

Public Function GetClipboardData(ByVal FormatName As String, Data As Variant, _
                                        Optional ByVal hWnd As Long) As Long

    GetClipboardData = 0
    If hWnd = 0 Then hWnd = GetDesktopWindow()

    ' Determine the Clipboard ID of the named format

    Dim lngFormatID As Long
    lngFormatID = FormatID(FormatName)

    ' Check to see if the clipboard has any data of this type

    If IsClipboardFormatAvailable(lngFormatID) Then
        If OpenClipboard(hWnd) Then

            ' Get a hadle to the data on the clipboard, and from that,
            ' a pointer from which to extract the data

            Dim lngGlobalHandle As Long
            lngGlobalHandle = GetClipboardDataAPI(lngFormatID)

            Dim lngGlobalPtr As Long
            lngGlobalPtr = GlobalLock(lngGlobalHandle)

            ' Extract the data type, and number of bytes of data
            ' from the Clipboard

            Dim intVarType As Integer
            CopyMemFromPtr intVarType, lngGlobalPtr, 2

            Dim lngDataLen As Long
            CopyMemFromPtr lngDataLen, lngGlobalPtr + 2, 4

            ' Extract the data from the clipboard

            lngGlobalPtr = lngGlobalPtr + 6

            Select Case intVarType
            Case vbString, vbArray, 8209
                ReDim buf(0 To lngDataLen - 1) As Byte
                CopyMemFromPtr buf(0), lngGlobalPtr, lngDataLen - 1
                Data = buf
                GetClipboardData = UBound(buf) - LBound(buf) + 1
            Case vbByte
                Dim b As Byte
                CopyMemFromPtr b, lngGlobalPtr, LenB(b)
                Data = b
                GetClipboardData = Len(b)
            Case vbLong
                Dim l As Long
                CopyMemFromPtr l, lngGlobalPtr, LenB(l)
                Data = l
                GetClipboardData = Len(l)
            Case vbInteger
                Dim i As Integer
                CopyMemFromPtr i, lngGlobalPtr, LenB(i)
                Data = i
                GetClipboardData = Len(i)
            Case vbSingle
                Dim s As Single
                CopyMemFromPtr s, lngGlobalPtr, LenB(s)
                Data = s
                GetClipboardData = Len(s)
            Case vbDouble
                Dim d As Double
                CopyMemFromPtr d, lngGlobalPtr, LenB(d)
                Data = d
                GetClipboardData = Len(d)
            Case vbCurrency
                Dim c As Currency
                CopyMemFromPtr c, lngGlobalPtr, LenB(c)
                Data = c
                GetClipboardData = Len(c)
            Case vbDate
                Dim dte As Date
                CopyMemFromPtr dte, lngGlobalPtr, LenB(dte)
                Data = dte
                GetClipboardData = Len(dte)
            Case vbBoolean
                Dim bln As Boolean
                CopyMemFromPtr bln, lngGlobalPtr, LenB(bln)
                Data = bln
                GetClipboardData = Len(bln)
            Case Else
                Err.Raise vbObjectError, "modClipBoard::GetClipboardData()", _
                    "modClipBoard::GetClipboardData() - Unsupported Data Type"
            End Select

            ' Release the memory, and close the connection to the clipboard

            Dim lngRet As Long
            lngRet = GlobalUnlock(lngGlobalHandle)
            lngRet = CloseClipboard()

        End If
    End If
End Function


Vamos a ver un ejemplo. Definiremos un tipo de dato, le daremos valores, lo mandaremos al portapapeles, lo vaciaremos y lo volveremos a leer del portapapeles.

Private Type Persona
    Nombre As String * 30
    Apellidos As String * 60
    Dni As Long
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Dim P As Persona, var() As Byte, l As Long

P.Nombre = "José"
P.Apellidos = "Rubí de la Vega"
P.Dni = 9378093
'como VB se empeña en no dejarnos pasar p como parámetro a la función ...
l = LenB(P)
ReDim var(l)
CopyMemory var(0), P, l
'lo ponemos en el portapales
SetClipboardData "FormatoPepe1", var
'borramos los datos
P.Nombre = "": P.Dni = 0: P.Apellidos = ""
'lo volvemos a leer del portapapeles
GetClipboardData "FormatoPepe1", var
CopyMemory P, var(0), l
Debug.Print P.Nombre

Y funciona !!



Trucos Trucos

Visual Basic Página de Visual Basic

Página principal Página principal

www.jrubi.com