程式碼批量新增ACL管理員許可權

1  代理
Sub Initialize
 On Error Goto ErrHandler
 Dim sView As NotesView
 Dim sDoc As NotesDocument
 Set s = New NotesSession
 Set db = s.CurrentDatabase
 Dim isExist As String
 'Dim Level As Integer
 
 Dim admin(0 To 0) As String'需要新增的帳號資訊
 admin(0) = "CN=With Wang/OU=CN/O=CMINL"   '  "With Wang/CN/CMINL"
 
 '需要新增管理員許可權的系統View
 Set ApList = db.getView("Vw_ApList")
 Set Ap = ApList.GetFirstDocument
 While Not(Ap Is Nothing)
  If Ap.ServerIp(0) = "10.189.128.3" Then
   Set refreshDB = s.GetDatabase(Ap.ServerIp(0),Ap.ApPath(0))
   Call refreshDB.sign(DBSIGN_DOC_ALL)
   Set acl = refreshDB.ACL
   stringArray = acl.roles
   Print "Ap:name" & Ap.ServerName(0)
  'Level = refreshDB.QueryAccess(session.UserName)
   If refreshDB.QueryAccess(s.UserName) <> 6 Then
    Print "您不是系統管理員，無權執行此程式!!!!"
   'Call SendToMail(Ap.ServerName(0)&"您不是系統管理員，無權執行此程式!!!!")
   'Exit Sub
   'Set Ap = ApList.GetNextDocument(Ap)
    Goto ErrHandler
   End If
   
   For j = 0 To Ubound(admin)
    Print "admin" & admin(j)
    isExist ="N"
    Set entry = acl.GetFirstEntry   
    While Not(entry Is Nothing)
   '只更新 Person
     If entry.IsPerson And Not(entry.IsGroup) Then
      Print entry.Name
    '檢查帳號是否存在
      If Ucase(entry.Name) = Ucase(admin(j)) Then
       isExist ="Y"
      End If
     End If
     Set entry = acl.GetNextEntry(entry)
    Wend 
    
    If isExist <>"Y" Then
        '在ACL中新增新條目:
     Set acl = refreshDB.ACL
     '這個例子中，我們新增管理員 With Wang/CN/CMINL
     Set nEntry = acl.CreateACLEntry(admin(j), 6 )
     nEntry.CanDeleteDocuments=True
     nEntry.IsPerson=True
     '取決於要分配的許可權，您可以包含下列可選屬性
     nEntry.CanCreateSharedFolder=True
     nEntry.CanCreatePersonalFolder=True
     nEntry.CanCreatePersonalAgent=True
     nEntry.CanCreateLSOrJavaAgent=True
     For i=0 To Ubound(stringArray)
      Call nEntry.EnableRole(stringArray(i))
     Next
    End If
   Next 
'儲存對ACL的更改  
   Call acl.Save
   Ap.sflag = "Y"
   Call Ap.Save(True,True)
  End If
  
  Goto ErrHandler
ErrHandler:
  Set Ap = ApList.GetNextDocument(Ap)
 Wend 
 Msgbox("OK")
 Call SendToMail("OK")
 
 
 'Msgbox("Error")
 'Print "Error"
 'Call SendMail("Error")
End Sub

2  SendToMail:
Sub SendToMail(subject As String)
 Dim  s  As New  Notessession
 Dim maildb As  Notesdatabase
 Dim db As notesdatabase
 Set db=s.CurrentDatabase
 Set maildb=s.currentdatabase
 Dim maildoc As notesdocument
 Set maildoc = New notesdocument(maildb)
 Dim rtitem As notesrichtextitem
 Set rtitem = New notesrichtextitem(maildoc,"Body")
 maildoc.Form. = "memo"
 maildoc.Subject = subject
 maildoc.cFrom = db.server+"Notes伺服器"
 maildoc.From = db.server
 maildoc.SendTo = "With Wang/CN/CMINL"
 'Call rtitem.AppendDocLink(Doc, doc.FormTitle(0))
 Call maildoc.send(False)
End Sub

來自 “ ITPUB部落格 ” ，連結：http://blog.itpub.net/24998103/viewspace-700377/，如需轉載，請註明出處，否則將追究法律責任。