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 !!