GroupMembersReport (agent)
(Options)
Option Public
Option Declare
(Declarations)
Dim gMLst As Variant ' group members
Sub Initialize
' agent mines group and sends e-mail with results
Dim snm As String ' server w/names.nsf
Dim gnm As String ' group name to mine
Dim sendtonm As String ' person to receive report
' ******************* update below **********
snm = "cn=myserver/0=mydomain"
gnm = "mygroupname"
sendtonm = "My Name/OU/Org@Domain"
'**********************************************
Dim s As New NotesSession
Dim db As NotesDatabase ' current db
Dim nDb As NotesDatabase ' directory
Dim nV As NotesView ' groups view
Dim nvnm As String ' groups lookup view name
Dim nDoc As NotesDocument ' group doc
Dim gmLst As Variant ' list of group members
On Error Goto SErrorHandler
Set db = s.CurrentDatabase
' get directory and lookup view
Set nDb =GetServerDb(s, snm, "names.nsf")
If (nDb Is Nothing) Then
Print "Cancelled. Unable to get Domino Directory on server: " & snm & "."
Exit Sub
End If
nvnm = "($VIMGroups)"
Set nV = nDb.GetView(nvnm)
If (nV Is Nothing) Then
Print "Cancelled. Unable to get view, " & nvnm & ", in Domino Directory on server: " & snm & "."
Exit Sub
End If
' get group
Set nDoc = nV.GetDocumentByKey(gnm)
If (nDoc Is Nothing) Then
Print "Cancelled. No group named, " & gnm & ", in Domino Directory on server: " & snm & ". Done."
Exit Sub
End If
' process group members
gmLst = ProcessGroup(nDb, nV, nDoc)
' have list, e-mail
Call DoNotify(db, nDb, nDoc, gmLst , sendtonm)
' done
Print "Done execution."
SExit:
Exit Sub
SErrorHandler:
Print "(GroupMembersReport - Initialize) Unexpected Error: " & Cstr(Err) & " " & Error$ & ", on line: " & Cstr(Erl) & ".
"
Resume SExit
End Sub
Function GetServerDb(s As NotesSession, servernm As String, dbfilepath As String) As NotesDatabase
' gets app by server and path, returns nothing if not able to get and open
Dim aDb As NotesDatabase ' database to get
On Error Goto FErrorHandler
Set aDb = s.GetDatabase(servernm, dbfilepath, False)
If (aDb Is Nothing) Then
Set GetServerDb = Nothing
Exit Function
End If
If (aDb.IsOpen) Then
' return app
Set GetServerDb = aDb
Exit Function
Else
' try to open again
Call aDb.Open(servernm, dbfilepath)
If (aDb.IsOpen) Then
' return app
Set GetServerDb = aDb
Exit Function
Else
' not open still, return nothing
Set aDb = Nothing
Set GetServerDb = Nothing
Exit Function
End If
End If
FExit:
Exit Function
FErrorHandler:
Print "(GetServerDb) Unexpected Error: " & Cstr(Err) & " " & Error$ & ", on line: " & Cstr(Erl) & ".
"
Set GetServerDb = Nothing
Resume FExit
End Function
Function ProcessGroup(nDb As NotesDatabase, nV As NotesView, nDoc As NotesDocument) As Variant
' processes group membership
' nDb - names.nsf
' nV - group lookup view
' nDoc - current group document to get members
Dim nMembers As NotesItem ' nDoc group member field
Dim gmV As NotesView ' member view
Dim gmNm As NotesName ' member name for nest check
Dim gsubDoc As NotesDocument ' member that turns out to be nested group name
Dim gmembernm As String ' current name in members field values
Dim gmLst As Variant ' list of members mined
Dim gmsLst As Variant ' sub list to add back to main list
On Error Goto FErrorHandler
' setup list
Redim gmLst(0)
gmLst(0) = ""
' get members field
Set nMembers = nDoc.GetFirstItem("Members")
If (nMembers Is Nothing) Then
' return failure
gmLst(0) = ""
ProcessGroup = gmLst
Exit Function
End If
If (nMembers.Text="") Then
' no members, done
Print "Group empty."
gmLst(0) = ""
ProcessGroup = gmLst
Exit Function
End If
' loop through member values and mine
Forall membernm In nMembers.Values
gmembernm = Trim(Cstr(membernm))
If Not (gmembernm = "") Then
' check if current item is also a group
Set gmNm = New NotesName(gmembernm)
If Not (gmNm Is Nothing) Then
Set gsubDoc = nV.GetDocumentByKey( gmNm.Abbreviated)
End If ' end gmNm nothing test
' check if we have nested group doc
If (gsubDoc Is Nothing) Then
' current entry/name not a group, add name to list
gmLst = ListAdd(gmLst, gmembernm)
Else
' current entry is a group, mine nest
' *** start recursive call *******
gmsLst = ProcessGroup(nDb, nV, gsubDoc)
' add any members of sub group to this group
Forall submembernm In gmsLst
Call ListAdd(gmLst, Cstr(submembernm))
End Forall
' *** end recursive call ********
End If
End If
End Forall
' return final list for current group
ProcessGroup = gmLst
FExit:
Exit Function
FErrorHandler:
Print "(ProcessGroup) Unexpected Error: " & Cstr(Err) & " " & Error$ & ", on line: " & Cstr(Erl) & ".
"
Resume FExit
End Function
Function ListAdd(inLst As Variant, newvalstr As String) As Variant
' adds to existing array
' inLst - current array being appended to
' newvalstr - value to be added to inLst
Dim lstsize As Long ' counter/size of inLst
On Error Goto FErrorhandler
If (Isempty(inLst)) Then
Redim inLst(0) As String
End If
' start with return list = starting list
ListAdd = inLst
If (Ubound(inLst) = Lbound(inLst) And inLst(Ubound(inLst)) = "" ) Then ' error 200 if not initialized
' empty array, add value on top of first value
LstInitialized:
inLst(Lbound(inLst) ) = newvalstr
Else
' add to existing array
lstsize = Ubound(inLst) + 1
Redim Preserve inLst(lstsize)
inLst(lstsize) = newvalstr
End If
' return updated list
ListAdd = inLst
FExit:
Exit Function
FErrorHandler:
If (Err=200) Then
' list passed into function not initialized
Redim inLst(0 To 0)
Resume LstInitialized
Else
' unexpected error, abort
Print "(ListAdd) Unexpected Error: " & Cstr(Err) & " " & Error$ & ", on line: " & Cstr(Erl) & ".
"
Resume FExit
End If
End Function
Function DoNotify(db As NotesDatabase, nDb As NotesDatabase, nDoc As NotesDocument, gmLst As Variant , sendtonm As String) As Integer
' send results of report to sendtonm
Dim mailDoc As NotesDocument ' the mailer doc
Dim body As NotesRichTextItem ' the body field of memo
On Error Goto FErrorHandler
' create new memo
Set mailDoc = db.CreateDocument
mailDoc.SaveMessageOnSend = False
mailDoc.Form = "Memo"
mailDoc.From = db.Server
mailDoc.ReplyTo = sendtonm
mailDoc.SendTo = sendtonm
mailDoc.Principal = sendtonm
mailDoc.Subject = |Group membership report for group: | & nDoc.ListName(0) & |.|
Set body = New NotesRichTextItem(mailDoc, "Body")
Call body.AppendText("Group Members: ")
Call body.AddNewline(1)
Forall y In gmLst
Call body.AppendText(Cstr(y) & ", ")
End Forall
Call body.AddNewline(1)
' add doclink
Call body.AppendText("Doclink to Directory:")
Call body.AppendDocLink(nDb, db.Title)
Call body.AddNewline(1)
' send memo
Call mailDoc.Send(False, sendtonm)
' return success to main function
DoNotify=1
FExit:
Exit Function
FErrorHandler:
Print "(DoNotify) Unexpected Error: " & Cstr(Err) & " " & Error$ & ", on line: " & Cstr(Erl) & ".
"
DoNotify = 0
Resume FExit
End Function