DominoArea.org [Archive]

[syntax="ls"]Option Public

Declare Sub W32OSPathNetConstruct Lib "nnotes" Alias "OSPathNetConstruct" ( _
Byval portName As Lmbcs String, _
Byval ServerName As Lmbcs String, _
Byval FileName As String, _
Byval retPathName As String _
)

Declare Function W32NSFDbReadACL Lib "nnotes" Alias "NSFDbReadACL" ( _
Byval hDb As Long, _
hACL As Long _
) As Integer

Declare Function W32ACLGetHistory Lib "nnotes" Alias "ACLGetHistory" ( _
Byval hACL As Long, _
hHistory As Long, _
HistoryCount As Integer _
) As Integer

Declare Function W32NSFDbOpen Lib "nnotes" Alias "NSFDbOpen" ( _
Byval PathName As Lmbcs String, _
hDb As Long _
) As Integer

Declare Function W32NSFDbClose Lib "nnotes" Alias "NSFDbClose" ( _
Byval hDb As Long _
) As Integer

Declare Function W32OSMemFree Lib "nnotes" Alias "OSMemFree" ( _
Byval hObject As Long _
) As Integer

Declare Function W32OSLockObject Lib "nnotes" Alias "OSLockObject" ( _
Byval hObject As Long _
) As Long

Declare Function W32OSUnlockObject Lib "nnotes" Alias "OSUnlockObject" ( _
Byval hObject As Long _
) As Integer

Declare Function W32OSLoadString Lib "nnotes" Alias "OSLoadString" (Byval hModule As Long, _
Byval StringCode As Integer, _
Byval retBuffer As Lmbcs String, _
Byval BufferLength As Integer _
) As Integer

' --- Win32 API declare
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Byval pDest As String, _
Byval pSource As Long, _
Byval dwLength As Long _
)

Const NOERROR = 0
Const NULLHANDLE = 0&
Const PKG_NSF = &H200
Const ERR_NOT_NSF = PKG_NSF + 1
Const ERR_NSF_VERSION = PKG_NSF + 25
Const MAXPATH = 256

Sub Initialize
Dim session As New NotesSession
Dim hDb As Long, hLock As Long, hHistory As Long, hACL As Long
Dim iCount As Integer, iLoop As Integer, iStatus As Integer
Dim sPath As String, sHistory As String, sHold As String, sErrMsg As String, sList As String
If session.Platform <> "Windows/32" Then
Msgbox "Votre poste de travail ne fonctionne pas sur une plateforme Win32.", _
48, "Système d'exploitation Non supporté"
Else
sHold = ""
sPath = String$(MAXPATH, 0)
sHistory = String$(1, 0)
W32OSPathNetConstruct "", "", "C:\Lotus\Notes\Data\Base.nsf", sPath
sPath = Left$(sPath, Instr(1, sPath, Chr$(0)) - 1)
iStatus = W32NSFDbOpen(sPath, hDb)
If iStatus <> NOERROR Then
Select Case iStatus
Case ERR_NOT_NSF
sErrMsg = "Ce fichier n'est pas une base Notes"
Case ERR_NSF_VERSION
sErrMsg = "Version NSF invalide"
Case Else
sErrMsg = GetCAPIErrorMsg(iStatus)
End Select
Msgbox sErrMsg, 48, "Erreur d'appel API"
Else
iStatus = W32NSFDbReadACL(hDb, hACL)
If iStatus <> NOERROR Then
Msgbox GetCAPIErrorMsg(iStatus), 48, "Erreur d'appel API"
Else
iStatus = W32ACLGetHistory(hACL, hHistory, iCount)
If iStatus <> NOERROR Then
Msgbox GetCAPIErrorMsg(iStatus), 48, "Erreur d'appel API"
Else
If iCount > 0 Then
hLock = W32OSLockObject(hHistory)
If hLock <> 0 Then
iLoop = 0
Do While iLoop < iCount
CopyMemory sHistory, hLock, 1
If sHistory = Chr$(0) Then
iLoop = iLoop + 1
hLock = hLock + 1
sList = sList & sHold & Chr$(13)
sHold = ""
Else
hLock = hLock + 1
sHold = sHold + sHistory
End If
Loop
W32OSUnlockObject hHistory
End If
W32OSMemFree hHistory
Msgbox sList, 0, "Historique ACL"
End If
End If
W32OSMemFree hACL
End If
If hDb <> 0 Then
iStatus = W32NSFDbClose(hDb)
If iStatus <> NOERROR Then
Msgbox GetCAPIErrorMsg(iStatus), 48, "Erreur d'appel API"
End If
End If
End If
End If
End Sub

Function GetCAPIErrorMsg(iStatus As Integer) As String
Dim iLen As Integer
Dim sBuffer As String
sBuffer = String$(256, 0)
iLen = W32OSLoadString(NULLHANDLE, iStatus, sBuffer, Len(sBuffer) - 1)
If iLen > 0 Then
GetCAPIErrorMsg = Left$(sBuffer, Instr(1, sBuffer, Chr$(0)) - 1)
Else
GetCAPIErrorMsg = "Erreur inconnue"
End If
End Function[/syntax]Créer un agent partager
N'oublier pas de changer le chemin d'accès :
W32OSPathNetConstruct "", "", "C:\Lotus\Notes\Data\Base.nsf", sPath