Adapting Allen Browne's Field Level Permissions

[MSingh]

Hi,

I'm trying to adapt Allen Browne's "Field Level Permissions" for multiple, password protected back-ends.
The BE pwrds (in MS Access 2007-2013) could be different.

Your assistance would be greatly appreciated.

Kind Regards,
Mohamed

[HansV]

Open the code module of the frmAttribUser form.
Change the On Click event procedure of the cmdCommit command button as follows:

Code: Select all

Private Sub cmdCommit_Click()
    On Error GoTo Err_Handler
    'Purpose:   Set the custom permission property for the fields of the table.
    Dim dbLocal As DAO.Database 'This database
    Dim dbData As DAO.Database  'Data file, if the table is an attached database.
    Dim rs As DAO.Recordset     'This form's recordset clone (i.e. the list of fields)
    Dim tdf As DAO.TableDef     'The table whose fields are to be set.
    Dim strMsg As String        'Error message.
    Dim lngCurrentValue As Long 'Current setting of the field's custom property.
    Dim lngDesiredValue As Long 'Desired setting of the field's custom property.
    Dim lngKt As Long           'Count of fields changed.
    Dim bCancel As Boolean      'Flag to cancel
    Dim varConnect As Variant
    Dim strFile As String
    Dim strConnect As String
    Dim strDbConnect As String
    Dim strTable As String
    Dim lngPos As Long
    Dim arrParts As Variant
    Dim i As Long
    
    If IsNull(Me.TdfName) Then  'Check a table is loaded.
        strMsg = "Select a table first."
        Me.cboTable.SetFocus
        Me.cboTable.Dropdown
    Else
        If Me.Dirty Then        'Save any changes first.
            Me.Dirty = False
        End If
        
        'Get the Tabledef.
        strTable = Me.TdfName.Value
        Set dbLocal = CurrentDb()
        Set tdf = dbLocal.TableDefs(strTable)
        'If this is an attached table, get the TableDef in the original database.
        strConnect = tdf.Connect
        If Len(strConnect) > 0& Then
            'We handle only the default attached JET tables.
            arrParts = Split(strConnect, ";")
            For i = 0 To UBound(arrParts)
                If arrParts(i) Like "DATABASE=*" Then
                    strFile = Mid(arrParts(i), 10)
                ElseIf arrParts(i) Like "PWD=*" Then
                    strDbConnect = "MS Access;" & arrParts(i)
                End If
            Next i
            Set dbData = OpenDatabase(strFile, False, False, strDbConnect)
            'Reassign the tdf to the attached table
            strTable = tdf.SourceTableName
            Set tdf = Nothing
            Set tdf = dbData.TableDefs(strTable)
        End If
        
        'Loop through all the fields listed in the form's recordset.
        Set rs = Me.RecordsetClone
        If rs.RecordCount > 0 Then
            rs.MoveFirst
            Do While Not rs.EOF
                'Set the property for this field, if it changed.
                lngCurrentValue = Abs(rs!Current1.Value + 2& * rs!Current2.Value + 4& * rs!Current4.Value)
                lngDesiredValue = Abs(rs!Set1.Value + 2& * rs!Set2.Value + 4& * rs!Set4.Value)
                If lngDesiredValue <> lngCurrentValue Then
                    If SetPropertyDAO(tdf.Fields(rs!FldName.Value), "AttribUser", dbLong, lngDesiredValue, strMsg) Then
                        lngKt = lngKt + 1&
                    End If
                End If
                rs.MoveNext
            Loop
        End If
    End If
    
    'Display any error message collected.
    If strMsg <> vbNullString Then
        MsgBox strMsg, vbExclamation, "Problem"
    Else
        MsgBox IIf(lngKt = 1&, "One field", lngKt & " fields") & " changed in " & Me.TdfName & ".", vbInformation, "Permissions updated."
    End If
    
    'Disable the button.
    Me.cboTable.SetFocus
    Me.cmdCommit.Enabled = False
    
    'Clear the form. (The properties are not recognized quickly enough to reload it.)
    dbLocal.Execute "DELETE FROM tzAttribUser;", dbFailOnError
    Me.Requery
    
Exit_Handler:
    'Clean up
    On Error Resume Next
    Set rs = Nothing
    Set tdf = Nothing
    If Not (dbData Is Nothing) Then
        dbData.Close
        Set dbData = Nothing
    End If
    Set dbLocal = Nothing
    Exit Sub

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".cmdCommit_Click")
    Resume Exit_Handler
End Sub

I haven't stress-tested the changes, but it works for me in Access 2010 with a password-protected backend (the code works out the password for each backend separately).

[MSingh]

Hi Hans,
Many Thanks.
As always the solution is perfect!
Test on MS Access 2007 with multiple back-ends having different passwords.
Kind Regards,
Mohamed