【原创】LS程序 - 对于Lotus Notes数据库中文档的访问控制

程序原义是想用在控制对文档的读写控制上。但是扩展后可以用在多个地方，比如对于button和其他元素的一些控制
针对复杂的文档读写控制，比如角色的基础上，还需要对不同状态情况下文档读写控制，这个function将大大减少程序的复杂程度。

如下

Function toaccess (obj1 As Variant, chars As Variant , obj2 As String, equal As String) As Boolean
   
    On Error Goto sl
   
    '=====================================================================================================================
    '    This program is use to check if user have access to current object, such as button, form, view or others
    '    obj1 is current user or current object, normally, it would be user id or someone 's userid
    '    obj2 is the fixed parament, such as role, or namelist group or other related works.
    '
    '    "obj2" include:
    '    "ACL"
    '    "mutli-value"
    '    "string"
    '    "number"
    '
    '    equal is character to identify how to compare the obj1 and obj2. such as
    '    toaccess(notessession.commonusername,"[Admin]","=")
    '    it mean, if current user is Admin, the toaccess is true, or false
    '    toaccess("123",numberlist,"contain")
    '    it mean, if contain, true, or false
    '
    '    "equal" include:
    '     "="
    '    "<>"
    '    ">"
    '    "<"
    '    "contain"
    '    "notcontain"
    '
    '    Programmer: Jacky Shu
    '    Date: 2008-05-13
    '   
    '
    '
    '
    '====================================================================================================================   
    Dim ss As New NotesSession
    Dim ws As New NotesUIWorkspace
    Dim uidoc As NotesUIDocument
    Dim doc As NotesDocument
' defult value of toaccess is false   
   
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    If obj2 = "ACL" Then
    ' In ACL type, the equal parament only have two: contain / notcontain
        If equal <> "contain" And equal <> "notcontain" Then
            ReturnMsg("toaccess_parament_error")
            Exit Function
        End If
    ' ========================================Function Module 1 =============================================   
        Dim db As NotesDatabase
        Dim aclx As NotesACL
        Dim entry As NotesACLEntry
        Set db = ss.CurrentDatabase
        Set aclx = db.ACL
        Set entry = aclx.GetEntry(obj1)
        If equal = "contain" Then
            Forall r In entry.Roles
                If r = chars Then
                    toaccess = True
                    Exit Function
                End If
            End Forall
            toaccess = False
            Exit Function
        End If
        If equal = "notcontain" Then
            Forall r In entry.Roles
                If r = chars Then
                    toaccess = False
                    Exit Function
                End If
            End Forall
            toaccess = True
            Exit Function
        End If
        Exit Function
    End If
   
   
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<   
    If obj2 = "mutli-value" Then
        ' In mutli-value type, the equal parament only have two: contain / notcontain
        If equal <> "contain" And equal <> "notcontain" Then
            ReturnMsg("toaccess_parament_error")
            Exit Function
        End If
    ' ========================================Function Module 2 =============================================   
        If equal = "notcontain" Then
            Forall r In obj1
                If r = chars Then
                    toaccess = False
                    Exit Function
                End If
            End Forall
            toaccess = True
            Exit Function
        End If
       
        If equal = "contain" Then
            Forall r In obj1
                If r = chars Then
                    toaccess = True
                    Exit Function
                End If
            End Forall
            toaccess = False
            Exit Function
        End If
        Exit Function
    End If
   
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    If obj2 = "string" Then
        ' In string type, the equal parament only have two: contain / notcontain / = / <>
        If equal <> "contain" And equal <> "notcontain" And equal <> "=" And equal <> "<>" Then
            ReturnMsg("toaccess_parament_error")
            Exit Function
        End If
        ' ========================================Function Module 3 =============================================
        If equal = "contain" Then
            If Instr(obj1,chars) > 0 Then
                toaccess = True
                Exit Function
            End If
        End If
        If equal = "notcontain" Then
            If Instr(obj1,chars) = 0 Then
                toaccess = True
                Exit Function
            End If
        End If
        If equal = "=" Then
            If obj1 = chars Then
                toaccess = True
                Exit Function
            End If
        End If
        If equal = "<>" Then
            If obj1 <> chars Then
                toaccess = True
                Exit Function
            End If
        End If
        toaccess = False
        Exit Function
    End If
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    If obj2 = "number" Then
        ' In number type, the equal parament only have two: > / < / = / <>
        If equal <> ">" And equal <> "<" And equal <> "=" And equal <> "<>" Then
            ReturnMsg("toaccess_parament_error")
            Exit Function
        End If
        ' ========================================Function Module 4 =============================================
        If equal = "<" Then
            If Cint(obj1) < Cint(chars) Then
                toaccess = True
                Exit Function
            End If
        End If
        If equal = ">" Then
            If Cint(obj1) > Cint(chars) Then
                toaccess = True
                Exit Function
            End If
        End If
        If equal = "=" Then
            If Cint(obj1) = Cint(chars) Then
                toaccess = True
                Exit Function
            End If
        End If
        If equal = "<>" Then
            If Cint(obj1) <> Cint(chars) Then
                toaccess = True
                Exit Function
            End If
        End If
        toaccess = False
        Exit Function
    End If
   
   
   
sl:
    Msgbox "Error Message is : " & Error & Chr(13) & Chr(13) & "error line is : " & Erl
End Function