Une "Image" de la LCA

[Michael DELIQUE]

Code : Tout sélectionner

Function LCAImage(wDB As NotesDatabase) As Variant
   
      'renvois une "image" de la lca de la base cible
      'toutes les personnes/groupes  avec leur type d'accès et les roles    associés
   
      'Déclaration Variable
   Dim DBCible As Notesdatabase
   Dim lstValue List As String
   Dim acl As NotesACL
   Dim Entry As NotesACLEntry
   Dim i As Integer
   Dim nmEntry As NotesName
   Dim TypeEntry As String
   Dim TypeAccess As String
   Dim Role As String
   Dim Info As String
   
   On Error Goto ErreurHandle
   
   If DB Is Nothing Or Session Is Nothing Then
      Set Session = New NotesSession
      Set DB = Session.CUrrentdatabase
   End If
   
   If wdb Is Nothing Then
      Set DBCible = Session.currentdatabase
   Else
      If dbexists_ls(wDB) = False Then
         Error 9999,"base cible inaccessible"
         Exit Function
      End If
      Set DBCible = wDB
   End If
   
   Set acl = DBCible.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)
      Select Case Entry.UserType
      Case 0
         TypeEntry ="Unspecified"
      Case 1
         TypeEntry = "Person"
      Case 2
         TypeEntry = "Server"
      Case 3
         TypeEntry = "Mixed_Group"
      Case 4
         TypeEntry ="Person_Group"
      Case 5
         TypeEntry ="Server_Group"
      Case Else
         TypeEntry = "Unknown"
      End Select
      
      Select Case Entry.Level
      Case 0
         TypeAccess ="No Access"
      Case 1
         TypeAccess = "Depositor"
      Case 2
         TypeAccess = "Reader"
      Case 3
         TypeAccess = "Author"
      Case 4
         TypeAccess ="Editor"
      Case 5
         TypeAccess ="Designer"
      Case 6
         TypeAccess = "Manager"
      Case Else
         TypeAccess = "Unknown"
      End Select
      
      Role = ""
      Forall Role2 In Entry.roles
         If Trim(Role) = "" Then
            Role = Trim(Cstr(Role2))
         Else
            Role = Role+"-"+Trim(Cstr(Role2))
         End If
      End Forall
      
      If Trim(Role)<>"" Then
         Role = ", Role(s) : "+Role
      End If
      
      Info = ""
      If Entry.CanCreateDocuments = True Then
         Info = ", CanCreateDocuments"
      End If
      If Entry.CanDeleteDocuments = True Then
         If Trim(Info)="" Then
            Info = ", CanDeleteDocuments"
         Else
            Info = Info + ", CanDeleteDocuments"
         End If
      End If
      If Entry.IsPublicReader = True Then
         If Trim(Info)="" Then
            Info = ", PublicReader"
         Else
            Info = Info + ", PublicReader"
         End If
      End If
      If Entry.IsPublicWriter = True Then
         If Trim(Info)="" Then
            Info = ", PublicWriter"
         Else
            Info = Info + ", PublicWriter"
         End If
      End If
      
      lstValue(i) = nmEntry.abbreviated+"("+TypeEntry+") : "+TypeAccess+Role+Info
      
      Role = ""
      TypeEntry = ""
      TypeAccess = ""
      Info = ""
      Set nmEntry = Nothing
      Set Entry = Acl.getNextEntry(Entry)
   Wend
   
   LCAImage = lstValue
   Erase lstValue
   Set DBCible = Nothing
   Set acl = Nothing
   Exit Function
ErreurHandle:
   Msgbox "("+Structure_Log+" : "+Cstr(Getthreadinfo (1))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   Exit Function
End Function

Code : Tout sélectionner

Function DBExists_LS(wdb As NotesDatabase) As Integer
   'teste si une base de donnée est accéssible
'   renvoi true si elle est accéssible
' renvoi false si elle n'est pas accessible
   
   On Error Goto ErreurHandle
   
   'teste si la variable est renseigné
   If wDB Is Nothing Then
      DBExists_LS = False
      Exit Function
   Else
      'teste si la base est ouverte
      If wDB.IsOpen = True Then
      'teste si la base existe réelement il faut que la date de crétation existe ainsi que l'id de réplique
         If Trim(Cstr(wDB.Created)) = "" Or Trim(Cstr(wDB.ReplicaID)) = "" Then
            DBExists_LS = False
            Exit Function
         End If
      Else
         DBExists_LS = False
         Exit Function
      End If
   End If
   
   DBExists_LS = True
   
   Exit Function
ErreurHandle:
   Msgbox "("+Structure_Log+" : "+Cstr(Getthreadinfo (1))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   DBExists_LS = False
   Exit Function
End Function