View member feedback to this tip.
Use this code to speed up exports to Excel by using the clipboard and pasting the results to Excel, rather than dealing with each cell. (Note: This is specific to our company's address book. You will have to change the database name and the view/column names.)
Code:
Declare Function EmptyClipboard Lib "User32" () As Long Declare Function lstrcpy Lib "kernel32" (Byval lpString1 As String, Byval lpString2 As Long) As Long Declare Function lstrcpy1 Lib "kernel32" Alias "lstrcpy" (Byval lpString1 As Long, Byval lpString2 As String) As Long Declare Function SetClipboardData Lib "User32" (Byval wFormat As Long, Byval hMem As Long) As Long Declare Function OpenClipboard Lib "User32" (Byval hwnd As Long) As Long Declare Function CloseClipboard Lib "User32" () As Long Declare Function GetClipboardData Lib "User32" (Byval wFormat As Long) As Long Declare Function GlobalAlloc Lib "kernel32" (Byval wFlags&, Byval dwBytes As Long) As Long Declare Function GlobalLock Lib "kernel32" (Byval hMem As Long) As Long Declare Function GlobalUnlock Lib "kernel32" (Byval hMem As Long) As Long Declare Function GlobalSize Lib "kernel32" (Byval hMem As Long) As Long Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 Sub Initialize Dim fn As String Dim ssn As New NotesSession Dim db As NotesDatabase Dim docs As NotesView Dim Doc As NotesDocument
Requires Free Membership to View
Register today to access targeted resources from our editorial writers and independent industry experts focused on Lotus Domino, Notes, Workplace and other related technologies.
Dim xlapp As Variant
Dim RowNo As Integer
Dim PasteStr As String
Dim vbTab As String
Dim pasterow As Integer
Dim tmpName As Notesname
vbTab = Chr$(9)
Set xlApp = CreateObject
("Excel.application")
xlApp.Visible = False
xlApp.Workbooks.Add
PasteStr = "Person" & vbtab &
"Last Name" & vbtab & "First Name" &
vbtab & _
"Department" & vbtab & "Position #"
& vbtab & "Position Name" & vbtab
& "Service Area" & vbtab & _
"Office Phone" & vbtab & "Direct Line"
& vbtab & "Cell Phone" & vbtab
& "Home Phone" & vbtab & _
"Notes Name" & vbtab &
"Internet Address"& vbtab &
"Office" & vbtab
setclipboardtext (pasteStr)
RowNo = 1
xlApp.cells(RowNo,1).pastespecial
Set ssn = New NotesSession
Set db = ssn.CurrentDatabase
' This is an alias for the
MNP Team/admin view
Set docs = db.GetView
("MNP_Administration")
Set doc = Docs.GetFirstDocument
pastestr = ""
pasterow = 2
Do Until doc Is Nothing
' Do Until RowNo > 10
If rowno Mod 10 = 0 Then
Print "Processing record # "
& rowno & " - " &
doc.lastname(0) & ", " &
doc.firstname(0)
End If
RowNo = RowNo + 1
' Doing around 4k at a time
seems to work well. If we get
much over that the
overhead of appending to a long
' string appears to outweigh the
benefit of the block paste.
If Len(pastestr) > 4096 Then
setclipboardtext (pasteStr)
xlApp.cells(pasterow,1).
pastespecial
pasterow = rowno
pastestr = ""
End If
Set tmpname = New notesname
(doc.fullname(0))
pasteStr = pastestr & doc.EmployeeId(0)
& vbtab & doc.LastName
(0) & vbtab & doc.FirstName(0)
& vbtab & _
doc.department(0) & vbtab
& Left$(doc.JobTitle(0),2) & vbtab &
Mid$(doc.JobTitle(0),6) & vbtab & _
doc.MNPspecialtyArea(0)
& vbtab & doc.OfficePhoneNumber(0) &
vbtab & doc.DirectPhone(0)
& vbtab & _
doc.CellPhoneNumber(0)
& vbtab & doc.PhoneNumber(0) & vbtab &
tmpName.Abbreviated & vbtab & _
doc.InternetAddress(0) & vbtab
& doc.OfficeCity(0) & vbtab &
Chr$(10)
Set doc = Docs.GetNextDocument(doc)
Loop
setclipboardtext (pasteStr)
xlApp.cells(pasterow,1).pastespecial
xlapp.Rows("1:1").Select
xlapp.Selection.HorizontalAlignment = 3
' xlCenter ??
xlapp.Selection.WrapText = 1
'True ??
xlapp.Selection.font.fontstyle="Bold"
xlapp.selection.font.ColorIndex = 27
With xlapp.selection.borders(7)
' Left Edge
.Weight = 4 ' xlThick
.colorindex = 27
End With
With xlapp.selection.borders(8)
' Top Edge
.Weight = 4
' xlThick
.colorindex = 27
End With
With xlapp.selection.borders(9)
' Bottom Edge
.Weight = 4
' xlThick
.colorindex = 27
End With
With xlapp.selection.borders(10)
'Right Edge
.Weight = 4
' xlThick
.colorindex = 27
End With
xlapp.selection.interior.ColorIndex = 11
xlApp.Columns("A:Z").Columns.AutoFit
xlApp.Range("A2").Select
xlapp.ActiveWindow.FreezePanes = 1
xlApp.Visible = True
Set xlapp = Nothing
End Sub
Function SetClipBoardText(MyString
As String)
Dim hGlobalMemory As Long,
lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND,
Len(MyString) + 1)
' Allocate movable global memory.
lpGlobalMemory = GlobalLock
(hGlobalMemory)
' Lock the block to get a far pointer to
this memory.
lpGlobalMemory = lstrcpy1
(lpGlobalMemory,MyString)
' Copy the string to this global memory
If GlobalUnlock(hGlobalMemory)
<> 0 Then
' Unlock the memory.
Msgbox "Could not unlock
memory location. Copy aborted."
Goto SetError
End If
If OpenClipboard(0&) = 0 Then
' Open the Clipboard to copy data to.
Msgbox "Could not open the
Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
' Clear the Clipboard.
hClipMemory = SetClipboardData
(CF_TEXT, hGlobalMemory)
' Copy the data to the Clipboard
SetError:
If CloseClipboard() = 0 Then
Msgbox "Could not close Clipboard."
End If
End Function
If the comparison here is to copying data row by row using OLE automation, I wonder whether you couldn't get a corresponding speed increase with some way of copying multiple rows at a time via OLE automation? I don't know that it's possible; I just have to wonder.
FYI: This tip should disclose that it is a Windows-only solution.
Do you have comments on this tip? Let us know.
This tip was submitted to the SearchDomino.com tip exchange by member Matt Kiazyk. Please let others know how useful it is via the rating scale below. Do you have a useful Notes/Domino tip or code to share? Submit it to our monthly tip contest and you could win a prize and a spot in our Hall of Fame.
This was first published in May 2004