[LotusScript] 重新整理一般人員的ACL許可權

1  (Initialize)
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
 
 Set EmpDB=s.getdatabase(db.Server,"SYSTEM\\UGOP.nsf")
 Set EmpOldView= EmpDB.GetView("(ByOldEName)")
 
 Set ApList = db.getView("Vw_ApList")
 Set Ap = ApList.GetFirstDocument
 While Not(Ap Is Nothing)
  Set refreshDB = s.GetDatabase(Ap.ServerIp(0),Ap.ApPath(0))
  Print  "資料庫路徑:-----------" +Ap.ServerName(0)+":::::"+Ap.ApPath(0)
  Call refreshDB.sign(DBSIGN_DOC_ALL)
  Set acl = refreshDB.ACL
  
  If refreshDB.QueryAccess(s.UserName) <> 6 Then
   Msgbox "您不是系統管理員，無權執行此程式!!!!"
   'Call SendToMail(Ap.ServerName(0)&"您不是系統管理員，無權執行此程式!!!!")
   'Exit Sub
   Ap.aflag = "N"
   Call Ap.Save(True,True)
   Goto ErrHandler
  End If
  
  Set entry = acl.GetFirstEntry   
  While Not(entry Is Nothing)
   '只更新 Person
   If entry.IsPerson And Not(entry.IsGroup) Then
    Set EmpODoc = EmpOldView.getdocumentbykey(UserNames("[ABBREVIATE]",entry.Name),True)
    If Not( EmpODoc Is Nothing) Then
     '檢查帳號是否存在
     If Ucase(entry.Name) <> Ucase(EmpODoc.NotesFullName(0)) Then
      Print "Old Name:______________"+entry.Name
      Print "New Name:______________"+EmpODoc.NotesFullName(0)
      isExist = "N"
      Set aclcheck = refreshDB.ACL
      Set check = aclcheck.GetFirstEntry
      '檢查欲新增的帳號是否已存在
      While Not check Is Nothing
       If Ucase(check.Name) = Ucase(EmpODoc.NotesFullName(0)) Then
        isExist = "Y"
       End If
       Set check = aclcheck.GetNextEntry(check)
      Wend
      
      If isExist <>"Y" Then
           '在ACL中新增新條目:
       Set acl = refreshDB.ACL
       '這個例子中，我們新增管理員 With Wang/CN/CMINL
       Set nEntry = acl.CreateACLEntry(EmpODoc.NotesFullName(0), entry.Level )    
       stringArray = entry.Roles
       nEntry.CanCreateDocuments = entry.CanCreateDocuments
       nEntry.CanCreateLSOrJavaAgent = entry.CanCreateLSOrJavaAgent
       nEntry.CanCreatePersonalAgent = entry.CanCreatePersonalAgent
       nEntry.CanCreatePersonalFolder = entry.CanCreatePersonalFolder
       nEntry.CanCreateSharedFolder = entry.CanCreateSharedFolder
       nEntry.CanDeleteDocuments = entry.CanDeleteDocuments
       nEntry.CanReplicateOrCopyDocuments = entry.CanReplicateOrCopyDocuments
       nEntry.IsAdminReaderAuthor = entry.IsAdminReaderAuthor
       nEntry.IsAdminServer = entry.IsAdminServer
       nEntry.IsGroup = entry.IsGroup
       nEntry.IsPerson = entry.IsPerson
       nEntry.IsPublicReader = entry.IsPublicReader
       nEntry.IsPublicWriter = entry.IsPublicWriter 
       
       If entry.Roles(0) <>"" Then
        For i=0 To Ubound(stringArray)
         Call nEntry.EnableRole(stringArray(i))
        Next
       End If 
       
      End If
     End If
    End If
   End If
   Set entry = acl.GetNextEntry(entry)
  Wend  
'儲存對ACL的更改  
  Call acl.Save
  Ap.aflag = "Y"
  Call Ap.Save(True,True)
  Goto ErrHandler
ErrHandler:
  Set Ap = ApList.GetNextDocument(Ap)
 Wend 
 'Call SendMail("OK")
 'Msgbox("OK")
 Print "OK"
 'Call SendToMail("OK")
End Sub

2  Function UserNames
Function UserNames (Action As String, Username As Variant) As String
 Dim InputName As New NotesNAME(Username) 
 Action=Ucase(Action)
 Select Case Action
 Case "[CANONICAL]"
  UserNames=InputName.Canonical
 Case "[ABBREVIATE]"
  UserNames=InputName.Abbreviated
 Case "[CN]"
  UserNames=InputName.Common
 Case "[C]"
  UserNames=InputName.Country
 Case "[OU1]"
  UserNames=InputName.OrgUnit1
 Case "[OU2]"
  UserNames=InputName.OrgUnit2
 Case "[OU3]"
  UserNames=InputName.OrgUnit3
 Case "[O]"
  UserNames=InputName.Organization
 Case Else
  UserNames=InputName.Canonical
 End Select   
End Function

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