Access

B-ADOObjectPermissions-ST

'---------------------------------------------------------------
Public Function ADOObjectPermissions(strCnnPermissions As String, strAccessSystemTable As String, bolReadData As Boolean) As Boolean
'---------------------------------------------------------------
'Requires reference for Microsoft ADO Ext. 2.? for DDL and Security
'Add read data permission on table, ie MSysObjects, MSysRelationships, Emp Task
'ADOObjectPermissions("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Program Files\SSW Upsizing PRO\Sample\TestReadPermissions.mdb","MSysObjects", True)
'Date          27/09/2002 ST
'Master SSW Upsizing PRO

On Error GoTo Err_ADOObjectPermissions

ADOObjectPermissions = False

'Open the catalog
Dim cat As New ADOX.Catalog
cat.ActiveConnection = strCnnPermissions & ";" & "Jet OLEDB:System database=" & _
        CurrentProject.Connection.Properties("Jet OLEDB:System Database").Value

Dim lngPerm As Long
lngPerm = cat.Users("admin").GetPermissions(strAccessSystemTable, adPermObjTable)
If lngPerm = 0 Or lngPerm = 1024 Or lngPerm = 148480 Then
    If bolReadData Then
        'add read data permission
        cat.Users("Admin").SetPermissions strAccessSystemTable, adPermObjTable, _
          adAccessSet, lngPerm Or adRightRead
    ElseIf Not bolReadData Then
        'add modify design permission to write table/field name
        cat.Users("Admin").SetPermissions strAccessSystemTable, adPermObjTable, _
          adAccessSet, lngPerm Or adRightUpdate
    Else
        MsgBox "logic error", vbCritical + vbOKOnly, "Validation in ADOObjectPermissions"
    End If
    
ElseIf lngPerm <> 0 Or lngPerm <> 1024 Then
    'ignore all
Else
    MsgBox "logic error", vbCritical + vbOKOnly, "Valiadtion in function ADOObjectPermissions"
End If

ADOObjectPermissions = True

Exit_ADOObjectPermissions:
    Set cat = Nothing
    Exit Function
Err_ADOObjectPermissions:
    MsgBox "Error: " & Err.Number & " -- " & Err.Description, vbCritical + vbOKOnly, "ADOObjectPermissions"
    Resume Exit_ADOObjectPermissions
    Resume
End Function

Reports showing using an ALL record

'From Report rptEmpTimeSheet
'This technique shows using a Table with a record '<ALL>' 
'AC 21/1/2001


Private Sub Report_Open(Cancel As Integer)

'Since the report NEEDS the form opened first.
'The idea is, if the open the report from the database window then the report calls the form. Not the form calling the report.

DoCmd.OpenForm frm, , , , , acDialog
'All this code is suspended until the user chooses OK or closes the form

If Not IsLoaded(frm) Then
    DoCmd.CancelEvent
    Exit Sub    'They closed the form
Else
    'Apply the filter
    sql = ""
    If Forms(frm)!ctlEmpIDRpt <> "<ALL>" Then
        sql = "EmpID = '" & Forms(frm)!ctlEmpIDRpt & "'"
    End If
    
    If Forms(frm)!ctlCategoryID <> "<ALL>" Then
        If sql <> "" Then sql = sql & " and "
        sql = sql & "CategoryID = '" & Forms(frm)!ctlCategoryID & "'"
    End If

    If Forms(frm)!ctlReportOption = 1 Then
        'N/A
    ElseIf Forms(frm)!ctlReportOption = 2 Then
        'A date range was choosen
        If sql <> "" Then sql = sql & " and "
        sql = sql & "DateCreated between #" & Format(Forms(frm)!ctlDateStart, "mm/dd/yyyy") & "# and #" & Format(Forms(frm)!ctlDateEnd, "mm/dd/yyyy") & " 23:59:59pm #"
    ElseIf Forms(frm)!ctlReportOption = 3 Then
        'A day was choosen
        If sql <> "" Then sql = sql & " and "
        sql = sql & "DateCreated = #" & Format(Forms(frm)!ctlDateStart, "mm/dd/yyyy") & "#"
    Else
        MsgBox "Logic Error"
    End If

    '="For the period " & Format([Forms]![frmrptEmpTimeSheet]![ctlDateStart],"Long Date") & " To " & Format([Forms]![frmrptEmpTimeSheet]![ctlDateTo],"Long Date")
    lblSQL.Caption = sql
    'MsgBox sql
    Me.Filter = sql
    Me.FilterOn = True
End If

End Sub