DominoArea.org [Archive]

Code : Tout sélectionner

Declaration

Dim acl As NotesACL
Dim i As Integer
Dim Entry As NotesACLEntry
Dim nmEntry As NotesName
Dim TypeEntry As String
Dim TypeAccess As String
Dim Role As String
Dim Info As String
Dim lstValue List As String



Code : Tout sélectionner

Sub Initialize

Dim dbSource As NotesDatabase
Dim sourceServer As Variant
Dim sourcePath As Variant
Dim LstArchServer As Variant
   
sourceServer = "SerVeur"    Ou à passer en paramètre
sourcePath ="Base"                     Ou à passer en paramètre
   
Set dbSource=New NotesDatabase (sourceServer,sourcePath)
Call RemoveACL(dbSource)
   
End Sub



Code : Tout sélectionner

Function RemoveACL(dbSource As NotesDatabase)
   
'Supprime toutes les entrées de l'ACL d'une Base
'*****************************************************
Dim session As New NotesSession
Dim entryTemp
   
On Error Goto ErreurHandle
   
Set acl = dbSource.ACL
   
If acl Is Nothing Then
   Error 9999,"ACL inaccessible sur la base cible"
   Exit Function
End If
   
I = -1
   
Set Entry = Acl.getfirstEntry
   
While Not Entry Is Nothing
      i = i+1
      Set nmEntry = New NotesName(Entry.Name)
      lstValue(i) = nmEntry.abbreviated+"("+TypeEntry+") : "+TypeAccess+Role+Info
      
      If Entry.Name <> "-Default-" Then
         Set entrytemp = entry
      Else
         Set entryTemp = Nothing 
      End If   
      
      Set nmEntry = Nothing       
      Set Entry = Acl.getNextEntry(Entry)
      
      If Not entrytemp Is Nothing Then
         Call entrytemp.remove
      End If
   Wend
   
   Set entry = acl.CreateACLEntry ( "NOTES-CONSULTANT", ACLLEVEL_MANAGER )
   Call acl.Save
   
   Erase lstValue
   Set DBSource = Nothing
   Set acl = Nothing
   
   Exit Function
   
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo (1))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
Exit Function

End Function


* on peut simplifié un peu en virant les propriétés "TypeAccess+Role+Info" mais bon, ça mange pas de pain et peut s'avérer bien pratique


Rendons à jules ce qui appartient à Cesar :
Merci à Michael, car tout vient de sa super fonction :
http://forum.dominoarea.org/une-image-de-la-lca-t14551.html

Salut,

Y'a aussi ça qui est radical

http://www.domlike.net/domlike/dl2.nsf/ ... OME-6LHAGP

Ca marche au moins jusqu'a la 6.x et je ne vois pas pourquoi il auraient changé la structure des bases pour les versions ulterieures .