Create and convert CSV files to Excel XLS files using OLE

The code below was used in the Resource Brio Reporting database for IBM. This code creates CSV files on the local PC writtien to C:\Temp and dumps the content of each into their own tab in the newly created Resource.xls file. The "tabs" array contains the names of the files in the folder on the local drive. Rangebounds is used to calculate the end column and row based on the total column & row counts. All the modules of the agent have been pasted below in their own sections.


Dim session As NotesSession
Dim erisdb As NotesDatabase
Dim compdb As NotesDatabase
Dim exportdb As NotesDatabase
Dim server$, path$
Dim sourceview As NotesView
Dim headerview As NotesView
Dim controlview As Notesview
Dim detailvcollection As NotesViewEntryCollection
Dim docvcollection As NotesViewEntryCollection
Dim headervcollection As NotesViewEntryCollection
Dim detailentry As NotesViewEntry
Dim docentry As NotesViewEntry
Dim headerentry As NotesViewEntry
Dim detaildoc As NotesDocument
Dim headerdoc As NotesDocument
Dim doc As NotesDocument
Dim filename As String
Dim filenum As Integer
Dim detailtxt As String
Dim headertxt As String
Dim detailarray () As String
Dim sourceviewname As String
Dim outputfile As String
Dim npslog As NotesLog
Dim DetailEntryType() As String
Dim DetailFieldName() As String
Dim DetailFieldType() As String
Dim DetailReplaceNull() As String
Dim DetailReplaceValue() As String
Dim DetailDateFormat() As String

Sub Initialize

Sub Initialize
	Dim ws As New notesuiworkspace
	Dim tabs As Variant
	Dim xlsFileName As Variant
	Dim y As Integer
	Dim i As Double, k As Double, m As Double, n As Double
	Set session = New NotesSession
	Set exportdb = session.CurrentDatabase	
	GetServerAndPath server, path
	'Start the Notes Log 
	Set npslog = New NotesLog("Export Brio Report Agent")
	npslog.OPENNOTESLOG server, path & exportdb.filename
	npslog.LogAction "*** BRIO REPORT EXPORT STARTED (" & Cstr(Now) & ") ***" 
	' Start the process of export to Excel by gathering some information from the user
	' Get the path and filename from user profile
	Dim profileview As NotesView
	Set profileview = exportdb.GetView( "Profile" )
	Dim profiledoc As NotesDocument
	Set profiledoc = profileview.GetFirstDocument
	If profiledoc Is Nothing Then
		'Get appropriate file names when required
		Dim szFilter$
		szFilter = "Excel Spreadsheet|*.xls|All Files|*.*|"	
	     'Prompt user where to save the file
		xlsFileName = ws.OpenFileDialog(False, "Please choose a location for this spreadsheet", szFilter,"","Resource.xls")
		If xlsFileName(0) ="" Then
			Messagebox "You have not selected a location for this spreadsheet. Please retry again.", 48, "Selection Error"
			Exit Sub
		End If
		Redim xlsFileName(0) As String
		xlsFileName(0) = profiledoc.path(0) & profiledoc.filename(0)
	End If
	'********************************* Checks for Target Path **************************************
	'On Error Resume Next needs to be included to allow the code below to check for errors and continue
	On Error Resume Next
	Dim TargetPath$
	TargetPath = profiledoc.path(0)
	Chdir TargetPath									'Check that the TargetPath exists
	If Err = 76 Then									'If it did not exist, peform these tasks
		Mkdir TargetPath 								'Create the TargetPath
		Err = 0											'Reset Error Number for next check
		Chdir TargetPath 								'Verify that the TargetPath was successfully created
		If Err = 76 Then 								'If it wasn't created successfully
			Msgbox "Excel Path does not exist or could not be created, please specify another path in the profile document.", 0 + 16, "Invalid Path"
		End If
	End If
	On Error Goto errorHandler    
	' Get the array of  tabs to be processed
	Set headerview = exportdb.GetView("ColumnHeaders")
	Set controlview = exportdb.GetView("NPSM")
	tabs = Evaluate("@Unique(@DbColumn("""":""NoCache"";"""";""NPSM"";2))")
	Dim RangeBounds() As String
	Redim RangeBounds(Ubound(tabs)) As String
	y = 1
	Forall t In tabs
		'Open File and Write Header
		filenum = Freefile()
		outputfile = profiledoc.path(0) & t & ".csv"
		Open outputfile For Output As filenum
		'Process column headers to the tab
		Call AddColumnHeaders(t, headerview)
		Print "Processing contents for tab: " & Ucase(t)
		npslog.LogAction "          Processing contents for tab: " & Ucase(t)
	     'Get the first detail record to set the source view. All control documents must 
		'be referencing the same view. Mixing source views will cause problems in data.
		Set detailvcollection = headerview.GetAllEntriesByKey(t, True)
		Set detailentry = detailvcollection.GetfirstEntry
		Set detaildoc = detailentry.Document
		sourceviewname = detaildoc.NPS_SourceView(0)
          'Set the source database and view
		If detaildoc.NPS_SourceDB(0) = "Compensation Manager" Then
			Set compdb = session.GetDatabase(server, path & "eriscomp.nsf" )
			If Not(compdb.IsOpen) Then	'Verify if db is open
				Messagebox "The Compensation Database could be opened.", 48, "Database Open Error"
				Exit Sub
			End If
			Set sourceview = compdb.GetView(sourceviewname)
		Elseif detaildoc.NPS_SourceDB(0) = "Brio Reporting" Then
			'No need to check current db
			Set sourceview = exportdb.GetView(sourceviewname)
			Set erisdb= session.GetDatabase(server, path & "eris.nsf" )
			If Not(erisdb.IsOpen) Then 	'Verify if db is open
				Messagebox "The Filing Cabinet Database could be opened.", 48, "Database Open Error"
				Exit Sub				
			End If
			Set sourceview = erisdb.GetView(sourceviewname)
		End If
		If sourceview Is Nothing Then
			Messagebox "You specified an incorrect source view: " & sourceviewname & ". Please retry again.", 48, "Source View Error"
			Exit Sub
		End If
		Set docvcollection = sourceview.AllEntries
		'Populate only when there are records to process
		If docvcollection.count > 0 Then
			npslog.LogAction "                        " & Cstr(docvcollection.count) & " records for tab: " & Cstr(Ucase(t))
			Call DetailInstruction(detailvcollection)
			Set docentry = docvcollection.getfirstentry
			i = 1
				Set doc = docentry.document
				Print "Processing Row: " & Cstr(i) & " of " & (docvcollection.count) & " for tab: " & Ucase(t)
				Redim detailarray(0 To (detailvcollection.count - 1)) As String
				For k = 0 To (detailvcollection.count -1)	
					detailarray(k) = ProcessDetailRecord(doc, DetailEntryType(k), DetailFieldName(k), DetailFieldType(k), DetailReplaceNull(k), DetailReplaceValue(k), DetailDateFormat(k))
				n = 0
				detailtxt = ""
				Forall d In detailarray
					If n = 0 Then
						detailtxt = Chr(34) & d & Chr(34)
						detailtxt = detailtxt & "," & Chr(34) & d & Chr(34)
					End If
					n = n + 1
				End Forall
				Print #filenum, detailtxt	
				i = i + 1
				Set docentry = docvcollection.getnextentry(docentry)
			Loop Until docentry Is Nothing
			Close filenum
		End If
		'Populate  Rangebounds		
		RangeBounds(y-1) = CalculateRangeBounds (detailvcollection.Count) & docvcollection.count + 1
		'increment to next tab
		y = y + 1
	End Forall	
	npslog.LogAction "          Converting to Excel (" & Cstr(Now) & ") ***" 
	Call CopyCSVtoExcel ( Tabs , RangeBounds, TargetPath, Cstr(xlsFilename(0)) )
	npslog.LogAction "*** BRIO REPORT EXPORT COMPLETE (" & Cstr(Now) & ") ***" 
	Print "BRIO Report Export is complete."
	Exit Sub
	Messagebox "Error was encountered.  Please make sure that all the control documents are correct."
End Sub


Function CopyCSVtoExcel( tabs As Variant, RangeBounds() As String, TargetPath As String , xlsFilename As String)
	Dim xl As Variant
	Dim xlwbksFinal As Variant
	Dim xlWbkFinal As Variant, xlSheetsFinal As Variant, xlSheetFinal As Variant
	Dim xlWbkTemp As Variant, xlSheetsTemp As Variant, xlSheetTemp As Variant

	'Create the Excel Object
	Set xl = CreateObject("Excel.application")
	xl.visible = True

	'Create Final Workbook
	Set xlWbkFinal = xl.Workbooks.Add
	Set xlSheetsFinal = xlWbkFinal.Worksheets
	Set xlSheetFinal = xlWbkFinal.Worksheets(1)

	Dim y As Integer
	y = 1
	Forall t In tabs
		Print "Processing Excel Tab for " & T
		'Create Workbooks
		Set xlWbkTemp = xl.Workbooks.Open (TargetPath & t & ".csv")
		Set xlSheetsTemp = xlWbkTemp.Worksheets
	                'Initiate first worksheet based on the array of tab names
		Set xlSheetTemp = xlWbkTemp.Worksheets(1)
		Call xlSheetTemp.Activate
		xlSheetTemp.Name = t
		'Sets the Range Name = to the tab name (no spaces allowed)
		xlSheetTemp.Range("A1:" & RangeBounds(y-1)).Name = Cstr(t)
		xlSheetTemp.Name = t
		Call xlSheetsTemp.Move(xlWbkFinal.Worksheets(y))		
		Kill  TargetPath & t & ".csv"
		'Format the xl sheet
		'increment to next tab
		y = y + 1
	End Forall
	'Delete the extra sheets that were created by default in Excel
	xl.DisplayAlerts = False
	xlSheetsFinal ("Sheet1").Delete
	xlSheetsFinal ("Sheet2").Delete
	xlSheetsFinal ("Sheet3").Delete
	'Save only if there were tabs processed
	Call xlWbkFinal.SaveAs(xlsFileName)
	Call xlWbkFinal.Close
	Call xl.Quit
	'Release object handles
	xlSheetFinal = ""
	xlSheetsFinal = ""
	xlWbkFinal = ""
	xlSheetTemp = ""
	xlSheetsTemp = ""
	xlWbkTemp = ""
	xl = ""
	Messagebox "Export is Complete.  You may now open the saved spreadsheet: "  & xlsFileName
End Function


Function CalculateRangeBounds (ColumnCount As Long) As String
	' Used to calculate the column labels for the number of columns (i.e. 44 columns would equal AR )
	Dim AlphabetArray(1 To 26) As String
	AlphabetArray(1) = "A"
	AlphabetArray(2) = "B"
	AlphabetArray(3) = "C"
	AlphabetArray(4) = "D"
	AlphabetArray(5) = "E"
	AlphabetArray(6) = "F"
	AlphabetArray(7) = "G"
	AlphabetArray(8) = "H"
	AlphabetArray(9) = "I"
	AlphabetArray(10) = "J"
	AlphabetArray(11) = "K"
	AlphabetArray(12) = "L"
	AlphabetArray(13) = "M"
	AlphabetArray(14) = "N"
	AlphabetArray(15) = "O"
	AlphabetArray(16) = "P"
	AlphabetArray(17) = "Q"
	AlphabetArray(18) = "R"
	AlphabetArray(19) = "S"
	AlphabetArray(20) = "T"
	AlphabetArray(21) = "U"
	AlphabetArray(22) = "V"
	AlphabetArray(23) = "W"
	AlphabetArray(24) = "X"
	AlphabetArray(25) = "Y"
	AlphabetArray(26) = "Z"
	If ColumnCount <= 26 Then
		CalculateRangeBounds = AlphabetArray(ColumnCount)
		Dim FirstLetter As String
		FirstLetter = AlphabetArray(Left$((ColumnCount / 26) , 1 ))
		Dim SecondLetter As String
		Dim ModValue As Variant
		ModValue =  ColumnCount Mod 26
		SecondLetter = AlphabetArray(ModValue)
		CalculateRangeBounds = FirstLetter & SecondLetter
	End If
End Function


Function GetServerAndPath (server As String, path As String)
	Dim ss As New notessession
	Dim db As notesdatabase
	Dim i As Integer
	Set db=ss.currentdatabase
	For i=Len (db.filepath) To 1 Step -1
		If Mid(db.filepath,i,1)="\" Then
			If i > 1 Then
				path =Left (db.filepath, i-1) & "\"
			End If
			Exit For
		End If
End Function


Function ProcessDetailRecord(doc As NotesDocument, EntryType As String, Field As String, FieldType As String, ReplaceNull As String, ReplaceValue As String,DateFormat As String) As String
	' Collect and Write the details of each record the export file
	Dim item As NotesItem
	Dim tdate As NotesDateTime
	Dim length As Integer
	Dim composedby()
	Dim text
	ProcessDetailRecord = ""
	Select Case Ucase(EntryType)
	Case "STATIC"
		If detaildoc.NPS_FieldType(0) = "Text" Then
			ProcessDetailRecord = Field
		Elseif detaildoc.NPS_FieldType(0) = "Number" Then
			ProcessDetailRecord = Field
		End If
	Case "FIELD"
		'For Header Field is only set for accumulate
		Dim fieldname As String
		fieldname = Field
		'Check source item
		Set item = doc.GetFirstItem(fieldname)
		Redim text(0) As Variant
		If item Is Nothing Then
			If ReplaceNull = "Yes" Then
				text(0) = ReplaceValue
				text(0) = ""
			End If
			text(0) = item.text		
		End If
		If FieldType = "Date" Then
			If Cstr(text(0)) = "" Then
				If ReplaceNull = "Yes" Then
					text(0) = ReplaceValue
					text(0) = ""
				End If
			End If
			If Cstr(text(0)) <> "" Then
				If DateFormat = "YYYYMMDD" Then
					ProcessDetailRecord = Format$(text(0), "yyyy/mm/dd")			
					ProcessDetailRecord = Format$(text(0), "mm/dd/yyyy")
				End If
				ProcessDetailRecord = ""
			End If
		Else ' Process for FieldType Text and Number
			If Cstr(text(0)) <> "" Then
				ProcessDetailRecord = Cstr(text(0))
				If ReplaceNull = "Yes" Then
					ProcessDetailRecord = ReplaceValue
					ProcessDetailRecord = ""
				End If
			End If
		End If	
	End Select
End Function


Function AddColumnHeaders(t As Variant, headerview As NotesView)
	'Process the column headers for each tab
	Print "Processing Column Headers for Tab: " & Cstr(Ucase(t))
	Set headervcollection = headerview.GetAllEntriesByKey(t, True)
	Dim row As Double, col As Double
	headertxt = ""
	If headervcollection.count > 0 Then
		Set headerentry = headervcollection.GetfirstEntry
	     'Write the contents to the first row
		col = 1
			Set headerdoc = headerentry.Document
			If col = 1 Then
				headertxt = Chr(34) & headerdoc.NPS_Fieldname(0) & Chr(34)
				headertxt = headertxt & "," & Chr(34) & headerdoc.NPS_Fieldname(0) & Chr(34)
			End If
			col = col + 1
			Set headerentry = headervcollection.GetNextEntry(headerentry)
		Loop Until headerentry Is Nothing	
	End If
	Print #filenum, headertxt
End Function


Function DetailInstruction(vc As NotesViewEntryCollection)
	'This will make arrays of detail instructions for each document to process 
	Redim DetailEntryType(0 To (vc.count -1)) As String
	Redim DetailFieldName(0 To (vc.count - 1)) As String
	Redim DetailFieldType(0 To (vc.count -1)) As String
	Redim DetailReplaceNull(0 To (vc.count -1)) As String
	Redim DetailReplaceValue(0 To (vc.count -1)) As String
	Redim DetailDateFormat(0 To (vc.count -1)) As String
	Dim entry As NotesViewEntry
	Dim doc As NotesDocument
	Dim x As Integer
	Set entry = vc.GetFirstEntry
	x = 0
		Set doc = Entry.Document 
		DetailEntryType(x) = doc.NPS_EntryType(0)
		If doc.NPS_EntryType(0) = "Field" Then
			DetailFieldName(x) = doc.NPS_Fieldname(0)
			DetailFieldName(x) = doc.NPS_StaticFieldValue(0)
		End If
		DetailFieldType(x) = doc.NPS_FieldType(0)
		If doc.NPS_FieldType(0) = "Text" Then
			DetailReplaceNull(x) = doc.NPS_ReplaceNullText(0)
		Elseif doc.NPS_FieldType(0) = "Number" Then
			DetailReplaceNull(x) = doc.NPS_ReplaceNullNumber(0)
		Elseif doc.NPS_FieldType(0) = "Date" Then
			DetailReplaceNull(x) = doc.NPS_ReplaceNullDate(0)
		End If	
		If doc.NPS_FieldType(0) = "Text" Then
			DetailReplaceValue(x) = doc.NPS_ReplaceText(0)
		Elseif doc.NPS_FieldType(0) = "Number" Then
			DetailReplaceValue(x) = doc.NPS_ReplaceNumber(0)
		Elseif doc.NPS_FieldType(0) = "Date" Then
			DetailReplaceValue(x) = doc.NPS_ReplaceDate(0)
		End If
		If doc.NPS_FieldType(0) = "Date" Then
			DetailDateFormat(x) = doc.NPS_DateFormat(0)
			DetailDateFormat(x) = ""
		End If
		Set entry = vc.GetNextEntry(entry)
		x = x + 1
	Loop Until entry Is Nothing
End Function


Posted by fbrefere001 on Thursday August 8, 2002