Der hier veröffentliche Code lief bei mir weder unter 6.5.4, noch unter 8.5.1.
Ich hab dann ein wenig dran rumgebastelt, bin aber nicht wirklich weiter gekommen.
Ich kann nicht einschätzen, wie lange das online bleibt, daher noch die Script-Bibliothek "CLASSUserActivity" aus der Datenbank:
Option Public
Option Declare
%INCLUDE "lsconst.lss"
%REM
CLASSUserActivity - updated by Alex Elliott of AGECOM (http://www.agecom.com.au)
This class is an update of the original CLASSUserActivity code available for download from the Lotus Sandbox:
http://www.lotus.com/ldd/sandbox.nsf/0/c12a2fd2142758b68525688d00708397?OpenDocument
Updates in this release March 2010
============================
* Fixes to API function declarations to ensure the correct datatypes are supplied for function arguments (to match expected
compatible Lotus C-API data types).
- retUserCount in W32_NSFDbGetUserActivity is now correctly defined as an Integer
- handle in W32_OSLockObject is now defined as a Long.
- handle in W32_OSUnlockObject is now defined as a Long
- Return value for call to W32_OSMemFree is now retrieved.
- handle in W32_OSMemFree is now defined as a Long.
- hpvSource in CopyMemory is now defined as an Any.
- hpvSource in CopyMemoryString is now defined as an Any.
- Return value for call to W32_ConvertTIMEDATEToText is now retrieved.
* Reads object in NotesUserActivityEntry class is now defined as an Integer.
* Writes object in NotesUserActivityEntry class is now defined as an Integer.
* retUserCount object in NotesUserActivity class is now defined as an Integer.
* flgHasActivity object in NotesUserActivity class is now defined as a Boolean.
* If an error occurs in the GetNthUserActivityEntry function after the memory occupied by 'Me.rethUserInfo' is locked it is now
unlocked when the error handler catches the error.
* Call to 'PrevDayWrites' now correctly returns the Writes.
* Error Handling now implemented throughout the code.
This updated script library may be used and modified by anyone provided the above information remains with the code.
%END REM
' Constants
Const MAXALPHATIMEDATE = 80
Const MAXUSERNAME = 256
' The API functions return errors as non-zero values hence zero is success
Const STATUS_SUCCESS = 0
' When working with the API, handles (always Long) are NULL or empty when they are equal to zero
Const NULLHANDLE = 0
' API Errors
Const ERR_NOEXIST = 259
Const ERR_NO_MODIFIED_NOTES = 572
Const ERR_SPECIAL_ID = 578
Const ERR_NOACCESS = 582
Const ERR_NOT_FOUND = 1028
Const ERR_ITEM_NOT_FOUND = 546
Type TIMEDATE
Innards(1) 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 Integer) As Integer
Declare Function W32_OSLockObject Lib "nnotes.dll" Alias "OSLockObject" ( Byval handle As Long) As Long
Declare Function W32_OSLoadString Lib "nnotes.dll" Alias "OSLoadString" (Byval handle As Long, Byval S As Integer, Byval B As String, Byval nB As Integer) As Integer
Declare Sub W32_OSUnlockObject Lib "nnotes.dll" Alias "OSUnlockObject" (Byval handle As Long)
Declare Function W32_OSMemFree Lib "nnotes.dll" Alias "OSMemFree" (Byval handle As Long) As Integer
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( hpvDest As Any, Byval hpvSource As Any, Byval cbCopy As Long)
Declare Sub CopyMemoryString Lib "kernel32" Alias "RtlMoveMemory" ( Byval hpvDest As String, Byval hpvSource As Any, Byval cbCopy As Long)
Declare Function W32_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) As Integer
Class NotesUserActivityEntry
Public UserName As String
Public Reads As Integer
Public Writes As Integer
Public Time As String
End Class
Class NotesUserActivity
Private hDb As Long
Private pDbActivity As DBACTIVITY
Private rethUserInfo As Long
Private retUserCount As Integer
Private prvdb As NotesDatabase
Private flgHasActivity As Boolean
Sub Delete
Dim StatusResult As Integer
' Error Handler
On Error Goto Error_Handler
If Me.flgHasActivity Then
Call W32_OSMemFree(rethUserInfo)
End If
If hDb <> 0 Then
StatusResult = W32_NSFDbClose(hDb)
hDb = 0
If StatusResult <> STATUS_SUCCESS Then
' Database failed to close properly
Call Output_Status_Error(StatusResult, "ClassUserActivity - NotesUserActivity Class (Delete)", "Call to NSFDbClose failed", Getthreadinfo(LSI_THREAD_LINE)-4)
End If
End If
Exit Sub
Error_Handler:
Call Output_Error("ClassUserActivity Script Library - NotesUserActivity (Delete)", Erl, True)
Exit Sub
End Sub
Sub New (inpNotesDatabase As NotesDatabase)
Dim sDatabase As String
Dim StatusResult As Integer
' Error Handler
On Error Goto Error_Handler
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
StatusResult = W32_NSFDbOpen(sDatabase,Me.hDb)
If StatusResult <> STATUS_SUCCESS Then
' Database failed to open
Call Output_Status_Error(StatusResult, "ClassUserActivity - NotesUserActivity Class (New)", "Call to NSFDbOpen failed", Getthreadinfo(LSI_THREAD_LINE)-3)
Exit Sub
End If
' Get the Summary User information
StatusResult = W32_NSFDbGetUserActivity(Me.hDb, &h0, Me.pDbActivity, Me.rethUserInfo, Me.retUserCount)
If StatusResult <> STATUS_SUCCESS Then
' Couldn't get handle to database user activity
Call Output_Status_Error(StatusResult, "ClassUserActivity - NotesUserActivity Class (New)", "Call to NSFDbGetUserActivity failed", Getthreadinfo(LSI_THREAD_LINE)-3)
Exit Sub
End If
If retUserCount > 0 Then
' User activity was found
Me.flgHasActivity = True
End If
Exit Sub
Error_Handler:
Call Output_Error("ClassUserActivity Script Library - NotesUserActivity (New)", Erl, True)
Exit Sub
End Sub
' Global Times
Public Function First As String
' Error Handler
On Error Goto Error_Handler
First = ConvertTIMEtoText(pDbActivity.First)
Exit Function
Error_Handler:
Call Output_Error("ClassUserActivity Script Library - NotesUserActivity (First)", Erl, True)
Exit Function
End Function
Public Function Last As String
' Error Handler
On Error Goto Error_Handler
Last = ConvertTIMEtoText(pDbActivity.Last)
Exit Function
Error_Handler:
Call Output_Error("ClassUserActivity Script Library - NotesUserActivity (Last)", Erl, True)
Exit Function
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.PrevDayWrites
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 Integer
UserActivityCount = retUserCount
End Function
Public Function HasUserActivity As Boolean
HasUserActivity = Me.flgHasActivity
End Function
Public Function Parent As NotesDatabase
Set Parent = prvdb
End Function
Public Function GetNthUserActivityEntry(inpEntry As Integer) As NotesUserActivityEntry
Dim puActivity As Long
Dim lEntry As Integer
Dim puActivityEntry As DBACTIVITY_ENTRY
Dim StructureOffset As Long
Dim UsernameOffset As Long
Dim spUsername As String * MAXUSERNAME
Dim sUsername As String
Dim nuae As New NotesUserActivityEntry
' Error Handler
On Error Goto Error_Handler
lEntry = inpEntry - 1
If Not Me.flgHasActivity Then
Error 14104, "NotesUserActivity: No activity available"
End If
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(MAXUSERNAME)
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 W32_OSUnlockObject(Me.rethUserInfo)
puActivity = 0
Set GetNthUserActivityEntry = nuae
Exit Function
Error_Handler:
If puActivity <> 0 Then
' Unlock
Call W32_OSUnlockObject(Me.rethUserInfo)
End If
Call Output_Error("ClassUserActivity Script Library - NotesUserActivity (GetNthUserActivityEntry)", Erl, True)
Exit Function
End Function
End Class
Function ConvertTIMEtoText(TIMESTRUCT As TIMEDATE) As String
Dim Session As New NotesSession
Dim spTime As String * MAXALPHATIMEDATE
Dim retLength As Integer
Dim StatusResult As Integer
' Error Handler
On Error Goto Error_Handler
spTime = Space(MAXALPHATIMEDATE)
StatusResult = W32_ConvertTIMEDATEToText (&h0,&h0, TIMESTRUCT, spTime,MAXALPHATIMEDATE,retLength)
If StatusResult <> STATUS_SUCCESS Then
' Conversion failed
Call Output_Status_Error(StatusResult, "ClassUserActivity - ConvertTIMEToText", "Call to ConvertTIMEDATEToText failed", Getthreadinfo(LSI_THREAD_LINE)-3)
Else
ConvertTIMEtoText = Left(spTime,retLength)
End If
Exit Function
Error_Handler:
Call Output_Error("ClassUserActivity Script Library - ConvertTIMEToText", Erl, True)
Exit Function
End Function
Function Output_Status_Error(StatusError As Integer, FunctionName As Variant, Description As String, LineNumber As Variant) As Boolean
Dim MaskedStatusError As Integer
' Error Handler
On Error Goto Error_Handler
If StatusError = 0 Then
' This is a null status code
Exit Function
End If
MaskedStatusError = MaskedErrorStatus(StatusError)
If MaskedStatusError = 0 Then
' This is a null error code
Exit Function
End If
' Errors that we will ignore
If MaskedStatusError = ERR_NO_MODIFIED_NOTES Then
Exit Function
Elseif MaskedStatusError = ERR_SPECIAL_ID Then
Exit Function
Elseif MaskedStatusError = ERR_NOT_FOUND Then
Exit Function
End If
Call Output_API_Error(Cstr(FunctionName), Description, Cint(LineNumber), MaskedStatusError)
Output_Status_Error = True
Exit Function
Error_Handler:
Call Output_Error("ClassUserActivity Script Library - Output_Status_Error", Erl, True)
Exit Function
End Function
Function MaskedErrorStatus(StatusError As Integer) As Integer
' Error Handler
On Error Goto Error_Handler
MaskedErrorStatus = StatusError And &H3FFF
Exit Function
Error_Handler:
Call Output_Error("ClassUserActivity Script Library - MaskedErrorStatus", Erl, True)
Exit Function
End Function
Function Output_Error(FunctionName As String, ErrorLine As Integer, ContinueOnError As Integer)
' Output the error that has occurred
Dim ErrorString As String
Dim ErrorSession As New NotesSession
Dim NewLine As String
' Format the error for printing and outputting to the error log
NewLine = " "
ErrorString = "The following error has occurred:" & NewLine
ErrorString = ErrorString & "Function - " & FunctionName & NewLine
ErrorString = ErrorString & "Line - " & Trim(Cstr(ErrorLine)) & NewLine
ErrorString = ErrorString & "Error - " & Trim(Cstr(Err)) & NewLine
ErrorString = ErrorString & "Details - " & Error$
If ErrorSession.IsOnServer Then
' This is being called from a scheduled agent. Output error details to the Notes log and exit
Print ErrorString
If ContinueOnError Then
' ContinueOnError is true. Return execution to the calling function
Exit Function
Else
' ContinueOnError is false. Abort execution
End
End If
End If
' This is being called from an agent being manually run. Error details will be displayed in a message box
' Format the error for printing and outputting to the error log
NewLine = Chr(13)
ErrorString = "The following error has occurred:" & NewLine
ErrorString = ErrorString & "Function - " & FunctionName & NewLine
ErrorString = ErrorString & "Line - " & Trim(Cstr(ErrorLine)) & NewLine
ErrorString = ErrorString & "Error - " & Trim(Cstr(Err)) & NewLine
ErrorString = ErrorString & "Details - " & Error$ & NewLine & NewLine
ErrorString = ErrorString & "Would you like to continue processing?"
If Messagebox(ErrorString, MB_YESNO + MB_ICONSTOP, "Processing Error") = IDNO Then
' The no button was clicked
End
End If
End Function
Sub Output_API_Error(FunctionName As String, Description As String, ErrorLine As Integer, APIErrorCode As Integer)
' Output the the description for the passed API error code
Dim ThisSession As New NotesSession
Dim ErrorDescr As String
Dim ErrorString As String
Dim NewLine As String
If APIErrorCode = 0 Then
' Invalid error code
Exit Sub
End If
If ThisSession.Platform = "Windows/32" Then
ErrorDescr = String$(1024, " ")
Call W32_OSLoadString(0, APIErrorCode And &H3FFF, ErrorDescr, 1024)
If Instr(1, ErrorDescr, Chr$(0)) > 0 Then
ErrorDescr = Strleft(ErrorDescr, Chr$(0))
End If
If Trim(ErrorDescr) = "" Or ErrorDescr = "No error" Then
ErrorDescr = "Unknown error (&H" & Hex$(Cint(APIErrorCode)) & ")"
End If
Else
ErrorDescr = "Unknown error (&H" & Hex$(Cint(APIErrorCode)) & ")"
End If
If Trim(Description) <> "" Then
ErrorDescr = Description & ": " & ErrorDescr
End If
If ThisSession.IsOnServer Then
' Session is running on server (scheduled / background agent). Print the error then continue processing
' Format the error for printing
NewLine = ", "
ErrorString = "The following API error has occurred: "
ErrorString = ErrorString & "Function - " & FunctionName & NewLine
ErrorString = ErrorString & "Line - " & Trim(Cstr(ErrorLine)) & NewLine
ErrorString = ErrorString & "Error - " & Trim(Cstr(APIErrorCode)) & NewLine
ErrorString = ErrorString & "Details - " & ErrorDescr
Print ErrorString
Else
NewLine = Chr(13)
ErrorString = "The following API error has occurred:" & NewLine
ErrorString = ErrorString & "Function - " & FunctionName & NewLine
ErrorString = ErrorString & "Line - " & Trim(Cstr(ErrorLine)) & NewLine
ErrorString = ErrorString & "Error - " & Trim(Cstr(APIErrorCode)) & NewLine
ErrorString = ErrorString & "Details - " & ErrorDescr & NewLine & NewLine
ErrorString = ErrorString & "Would you like to continue processing?"
If Messagebox(ErrorString, MB_YESNO + MB_ICONSTOP, "Processing Error") = IDNO Then
' The no button was clicked
End
End If
End If
End Sub
