السلام عليكم و رحمة الله و بركاته
هديتى اليكم اليوم هى وحدة نمطية لمنع حذف الجداول يدويا
وجدت هذا الكود فى أحد المواقع و لقد حاولت مرارا التعديل عليها لمنع فتح الجداول و لكن باءت محاولاتى بالفشل
و التى لو نجحت لوفرت حماية كبيرة للقاعدة و لو كان بالامكان منع الاستيراد من القاعدة لاكتملت منظومة الحماية
عموما هذا الكود يمنع الحذف اليدوى للجداول و حتى تقوم بالغاء جدول يجب ايقاف الكود أولا ثم الالغاء أو الالغاء عن طريق كود
مثال لكود حذف الجدول
currentproject.connection.execute "DROP TABLE YourtableName"
ملحوظات :-
يجب ان تكون الجداول بها حقل ترقيم تلقائى ( ليس من الضرورى ان يكون مفتاح اساسى )
تقسيم القاعدة الى جزئين ( واجهة و بيانات ) يلغى عمل الكود ------- يمكنك اعادة تشغيل الكود فى القاعدة الخلفية من جديد بعد نقل الوحدة النمطية اليها
استيراد الجداول الى قاعدة بيانات جديدة ------- يحتاج اعادة تشغيل الكود فى القاعدة الجديدة من جديد بعد نقل الوحدة النمطية اليها
تطبيق الكود :-
1- انسخ الكود الى وحدة نمطية جديدة ثم احفظها
2- اضغط CTL + G لفتح immediate window
3- اكتب الكود التالى
?StopManualTableDelete("Yes")4- اضغط enter
حاول الان حذف اى جدول
لايقاف عمل الكود
كرر الخطوات من 2 الى 4
2- اضغط CTL + G لفتح immediate window
3- اكتب الكود التالى
?StopManualTableDelete("No")4- اضغط enter
حاول الان حذف اى جدول '
الان
تبقى لنا الوحدة النمطية
Public Function StopManualTableDelete(YesOrNo As String)
Dim fld As DAO.Field
Dim db As DAO.Database
Dim tbl As DAO.TableDef
Dim SQL_CreateConstraint As String, SQL_DropConstraint As String
Dim strConstraint As String ' this variable holds the name of the constraint
Dim i As Integer
Dim tblNames As String, DeleteInfo As String
Set db = CurrentDb()
i = 0
For Each tbl In db.TableDefs
' Bypass system tables with autonumbers Also any hidden table that starts with "~"
If Mid(tbl.Name, 1, 4) <> "MSys" Then
If Left(tbl.Name, 1) <> "~" Then
For Each fld In db.TableDefs(tbl.Name).Fields
If dbAutoIncrField = (fld.Attributes And dbAutoIncrField) Then 'Find autonumber
DoCmd.Hourglass True
strConstraint = "con_" & fld.Name & "_" & tbl.Name 'Build constraint name
If YesOrNo = "YES" Then
i = i + 1
'Drop any existing autonumber field constraints if there is one.
If FindCheckConstraint(strConstraint) = True Then
SQL_DropConstraint = "ALTER TABLE " & tbl.Name & " DROP CONSTRAINT " & strConstraint
CurrentProject.Connection.Execute SQL_DropConstraint
End If
DoEvents ' await a while just in case
'create the new constraint to disallow the table from being deleted.
SQL_CreateConstraint = " ALTER TABLE " & tbl.Name & " ADD " & " CONSTRAINT " & strConstraint & " CHECK (" & fld.Name & " IS NOT NULL))"
'Debug.Print SQL_CreateConstraint
CurrentProject.Connection.Execute SQL_CreateConstraint
DeleteInfo = "CANNOT"
End If
If YesOrNo = "NO" Then
'Drop any existing autonumber field constraints.
If FindCheckConstraint(strConstraint) = True Then
i = i + 1
SQL_DropConstraint = "ALTER TABLE " & tbl.Name & " DROP CONSTRAINT " & strConstraint
CurrentProject.Connection.Execute SQL_DropConstraint
DeleteInfo = "CAN"
End If
End If
tblNames = tblNames & tbl.Name & vbNewLine
Exit For
End If
Next fld
End If
End If
Next tbl
db.Close
Set db = Nothing
DoCmd.Hourglass False
If i > 0 Then
MsgBox i & " tables have been set so they " & DeleteInfo & " be deleted manually. " & vbNewLine & "These tables are:" & vbNewLine & vbNewLine & tblNames
Else
MsgBox "There are no tables with Autonumber fields present in this database." & vbNewLine & "Therefore this code did not have any effect on this database."
End If
End Function
Public Function FindCheckConstraint(MyConstraint As String) As Boolean
'this function checks to see if a check constraint already exist on the autonumber field.
Dim fld As ADODB.Field
Dim rst As ADODB.Recordset
Set rst = CurrentProject.Connection.OpenSchema(adSchemaCheckConstraints)
Do Until rst.EOF
For Each fld In rst.Fields
If fld.Name = "CONSTRAINT_NAME" Then
If fld.Value = MyConstraint Then
'Debug.Print fld.Value
FindCheckConstraint = True
Exit For
End If
End If
Next fld
rst.MoveNext
Loop
End Functionو نسألكم الدعاء
مرفق مثال تم التطبيق عليه
