AccessTr.neT

Tam Versiyon: Tablo Sayısını Bulmak
Şu anda arşiv modunu görüntülemektesiniz. Tam versiyonu görüntülemek için buraya tıklayınız.
Tablo sayısını bulmak
'---------------------------------------------------------------------------------------
' Procedure : GetRecordCounts
' Author    : Jack
' Date      : 11/04/2014
' Purpose   : Subprocedure to Loop through all tables in this database and
' provide Table Name, RecordCount and Current Date to Immediate window.
' Does not review system tables (MSys) or deleted (~TMPC)
'---------------------------------------------------------------------------------------
'
Sub GetRecordCounts()
          Dim db As DAO.Database
          Dim tbl As DAO.TableDef
          Dim SCNT As String
          Dim tblCount As Long
10    On Error GoTo GetrecordCounts_Error

20    Set db = CurrentDb
30    For Each tbl In db.TableDefs
40      If (Left(tbl.name, 4) <> "MSys") And Not (tbl.name Like "~TMPC*") Then
50          SCNT = Format(CLng((tbl.RecordCount)), "0000")
60          Debug.Print tbl.name & Space(35 - Len(tbl.name)) & Space(10 - Len(SCNT)) & SCNT & Space(3) & Date
70          tblCount = tblCount + 1
80      End If
90    Next tbl
100   Debug.Print "Total tables (non system) count :" & tblCount
110   On Error GoTo 0
120   Exit Sub

GetrecordCounts_Error:

130   MsgBox "Error " & Err.number & "  on line " & Erl & " (" & Err.Description & ") in procedure GetrecordCounts"
End Sub

SELECT MSysObjects.Name, DCount("*",[Name]) AS RecCount FROM MSysObjects
WHERE (((MSysObjects.Name) Not Like 'MSYS*') AND ((MSysObjects.Type)=1));
bir de böyle bir sorgu var
Sub DeleteTmpClpObjects()

'===============================================
'Purpose : remove any leftover TMPCLP objects from the database
'Author  : Colin Riddington - MendipData Systems
'Date    : 30/04/2017

'===============================================

'NOTE: an alternative approach that also works is:
'Just replace the 'phantom' object with a real one!

'Create a new form/report with the same name.
'Save it and replace the existing form when prompted
'Close the new form.
'It is automatically deleted along with the TMPCLP item

'===============================================

Dim Rs As DAO.Recordset
Dim strSQL As String
Dim N As Integer
Dim Q As Integer

On Error GoTo Err_Handler

    'check for '~TMPCLP' objects
    N = DCount("*", "MSysObjects", "MSysObjects.Name Like '~TMPCLP*'")
   
    If N = 0 Then
        MsgBox "There are no 'leftover' database objects named '~TMPCLP*" & _
            vbNewLine & vbNewLine & _
            "This routine will now close", vbInformation, "No TMPCLP objects"
        Exit Sub
    Else
        If MsgBox("There are " & N & " 'leftover' database objects named '~TMPCLP*" & _
            vbNewLine & vbNewLine & _
            "Click OK to remove these objects from the database", _
                vbExclamation + vbOKCancel, "Remove " & N & " TMPCLP objects?") = vbCancel Then Exit Sub
    End If
   
    If MsgBox("You should backup the 'front end' database BEFORE deleting these objects" & vbNewLine & vbNewLine & _
        "Do a backup now? (RECOMMENDED)", vbExclamation + vbYesNo, "Copy the front end database?") = vbYes Then
            CopyCurrentDatabase
    End If

    strSQL = "SELECT qryMSysObjectsTMPCLP.* FROM qryMSysObjectsTMPCLP;"

    Set Rs = CurrentDb.OpenRecordset(strSQL)

    Do Until Rs.EOF
        Select Case Rs("Type")
        Case 1, 4, 6 'tables
            DoCmd.DeleteObject acTable, Rs("Name")
        Case 5 'queries
            DoCmd.DeleteObject acQuery, Rs("Name")
        Case -32768 'form
            DoCmd.DeleteObject acForm, Rs("Name")
        Case -32764 'report
            DoCmd.DeleteObject acReport, Rs("Name")
        Case -32766
            DoCmd.DeleteObject acMacro, Rs("Name")
        Case -32761
            DoCmd.DeleteObject acModule, Rs("Name")
       
        Case Else
            '???
            'look at what was printed in the immediate window
            'and include the type in the select case
            Debug.Print Rs("Type"), Rs("Name")
       
        End Select

 
    Rs.MoveNext
    Loop
    Rs.Close
   
    Set Rs = Nothing

    'check again for '~TMPCLP' objects
    Q = DCount("*", "MSysObjects", "MSysObjects.Name Like '~TMPCLP*'")
   
    'end message
    If Q = N Then 'none removed
        MsgBox "None of the " & N & " 'leftover' database objects named '~TMPCLP*'" & _
            " could be removed from the database", vbCritical, "TMPCLP objects were not deleted"
    ElseIf Q = 0 Then 'all removed
        MsgBox "All " & N & " 'leftover' database objects named '~TMPCLP*'" & _
            " have been removed from the database", vbInformation, "TMPCLP objects successfully deleted"
    Else: 'partly deleted
        MsgBox N - Q & " 'leftover' database objects named '~TMPCLP*'" & _
            " have been removed from the database" & vbNewLine & vbNewLine & _
            "However, " & Q & " '~TMPCLP' objects were not removed", vbExclamation, "TMPCLP objects partly deleted"
    End If

Exit_Handler:
    Exit Sub
   
Err_Handler:
    MsgBox "Error " & err.Number & " in DeleteTmpClpObjects procedure :" & vbNewLine & _
        " - " & err.Description, vbExclamation, "Error"

    Resume Next
   
End Sub

Sub DeleteMSysErrorObjects()

'===============================================
'Purpose : remove any incorrectly flagged Msys objects from the database
'Author  : Colin Riddington - MendipData Systems
'Date    : 12/05/2017

'===============================================

Dim Rs As DAO.Recordset
Dim strSQL As String
Dim N As Integer
Dim Q As Integer

On Error GoTo Err_Handler

    'check for incorrectly flagged objects
    N = DCount("*", "qryMSysObjectsERROR")
   
    If N = 0 Then
        MsgBox "There are no 'incorrectly flagged' database objects" & _
            vbNewLine & vbNewLine & _
            "This routine will now close", vbInformation, "No incorrectly flagged objects"
        Exit Sub
    Else
        If MsgBox("There are " & N & " 'incorrectly flagged' database objects" & _
            vbNewLine & vbNewLine & _
            "Click OK to remove these objects from the database", _
                vbExclamation + vbOKCancel, "Remove " & N & " incorrectly flagged objects?") = vbCancel Then Exit Sub
    End If
   
    If MsgBox("You should backup the 'front end' database BEFORE deleting these objects" & vbNewLine & vbNewLine & _
        "Do a backup now? (RECOMMENDED)", vbExclamation + vbYesNo, "Copy the front end database?") = vbYes Then
            CopyCurrentDatabase
    End If
   
    strSQL = "SELECT qryMSysObjectsERROR.* FROM qryMSysObjectsERROR;"
   

    Set Rs = CurrentDb.OpenRecordset(strSQL)

    Do Until Rs.EOF
        Select Case Rs("Type")
        Case 1, 4, 6 'tables
            DoCmd.DeleteObject acTable, Rs("Name")
        Case 5 'queries
            DoCmd.DeleteObject acQuery, Rs("Name")
        Case -32768 'form
            DoCmd.DeleteObject acForm, Rs("Name")
        Case -32764 'report
            DoCmd.DeleteObject acReport, Rs("Name")
        Case -32766
            DoCmd.DeleteObject acMacro, Rs("Name")
        Case -32761
            DoCmd.DeleteObject acModule, Rs("Name")
       
        Case Else
            '???
            'look at what was printed in the immediate window
            'and include the type in the select case
            Debug.Print Rs("Type"), Rs("Name")
       
        End Select

 
    Rs.MoveNext
    Loop
    Rs.Close
   
    Set Rs = Nothing

    'check again for incorrectly flagged objects
    Q = DCount("*", "qryMSysObjectsERROR")
   
    'end message
    If Q = N Then 'none removed
        MsgBox "None of the " & N & " 'incorrectly flagged' database objects'" & _
            " could be removed from the database", vbCritical, "Incorrectly flagged objects were not deleted"
    ElseIf Q = 0 Then 'all removed
        MsgBox "All " & N & " 'incorrectly flagged' database objects" & _
            " have been removed from the database", vbInformation, "Incorrectly flagged objects successfully deleted"
    Else 'partly deleted
        MsgBox N - Q & " 'Incorrectly flagged' database objects" & _
            " have been removed from the database" & vbNewLine & vbNewLine & _
            "However, " & Q & " 'incorrectly flagged' objects were not removed", vbExclamation, "Incorrectly flagged objects partly deleted"
    End If

Exit_Handler:
    Exit Sub
   
Err_Handler:
    MsgBox "Error " & err.Number & " in DeleteMSysErrorObjects procedure :" & vbNewLine & _
        " - " & err.Description, vbExclamation, "Error"

    Resume Next
   
End Sub

Sub DeleteMSysExtinctObjects()

'===============================================
'Purpose : remove any Msys objects that are no longer in the database
'Author  : Colin Riddington - MendipData Systems
'Date    : 13/05/2017

'===============================================

Dim Rs As DAO.Recordset
Dim strSQL As String
Dim N As Integer
Dim Q As Integer

On Error GoTo Err_Handler

    'check for MSys objects that are 'extinct' (no longer in the database)
    N = DCount("*", "qryMSysObjectsEXTINCT")
   
    If N = 0 Then
        MsgBox "There are no 'extinct' database objects" & _
            vbNewLine & vbNewLine & _
            "This routine will now close", vbInformation, "No extinct objects"
        Exit Sub
    Else
        If MsgBox("There are " & N & " 'extinct' database objects" & _
            vbNewLine & vbNewLine & _
            "Click OK to remove these objects from the database", _
                vbExclamation + vbOKCancel, "Remove " & N & " extinct objects?") = vbCancel Then Exit Sub
    End If
   
    If MsgBox("You should backup the 'front end' database BEFORE deleting these objects" & vbNewLine & vbNewLine & _
        "Do a backup now? (RECOMMENDED)", vbExclamation + vbYesNo, "Copy the front end database?") = vbYes Then
            CopyCurrentDatabase
    End If
   
   
    strSQL = "SELECT qryMSysObjectsEXTINCT.* FROM qryMSysObjectsEXTINCT;"
   

    Set Rs = CurrentDb.OpenRecordset(strSQL)

    Do Until Rs.EOF
        Select Case Rs("Type")
        Case 1, 4, 6 'tables
            DoCmd.DeleteObject acTable, Rs("Name")
        Case 5 'queries
            DoCmd.DeleteObject acQuery, Rs("Name")
        Case -32768 'form
            DoCmd.DeleteObject acForm, Rs("Name")
        Case -32764 'report
            DoCmd.DeleteObject acReport, Rs("Name")
        Case -32766
            DoCmd.DeleteObject acMacro, Rs("Name")
        Case -32761
            DoCmd.DeleteObject acModule, Rs("Name")
       
        Case Else
            '???
            'look at what was printed in the immediate window
            'and include the type in the select case
            Debug.Print Rs("Type"), Rs("Name")
       
        End Select

 
    Rs.MoveNext
    Loop
    Rs.Close
   
    Set Rs = Nothing

    'check again for MSys objects that are 'extinct' (no longer in the database)
    Q = DCount("*", "qryMSysObjectsEXTINCT")
   
    'end message
    If Q = N Then 'none removed
        MsgBox "None of the " & N & " 'extinct' database objects'" & _
            " could be removed from the database", vbCritical, "Extinct database objects were not deleted"
    ElseIf Q = 0 Then 'all removed
        MsgBox "All " & N & " 'incorrectly flagged' database objects" & _
            " have been removed from the database", vbInformation, "Extinct database objects successfully deleted"
    Else 'partly deleted
        MsgBox N - Q & " 'extinct' database objects" & _
            " have been removed from the database" & vbNewLine & vbNewLine & _
            "However, " & Q & " 'extinct' database objects were not removed", _
                vbExclamation, "Extinct database objects partly deleted"
    End If

Exit_Handler:
    Exit Sub
   
Err_Handler:
  '  If Err <> 5 And Err <> 3071 And Err <> 2498 Then
        MsgBox "Error " & err.Number & " in DeleteMSysEXTINCTObjects procedure :" & vbNewLine & _
            " - " & err.Description, vbExclamation, "Error"
  '  End If
    Resume Next
   
End Sub

örnek proje
Sağolunuz.