Page 1 sur 1
Forcer le format des utilisateur d'un groupe
Publié:
27 Oct 2010 à 10:48par 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
Publié:
27 Oct 2010 à 10:48par 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