17/05/2020, 10:44
Tablo sayısını bulmak
örnek proje
'---------------------------------------------------------------------------------------
' 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 SubSELECT MSysObjects.Name, DCount("*",[Name]) AS RecCount FROM MSysObjects
WHERE (((MSysObjects.Name) Not Like 'MSYS*') AND ((MSysObjects.Type)=1));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 SubSub 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 SubSub 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