ACL manager

***** DECLARATIONS
==================
Dim db As NotesDatabase
Dim acl As NotesACL
Dim entry As NotesACLEntry

Dim TabVal As Variant
Dim TabKey As Variant
Dim TabRoles As Variant
Dim TabColonne(9) As String

Const Txt1DB = "ACL DB"
Const Sep1 = "%"
Const File1 = "C:NOTMACROACL.TXT"
Const File2 = "C:NOTMACROACLTRC.TXT"

***** SUB INITIALIZE
================
	Sub Initialize
                Dim ws As New NotesUIWorkspace
	Dim uidoc As NotesUidocument
	Dim session As New NotesSession
	Dim RigaTitoli As String
	Dim RigaValori As String
	Set db = session.CurrentDatabase
	If session.CommonUserName <> "Lisa Fioretti" And _
	session.CommonUserName<>"Mirko Malaguti" And session.CommonUserName<>"Alberto Forni" Then
		Exit Sub
	End If
	f1 = Freefile
	Call PreparaVariabili
	Set acl = db.ACL
	a1 = Messagebox("premere YES x salvare la ACL del DB sul file " & File1 & Chr(13) & _
	"premere NO x ripristinare la ACL precedentemente memorizzata sul 
 file " & File1 & Chr(13) & _
	"CANCEL per ulteriori funzioni", 35, "Gestione ACL")
	If a1 = 6 Then ' YES = download ACL
		Open File1 For Output As #1
		Print # 1 , Txt1DB & Sep1 & db.FilePath & Sep1 & Now
		Set entry = acl.GetFirstEntry
		Call GestioneRiga("TITOLI", RigaTitoli)
		Print # 1 , RigaTitoli
		Do While Not entry Is Nothing
			Call GestioneRiga("Dati", RigaValori)
			Print # 1 , RigaValori
			Set entry = acl.GetNextEntry(entry)
		Loop
		Print # 1 , Txt1DB & Sep1 & db.FilePath & Sep1 & Now
		Close # 1
		Messagebox "ACL scritta sul file " & File1
	End If
	If a1 = 7 Then ' NO = Reload ACL
		Open File1 For Input As #1
		Open File2 For Output As #2
		Print # 2 , Txt1DB & Sep1 & db.FilePath & Sep1 & Now
		Line Input # 1 , Riga1$
		Print # 2 , "read line 1=" & Riga1$
		numV = ExplodeMultiValues(Riga1$, TabVal, Sep1)
		If TabVal(0) <> Txt1DB Then
			Mex = "il file di input " & File1 & " non inizia con la 
 stringa chiave [" & Txt1DB & "] (" & Riga1$ & ")"
			Print # 2 , Mex
			Messagebox Mex
			Exit Sub
		End If
		Mex = "DB is " & TabVal(1)
		Print # 2 , Mex
		If TabVal(1) <> db.FilePath Then
			Mex = "Attenzione: il DB relativo alla ACL scaricata 
 sul file " & File1 & " (" & TabVal(1) & ")" & _
			" non corrisponde con il DB attualmente aperto (" & 
 db.FilePath & ")"
			Print # 2 , Mex
			a2 = Messagebox (Mex & Chr(13) & "premere OK x eseguire 
 ugualmente il ripristino della ACL", 49, "Gestione ACL")
			If a2 <> 1 Then ' non premuto OK
				Exit Sub				
			End If
		End If
		Mex = "premere OK x ripristinare l'ACL scaricata dal DB " & 
 TabVal(1) & " il giorno " & TabVal(2)
		Print # 2 , Mex
		a3 = Messagebox (Mex, 65, "Gestione ACL")
		If a3 <> 1 Then ' non premuto OK
			Exit Sub				
		End If
		Line Input # 1 , Riga2$
		Print # 2 , "read line 2=" & Riga2$
		numV = ExplodeMultiValues(Riga2$, TabKey, Sep1)
		cnt3 = 2
		Do Until Eof(1)
			cnt3 = cnt3 + 1		
			Line Input #1, Riga3$
			Print # 2 , "read line " & cnt3 & "=" & Riga3$
			numV = ExplodeMultiValues(Riga3$, TabVal, Sep1)
			If TabVal(0) = Txt1DB Then
				Exit Do
			End If
			Mex = "run on UT=" & TabVal(1)
			Print # 2 , Mex
			Set entry = acl.GetEntry(TabVal(1))
			If entry Is Nothing Then
				Mex = "Attenzione: l'utenza " & TabVal(1) & " 
 non e piu presente nella ACL di questo DB"
				Print # 2 , Mex
				a4 = Messagebox (Mex & Chr(13) & " premere YES 
 x inserirla" & Chr(13) & _
				" premere NO x bypassare questa utenza; CANCEL 
 x interrompere l'elaborazione", 51, "Gestione ACL")
				If a4 = 2 Then ' premuto CANCEL
					Exit Sub				
				End If
				If a4 = 7 Then ' NO
					Goto Lettura
				End If
				Set Entry = acl.CreateACLEntry( TabVal(1), 0)
				Mex = "Inserita utenza " & TabVal(1)
				Print # 2 , Mex
			End If
			Call GestioneRiga("UPD", RigaTitoli)
Lettura:
		Loop
		Print # 2 , "save ACL"
		Call acl.save
		Print # 2 , "fine elaborazione RELOAD"
	End If
	If a1 = 2 Then ' CANCEL = altre opzioni
		a4 = Messagebox("premere OK x disabilitare tutti gli utenti 
 dalla ACL, ad esclusione dei Manager", 33, "Gestione ACL")
		If a4 = 1 Then ' premuto OK
			Open File2 For Output As #2
			Print # 2 , Txt1DB & Sep1 & db.FilePath & Sep1 & Now
			Set entry = acl.GetFirstEntry
			Do While Not entry Is Nothing
				Print # 2 , "Run on UT=" entry.name
				If entry.level > 0 And entry.level < 6 Then
					entry.level = 0
					Print # 2 , "No Access for UT=" entry.name
				End If
				Set entry = acl.GetNextEntry(entry)
			Loop	
			Print # 2 , "save ACL"
			Call acl.save
			Print # 2 , "fine elaborazione NO ACCESS"
		End If
	End If
	End Sub

***** FUNCTION EXPLODEMULTIVALUES
================================
Function ExplodeMultiValues(buffer$, vArr, delim$) As Long 
	
     'This function returns a variant string array representing the 
     'multi-values in the string buffer delimited by 'delim'. 
	
	Const funcName = "ExplodeMultiValues" 
	ExplodeMultiValues = 1 
	Dim tmpV() As Variant 
	Dim beg&, nxt&, idx& 
	
     '----- Set up the default value 
	Dim defV(0 To 0) As Variant 
	defV(0) = buffer 
	vArr = defV 
	
     '----- No delimiter, no multi-values 
	If Trim$(delim) = "" Or Trim$(buffer) = "" Then Goto TheEnd 
	
     '----- Parse the values 
	idx = 0 
	beg = 1 
	nxt = 1 
	Do While nxt > 0 
		
          '----- Look for the next delimiter 
		nxt = Instr(beg, buffer, delim) 
		
          '----- Expand the values array by one (expect at least 
          '      one value at this point) 
		Redim Preserve tmpV(0 To idx) 
		
          '----- If we found a delimiter 
		If nxt > 0 Then 
			tmpV(idx) = Mid$(buffer, beg, nxt-beg) 
			
          '----- This is the last value 
		Elseif nxt = 0 And beg <= Len(buffer) Then 
			tmpV(idx) = Mid$(buffer, beg)               
		End If 
		idx = idx + 1 
		beg = nxt + Len(delim) 
	Loop 
	ExplodeMultiValues = Ubound(tmpV)+1 
	vArr = tmpV 
	
TheEnd: 
	Exit Function 
	
Errors: 
	Print funcName & ": ERROR: " & Error$ 
	Resume TheEnd 
	
End Function

***** SUB PREPARAVARIABILI
========================
Sub PreparaVariabili
	TabColonne(0) = "DB"
	TabColonne(1) = "Name"
	TabColonne(2) = "Level"
	TabColonne(3) = "Roles"
	TabColonne(4) = "CanCreateDoc"
	TabColonne(5) = "CanCreateAgent"
	TabColonne(6) = "CanCreateFolder"
	TabColonne(7) = "CanDelDoc"
	TabColonne(8) = "PubRead"
	TabColonne(9) = "PubWrite"
End Sub

***** SUB GESTIONERIGA
====================
Sub GestioneRiga (tipo As String, RigaOut As String)
	Dim Valore As String
	Dim ValUPD As Variant
	RigaOut = ""
	Select Case Ucase(tipo)
	Case "TITOLI"
		j1 = -1
		Forall C1 In TabColonne
			j1 = j1 +1
			If j1 = 0 Then
				RigaOut = C1
			Else
				RigaOut = RigaOut & Sep1 & C1
			End If
		End Forall
	Case "DATI"
		j1 = -1
		Forall C1 In TabColonne
			j1 = j1 +1
			Select Case C1
			Case "DB"
				Valore = db.FilePath
			Case "Name"
				Valore = entry.name
			Case "Level"
				Valore = entry.Level
			Case "Roles"
				TabRuoli = ""
				Forall R1 In entry.roles
					If TabRuoli = "" Then
						TabRuoli = R1
					Else
						TabRuoli = TabRuoli & ";" & R1
					End If
				End Forall
				Valore = TabRuoli
			Case "CanCreateDoc"
				Valore = entry.CanCreateDocuments
			Case "CanCreateAgent"
				Valore = entry.CanCreatePersonalAgent
			Case "CanCreateFolder"
				Valore = entry.CanCreatePersonalFolder
			Case "CanDelDoc"
				Valore = entry.CanDeleteDocuments
			Case "PubRead"
				Valore = entry.IsPublicReader
			Case "PubWrite"
				Valore = entry.IsPublicWriter
			Case Else
				Valore = "???"
			End Select
			If j1 = 0 Then
				RigaOut = Valore
			Else
				RigaOut = RigaOut & Sep1 & Valore
			End If
		End Forall
	Case "UPD"
		j1 = -1
		Print #2, "Reload ACL for " & TabVal(1)
		Forall C2 In TabKey
			j1 = j1 +1
			Valore = TabVal(j1)
			If Ucase(Valore) = "TRUE" Then
				ValUPD = True
			Else
				If Ucase(Valore) = "FALSE" Then
					ValUPD = False
				Else
					If Instr(Valore, ";") > 0 Then
						numV = ExplodeMultiValues(Valore, ValUPD, ";")
					Else
						ValUPD = Valore
					End If
				End If
			End If
			Select Case C2
			Case "Level"
				entry.Level = ValUpd
			Case "Roles"
				If Isarray(ValUPD) Then
					Forall R1 In ValUPD
						Call Entry.EnableRole( R1 )
					End Forall
				End If
			Case "CanCreateDoc"
				entry.CanCreateDocuments = ValUPD
			Case "CanCreateAgent"
				entry.CanCreatePersonalAgent = ValUPD
			Case "CanCreateFolder"
				entry.CanCreatePersonalFolder = ValUPD
			Case "CanDelDoc"
				entry.CanDeleteDocuments = ValUPD
			Case "PubRead"
				entry.IsPublicReader = ValUPD
			Case "PubWrite"
				entry.IsPublicWriter = ValUPD
			Case Else
			End Select
		End Forall
	End Select
End Sub