Sub Click(Source As Button)
'Copyright Botstation (www.botstation.com)
Dim session As New NotesSession
Dim wks As New NotesUIWorkspace
Dim db As NotesDatabase
Dim view As NotesView
Dim uiView As NotesUIView
Dim doc As NotesDocument
Dim column As NotesViewColumn
Dim row As Long,colcounter As Long,arrcnt As Long,arrcounter As Long, x As Long
Dim filename As String, currentvalue As String
Dim rowsatonce As Integer,cn As Integer
Dim xlApp As Variant, xlsheet As Variant,xlwb As Variant, xlrange As Variant, tempval As Variant
Dim DataArray
Dim VColumns List As String
Redim DataArray(0, 80) As String
'80 columns is our expected max number of columns in the view. It's dynamically recomputed below to actual (lower) number. Change if the number of columns is larger.
Set db=session.CurrentDatabase
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True 'Excel program is visible (to avoid errors and see what is happening)
Set xlwb=xlApp.Workbooks.Add
Set xlsheet =xlwb.Worksheets(1)
Set uiView = wks.CurrentView
Set view = db.GetView( uiView.ViewName ) ' get the view currently open in UI
arrcnt=0
row=1
colcounter=0
rowsatonce=20
Forall c In view.Columns
If c.isIcon<>True Then ' do not include icon columns
If c.Formula<>"""1""" And c.Formula<>"1" Then 'do not include columns which are used for counting docs (Total)
colcounter=colcounter+1
DataArray(row-1, colcounter-1) =c.Title
VColumns(Cstr(cn))=Cstr(cn)
End If
End If
cn=cn+1
End Forall
Redim Preserve DataArray(0, colcounter-1) As String
xlsheet.Range("A1").Resize(1, colcounter).Value = DataArray ' set column names
Redim DataArray(rowsatonce-1, colcounter-1) As String
row=2
x=0
Set doc = view.GetFirstDocument
While Not ( doc Is Nothing )
Forall col In VColumns
currentvalue=""
tempval= doc.ColumnValues(Val(col))
If Isarray(tempval) Then
Forall v In tempval
If currentvalue="" Then
currentvalue=v
Else
currentvalue=currentvalue+","+v
End If
End Forall
Else
currentvalue=tempval
End If
x=x+1
DataArray(arrcounter, x-1) =currentvalue
End Forall
x=0
row=row+1
arrcounter=arrcounter+1
If arrcounter/rowsatonce=arrcounter\rowsatonce And arrcounter<>0 Then
xlsheet.Range("A"+Cstr(arrcnt*rowsatonce+2)).Resize(rowsatonce, colcounter).Value = DataArray
arrcnt=arrcnt+1
arrcounter=0
Redim DataArray(rowsatonce-1, colcounter-1) As String
End If
Set doc = view.GetNextDocument (doc)
Wend
If arrcounter/rowsatonce<>arrcounter\rowsatonce And arrcounter>0 Then
' Redim Preserve DataArray(arrcounter, colcounter-1) As String
xlsheet.Range("A"+Cstr(arrcnt*rowsatonce+2)).Resize(arrcounter, colcounter).Value = DataArray
End If
xlsheet.Cells.Select
xlsheet.Cells.EntireColumn.AutoFit
xlsheet.Rows("1:1").Select
xlapp.Selection.Font.Bold = True
xlapp.Selection.Interior.Pattern = 1
xlapp.Selection.Interior.PatternColorIndex = -4105
xlapp.Selection.Interior.ThemeColor =3
xlapp.Selection.Interior.TintAndShade = 0
xlapp.Selection.Interior.PatternTintAndShade = 0
xlapp.Selection.RowHeight = 41.25
xlapp.Selection.Insert Shift = -4121
xlapp.Range("A1").Select
xlapp.ActiveCell.FormulaR1C1 = Datevalue(Now)
xlapp.Range("B1").Select
xlapp.ActiveCell.FormulaR1C1 = "Retail Project Request Status"
xlsheet.Rows("1:1").Select
xlapp.Selection.Font.Bold = True
xlapp.Selection.Interior.Pattern = 1
xlapp.Selection.Interior.PatternColorIndex = -4105
xlapp.Selection.Interior.ThemeColor =3
xlapp.Selection.Interior.TintAndShade = 0
xlapp.Selection.Interior.PatternTintAndShade = 0
xlapp.Columns("A:A").ColumnWidth = 10.14
Msgbox "Done"
End Sub
|