You're lucky, this was easier than I thought it would be at first sight.
My first thought was you would need to get the correct clipboard format, it
turns out you can use tab delimited data with a CrLf line delimiter as the
data to use on the clipboard and it will paste into the cells correctly,
Paste the following code into a module.
' ********** Code Start *************
Option Compare Database
Option Explicit
Private Const GHND = &H42
Private Const MAXSIZE = 4096
Private Const CF_TEXT = 1
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal _
dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) _
As Long
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _
As Long
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 EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long
Private Sub 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 Sub
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 Sub
Sub rsToClipboard(RHS As DAO.Recordset)
Dim strClip As String
Dim varRows As Variant
Dim intCol As Integer
With RHS
If Not (.EOF And .BOF) Then
.MoveFirst
strClip = ""
Do Until .EOF
varRows = RHS.GetRows
For intCol = 0 To UBound(varRows, 1)
strClip = strClip & varRows(intCol, 0) & vbTab
Next
strClip = strClip & vbCrLf
Loop
End If
End With
Call ClipBoard_SetData(strClip)
End Sub
' ********** Code End *************
You then just pass your DAO recordset to rsToClipboard, if you're using an
ADO recordset you would replace Sub rsToClipboard ... with the following
Sub rsToClipboard(RHS As ADODB.Recordset)
Dim strClip As String
Dim varRows As Variant
Dim intCol As Integer
Dim lngRow As Long
With RHS
If Not (.EOF And .BOF) Then
.MoveFirst
strClip = ""
varRows = RHS.GetRows
For lngRow = 0 To UBound(varRows, 2)
For intCol = 0 To UBound(varRows, 1)
strClip = strClip & varRows(intCol, lngRow) & vbTab
Next
strClip = strClip & vbCrLf
Next
End If
End With
Call ClipBoard_SetData(strClip)
End Sub
