Sample Code to Re-create User Personal Contact Applications

Mindwatering Incorporated

Author: Tripp W Black

Created: 04/07/2012 at 12:38 AM

 

Category:
Notes Developer Tips
LotusScript

Issue:
You have lost a bunch of local names.nsf Contacts apps. You need to recreate them.

Solution:

Sample code:

Option Public
Option Declare

Sub Initialize
Dim s As New NotesSession
Dim db As NotesDatabase ' current db
Dim w As New NotesUIWorkspace
Dim nDb As NotesDatabase ' domino directory app
Dim nV As NotesView ' domino view
Dim nCol As NotesDocumentCollection ' collection of docs maching key domsvrcat
Dim nDoc As NotesDocument ' current doc in nCol being processed
Dim idnm As String ' user id/shortname from nDoc
Dim idfullnm As String ' user fullname(0) value for title from nDoc
Dim mailsvrnm As String ' user mail server name from nDoc
Dim maildbpath As String ' user mailfile path from nDoc
Dim emailaddr As String ' user e-mail address from nDoc
' agent log / logging dims
Dim agentLog As NotesDocument ' agent log, used to add logging msgs to agent as code executes through various subs
Dim numdocs As Integer ' number of schedule docs (sDocs) processed

' location dims
Dim stagepath As String ' starting staging path
Dim stagepathfull As String ' full path to save file including idnm subfolder
Dim pernamespath As String ' fullpath including name to pernames.ntf template
Dim domsvrnm As String ' server w/ names.nsf / Domino Directory
Dim domsvrcat As String ' category of users to get from view

On Error Goto ErrorHandler

' location values
stagepath = "c:\temp\" ' include trailing slash
pernamespath = "c:\AppTemplates\names.nsf"
domsvrnm = "CN=Server/O=MyOrg" ' canonical format
domsvrcat = "AnotherServer/MyOrg" ' abbrev format

' setup
Set db = s.CurrentDatabase
Set nDb=s.GetDatabase(domsvrnm, "names.nsf", False)
If (nDb Is Nothing) Then
' give up
Print "(Initialize) Missing Domino Directory."
Exit Sub
End If
If Not (nDb.IsOpen) Then
Call nDb.Open(domsvrnm, "names.nsf")
If Not (nDb.IsOpen) Then
Print "(Initialize) Cannot open Domino Directory."
Exit Sub
End If
End If
' get lookup view
Set nV = nDb.GetView("Mail Users")
If (nV Is Nothing) Then
Print "(Initialize) Cannot open Domino Directory lookup view MailUsers."
Exit Sub
End If
' get docs to process
Set nCol = nV.GetAllDocumentsByKey(domsvrcat, True)
If (nCol Is Nothing) Then
Print "(Initialize) Cannot create collection for lookup view MailUsers."
Exit Sub
End If

' start agent log
Set agentLog = ALogStart(s, db)

If (nCol.Count = 0) Then
' nothing to do done.
Print "(Initialize) No users match key " & domsvrcat & ". Done."
Call ALogUpdate(agentLog, "No users match key " & domsvrcat & ". Done.", 2)
Call ALogEnd(agentLog, numdocs, 0)
Exit Sub
End If

Call ALogUpdate(agentLog, "Have " & Cstr(nCol.Count) & " person(s) to process for category " & domsvrcat & ".", 2)

' verify starting path is okay
If Not (TestFileExists(stagepath) = 1) Then
' stage file missing
Print "(Initialize) Temporary staging path not found " & stagepath & ". Done."
Call ALogUpdate(agentLog, "Temporary staging path not found " & stagepath & ". Done.", 2)
Exit Sub
End If

' loop and process
Set nDoc = nCol.GetFirstDocument()
While Not (nDoc Is Nothing)
' increment counter
numdocs = numdocs + 1
' get needed person values
idnm = nDoc.ShortName(0)
idfullnm = nDoc.FullName(0)
mailsvrnm = nDoc.MailServer(0)
maildbpath = nDoc.MailFile(0)
emailaddr = nDoc.InternetAddress(0)

' create the staging folder
stagepathfull = stagepath & idnm
Call CreateSFolder(stagepathfull)
stagepathfull = stagepathfull & "\"

Print "(Initialize) Final temporary stage folder:" & stagepathfull
Call ALogUpdate(agentLog, "Final temporary stage folder:" & stagepathfull , 2)

If (DoCustomizeNamesNSF(s, pernamespath, idfullnm, stagepathfull, mailsvrnm, maildbpath, _
emailaddr, agentLog)=1 ) Then
' success
Print "(Initialize) Completed customized personal names.nsf for " & idfullnm
Call ALogUpdate(agentLog, "Completed customizations for personal names db.", 2)
Else
' error doing mail file customization, add error to log
Print "(Initialize) Error making customized personal names.nsf for " & idfullnm
Call ALogUpdate(agentLog, "Error during personal names db customizations.", 1)
End If

' loop
Set nDoc = nCol.GetNextDocument(nDoc)
Wend

' close agent log
Call ALogUpdate(agentLog, "Agent finished. " & Cstr(numdocs) & " person(s) were processed.", 2)
'Call ALogEnd(agentLog, numdocs, numids)
Print "Agent finished. " & Cstr(numdocs) & " person(s) were processed."

Exit Sub

ErrorHandler:
Print "(Initialize) Unexpected error: " & Error$ & " (" & Cstr(Err) & "), on line: " & Cstr(Erl)
Exit Sub
End Sub

Function DoCustomizeNamesNSF(s As NotesSession, tempfilepath As String, usernm As String, _
stagepath As String, mailsvrnm As String, maildbpath As String, emailaddr As String, agentLog As NotesDocument) As Integer
' copies/creates and then performs customizations to new names.nsf, returns 1 for success
' s - used to get database
' tempfilepath - filepath to personal names.nsf "template"
' usernm - user's name in abberv. format
' stagepath - staging folder for current user
' mailsvrnm - home mail server to populate location doc
' maildbpath - mail db filepath to populate location doc
' emailaddr - email address to populate location doc
' agentLog - agent log doc to add error msgs
Dim tnamesDb As NotesDatabase ' template personal names.nsf
Dim namesDb As NotesDatabase ' user's new names.nsf created in temp folder
Dim namesACL As NotesACL ' ACL of mailDb, needed to add new entry for usernm
Dim namesDbRep As NotesReplication ' replication info object for namesDb
Dim userACLEntry As NotesACLEntry ' usernm's new ACL entry in namesACL
Dim npDoc As NotesDocument ' names/directory profile document in user's personal address book db
Dim allCol As NotesDocumentCollection ' collection of all existing docs in new namesDb, used to find location docs
Dim aDoc As NotesDocument ' location doc in allCol

On Error Goto FErrorHandler

' 1 - Create/copy new names.nsf database in staging directory
Set tnamesDb=s.GetDatabase("", tempfilepath, False)
If (tnamesDb Is Nothing) Then
' nothing to copy/customize, return failure
Call ALogUpdate(agentLog, "Unable to get personal names database, " & tempfilepath & ", for user " & usernm & ".", 1)
DoCustomizeNamesNSF=0
Exit Function
End If
Set namesDb=s.GetDatabase("", stagepath & "names.nsf", False)
If (namesDb Is Nothing) Then
' db does not yet exist (as it should be), create it
Set namesDb = tnamesDb.CreateCopy("", stagepath & "names.nsf")
Call ALogUpdate(agentLog, "Copied personal names.nsf for user " & usernm & ".", 2)
End If

' 2 - Update ACL, adding new entry for user
Set namesACL = namesDb.ACL
' see if user already exists
Set userACLEntry = namesACL.GetEntry(usernm)
If (userACLEntry Is Nothing) Then
' create the entry
Set userACLEntry = namesACL.CreateACLEntry(usernm, 6) ' user has manager access over personal names.nsf
' else, verify the acl level
userACLEntry.Level = 6
End If
Call namesACL.Save()

' 3 - Customize the directory profile for the user's personal address book
Set npDoc = namesDb.GetProfileDocument("DirectoryProfile")
npDoc.Owner = usernm
Call npDoc.Save(True, False)
Call ALogUpdate(agentLog, "Updated new personal names.nsf ACL & Directory Profile for user " & usernm & ".", 2)

' 3 - Update "Office" Location document(s) for user
' get all docs (will loop to find locations)
Set allCol = namesDb.AllDocuments
If (allCol.Count = 0) Then
' missing location sample doc, have to create one
Set aDoc = namesDb.CreateDocument()
aDoc.Form = "Location"
aDoc.Name = "Office"
' aDoc.Name = "Online"
aDoc.MailServer = mailsvrnm
aDoc.DirectoryServer = mailsvrnm
aDoc.MailFile = maildbpath
aDoc.ImailAddress = emailaddr
Call aDoc.ComputeWithForm(False, False)
' aDoc.DefaultPassthruServer = "" ' populated by computewithform, comment out if not wanted
Call aDoc.Save(True, False)
Call ALogUpdate(agentLog, "Created new personal names.nsf location for user " & usernm & ".", 2)
Else
' update docs
Set aDoc = allCol.GetFirstDocument()
While Not (aDoc Is Nothing)
' check if current lDoc is location
If (aDoc.Form(0) = "Location" ) Then
Select Case aDoc.Name(0)
Case "Office"
' update office location
aDoc.MailServer=mailsvrnm
aDoc.DirectoryServer=mailsvrnm
aDoc.MailFile = maildbpath
aDoc.ImailAddress=emailaddr
Call aDoc.Save(True, False)
Call ALogUpdate(agentLog, "Updated new personal names.nsf Office location for user " & usernm & ".", 2)
Case "Online"
' update office location
aDoc.MailServer=mailsvrnm
aDoc.DirectoryServer=mailsvrnm
aDoc.MailFile = maildbpath
aDoc.ImailAddress=emailaddr
Call aDoc.Save(True, False)
Call ALogUpdate(agentLog, "Updated new personal names.nsf Online location for user " & usernm & ".", 2)
Case "Mobile"
' update mobile location (MailType field controls if mail is located on server/0 or on local/1)
aDoc.MailServer = mailsvrnm
aDoc.DirectoryServer = mailsvrnm
aDoc.MailFile = maildbpath
aDoc.ImailAddress = emailaddr
Call aDoc.Save(True, False)
Call ALogUpdate(agentLog, "Updated new personal names.nsf Mobile location for user " & usernm & ".", 2)
Case "Else"
' do nothing, skip
End Select
End If
' loop
Set aDoc = allCol.GetNextDocument(aDoc)
Wend
End If

' return success
DoCustomizeNamesNSF=1
FExit:
Exit Function

FErrorHandler:
Print "(Initialize) Unexpected error: " & Error$ & " (" & Cstr(Err) & "), on line: " & Cstr(Erl)
DoCustomizeNamesNSF=0
Resume FExit
End Function

Function ALogStart(s As NotesSession, db As NotesDatabase) As NotesDocument
' begins the agent log document in this database
Dim aDoc As NotesDocument ' new agent log doc
Dim msgItem As NotesItem ' messages field which agent appends comments/messages
Dim timenow As String ' now, for starting msg in msgItem

On Error Goto FErrorHandler

' skip right now
Set ALogStart = Nothing
Exit Function

'create log document
Set aDoc=db.CreateDocument()
aDoc.Form="Log"
aDoc.Log_AgentName="agRegStage"
aDoc.Log_DateRan=Today
aDoc.Log_Action="Registers users, creates their files, stages files for Xcellenet"
aDoc.Log_TimeStarted=Format(Now() , "Long Time")
aDoc.Log_Msgs=""
aDoc.Log_Errors=""
Set msgItem =aDoc.GetFirstItem("Log_Msgs")
If (msgItem Is Nothing) Then
Set msgItem = New NotesItem(aDoc, "Log_Msgs", 1280)
End If
timenow$=Format(Now() , "Long Time")
Call msgItem.Appendtotextlist(timenow$ & " RegStage Agent Started ")
Call aDoc.save(True, False)

' return new doc
Set ALogStart = aDoc
Exit Function

FErrorHandler:
Print "(ALogStart) Unexpected error: " & Error$ & " (" & Cstr(Err) & "), on line: " & Cstr(Erl)
Exit Function

End Function


Function ALogUpdate(aDoc As NotesDocument, msg As String, msgtype As Integer) As Integer
' updates existing the agent log document created in ALogStart
' aDoc - doc object
' msg - message to add to doc
' msgtype - regular message or error message
Dim docid As String ' aDoc's UNID
Dim db As NotesDatabase ' aDoc's db
Dim msgItem As NotesItem ' messages field which agent appends comments/messages
Dim timenow As String ' now, for starting msg in msgItem

' not using right now
ALogUpdate = 1
Exit Function

' get most recent version of aDoc
Set db=aDoc.ParentDatabase
docid = aDoc.UniversalID
Set aDoc = db.GetDocumentByUNID(docid)

' update log document
Select Case msgtype
Case 2
' error msg
Set msgItem =aDoc.GetFirstItem("Log_Msgs")
Case Else
' msg
Set msgItem =aDoc.GetFirstItem("Log_Errors")
End Select
timenow$=Format(Now() , "Long Time")
Call msgItem.Appendtotextlist(timenow$ & ", " & msg)
Call aDoc.save(True, False)

' return 1 for success
ALogUpdate = 1
Exit Function

End Function


Function ALogEnd(aDoc As NotesDocument, numdocs As Integer, numids As Long) As Integer
' completes final tallies and updates to log document

' skip for now
ALogEnd = 1
Exit Function

aDoc.Log_TimeEnded=Format(Now() , "Long Time")
aDoc.Log_NumDocs = numdocs
aDoc.Log_NumIDs= numids
aDoc.Log_RanBy = "System"
' save
Call aDoc.save(True, False)

' return 1 for success
ALogEnd = 1
Exit Function
End Function


Function TestFileExists(filenm As String) As Integer
' tests if file exists, returns 1 for exists/success, 0 for nope

On Error Goto FErrorHandler

' test file
If (Dir$(filenm) = "") Then
' no file exists
TestFileExists=0
Else
' file exists
TestFileExists=1
End If
Exit Function

FErrorHandler:
TestFileExists=0
Exit Function

End Function


Function CreateSFolder(newfilepath As String) As Integer
' called to create new store staging subfolder or new store temporary folder
On Error 75 Resume Next
On Error 76 Resume Next
Chdir newfilepath
If Err>0 Then
Mkdir newfilepath
End If

' return success
CreateSFolder=1
End Function






previous page