'R5_Export_to_Excel: 

Option Explicit
'Export_R5_Only: 


Declare Function NEMGetFile Lib "nnotesws" Alias "NEMGetFile" ( wUnk As Integer, Byval szFileName As String, Byval szFilter As String, Byval szTitle As String ) As Integer 
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 ) 
Const NPB_TWOLINE% = 1 '1 is for the big "in its window" progress bar
Const NPB_NOTEXT%=32 'and 32 is for the small blue line at the bottom of the screen
Const xlAutomatic = -4105
Const xlBottom = -4107
Const xlCategory = 1
Const xlCenter = -4108
Const xlColumnClustered = 51
Const xlContinuous = 1
Const xlDataLabelsShowValue = 2
Const xlDataLabelsShowPercent = 3
Const xlEdgeBottom = 9
Const xlEdgeLeft = 7
Const xlEdgeRight = 10
Const xlEdgeTop = 8
Const xlHairline = 1
Const xlInsideHorizontal = 12
Const xlInsideVertical = 11
Const xlLandscape = 2
Const xlLeft = -4131
Const xlLine=4
Const xlLineMarkers = 65
Const xlLocationAsObject = 2
Const xlMedium = -4138
Const xlNone = -4142
Const xlPie=5
Const xlPortrait = 1
Const xlRows = 1
Const xlThick = 4
Const xlThin = 2
Const xlTop = -4160 
Const xlValue = 2


Sub Click(Source As Button)

'This button will generate an Excel spreadsheet using all data from a view.
      Dim szFilter As String
      Dim startTime As Single
      Dim processingTime As Single
      Dim session As New NotesSession
      Dim db As NotesDatabase
      Dim v As NotesView
      Dim dc As notesdocumentcollection
      Dim ws As New notesuiworkspace
      Dim uiview As NotesUIView
      Dim docX As NotesDocument
      Dim promptlist(3) As String, choice As String, promptlist2(1) As String, exportall As String
      Dim platform As String, view As String
      Dim xl As Variant, xlWbk As Variant, xlSheet As Variant, hwnd As Variant, xlsFileName As Variant
      Dim row As Integer, col As Integer, numdocs As Integer

'     On Error Goto errorHandler3
'Check to see if the user is on a MacIntosh
'the "Create Object" function does not run on a Mac
      platform = session.Platform
      If Not Instr (platform, "MacIntosh") = 0 Then
            Messagebox ("This function cannot be run on a MacIntosh. Please use a PC to pull this data into a spreadsheet.")
            Exit Sub
      End If
      promptlist(0)="New Spreadsheet - Display When Completed"
      promptlist(1)="New Spreadsheet - Save Directly to Disk"
      promptlist(2)="Open Existing Spreadsheet - Display When Completed"
      promptlist(3)="Open Existing Spreadsheet - Save Directly to Disk"
      choice=ws.prompt(PROMPT_OKCANCELLIST, "Select Action", "Please choose how you would like to perform the export.", promptlist(0), promptlist)
      If (choice="") Then
            Exit Sub
      End If

      promptlist2(0)="Everything"
      promptlist2(1)="Selected Documents"
      exportall=ws.prompt(PROMPT_OKCANCELLIST, "Export Selection", "Export Everything?", promptlist2(0), promptlist2)
      If (exportall="") Then
            Exit Sub
      End If

      'Get appropriate file names when required
      szFilter = "Excel Spreadsheet|*.xls|All Files|*.*|"
      If choice = promptlist(0) Then
      Else
            xlsFileName = ws.OpenFileDialog (False, "Select Spreadsheet", szFilter)
            If xlsFileName(0) ="" Then
                  Exit Sub
            End If
      End If

'Set the session variables
      startTime = Timer
      Set db = session.CurrentDatabase
      Set dc = db.unprocesseddocuments
      Set uiview = ws.currentview
      Set v = uiview.view
      If exportall="Everything" Then
      Else
            Dim folderName As String
            Randomize
            folderName="TmpExportView" + Cstr (Int(Rnd()*100))
            Dim doc As notesdocument, newdoc As notesdocument
            If Not v Is Nothing Then
                  Set doc=db.getdocumentbyunid(v.universalid)
                  If Not doc Is Nothing Then
                        Set newdoc=doc.copytodatabase(db)
                        Call newdoc.replaceitemvalue("$Title",foldername)
                        Call newdoc.replaceitemvalue("$Flags","3FY")
                        Call newdoc.save(True,True)
                  End If
            End If
            Set v = db.getview(folderName)
            Call dc.putallinfolder(folderName)
      End If
      numDocs=v.allentries.count

' Initialise Progress Bar
      hwnd = NEMProgressBegin( NPB_TWOLINE ) ' use window style progress bar
      NEMProgressSetBarRange hwnd, numDocs ' set range of bar to number of rows
      NEMProgressSetText hwnd, "Exporting view to Excel.", "Starting Export to Excel..."

      Set xl = CreateObject("Excel.application")
      If choice = promptlist(0) Or choice = promptlist(1) Then
            Set xlWbk = xl.Workbooks.Add
      Else
            Set xlWbk = xl.Workbooks.Open(xlsFileName(0))
      End If
      Set xlSheet = xlWbk.Worksheets(1)
      Call xlSheet.Activate
      On Error Goto errorHandler
      xlSheet.Name = "Notes Exported Data"
      xl.Cells.select
      xl.Selection.ClearContents

'Start filling in the header column.  You can get rid of this if you want to, but then get rid of the section lower that highlights it...
      col=1
      With xlSheet
            Forall vColumn In v.Columns
                  If vColumn.IsHidden = True Then
                  Else
                        .Cells(1, col)=vColumn.Title
                        col=col+1
                  End If
            End Forall
      End With


'Row by Row, Column by Column, fill in the values
'
      Dim tempItem As Notesitem
      Dim tempVal As String

      Set docX=v.GetFirstDocument
      row=2
      On Error Goto errorHandler
      With xlSheet
            While Not docX Is Nothing
                  col=1
                  Forall cValue In docX.ColumnValues
                        .Cells(row, col)=implode(cValue, Chr(10))
continue:
                        col=col+1
                  End Forall
                  row=row+1
                  If row Mod 10 = 0 Then
                        processingTime = Timer - startTime
                        NEMProgressSetBarPos hwnd,row
                        NemProgressSetText hwnd, "Exporting view to Excel.", "Exporting: "& Cstr(row) & " of " & Cstr(numDocs) & "  documents exported in "  & Format$(processingTime, "0.00") & " seconds, AVG = " & Format$(row / processingTime , "0.000")
                  End If
                  Set docX=v.GetNextDocument(docX)
            Wend
      End With
      On Error Goto errorHandler2

'Set sizing, fonts, etc to make the spreadsheet readable.
      xl.Cells.select
      xl.selection.Font.Name = "Verdana"
      xl.selection.Font.Size = 9
      xl.Rows("1:1").Select
      xl.Selection.Font.Bold = True
      xl.selection.Font.size = 12
      xl.selection.RowHeight = 15
      xl.Cells.select
      xl.selection.columnwidth = 100
      xl.selection.columns.Autofit
      xl.selection.rows.Autofit
      xl.selection.VerticalAlignment = xlTop
      xl.ActiveSheet.Range("A1").Select

'Stop Progress Bar
      NEMProgressEnd hwnd


'Save and be gone!
      On Error Goto errorHandler3
      If choice = promptlist(1) Or choice = promptlist(3) Then
            Call xlWbk.SaveAs(xlsFileName(0))
            Call xlWbk.Close
            Messagebox "Export is Complete.  You may now open the saved spreadsheet: "&xlsFileName(0)
            Call xl.Quit
            xl = ""
      Else
            xl.Visible=True
      End If
' LotusScript code...
      processingTime = Timer - startTime
      Print "The script ran in " & Format$(processingTime, "0.00") & " seconds."
      If exportall = promptlist2(1) Then
            Call v.remove
      End If

      Exit Sub

errorHandler:
'This is called when there is bad data in a notes view, usually text in a date field, etc.
'Notes will show it, but it will fail to export correctly.  This replaces the Excel cell with a bad data text.
      Resume

errorHandler2:
      NEMProgressEnd hwnd
      Messagebox "Bad Options setting Spreadsheet format"
      Call xl.Quit
      If folderName Then
            Call v.remove
      End If

      xl = ""
      Exit Sub

errorHandler3:
      NEMProgressEnd hwnd
      Messagebox "Bad Filename Specified.  Please make sure that the directory name is correct."
      Call xl.Quit
      xl = ""
      If folderName Then
            Call v.remove
      End If
      Exit Sub
End Sub


Function Implode(Array As Variant,Separator As String) As String
	Dim text As String
	Dim i As Integer
	If Isarray(Array) Then
		For i=0 To Ubound(Array)
			If i=Ubound(Array) Then
				text=text & array(i)
			Else
				text=text & array(i) & separator
			End If
		Next
		Implode=text
	Else
		Implode=Array
	End If
End Function