Créer un Groupe

[Michael DELIQUE]

Code : Tout sélectionner

Function GroupeCreate(wDBNAB As NotesDatabase, wServer As String, wGroupe As String, wGroupeType As String,wvrMember As Variant,wFormat As String,wListOwner As String, wLocalAdmin As String,wnbCacheReset As Boolean) As NotesDocument
   
   Dim Session As New NotesSession   
   Dim nmGroupe As NotesName
   Dim nmServer As NotesName
   Dim DocGroupe As NotesDocument
   Dim nbCanonical As Boolean
   Dim nbGroupeType As Integer
   Dim item As NotesItem
   
   On Error Goto ErreurHandle
   
   Set GroupeCreate = Nothing
   
   If Trim(wGroupe) = "" Then
      Error 9999,"wGroupe isEmpty"
   End If
   
   Select Case Ucase(Trim(wGroupeType))
   Case "0","M","MULTI","MULTIFONCTION"
      nbGroupeType =0
   Case "2","LCA","ACL","LCA ONLY","ACL UNIQUEMENT"
      nbGroupeType = 2
   Case "1","MESSAGERIE","MAIL","MAIL ONLY","MESSAGERIE UNIQUEMENT"
      nbGroupeType = 1
   Case "4","S","SERVER","SERVERS","SERVEUR","SERVEURS","SERVERS ONLY","SERVEURS UNIQUEMENT"
      nbGroupeType = 4
   Case "3","I","INTRUS"
      nbGroupeType = 3
   Case Else
      nbGroupeType = 0
   End Select
   
   Select Case Ucase(Trim(wFormat))
   Case ""
      Error 9999,"wFormat isEmpty"   
      Exit Function
   Case "ABBREVIATED","ABBREVIATE","ABB","AB","A"
      nbCanonical = False
   Case "CANONICAL","CANONICALIZE","CAN","CANON","CA","C"
      nbCanonical = True
   Case Else
      Error 9999,"Bad wFormat : "+wFormat
      Exit Function
   End Select
   
   If wDBNAB Is Nothing Then      
      If Trim(wServer) = "" Then
         Set  nmServer = New NotesName(Session.CurrentDatabase.Server)
      Else
         Set nmServer = New NotesName(Trim(wServer))
      End If   
      Set wDBNAB = DBOpenNAB( nmServer.Abbreviated)
      Set nmGroupe = Nothing
   Else
      Set nmServer = New NotesName(wDBNAB.Server)
   End If
   
   If wDBNAB Is Nothing Then
      Error 9999,"wDBNAB is Nothing"
      Exit Function
   End If
   
   If GroupeIsValide(wDBNAB,wDBNAB.Server,wGroupe) = True Then
      Set nmGroupe = Nothing
      Set DocGroupe = Nothing
      Error 9999,"this group already exists : "+Trim(wGroupe)
      Exit Function
   End If
   
   Set DocGroupe = wDBNAB.CreateDocument   
   Call DocGroupe.ReplaceItemValue("Form","Group")
   Call DocGroupe.ReplaceItemValue("ListName",nmGroupe.Abbreviated)
   Call DocGroupe.ReplaceItemValue("GroupType",nbGroupeType)
   
   Set item = New NotesItem(DocGroupe,"ListOwner","",AUTHORS)
   Select Case Trim(wListOwner)
   Case "" 'on fait rien
   Case "*"
      Call item.AppendToTextList("*")      
   Case Else
      Set nmGroupe = New NotesName( Trim(wListOwner))
      Call item.AppendToTextList(nmGroupe.Canonical)
      Set nmGroupe = Nothing      
   End Select
   Set item = Nothing
   
   Set item = New NotesItem(DocGroupe,"LocalAdmin","",AUTHORS)
   Select Case Trim(wLocalAdmin)
   Case "" 'on fait rien
   Case "*"
      Call item.AppendToTextList("*")   
   Case Else
      Set nmGroupe = New NotesName( Trim(wLocalAdmin))
      Call item.AppendToTextList(nmGroupe.Canonical)
      Set nmGroupe = Nothing      
   End Select
   Set item = Nothing
   
   Set Item = New NotesItem(DocGroupe,"Members","",NAMES)
   If Isarray(wvrMember) Or Islist(wvrMember) Then
      Forall value In wvrMember
         If Trim(Cstr(value)) <> "" Then
            Set nmGroupe = New NotesName(Trim(Cstr(wvrMember)))
            If nbCanonical = True Then
               Call Item.AppendToTextList(nmGroupe.Canonical)
            Else
               Call Item.AppendToTextList(nmGroupe.Abbreviated)
            End If
            Set nmGroupe = Nothing
         End If
      End Forall
   Elseif  Ucase(Typename(wvrMember)) = "STRING" Then
      Set nmGroupe = New NotesName(Trim(Cstr(wvrMember)))
      If nbCanonical = True Then
         Call Item.AppendToTextList(nmGroupe.Canonical)
      Else
         Call Item.AppendToTextList(nmGroupe.Abbreviated)
      End If
      Set nmGroupe = Nothing
   End If
   Set Item = Nothing
   
   Call DocGroupe.ComputeWithForm(True,False)
   Call DocGroupe.Save(True,False)
   
   Set GroupeCreate = DocGroupe
   Set DocGroupe = Nothing
   
   If wnbCacheReset = True Then
      Call Session.SendConsoleCommand(nmServer.Canonical,  "show nlcache reset")
      Call Session.SendConsoleCommand(nmServer.Canonical,  "DBCache Flush")
   End If
   
   Set nmServer = Nothing
   
   Exit Function
ErreurHandle:
   Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Cstr(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   Set GroupeCreate = Nothing
   Exit Function   
End Function