Colorful Life²⁰¹⁰

前提：机器上当然要状有EXCEL了

将下面的代码直接放到VIEW的一个ACTION按钮上就行了

这个还包含了前一篇的进度条的功能

Sub Click(Source As Button)
	'define
	Dim ws As New NotesUIWorkspace
	Dim se As New NotesSession
	Dim db As NotesDatabase
	Dim view As NotesView
	Dim entry As NotesViewEntry
	Dim iRow As Integer
	Dim iCol As Integer
	Dim oVal As String
	Dim vc As NotesViewEntryCollection
	Dim maxrows As Integer
	' EXCEL
	Dim xlApp As Variant ' Excel Application
	Dim xlbook As Variant ' Workbook
	Dim xlsheet As Variant ' Worksheet
	
	'get the data view
	Set db = se.CurrentDatabase
	Set view = ws.CurrentView.View
	
	If Messagebox("confirm to export the view data?", 32 + 1, "Exporting Data") <> 1 Then Exit Sub
	
	' EXCEL
	Set xlApp = CreateObject("Excel.Application")
	xlApp.Visible = True
	Set xlbook = xlApp.Workbooks.Add
	Set xlsheet = xlbook.Worksheets(1)
	xlApp.ScreenUpdating = False
	
	Set vc = view.AllEntries
	Set entry = vc.GetFirstEntry
	'titles
	xlsheet.Rows(1).NumberFormat = "@" 
	iCol = 1
	Forall col In view.Columns
		xlsheet.Cells(1, iCol).Value = col.Title
		iCol = iCol + 1
	End Forall
	iRow = 2
	maxrows = vc.Count
	
	'Create the progress bar
	hwnd = NEMProgressBegin( NPB_TWOLINE )
	'Set the bar range - the default is 100
	NEMProgressSetBarRange hwnd, maxrows
	'Display some text on the dialog.  The second line is ignored if NPB_TWOLINE not specified
	NemProgressSetText hwnd, "Exporting Data...", ""
	
	On Error Goto goout
	While Not(entry Is Nothing)		
		'update process bar's status & text
		NEMProgressSetBarPos hwnd, iRow-1
		NemProgressSetText hwnd, "Exporting Data...", Cstr(iRow-1) &" record(s) have been processed..."
		
		iCol = 1
		Forall colVal In entry.ColumnValues
			If Instr(Typename(colVal), "STRING") = 1 Then ' STRING or STRING( )
				xlsheet.Cells(iRow, iCol).NumberFormat = "@" 
			End If
			If Isarray(colVal) Then 
				oVal$ = Implode(colVal, ",")
			Else
				oVal$ = Cstr(colVal)
			End If
			xlsheet.Cells(iRow, iCol).value = oVal
			iCol = iCol + 1
		End Forall
		
		iRow = iRow + 1
		Set entry = vc.GetNextEntry(entry)
	Wend    
	
	'save the Excel file
	xlApp.ActiveWorkbook.Worksheets(1).Rows.RowHeight=14
	xlApp.ActiveWorkbook.Worksheets(1).Columns.AutoFit
	xlApp.ActiveWindow.FreezePanes = False
	xlApp.ActiveWindow.SplitRow = 1
	xlApp.ActiveWindow.FreezePanes = True
	xlApp.ScreenUpdating = True 
goout:
	'Destroy the dialog when we're done
	NEMProgressEnd hwnd
	Exit Sub
End Sub