Lotus Domino script snippet export any Notes view to Excel

This piece of LotusScript can export any Notes view to Excel.


Option Public
Option Declare
' Excel Contants 
' Excel Class XlSortOrder
Const xlAscending = 1
Const xlDescending = 2

%REM
' Excel Class XlSortType (Pivot only)
Const xlSortValues = 1
Const xlSortLabels = 2
%END REM

' Excel Class XlYesNoGuess (Header)
Const xlGuess = 0
Const xlYes = 1
Const xlNo = 2

' Excel Class Constants
Const xlTopToBottom = 1
Const xlLeftToRight = 2

' Excel Class XlSortOrientation
' Don't use this! Probably wrong. Use xlTopToBottom 
' and xlLeftToRight defined in Excel Class Constants.
' Even Excel 2002 (Office XP) uses xlTopToBottom and 
' xlLeftToRight in recorded macros.
Const xlSortColumns = 1
Const xlSortRows = 2

' Excel Class XlSortMethod
Const xlPinYin = 1
Const xlStroke = 2

' Excel Class XlSortDataOption
Const xlSortNormal = 0
Const xlSortTextAsNumbers = 1
Sub Initialize
	
	Dim workspace As NotesUIWorkspace
	Dim uiview As NotesUIView
	Dim view As NotesView
	Dim column As NotesViewColumn
	Dim viewentries As NotesViewEntryCollection
	Dim viewnav As NotesViewNavigator
	Dim viewentry As NotesViewEntry
	Dim session As NotesSession
	Dim db As NotesDatabase
	Dim dc As NotesDocumentCollection		
	Dim doc As NotesDocument
	Dim askme As Integer
	Dim entryvalues As Variant, handle As Variant, wbook As Variant, wsheet As Variant, viewcolumns As Variant
	Dim currententry As String, currentprocess As String, viewname As String, filename As String
	Dim columnheadings As String, columnvalues As String, columntitle As String
	Dim counter As Integer, x As Integer, y As Integer ,slashpos As Integer, spacepos As Integer
	Dim hyphenpos As Integer, filenum As Integer, mycounter As Integer, commapos As Integer
	
	On Error GoTo processerror	
	
	'set objects
	currentprocess = "setting objects"
	Set session = New NotesSession
	Set db = session.CurrentDatabase
	Set workspace = New NotesUIWorkspace
	Set uiview = workspace.CurrentView
	Set view = uiview.View
	'Set view = db.GetView("Export")
	Call view.Resortview("Company")
	
	'NEW
	Dim vwLU As NotesView
	Set vwLU = db.GetView("Export")
	Set viewnav = vwLU.Createviewnav()
	'Set viewnav = view.CreateViewNav()
	
	%REM
	askme = workspace.Prompt(PROMPT_YESNO, "Sorted Columns", "Please make sure that no column is sorted before exporting to Excel" & Chr(13) _
	& "Do you want to continue the export?")
	If askme <> 1 Then
		Print "Export aborted"
		Exit Sub
	End If	
	%END REM

	
	'get the current view's name and replace all backslashes with a hyphen
	currentprocess = "getting the view name and replacing backslashes with hyphens"
	viewname = view.Name
	slashpos = InStr(viewname, "\")
	If slashpos > 0 Then
		Do While slashpos > 0
			Mid(viewname, slashpos) = "-"
			slashpos = InStr(viewname, "\")			
		Loop
	End If
	
	'now replace all forward slashes with a hyphen
	currentprocess = "replacing all forward slashes in the view name with hyphens"
	slashpos = InStr(viewname, "/")
	If slashpos > 0 Then
		Do While slashpos > 0
			Mid(viewname, slashpos) = "-"
			slashpos = InStr(viewname, "/")
		Loop
	End If	
	
	'reduce view name to a maximum of 31 characters but keep whole words only (cut at first space or hyphen encountered)
	currentprocess = "truncating the view name to 31 characters (whole words only)"
	If Len(viewname) > 31 Then
		viewname = Right(viewname, 31)
		spacepos = InStr(viewname, " ")
		hyphenpos = InStr(viewname, "-")
		If spacepos < hyphenpos Then 
			viewname = Right(viewname, Len(viewname) - spacepos) 
		Else 
			viewname = Right(viewname, Len(viewname) - hyphenpos) 
		End If
	End If 
	'collect the selected documents 
	currentprocess = "collecting the selected documents" 
	Set dc = db.UnprocessedDocuments 
	'check that documents have been selected at all 
	currentprocess = "checking that documents were selected at all" 
	If dc.count = 0 Then 
		Msgbox "You must select the documents you wish to export. Press CTRL+A to select all documents", 0 + 48, "Error !" 
		Exit Sub 
	End If 
	'if documents have been selected create text file 
	currentprocess = "creating a text file for output" 
	filenum = Freefile() 
	filename = "c:\temp\" & viewname & ".xls" 
	Open filename For Output As filenum 
	'create header row in text file 
	currentprocess = "recreating the column names as header in the text file" 
	'viewcolumns = view.Columns 
	viewcolumns = vwLU.Columns 
	Set column = viewcolumns(Lbound(viewcolumns)) 
	columnheadings = column.Title 
	For x = (Lbound(viewcolumns) + 1) To Ubound(viewcolumns) 
		Set column = viewcolumns(x) 
		columnheadings = columnheadings & " " & column.Title 
	Next 
	Print #filenum, columnheadings 
	'access each selected document in turn 
	currentprocess = "starting to process each document in turn" 
	Set doc = dc.GetFirstDocument 
	mycounter = 0 
	counter = 1 
	Do 
		counter = counter + 1 
		currentprocess = "accessing the view entry corresponding to the current document" 
		'get the view entry corresponding to the current selected document 
		Set viewentry = viewnav.GetEntry(doc) 
		If viewentry Is Nothing Then 
			Print #filenum, "Document ID " & doc.UniversalID & _ 
			" appears under multiple categories. Unable to export, please transfer the data manually." 
		Else 
			'Redim entryvalues(0) 
			entryvalues = viewentry.ColumnValues 
			If Isarray(entryvalues) Then 
				currentprocess = "creating each column value in its respective cell" 
				'create each column value in its respective cell 
				columnvalues = entryvalues(Lbound(entryvalues)) 
				For y = (Lbound(entryvalues)+1) To UBound(entryvalues) 
					currentprocess = "replacing any comma in the entry with a semicolon" 
					'seek and replace commas in entry 
					currententry = entryvalues(y) 
					commapos = Instr(currententry, ",") 
					If commapos > 0 Then
						Do While commapos > 0
							Mid(currententry, commapos) = ";"
							commapos = InStr(currententry, ",")
						Loop
						entryvalues(y) = currententry
					End If	
					columnvalues = columnvalues & "	" & entryvalues(y)
				Next
				currentprocess = "writing the current view entry to the file"
				Print #filenum, columnvalues
			End If
		End If
		
		'reporting how many documents of how many in total have been exported so far
		currentprocess = "reporting progress in status bar"		
		mycounter = mycounter + 1
		Print "Exporting " & CStr(mycounter) & "/" & dc.Count & " documents."
		
		currentprocess = "accessing the next selected document in the list"
		'get the next selected document		
		Set doc = dc.GetNextDocument(doc)
	Loop Until (doc Is Nothing)
	
	currentprocess = "closing the file"
	Close filenum
	
	'create Excel sheet
	currentprocess = "creating an Excel spreadsheet"
	Set handle = CreateObject("Excel.Application")
	handle.visible = False
	Set wbook = handle.Workbooks.Open(filename)
	Set wsheet = handle.Application.Workbooks(1).Worksheets(1)
	
	'format spreadsheet
	currentprocess = "formatting the spreadsheet"
	wsheet.Name = viewname
	wsheet.Cells.Font.Size = 8
	wsheet.Rows("1:1").Select
	wsheet.Rows("1:1").AutoFilter
	wsheet.Rows("1:1").Font.Bold = True
	wsheet.Rows("1:1").RowHeight = 18
	wsheet.Cells.EntireColumn.Autofit
	'return to cell A2 for tidyness
	wsheet.Range("A2").Select
	handle.Activewindow.FreezePanes = 1
	
	'NEW
	'SORTING...
	Call wsheet.Cells.Select
	Call handle.Selection.Sort(wsheet.Range("A1"), xlAscending, Null, Null, Null, Null, Null, xlYes, 1, False, xlTopToBottom, xlPinYin, xlSortNormal, xlSortNormal, xlSortNormal)	
	wsheet.Range("A1").Select
	'Call wbook.save(True)
	handle.displayAlerts = False
	Call wbook.SaveAs(filename, -4143, "", "", False, False)
	handle.displayAlerts = True
	handle.Visible = True
	'handle.quit
	Set handle = Nothing ' free up the memory
	currentprocess = "terminating the export job"
	Exit Sub
	
processerror:
	If Err = 208 Then
		MsgBox "It appears you do not have Microsoft Excel on your computer. " & _
		"Although they won't be displayed on screen the exported data are still available " & _
		"in " & filename, 0 + 64, "Warning !"
	Else
		MsgBox "Error " & Err & " occurred whilst " & currentprocess	& ", line " & Erl & ", execution aborted.", 0 + 48, "Error !"
	End If
	
	Exit Sub
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

Option Public

Option Declare

' Excel Contants

' Excel Class XlSortOrder

Const xlAscending = 1

Const xlDescending = 2

%REM

' Excel Class XlSortType (Pivot only)

Const xlSortValues = 1

Const xlSortLabels = 2

%END REM

' Excel Class XlYesNoGuess (Header)

Const xlGuess = 0

Const xlYes = 1

Const xlNo = 2

' Excel Class Constants

Const xlTopToBottom = 1

Const xlLeftToRight = 2

' Excel Class XlSortOrientation

' Don't use this! Probably wrong. Use xlTopToBottom

' and xlLeftToRight defined in Excel Class Constants.

' Even Excel 2002 (Office XP) uses xlTopToBottom and

' xlLeftToRight in recorded macros.

Const xlSortColumns = 1

Const xlSortRows = 2

' Excel Class XlSortMethod

Const xlPinYin = 1

Const xlStroke = 2

' Excel Class XlSortDataOption

Const xlSortNormal = 0

Const xlSortTextAsNumbers = 1

Sub Initialize

Dim workspace As NotesUIWorkspace

Dim uiview As NotesUIView

Dim view As NotesView

Dim column As NotesViewColumn

Dim viewentries As NotesViewEntryCollection

Dim viewnav As NotesViewNavigator

Dim viewentry As NotesViewEntry

Dim session As NotesSession

Dim db As NotesDatabase

Dim dc As NotesDocumentCollection

Dim doc As NotesDocument

Dim askme As Integer

Dim entryvalues As Variant, handle As Variant, wbook As Variant, wsheet As Variant, viewcolumns As Variant

Dim currententry As String, currentprocess As String, viewname As String, filename As String

Dim columnheadings As String, columnvalues As String, columntitle As String

Dim counter As Integer, x As Integer, y As Integer ,slashpos As Integer, spacepos As Integer

Dim hyphenpos As Integer, filenum As Integer, mycounter As Integer, commapos As Integer

On Error GoTo processerror

'set objects

currentprocess = "setting objects"

Set session = New NotesSession

Set db = session.CurrentDatabase

Set workspace = New NotesUIWorkspace

Set uiview = workspace.CurrentView

Set view = uiview.View

'Set view = db.GetView("Export")

Call view.Resortview("Company")

'NEW

Dim vwLU As NotesView

Set vwLU = db.GetView("Export")

Set viewnav = vwLU.Createviewnav()

'Set viewnav = view.CreateViewNav()

%REM

askme = workspace.Prompt(PROMPT_YESNO, "Sorted Columns", "Please make sure that no column is sorted before exporting to Excel" & Chr(13) _

& "Do you want to continue the export?")

If askme <> 1 Then

Print "Export aborted"

Exit Sub

End If

%END REM

'get the current view's name and replace all backslashes with a hyphen

currentprocess = "getting the view name and replacing backslashes with hyphens"

viewname = view.Name

slashpos = InStr(viewname, "\")

If slashpos > 0 Then

Do While slashpos > 0

Mid(viewname, slashpos) = "-"

slashpos = InStr(viewname, "\")

Loop

End If

'now replace all forward slashes with a hyphen

currentprocess = "replacing all forward slashes in the view name with hyphens"

slashpos = InStr(viewname, "/")

If slashpos > 0 Then

Do While slashpos > 0

Mid(viewname, slashpos) = "-"

slashpos = InStr(viewname, "/")

Loop

End If

'reduce view name to a maximum of 31 characters but keep whole words only (cut at first space or hyphen encountered)

currentprocess = "truncating the view name to 31 characters (whole words only)"

If Len(viewname) > 31 Then

viewname = Right(viewname, 31)

spacepos = InStr(viewname, " ")

hyphenpos = InStr(viewname, "-")

If spacepos < hyphenpos Then

viewname = Right(viewname, Len(viewname) - spacepos)

Else

viewname = Right(viewname, Len(viewname) - hyphenpos)

End If

'collect the selected documents

currentprocess = "collecting the selected documents"

Set dc = db.UnprocessedDocuments

'check that documents have been selected at all

currentprocess = "checking that documents were selected at all"

If dc.count = 0 Then

Msgbox "You must select the documents you wish to export. Press CTRL+A to select all documents", 0 + 48, "Error !"

Exit Sub

End If

'if documents have been selected create text file

currentprocess = "creating a text file for output"

filenum = Freefile()

filename = "c:\temp\" & viewname & ".xls"

Open filename For Output As filenum

'create header row in text file

currentprocess = "recreating the column names as header in the text file"

'viewcolumns = view.Columns

viewcolumns = vwLU.Columns

Set column = viewcolumns(Lbound(viewcolumns))

columnheadings = column.Title

For x = (Lbound(viewcolumns) + 1) To Ubound(viewcolumns)

Set column = viewcolumns(x)

columnheadings = columnheadings & " " & column.Title

Print #filenum, columnheadings

'access each selected document in turn

currentprocess = "starting to process each document in turn"

Set doc = dc.GetFirstDocument

mycounter = 0

counter = 1

counter = counter + 1

currentprocess = "accessing the view entry corresponding to the current document"

'get the view entry corresponding to the current selected document

Set viewentry = viewnav.GetEntry(doc)

If viewentry Is Nothing Then

Print #filenum, "Document ID " & doc.UniversalID & _

" appears under multiple categories. Unable to export, please transfer the data manually."

Else

'Redim entryvalues(0)

entryvalues = viewentry.ColumnValues

If Isarray(entryvalues) Then

currentprocess = "creating each column value in its respective cell"

'create each column value in its respective cell

columnvalues = entryvalues(Lbound(entryvalues))

For y = (Lbound(entryvalues)+1) To UBound(entryvalues)

currentprocess = "replacing any comma in the entry with a semicolon"

'seek and replace commas in entry

currententry = entryvalues(y)

commapos = Instr(currententry, ",")

If commapos > 0 Then

Do While commapos > 0

Mid(currententry, commapos) = ";"

commapos = InStr(currententry, ",")

Loop

entryvalues(y) = currententry

End If

columnvalues = columnvalues & " " & entryvalues(y)

currentprocess = "writing the current view entry to the file"

Print #filenum, columnvalues

End If

'reporting how many documents of how many in total have been exported so far

currentprocess = "reporting progress in status bar"

mycounter = mycounter + 1

Print "Exporting " & CStr(mycounter) & "/" & dc.Count & " documents."

currentprocess = "accessing the next selected document in the list"

'get the next selected document

Set doc = dc.GetNextDocument(doc)

Loop Until (doc Is Nothing)

currentprocess = "closing the file"

Close filenum

'create Excel sheet

currentprocess = "creating an Excel spreadsheet"

Set handle = CreateObject("Excel.Application")

handle.visible = False

Set wbook = handle.Workbooks.Open(filename)

Set wsheet = handle.Application.Workbooks(1).Worksheets(1)

'format spreadsheet

currentprocess = "formatting the spreadsheet"

wsheet.Name = viewname

wsheet.Cells.Font.Size = 8

wsheet.Rows("1:1").Select

wsheet.Rows("1:1").AutoFilter

wsheet.Rows("1:1").Font.Bold = True

wsheet.Rows("1:1").RowHeight = 18

wsheet.Cells.EntireColumn.Autofit

'return to cell A2 for tidyness

wsheet.Range("A2").Select

handle.Activewindow.FreezePanes = 1

'NEW

'SORTING...

Call wsheet.Cells.Select

Call handle.Selection.Sort(wsheet.Range("A1"), xlAscending, Null, Null, Null, Null, Null, xlYes, 1, False, xlTopToBottom, xlPinYin, xlSortNormal, xlSortNormal, xlSortNormal)

wsheet.Range("A1").Select

'Call wbook.save(True)

handle.displayAlerts = False

Call wbook.SaveAs(filename, -4143, "", "", False, False)

handle.displayAlerts = True

handle.Visible = True

'handle.quit

Set handle = Nothing ' free up the memory

currentprocess = "terminating the export job"

Exit Sub

processerror:

If Err = 208 Then

MsgBox "It appears you do not have Microsoft Excel on your computer. " & _

"Although they won't be displayed on screen the exported data are still available " & _

"in " & filename, 0 + 64, "Warning !"

Else

MsgBox "Error " & Err & " occurred whilst " & currentprocess & ", line " & Erl & ", execution aborted.", 0 + 48, "Error !"

End If

Exit Sub

End Sub

Lotus Domino script snippet export any Notes view to Excel

You Might Also Like

Lotus Notes Inviewedit script

Lotus Notes CSV Export

Lotus Domino script snippet Export Notes Database Design to XML