Forcer le format des utilisateur d'un groupe

[Michael DELIQUE]

Code : Tout sélectionner

Function GroupeFormat(wDBNAB As NotesDatabase, wServer As String, wGroupe As String,wFormat As String, wnbCacheReset As Boolean) As Boolean
   
   Dim Session As New NotesSession
   Dim nmServer As NotesName
   Dim nmUser As NotesName
   Dim nmGroupe As NotesName
   Dim vwGroupe As NotesView
   Dim DocGroupe As NotesDocument
   Dim Item As NotesItem
   Dim vrValue As Variant
   Dim nbSave As Boolean
   Dim nbCanonical As Boolean
   
   On Error Goto ErreurHandle
   
   GroupeFormat = False
   
   If Trim(wGroupe) = "" Then
      Error 9999,"wGroupe isEmpty"
   Else
      Set nmGroupe = New NotesName(Trim(wGroupe))
   End If
   
   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)
   Else
      Set nmServer = New NotesName(wDBNAB.Server)
   End If
   
   If wDBNAB Is Nothing Then
      Error 9999,"wDBNAB is Nothing"
      Exit Function
   End If
   Set vwGroupe = wDBNAB.GetView("($Groups)")
   If vwGroupe Is Nothing Then
      Error 9999,"vwGroupe '($Groups)' is Nothing"
      Exit Function
   End If
   Call vwGroupe.Refresh
   Set DocGroupe = vwGroupe.GetDocumentByKey(nmGroupe.Abbreviated,True)
   Set vwGroupe = Nothing
   
   If Not DocGroupe Is Nothing Then
      Set Item = DocGroupe.GetFirstItem("Members")
      If Not Item Is Nothing Then
         vrValue = Item.Values
         Item.Values = Null
         If Isarray(vrValue) =True Then
            If Isempty(vrValue) = False Then
               nbSave = False
               Forall value In vrValue
                  If Trim(Cstr(value)) <> "" Then
                     Set nmUser = New NotesName(Trim(Cstr(value)))
                     If nbCanonical = True Then
                        If Trim(Cstr(value)) <> nmUser.Canonical Then
                           nbSave = True
                        End If
                        Call Item.AppendToTextList(nmUser.Canonical)
                     Else
                        If Trim(Cstr(value)) <> nmUser.Abbreviated Then
                           nbSave = True
                        End If
                        Call Item.AppendToTextList(nmUser.Abbreviated)
                     End If
                     Set nmUser = Nothing
                  End If
               End Forall
               If nbSave = True Then
                  Call DocGroupe.ComputeWithForm(True,False)
                  Call DocGroupe.Save(True,False)
               End If
               GroupeFormat = True
            End If
            vrValue = Null
            Set Item = Nothing
         End If
      End If
      Set DocGroupe = Nothing
   End If   
   
   Set nmGroupe = Nothing
   
   If wnbCacheReset = True Then
      If nbSave = True Then
         Call Session.SendConsoleCommand(nmServer.Canonical,  "show nlcache reset")
         Call Session.SendConsoleCommand(nmServer.Canonical,  "DBCache Flush")
      End If
   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 !"
   GroupeFormat = False
   Exit Function   
End Function

[Michael DELIQUE]

Code : Tout sélectionner

Sub GroupeFormatAll(wDBNAB As NotesDatabase,wServer As String, wFormat As String, wnbCacheReset As Boolean)
   
   Dim Session As New NotesSession
   Dim nmServer As NotesName
   Dim nmUser As NotesName
   Dim vwGroupe As NotesView
   Dim DocGroupe As NotesDocument
   Dim Item As NotesItem
   Dim vrValue As Variant
   Dim nbSave As Boolean
   Dim nbCacheReset As Boolean
   Dim nbCanonical As Boolean
   
   On Error Goto ErreurHandle
   
   Select Case Ucase(Trim(wFormat))
   Case ""
      Error 9999,"wFormat isEmpty"   
      Exit Sub
   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 Sub
   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)
   Else
      Set nmServer = New NotesName(wDBNAB.Server)
   End If
   
   If wDBNAB Is Nothing Then
      Error 9999,"wDBNAB is Nothing"
      Exit Sub
   End If
   
   Set vwGroupe = wDBNAB.GetView("($Groups)")
   If vwGroupe Is Nothing Then
      Error 9999,"vwGroupe '($Groups)' is Nothing"
      Exit Sub
   End If
   Call vwGroupe.Refresh
   
   nbCacheReset = False
   
   Set DocGroupe = vwGroupe.GetFirstDocument
   While Not DocGroupe Is Nothing
      Set Item = DocGroupe.GetFirstItem("Members")
      If Not Item Is Nothing Then
         vrValue = Item.Values
         Item.Values = Null
         If Isarray(vrValue) =True Then
            If Isempty(vrValue) = False Then
               nbSave = False
               Forall value In vrValue
                  If Trim(Cstr(value)) <> "" Then
                     Set nmUser = New NotesName(Trim(Cstr(value)))
                     If nbCanonical = True Then
                        If Trim(Cstr(value)) <> nmUser.Canonical Then
                           nbSave = True
                        End If
                        Call Item.AppendToTextList(nmUser.Canonical)
                     Else
                        If Trim(Cstr(value)) <> nmUser.Abbreviated Then
                           nbSave = True
                        End If
                        Call Item.AppendToTextList(nmUser.Abbreviated)
                     End If
                     Set nmUser = Nothing
                  End If
               End Forall
               If nbSave = True Then
                  Call DocGroupe.ComputeWithForm(True,False)
                  Call DocGroupe.Save(True,False)
                  nbCacheReset = True
               End If
            End If
            Set Item = Nothing
         End If
      End If      
      Set DocGroupe = vwGroupe.GetNextDocument(DocGroupe)
   Wend
   Set vwGroupe = Nothing
   
   If wnbCacheReset = True Then
      If nbCacheReset = True Then
         Call Session.SendConsoleCommand(nmServer.Canonical,  "show nlcache reset")
         Call Session.SendConsoleCommand(nmServer.Canonical,  "DBCache Flush")
      End If
   End If
   
   Set nmUser = Nothing
   
   Exit Sub
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 !"
   Exit Sub
End Sub