Subject: Agent code
This may need some tweeking
Options
'*************************************************
Option Public
Option Explicit
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
'*************************************************
Declarations:
'*************************************************
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 )
Dim szFilter As String
Dim startTime As Single
Dim processingTime As Single
Dim dbCurrent As NotesDatabase
Dim dbnames As NotesDatabase
Dim promptlist(3) As String, choice As String, promptlist2(1) As String, exportall As String
Dim xl As Variant, xlWbk As Variant, hwnd As Variant, xlsFileName As Variant
Dim NamesList() As String
Dim NameCnt As Integer
Dim nameDoc As notesdocument
Dim xlSheet As Variant
Dim xlSheet1 As Variant
Dim xlSheet2 As Variant
Dim xlSheet3 As Variant
Dim iCurrentXLRow1 As Integer
Dim iCurrentXLRow2 As Integer
Dim iCurrentXLRow3 As Integer
Dim db As NotesDatabase
Dim v As NotesView
Dim n As NotesViewNavigator
'**************************************************
Sub Initialize
Dim session As New NotesSession
Dim ws As New notesuiworkspace
Const bShowProgressBar = False
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 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 whoops
Set dbCurrent = session.CurrentDatabase
Set dbNames = session.GetDatabase(dbCurrent.Server, "Names.nsf")
If Not dbNames.IsOpen Then
Messagebox "names.nsf does not exist ",, "No names.nsf"
Else
Messagebox dbNames.Title,, "Title of names.nsf"
End If
Dim viewActive As NotesView
Dim viewNames As NotesView
Dim iCurrentXLRow As Integer ' Keep a count of which row we've got to write out to in the XLS
Set viewActive = dbCurrent.GetView("users")
Set viewNames = dbNames.GetView("_People")
Set nameDoc = viewNames.GetFirstDocument
iCurrentXLRow = 0
Dim intb As Integer
Dim namename As String
Dim NamesTable As New TableJar
While Not(nameDoc Is Nothing)
Print("Names " + Cstr(iCurrentXLRow))
namename = Lcase(nameDoc.FirstName(0) + " " + nameDoc.Lastname(0))
For intb = 0 To NamesTable.Count - 1
If NamesTable.getValue(intb,0) = namename Then
Goto nextnamedoc
End If
Next
Call NamesTable.setValue(iCurrentXLRow, 0, namename)
Call NamesTable.setValue(iCurrentXLRow, 1, nameDoc.FullName(0))
iCurrentXLRow = iCurrentXLRow +1
nextnamedoc:
Set nameDoc= viewNames.GetNextDocument(nameDoc)
Wend
iCurrentXLRow = 0
Dim activeDoc As notesdocument
Dim activeTable As New TableJar
Dim activename As String
Set activeDoc = viewActive.GetFirstDocument
Call activeTable.setValue(iCurrentXLRow, 0, "")
Call activeTable.setValue(iCurrentXLRow, 1, "")
Call activeTable.setValue(iCurrentXLRow, 2, "")
Call activeTable.setValue(iCurrentXLRow, 3, "")
Dim actcnt As Double
Dim allcnt As Double
Dim smalleractive As New Tablejar
Dim smcnt As Integer
Dim entryA As NotesViewEntry
Dim entryB As NotesViewEntry
Dim doc As NotesDocument
Dim sleft As String
Dim sright As String
Dim v1 As Variant
Dim v2 As Variant
Dim createDate As Variant
sleft = "CN="
sright="/OU"
Set n = viewActive.CreateViewNav
Set entryA = n.GetFirst
While Not(entryA Is Nothing)
Set entryB = n.GetChild(entryA)
Set doc = entryB.Document
If Not doc Is Nothing Then
Print("Active " + Cstr(iCurrentXLRow))
activename = doc.AuthenticatedUser(0)
v1 = Strright( activename,sleft )
v2 = Strleft( Cstr(v1),sright )
Print("Active " + Cstr(iCurrentXLRow) + " " + Cstr(v2))
createDate = doc.Created
Call activeTable.setValue(iCurrentXLRow, 0, Cstr(v2))
Call activeTable.setValue(iCurrentXLRow, 1, Cstr(createDate))
Call activeTable.setValue(iCurrentXLRow, 2, doc.UserAddress(0))
Call activeTable.setValue(iCurrentXLRow, 3, doc.AuthenticatedUser(0))
iCurrentXLRow = iCurrentXLRow +1
End If
Set entryA = n.GetNextCategory(entryA)
Wend
Dim cnt1 As Integer
Dim cnt2 As Integer
Dim nm As String
Dim fnm As String
Dim am As String
Dim NoTable As New TableJar
cnt2 = 0
iCurrentXLRow = 0
For cnt1 = 0 To NamesTable.Count - 1
Print("No " + Cstr(iCurrentXLRow))
nm = Lcase(NamesTable.getValue(cnt1,0))
fnm = NamesTable.getValue(cnt1,1)
For cnt2 = 0 To activeTable.Count -1
am = Lcase(activeTable.getValue(cnt2,0))
If nm = am Then
Goto namefound
End If
Next
Call NoTable.setValue(iCurrentXLRow, 0, nm)
Call NoTable.setValue(iCurrentXLRow, 1, fnm)
iCurrentXLRow = iCurrentXLRow + 1
namefound:
Next
Call outputSheet1(NamesTable)
Call outputSheet2(activeTable)
Call outputSheet3(NoTable)
'Stop Progress Bar
If bShowProgressBar Then NEMProgressEnd hwnd
'Save and be gone!
On Error Goto errorHandler3
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 = ""
processingTime = Timer - startTime
Print "The script ran in " & Format$(processingTime, "0.00") & " seconds."
Exit Sub
errorHandler:
Dim strErrMsg
strErrMsg = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
strErrMsg = strErrMsg + ". Please report this to the IT staff"
Msgbox strErrMsg
Exit Sub
errorHandler2:
If bShowProgressBar Then NEMProgressEnd hwnd
Messagebox "Bad Options setting Spreadsheet format"
Call xl.Quit
xl = ""
Exit Sub
errorHandler3:
If bShowProgressBar Then NEMProgressEnd hwnd
Messagebox "Bad Filename Specified. Please make sure that the directory name is correct."
Call xl.Quit
xl = ""
Exit Sub
whoops:
Dim strErrMsgx
strErrMsgx = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
strErrMsgx = strErrMsgx + ". Please report this to the IT staff"
Msgbox strErrMsgx
Exit Sub
End Sub
'*************************************************
Function outputsheet1(VessTable1 As TableJar)
Dim ret As Variant
Dim teststr As String
Dim delim As String
Dim resultArr As Variant
Dim outstring As String
Dim outx As Integer
On Error Goto whoops
'==============================
'Set up the excel worksheets
Set xlSheet1 = xlWbk.Worksheets(1)
Call xlSheet1.Activate
xlSheet1.Name = "All Names"
xl.Cells.select
xl.Selection.ClearContents
xlSheet1.Cells(1, 1) = "Name"
xlSheet1.Cells(1, 2) = "Full Name"
Dim thisrow As Integer
Dim walker As Integer
walker = 1
Dim ix As Integer
For ix = 0 To VessTable1.Count - 1
thisrow = ix + 2
xlSheet1.cells(thisrow, 1) = cellvalueStr(VessTable1, ix, 0)
xlSheet1.cells(thisrow, 2) = cellvalueStr(VessTable1, ix, 1)
Next
'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 = 10
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
Exit Function
whoops:
Dim strErrMsg
strErrMsg = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
strErrMsg = strErrMsg + ". Please report this to the IT staff"
Msgbox strErrMsg
Exit Function
End Function
'**********************************************
Function cellvalueStr(srchTable As tablejar, row As Integer, col As Integer) As String
On Error Goto whoops
Dim tvar As Variant
cellvalueStr = ""
tvar = srchTable.getValue(row, col)
If Datatype(tvar) = 0 Or Datatype(tvar)= 1 Or Datatype(tvar) = 9 Or Datatype(tvar)= 10 Or Datatype(tvar) = 13 Then
cellvalueStr = ""
Else
cellvalueStr = Cstr(tvar)
End If
Exit Function
whoops:
Dim strErrMsg
strErrMsg = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
strErrMsg = strErrMsg + ". Please report this to the IT staff"
Msgbox strErrMsg
cellvalueStr = ""
Exit Function
End Function
'************************************************
Function outputsheet2(VessTable2 As TableJar)
Dim ret As Variant
Dim teststr As String
Dim delim As String
Dim resultArr As Variant
Dim outstring As String
Dim outx As Integer
On Error Goto whoops
'=========================================================================================================
'Set up the excel worksheets
Set xlSheet1 = xlWbk.Worksheets(2)
Call xlSheet1.Activate
xlSheet1.Name = "Active Names"
xl.Cells.select
xl.Selection.ClearContents
xlSheet1.Cells(1, 1) = "Name"
xlSheet1.Cells(1, 2) = "Date Last Accessed"
xlSheet1.Cells(1, 3) = "From"
xlSheet1.Cells(1, 4) = "Full Name"
Dim thisrow As Integer
Dim walker As Integer
walker = 1
Dim ix As Integer
For ix = 0 To VessTable2.Count - 1
thisrow = ix + 2
xlSheet1.cells(thisrow, 1) = cellvalueStr(VessTable2, ix, 0)
xlSheet1.cells(thisrow, 2) = cellvalueStr(VessTable2, ix, 1)
xlSheet1.cells(thisrow, 3) = cellvalueStr(VessTable2, ix, 2)
xlSheet1.cells(thisrow, 4) = cellvalueStr(VessTable2, ix, 3)
Next
'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 = 10
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
Exit Function
whoops:
Dim strErrMsg
strErrMsg = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
strErrMsg = strErrMsg + ". Please report this to the IT staff"
Msgbox strErrMsg
Exit Function
End Function
'************************************************
Function outputsheet3(VessTable3 As TableJar)
Dim ret As Variant
Dim teststr As String
Dim delim As String
Dim resultArr As Variant
Dim outstring As String
Dim outx As Integer
On Error Goto whoops
'=========================================================================================================
'Set up the excel worksheets
Set xlSheet1 = xlWbk.Worksheets(3)
Call xlSheet1.Activate
xlSheet1.Name = "InActive Names"
xl.Cells.select
xl.Selection.ClearContents
xlSheet1.Cells(1, 1) = "Name"
xlSheet1.Cells(1, 2) = "Full Name"
Dim thisrow As Integer
Dim walker As Integer
walker = 1
Dim ix As Integer
For ix = 0 To VessTable3.Count - 1
thisrow = ix + 2
xlSheet1.cells(thisrow, 1) = cellvalueStr(VessTable3, ix, 0)
xlSheet1.cells(thisrow, 2) = cellvalueStr(VessTable3, ix, 1)
Next
'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 = 10
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
Exit Function
whoops:
Dim strErrMsg
strErrMsg = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
strErrMsg = strErrMsg + ". Please report this to the IT staff"
Msgbox strErrMsg
Exit Function
End Function
