'Export to Excel v2.06: 

Option Public
%REM
================================================================================
Export-Script
================================================================================
This Script has been created by D. Hasa, Yel GmbH, Switzerland  in April 2001

It may be distributed and modified freely, as long as this header is kept intact.

Please report any bugs, fixes or enhancements to d.h@yel.ch

This script exports a UIView 'As-Is' from Notes 5 to Excel 2000
It has been tested with Notes 5.03/5.05 into Excel97 & 2000

--> every column (include headers) is a column in Excel 
     and every value displayed of a document is a row in Excel
Every Value will be inserted as Text into Excel

================================================================================
Implementation
================================================================================
It is only a script without any Dialog-Boxes by exception --> Distribution and 
Implementation is very easy

Simply copy this whole file into an Agent:
Name: 	Export to Excel
Run:		Manually from Actions Menu
act on:	All documents in View
Run:		Lotus Script

--> Export works in any View/Folder of that database
================================================================================
Updates:
================================================================================
30.11.01
SELECTED DOCUMENTS
You can now export also only selected documents, but the script gets thru all documents in a view, 
because the the property doc.ColumnValues(n) only returns a value, if it has been fetched from a view 
(selected documents get fetched by a NotesDocumentCollection).
----
Excel-Object Problems
Added another ExcelApp-Constant (Excel.Application.8)
----
Visualised Progress
This script is From http://www.notes.net/50beta.nsf/7d6a87824e2f09768525655b0050f2f2/1B5AFDF4B4ACC732852566BB005CDC45?OpenDocument
Thanks to Les Szklanny
--> I cannot give you any  guaranty of proper functionality you can turn it on or of --> const visualproc
================================================================================
14.01.02
================================================================================
Changed Error-Handling on ExcelObject Create
================================================================================
09.03.02
================================================================================
- Removed Form1..4 from Formatting (does not exist anymore)
- Added Constant for Papersize
- If titbar-rotate = 0 then autofit from line 1 else from line 2
================================================================================
02.07.02
================================================================================
- Removed Error with 'count'-columns
30.07.02
- Changed bug if only one doc is selected (Thanks to A. Migliore)
================================================================================
14.12.02
================================================================================
- Added ability to export multivalue columns (Functions ListText and ReplaceSubString)
================================================================================
01.11.03
================================================================================
- Changed force 'Text'-Export
- Trim for all values
- Ask for Exporting ResponseDocs
- Retrieve and keep numbervalues (asked to convert to text)
================================================================================
%ENDREM

'Set Papersize: 10*14=16 / 11*17=17 / A3=8 / A4=9 / A4small=10 / A5=11 / B4=12 / B5=13
Const psize = 9 
Const visualproc = True 'Display VisualProgress true = yes /false = no
Const AppConst = "Excel.Application"
Const AppConst2 = "Excel.Application.8"
Const NPB_TWOLINE% = 1 '1 is for the big "in its window" progress bar and 32 is for the small blue line at the bottom of the screen

' Procedures in nnotesws.dll (undocumented!!).






Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Dim nc, nl, nmore
Dim selList(0 To 16) As String
Dim vcol List As String
Dim indoresp As Integer, inleaveString As Integer
Dim excelAppObject As Variant
Declare Function NEMProgressBegin Lib "nnotesws.dll" ( Byval wFlags As Integer ) As Long
Declare Sub NEMProgressEnd Lib "nnotesws.dll" ( Byval hwnd As Long )
Declare Sub NEMProgressSetBarPos Lib "nnotesws.dll" ( Byval hwnd As Long, Byval dwPos As Long)
Declare Sub NEMProgressSetBarRange Lib "nnotesws.dll" ( Byval hwnd As Long, Byval dwMax As Long )
Declare Sub NEMProgressSetText Lib "nnotesws.dll" ( Byval hwnd As Long, Byval pcszLine1 As String, _
Byval pcszLine2 As String )
Class ProgressBar
' Objects
	Private hwnd As Long
	
' Constructor.
	Sub New (BarRange As Long) 
		On Error Goto ErrorHandler
		
' Create the progress bar.
		Me.hwnd = NEMProgressBegin (NPB_TWOLINE)
		
' Set the bar range.
		Call NEMProgressSetBarRange (Me.hwnd, BarRange)
		
		Exit Sub
		
ErrorHandler:
		Dim TheError As String
		TheError = "Constructor: Error " + Str(Err) + ": " + Error$ 
		Messagebox TheError, 0 + 48, "Progress Bar Error"
	End Sub
	
' Destructor.
	Sub Delete
' Destroy the progress bar.
		Call NEMProgressEnd (Me.hwnd) 
	End Sub
	
	Public Sub UpdatePosition (BarPos As Long)
' Update the bar position.
		Call NEMProgressSetBarPos (Me.hwnd, BarPos)
	End Sub
	
	Public Sub UpdateProgressText (BarMsg As String, UpdateMsg As String)
' Update progress text.
		Call NEMProgressSetText (Me.hwnd, BarMsg, UpdateMsg)
	End Sub 
End Class

Sub Initialize
	On Error Goto ExitExcel
'Main Code
	Dim session As New NotesSession
	Dim workspace As New NotesUIWorkspace
	Dim UIview As NotesUIView
	Dim collection As NotesDocumentCollection	
	Dim coldoc As NotesDocument
	Dim BarMsg As String, UpdateMsg As String
	Dim countall As Long, countthis As Long, countallsel As Long, countthissel As Long
	Dim NChar As String
	
	Set UIview = workspace.CurrentView
	Set db = session.CurrentDatabase
	UIViewname = UIView.ViewName
	UIViewAlias = UIView.Viewalias
	Set view = db.GetView( UIViewName )
	
	Set collection = db.UnprocessedDocuments
	gowithselection = False
	goonall = True
	
	'Determine if it is a collection
	countallsel = collection.count
	If countallsel >=1 Then
		gowithselection = workspace.Prompt(PROMPT_YESNO, "Selection found", "Export only selected documents?") 
		Set doc=collection.getfirstdocument
		'Check if there is really a doc selected
		If (doc Is Nothing) And (goonwithselection) Then 
			Msgbox "Invalid selection"
			Exit Sub
		End If
		Set doc = Nothing
		BarMsg = "Exporting selected documents ..."
	Else
		goonall = workspace.Prompt(PROMPT_YESNO, "No Selection found", "Export all documents?" + Chr$(13) + "Info: If you want to export only selected documents," + Chr$(13) + "please select these documents before running this script.")
		If goonall=False Then
			Print "Exiting..."
			Exit Sub
		End If
		Set collection = Nothing
		BarMsg = "Exporting documents ..."
	End If
	
	doformat = Messagebox("Format the Excel-Sheet?", 36)
	If doFormat = 6 Then
		'SET THE AUTOFORMAT
		Call SetSelList()
		SelForm = workspace.Prompt(PROMPT_OKCANCELLIST, "AutoFormat-Form","Select the Autoformat-Form", "Simple" , SelList) 
		TitleBar = Cint(Inputbox ( "How many degrees shall the Title-Line be turned", "Title-Turn", "0"))
		If Titlebar > 90 Then 
			TitleBar = 90
		Elseif TitleBar < -90 Then
			TitleBar = -90
		End If
	End If
	
	SelAutoForm = getAutoForm( selForm )
	
	indoresp = Messagebox("Exporting also possible Response-Documents?", 36)
	inleaveString = Messagebox("Export all as text (Numbers converted to Text)?", 36)
	
'Launch Excel and open it in the UI
	On Error Goto 0
	Set excelAppObject = CreateObject( AppConst )
	'Try other AppConst
	If excelAppObject Is Nothing Then
		Set excelAppObject = CreateObject( AppConst2 )
		If excelAppObject Is Nothing Then
			Msgbox "Could not create an Excel Object"
			Exit Sub
		End If
	End If
	On Error Goto ExitExcel
	excelAppObject.Visible = False
	Call excelAppObject.Workbooks.Add
	Set excelWorksheetObject = excelAppObject.ActiveSheet
	
'Add the table labels
	nc=64
	nmore=0
	Forall c In view.Columns
		'do not export hidden columns or those with fixed vals (not displayed as doc.columnvalues!!!!)
		If Not c.ishidden And Not c.IsIcon And Not (c.IsFormula And Not Instr(1, c.Formula, "@") And Not Instr(1, c.Formula, "+")) Then
			nchar = countcol(nChar)
			excelWorksheetObject.Range( nchar + "1").Value = Trim(c.Title)
		End If
	End Forall
	
	m_let = nchar
	nl=1
	
	'Export Documents
	Set doc = view.GetFirstDocument
	If gowithselection Then countall = countallsel Else countall = view.AllEntries.Count
	countthis = 0
	countthissel = 0
	exitnow = False
	If visualProc Then Dim RefreshProgress As New ProgressBar (countall) 'display the ProcessWindow/Bar
	
	While Not ( doc Is Nothing Or exitnow)
		countthis = countthis + 1
		If gowithselection Then
			Set coldoc = Nothing
			Set coldoc = collection.GetDocument(doc)
			If Not coldoc Is Nothing Then 'Exports only if doc is part of collection
				If (doc.isResponse And indoresp=6) Or Not doc.isResponse Then
					Call ExportDoc(excelWorksheetObject)
					countthissel = countthissel + 1
				End If
			End If
			If visualproc Then 
				UpdateMsg = "Exporting document " + Cstr(countthissel) + " of " + Cstr(countall) + Chr$(13) + "Processing Doc in View: " + Cstr(countthis)				
				Call RefreshProgress.UpdatePosition (countthissel)
			Else
				Print "Exporting document " + Cstr(countthissel) + " of " + Cstr(countall) + " / " + "Processing Doc in View: " + Cstr(countthis)
			End If
			'Exit routine if all selected docs are exported
			If countall = countthissel Then exitnow = True
		Else
			If (doc.isResponse And indoresp=6) Or Not doc.isResponse Then
				Call ExportDoc(excelWorksheetObject)
				UpdateMsg = "Exporting document " + Cstr(countthis) + " of " + Cstr(countall)
				If visualproc Then 
					Call RefreshProgress.UpdatePosition (countthis)
				Else
					Print UpdateMsg
				End If
			End If
		End If
		If visualproc Then Call RefreshProgress.UpdateProgressText (BarMsg, UpdateMsg)
		Set doc = view.GetNextDocument(doc)
	Wend
	
	
 'formating the Worksheet
	If doformat = 6 Then
		BarMsg = "One moment please..."
		UpdateMsg = "Formating the document..."
		If visualproc Then Call RefreshProgress.UpdateProgressText (BarMsg, UpdateMsg) Else Print Updatemsg
		If titlebar=0 Then
			excelWorksheetObject.Range("A2:" + m_let + Cstr(nl) ).Select
		Else
			excelWorksheetObject.Range("A1:" + m_let + Cstr(nl) ).Select
		End If
		excelAppObject.Selection.Columns.AutoFit
		excelWorksheetObject.Range("A1:" + m_let + Cstr(nl)).Select
		With excelAppObject.Selection
			.AutoFormat SelAutoForm, False, True, False, True, True, False
			.VerticalAlignment = -4160
		End With
		
		excelWorksheetObject.Rows("1:1").Select
		With excelAppObject.Selection
			.VerticalAlignment = -4107
			.HorizontalAlignment = -4108
			.WrapText = True
			.Orientation = Cint(titlebar)
			.ShrinkToFit = False
			.MergeCells = False
'			.RowHeight = 215			
		End With
		
		excelWorksheetObject.Range("A:" + m_let).Select
		With excelAppObject.Selection.Font
			.Name = "Arial"
			.Size = 10
		End With
		
		excelAppObject.Selection.Columns.Autofit
		excelWorksheetObject.Range("A1").Select
		
		With excelAppObject.Windows(1)     
			.SplitRow=1
			.FreezePanes=True
		End With  
		
		With excelWorksheetObject.PageSetup
			.Orientation = 2
			.LeftHeader = "&""Arial,Bold""&18"+db.Title+" - "+ UIViewAlias
			.CenterHeader = ""
			.RightHeader = "Datum: &D"
			.LeftFooter = ""
			.CenterFooter = ""
			.RightFooter = "Seite &P"
			.PrintArea = ("A1:"+ m_let + Cstr(nl))               
			.PaperSize = 9
			.CenterHorizontally = True          
			.FitToPagesTall =False
			.zoom = False
			.FitToPagesWide=1 
			.PrintTitleRows=excelWorksheetObject.Rows("1:1").Address
		End With          
	End If
	excelAppObject.Visible = True
	Exit Sub
	
ExitExcel:
	Print "Error in Line " + Cstr(Erl) + " : " + Cstr(Error)
	excelAppObject.DisplayAlerts = False
	excelAppObject.Quit
	Exit Sub
End Sub
Function countcol( nChar As String)
	nc=nc+1
	If nc=91 Then
		nmore = nmore+1 'PreChar = Axx (AC23)
		nc=65 'reset to A
	End If
	If nmore > 0 Then
		nchar=Cstr(Chr(nmore+64))+Cstr(Chr(nc))
	Else
		nchar = Cstr(Chr(nc))	
	End If
	countcol = nchar
End Function
Function getAutoForm( selForm) As Integer
	Select Case SelForm
	Case "Simple"
		SelAutoForm = -4154
	Case "Classic1"
		SelAutoForm =1
	Case "Classic2"
		SelAutoForm =2
	Case "Classic3"
		SelAutoForm =3
	Case "Accounting1"
		SelAutoForm =4
	Case "Accounting2"
		SelAutoForm =5
	Case "Accounting3"
		SelAutoForm =6
	Case "Color1"
		SelAutoForm =7
	Case "Color2"
		SelAutoForm =8
	Case "Color3"		
		SelAutoForm =9
	Case "List1"
		SelAutoForm =10
	Case "List2"
		SelAutoForm =11
	Case "List3"
		SelAutoForm =12
	Case "D3Effects1"
		SelAutoForm =13
	Case "D3Effects2"
		SelAutoForm =14
	Case "Accounting4"
		SelAutoForm =17
	Case Else
		SelAutoForm =-4142
	End Select
	GetAutoForm = SelAutoForm	
End Function
Sub SetSelList()
	SelList(0) = "Simple"
	SelList(1) = "Classic1"
	SelList(2) = "Classic2"	
	SelList(3) = "Classic3"	
	SelList(4) = "Accounting1"
	SelList(5) = "Accounting2"
	SelList(6) = "Accounting3"
	SelList(7) = "Accounting4"
	SelList(8) = "Color1"
	SelList(9) = "Color2"
	SelList(10) = "Color3"
	SelList(11) = "List1"
	SelList(12) = "List2"
	SelList(13) = "List3"
	SelList(14) = "D3Effects1"
	SelList(15) = "D3Effects2"
	SelList(16) = "None"	
End Sub
Sub ExportDoc(excelWorksheetObject)
	On Error Goto ErrorEntry
	Dim nChar As String, MyString As String
	Dim MyVal As Variant, MyRepl(1) As Variant
	Dim inisString As Integer
	nl= nl+1
	nc=64
	nmore=0
	ocount = 0
	MyRepl(0) = Chr$(13)+Chr$(10)
	MyRepl(1) = Chr$(13)
	inisString = True
	Forall c In view.Columns
		'do not export hidden columns!
		If Not c.ishidden And Not c.IsIcon And Not (c.IsFormula And Not Instr(1, c.Formula, "@") And Not Instr(1, c.Formula, "+")) Then
			nchar = countcol(nChar)
			MyVal = doc.ColumnValues(ocount)
			If Isarray(MyVal) Then 
				MyString = ListToText(MyVal)
			Else 
				If Isnumeric(MyVal) Then inisString = False
				MyString = MyVal
			End If
			MyString = ReplaceSubString( MyString , MyRepl , Chr$(10) )
			With excelWorksheetObject.Range(nchar + Cstr(nl))
				If Not inisString And inleaveString=7 Then
					.NumberFormat = "0"
				Else
					.NumberFormat = "@"
				End If
				.Value = MyString
			End With
		End If
		ocount=ocount+1	
	End Forall
	Exit Sub
	
ErrorEntry:
	With excelWorksheetObject.Range(nchar + Cstr(nl))
		.NumberFormat = "@"			
		.Value = "ERROR: WRONG VALUE"
	End With
	Resume Next
End Sub
Function ListtoText ( MyVal As Variant )
	Dim NewVal As String
	NewVal = ""
	
	Forall x In MyVal
		If NewVal = "" Then
			NewVal = x
		Else
			NewVal = NewVal + Chr$(10) + x			
		End If
	End Forall
	
	If NewVal = "" Then NewVal = MyVal Else ListtoText = NewVal
End Function
Function ReplaceSubString(stOriginal As String , vaAll As Variant , stTo As String) As String
	Dim stString As String
	Dim inFound As Integer,inStart As Integer,inDone As Integer
	stString=stOriginal
	Forall stWhat In vaAll
		If (stWhat<>stTo) Then 
			inFound=Instr(stString,stWhat)
			inDone=(inFound=0)
			While Not inDone
				stString=Left(stString,inFound-1)+stTo+Mid(stString,inFound+Len(stWhat))
				inStart=inFound+1
				inFound=Instr(inStart,stString,stWhat)
				If inFound=0 Then inFound=Instr(stString,stWhat)
				inDone=(inFound=0)
			Wend
		End If
	End Forall
	ReplaceSubString=stString
End Function