Subject: CLASSUserActivity crashes client / server at W32_OSLockObject
Hi Normunds and Rob,
Thanks for your input. I guess it would help if I posted the whole code huh? 
Here’s my agent. It’s to log all databases in a directory, and pick up last user activity, so we can weed out unused DBs.
So yes I capture errors, but I do use Resume Next. The actual error itself isn’t being logged as I’m not logging from the class itself, which is bloomin’ annoying. Not a fan of custom classes myself, would much rather just use regular subs and functions in a script library.
OK enough waffling, here’s the code:
=======================================
Option Public
Option Declare
Use “Agent Log”
Use “CLASSUserActivity”
Dim session As NotesSession
Dim dbThis As NotesDatabase
Dim i As Integer
Sub Initialize
Dim lookupView As NotesView
Dim lookupDoc As NotesDocument
Dim lookupItem As NotesItem
Dim mflookupView As NotesView
Dim db As NotesDatabase
Dim dbDir As NotesDbDirectory
Dim doc As NotesDocument
Dim eListDoc As NotesDocument
Dim eListItem As NotesItem
Dim strFolderPortion As String
Dim intPos As Integer
Call StartAgentLog
On Error Goto ErrorHandler
Set session = New NotesSession
Set dbThis = session.CurrentDatabase
'Lookups for mail server list and directory exceptions list
Set lookupView = dbThis.GetView("Lookup")
Set lookupDoc = lookupView.GetDocumentByKey("MailServers", True)
Set lookupItem = lookupDoc.GetFirstItem("LookupValues")
Set mflookupView = dbThis.GetView("MailFileLookup")
Set eListDoc = lookupView.GetDocumentByKey("ExceptionList", True)
Set eListItem = eListDoc.GetFirstItem("LookupValues")
'Get rid of this server's old DB info capture documents
Call DeleteOldDocs
Set dbDir = New NotesDbDirectory(dbThis.Server)
Call WriteAgentLog("dbThis.Server: " & dbThis.Server)
Call WriteAgentLog("dbDir.Name: " & dbDir.Name)
Set db = dbDir.GetFirstDatabase( DATABASE )
'Loop through the databases
'on each server
i = 1
While Not (db Is Nothing)
Print i
If Not(isOnRoot(db)) Then
'No - extract the left most folder
strFolderPortion = Left$(db.Filepath, Instr(1, db.Filepath, "\", 5))
'Search for exceptions
If Isnull(Arraygetindex(eListItem.Values, Cvar(strFolderPortion), 5)) Then
'Not in Exceptions List, so try to open the database
If Not(db.IsOpen) Then Call db.Open(db.Server,db.FilePath)
'Proceed if managed to open database otherwise write to log and continue
If db.IsOpen Then
Call CreateNewDoc(db, doc)
Call LogUserActivity(db, doc)
Call IsOrphanMailFile(db, doc, mflookupView, lookupItem.Values)
'Save the doc and get the next
'database in the directory
Call doc.ComputeWithForm(False, False)
Call doc.Save(True, False)
’ Else
'RestartHere:
’ Call WriteAgentLog( "*** Unable to Open " & db.FilePath & ", " & db.Title)
End If
'^^ End of checking that database can be opened
End If
End If
'Get the next database to have a gander at
Set db = dbDir.GetNextDatabase
i = i+1
Wend
'All done, stop the Agent Log
Call StopAgentLog
Exit Sub
Errorhandler:
Call ErrorAgentLog("Initialize: " & Err() & ", " & Error() & " " & "at line " & Erl())
Resume Next
End Sub
Sub DeleteOldDocs
Dim coll As NotesDocumentCollection
Dim colldoc As NotesDocument
Dim tempdoc As NotesDocument
Dim strSearch As String
On Error Goto ErrorHandler
'Get rid of the old documents for this server
strSearch = |Form="DatabaseCapture" & Deleted=("" : "No") & db_server="| & dbThis.Server & |"|
Set coll = dbThis.Search(strSearch, Nothing, 0)
If coll.Count > 0 Then
'Loop through the documents to
'ensure they all get deleted properly
Set colldoc = coll.GetFirstDocument
Do Until colldoc Is Nothing
Set tempdoc = coll.GetNextDocument(colldoc)
Call colldoc.Remove(True)
Set colldoc = tempdoc
Loop
End If
Exit Sub
Errorhandler:
Call ErrorAgentLog("DeleteOldDocs: " & Err() & ", " & Error() & " " & "at line " & Erl())
Resume Next
End Sub
Sub CreateNewDoc(db As NotesDatabase, doc As NotesDocument)
Dim linkitem As NotesRichTextItem
On Error Goto ErrorHandler
'Create a new Database Capture document
Set doc = New NotesDocument(dbThis)
With doc
Call .ReplaceItemValue("Form", "DatabaseCapture")
Call .ReplaceItemValue("db_server", dbThis.Server)
Call .ReplaceItemValue("db_path", db.FilePath)
Call .ReplaceItemValue("db_title", db.Title)
Call .ReplaceItemValue("db_size", db.Size)
Call .ReplaceItemValue("db_notesurl", db.NotesURL)
Call .ReplaceItemValue("db_replicaid", db.ReplicaID)
End With
'Add a DB Link
Set linkitem = New NotesRichTextItem(doc, "db_link")
Call linkitem.AppendDocLink( db, "Click to open " & db.Title )
Exit Sub
Errorhandler:
Call ErrorAgentLog("CreateNewDoc: " & Err() & ", " & Error() & " " & "at line " & Erl())
Resume Next
End Sub
Sub LogUserActivity(db As NotesDatabase, doc As NotesDocument)
If Not (i = 65) Then
'User Activity
Dim ua As NotesUserActivity
Dim uae As NotesUserActivityEntry
On Error Goto ErrorHandler
'On Error Resume Next
Set ua = New NotesUserActivity(db)
If ua.HasUserActivity Then
Set uae = ua.GetNthUserActivityEntry(1)
' Call .ReplaceItemValue("rtime", Cdat(uae.Time))
doc.rtime = uae.Time
doc.rname = uae.UserName
End If
End If
Exit Sub
Errorhandler:
Call ErrorAgentLog("LogUserActivity: " & Err() & ", " & Error() & " " & "at line " & Erl())
Resume Next
End Sub
Sub LogUserActivity(db As NotesDatabase, doc As NotesDocument)
If Not (i = 65) Then
'User Activity
Dim ua As NotesUserActivity
Dim uae As NotesUserActivityEntry
On Error Goto ErrorHandler
'On Error Resume Next
Set ua = New NotesUserActivity(db)
If ua.HasUserActivity Then
Set uae = ua.GetNthUserActivityEntry(1)
' Call .ReplaceItemValue("rtime", Cdat(uae.Time))
doc.rtime = uae.Time
doc.rname = uae.UserName
End If
End If
Exit Sub
Errorhandler:
Call ErrorAgentLog("LogUserActivity: " & Err() & ", " & Error() & " " & "at line " & Erl())
Resume Next
End Sub
Function isOnRoot(db As NotesDatabase) As Boolean
On Error Goto ErrorHandler
Dim intPos As Integer
isOnRoot = False
intPos = Instr(1, db.Filepath, "\", 5)
If Not(intPos <> 0) Then isOnRoot = True
Exit Function
Errorhandler:
Call ErrorAgentLog("isOnRoot: " & Err() & ", " & Error() & " " & "at line " & Erl())
Resume Next
End Function
Function isMailServer(db As NotesDatabase, varLookupValues As Variant) As Boolean
On Error Goto ErrorHandler
isMailServer = False
If Not(Isnull(Arraygetindex(varLookupValues, Cvar(db.Server), 5))) Then isMailServer = True
Exit Function
Exit Function
Errorhandler:
Call ErrorAgentLog("isMailServer: " & Err() & ", " & Error() & " " & "at line " & Erl())
Resume Next
End Function
=======================================
And here’s the third-party UserActivity class:
Option Public
Option Explicit
Const MAXALPHATIMEDATE = 80
Type TIMEDATE
Innard1 As Long
Innard2 As Long
End Type
Type DBACTIVITY
First As TIMEDATE
Last As TIMEDATE
Uses As Long
Reads As Long
Writes As Long
PrevDayUses As Long
PrevDayReads As Long
PrevDayWrites As Long
PrevWeekUses As Long
PrevWeekReads As Long
PrevWeekWrites As Long
PrevMonthUses As Long
PrevMonthReads As Long
PrevMonthWrites As Long
End Type
Type DBACTIVITY_ENTRY
Time As TIMEDATE
Reads As Integer
Writes As Integer
UserNameOffset As Long
End Type
Declare Function W32_NSFDbOpen Lib “nnotes.dll” Alias “NSFDbOpen” ( Byval dbName As String, hDb As Long) As Integer
Declare Function W32_NSFDbClose Lib “nnotes.dll” Alias “NSFDbClose” ( Byval hDb As Long) As Integer
Declare Function W32_NSFDbGetUserActivity Lib “nnotes.dll” Alias “NSFDbGetUserActivity” ( Byval hDB As Long, Byval flags As Long, retDbActivity As DBActivity, rethUserInfo As Long, retUserCount As Long) As Integer
Declare Function W32_OSLockObject Lib “nnotes.dll” Alias “OSLockObject” ( Byval handle) As Long
Declare Sub OSUnlockObject Lib “NNOTES.DLL” Alias “OSUnlockObject” (Byval handle)
Declare Sub W32_OSMemFree Lib “NNOTES.DLL” Alias “OSMemFree” (Byval handle)
Declare Sub CopyMemory Lib “KERNEL32” Alias “RtlMoveMemory” ( hpvDest As Any, Byval hpvSource As Long, Byval cbCopy As Long)
Declare Sub CopyMemoryString Lib “KERNEL32” Alias “RtlMoveMemory” ( Byval hpvDest As String, Byval hpvSource As Long, Byval cbCopy As Long)
Declare Sub ConvertTIMEDATEToText Lib “NNOTES.DLL” Alias “ConvertTIMEDATEToText” (Byval IntlFormat As Long,Byval TextFormat As Long, actTIMEDATE As TIMEDATE, Byval retTextBuffer As String,Byval TextBufferLength As Integer,retTextLength As Integer)
Class NotesUserActivityEntry
Public UserName As String
Public Reads As Long
Public Writes As Long
Public Time As String
End Class
Class NotesUserActivity
Private hDb As Long
Private pDbActivity As DBACTIVITY
Private rethUserInfo As Long
Private retUserCount As Long
Private prvdb As NotesDatabase
Private flgHasActivity As Integer
Sub Delete
If Me.flgHasActivity Then Call W32_OSMemFree(rethUserInfo)
If hDb <> 0 Then Call W32_NSFDbClose(hDb)
End Sub
Sub New (inpNotesDatabase As NotesDatabase)
Dim sDatabase As String
Dim rc As Integer
Me.flgHasActivity = False
'Get a valid NotesDatabase to the specified database
If inpNotesDatabase Is Nothing Then
Error 14101, "NotesUserActivity: Database Object is invalid"
Exit Sub
End If
Set prvdb = New NotesDatabase(inpNotesDatabase.Server, inpNotesDatabase.FilePath)
If prvdb.Server = "" Then
sdatabase = prvdb.filepath
Else
sdatabase = prvdb.server + "!!" + prvdb.filepath
End If
'Open the target database
rc = W32_NSFDbOpen(sDatabase,Me.hDb)
If rc <> 0 Then
Me.flgHasActivity = False
End If
'Get the Summary User information
rc = W32_NSFDbGetUserActivity(Me.hDb, &h0, Me.pDbActivity, Me.rethUserInfo, Me.retUserCount)
If rc <> 0 Then
Me.flgHasActivity = False
End If
Me.flgHasActivity = True
End Sub
'Global Times
Public Function First As String
First = ConvertTIMEtoText(pDbActivity.First)
End Function
Public Function Last As String
Last = ConvertTIMEtoText(pDbActivity.Last)
End Function
'Total summary
Public Function Uses As Long
Uses = pDbActivity.Uses
End Function
Public Function Reads As Long
Reads = pDbActivity.Reads
End Function
Public Function Writes As Long
Writes = pDbActivity.Writes
End Function
'Day summary
Public Function PrevDayUses As Long
PrevDayUses = pDbActivity.PrevDayUses
End Function
Public Function PrevDayReads As Long
PrevDayReads = pDbActivity.PrevDayReads
End Function
Public Function PrevDayWrites As Long
PrevDayWrites = pDbActivity.PrevDayReads
End Function
'Week summary
Public Function PrevWeekUses As Long
PrevWeekUses = pDbActivity.PrevWeekUses
End Function
Public Function PrevWeekReads As Long
PrevWeekReads = pDbActivity.PrevWeekReads
End Function
Public Function PrevWeekWrites As Long
PrevWeekWrites= pDbActivity.PrevWeekWrites
End Function
'Month summary
Public Function PrevMonthUses As Long
PrevMonthUses = pDbActivity.PrevMonthUses
End Function
Public Function PrevMonthReads As Long
PrevMonthReads = pDbActivity.PrevMonthReads
End Function
Public Function PrevMonthWrites As Long
PrevMonthWrites = pDbActivity.PrevMonthWrites
End Function
Public Function UserActivityCount As Long
UserActivityCount = retUserCount
End Function
Public Function HasUserActivity As Integer
HasUserActivity = Me.flgHasActivity
End Function
Public Function Parent As NotesDatabase
Set Parent = prvdb
End Function
Public Function GetNthUserActivityEntry(inpEntry As Long) As NotesUserActivityEntry
Dim puActivity As Long
Dim lEntry As Long
Dim puActivityEntry As DBACTIVITY_ENTRY
Dim StructureOffset As Long
Dim UsernameOffset As Long
Dim spUsername As String * 256
Dim sUsername As String
Dim nuae As New NotesUserActivityEntry
lEntry = inpEntry - 1
If Not Me.flgHasActivity Then Error 14104, "NotesUserActivity: No activity available"
If lEntry > Me.retUserCount Or lEntry < 0 Then
Error 14103, "NotesUserActivity: Subscript out of range."
End If
'Lock the structure get the required entry
puActivity = W32_OSLockObject(Me.rethUserInfo)
StructureOffset = puActivity + (Lenb(puActivityEntry) * lEntry)
Call CopyMemory (puActivityEntry, StructureOffset, Len(puActivityEntry))
'Load the User name for the Activity Structure
UsernameOffset = puActivity + puActivityEntry.UserNameOffset
spUsername = Space(256)
Call CopyMemoryString(spUsername, UsernameOffset,Lenb(spUsername))
sUserName = Left(spUsername, Instr(spUsername, Chr(0)) - 1)
With nuae
.UserName = sUserName
.Reads = puActivityEntry.Reads
.Writes = puActivityEntry.Writes
.Time = ConvertTIMEtoText(puActivityEntry.Time)
End With
Call OSUnlockObject(rethUserInfo)
Set GetNthUserActivityEntry = nuae
End Function
End Class
Function ConvertTIMEtoText(TIMESTRUCT As TIMEDATE) As String
Dim spTime As String * MAXALPHATIMEDATE
Dim retLength As Integer
spTime = Space(MAXALPHATIMEDATE)
Call ConvertTIMEDATEToText (&h0,&h0, TIMESTRUCT, spTime,MAXALPHATIMEDATE,retLength)
ConvertTIMEtoText = Left(spTime,retLength)
End Function
