البحث في الموقع

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة تشفير السجلات في الجداول ، والذي تهدف إلى حماية البيانات من المتطفلين عند محاولتهم استيراد بيانات الجداول . والفكرة تم تطبيقها وإكمالها خلال طرح مشاركة معلمي الفاضل @ابوخليل في رده على أخونا @الحلبي في مشاركة في موضوع سابق . ولكني هنا اعتمدت على الجدول ( EncryptionStatus ) يحتوي حقل واحد ( Status ) من نوع Yes / No لمعرفة حالة التشفير عند تشغيل التطبيق .. ⭐ البرنامج يهدف إلى تنفيذ عملية تشفير و فك تشفير على كافة جداول قاعدة البيانات باستخدام خوارزمية XOR . وتحتوي الأداة على عدة دوال و وظائف تم تقسيمها وتوزيعها بشكل منفصل لتسهيل فهم وصيانة وتعديل الكود حسب الرغبة والحاجة . وبشكل مختصر سأذكر بعض وظائف هذه الدوال تالياً ، ثم ننتقل الى الكود لاحقاً :- الدالة EncryptDecrypt :- هذه الدالة الرئيسية التي تعمل على تشفير أو الغاء التشفير ؛ حيث تستخدم مفتاح التشفير ( المحدد في strKey ) لتطبيق عملية XOR بين البيانات والنص المشفر . الدالة GetAllTables :- هذه الدالة تقوم بإرجاع قائمة بأسماء كل الجداول في قاعدة البيانات الحالية ( طبعاً باستثناء جداول النظام ) . الدالة CheckEncryptionStatus :- هذه الدالة تتحقق من حالة التشفير ، عن طريق التحقق من قيمة الحقل Status في جدول EncryptionStatus . بحيث إذا كانت قيمة الحقل = True ، فإن قاعدة البيانات تكون مشفرة . الدالة EncryptAllTablesIndependently : - تم إضافتها لاستدعائها عند الخلل ( إجراء إحترازي ) .... والعديد من الدوال . كود المديول :- Option Compare Database Public Const EnCodeKey As String = "Officna2024" Public Function EncryptDecrypt(strData As String, strKey As String) As String Dim i As Integer Dim strResult As String Dim keyLen As Integer Dim keyValue As Integer strResult = "" If Len(strKey) = 0 Then MsgBox "مفتاح التشفير غير صحيح", vbCritical, "" Exit Function End If keyLen = Len(strKey) For i = 1 To Len(strData) keyValue = Asc(Mid(strKey, ((i - 1) Mod keyLen) + 1)) strResult = strResult & Chr(Asc(Mid(strData, i, 1)) Xor keyValue) Next i EncryptDecrypt = strResult End Function Public Function GetAllTables() As Collection Dim db As DAO.Database Dim tblDef As DAO.TableDef Dim tblNames As New Collection Set db = CurrentDb For Each tblDef In db.TableDefs If Left(tblDef.Name, 4) <> "MSys" Then tblNames.Add tblDef.Name End If Next tblDef Set GetAllTables = tblNames End Function Public Function CheckEncryptionStatus() As Boolean On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim status As Boolean Set db = CurrentDb Set rs = db.OpenRecordset("EncryptionStatus", dbOpenDynaset) If Not (rs.EOF And rs.BOF) Then rs.MoveFirst status = rs!status Else status = False End If rs.Close Set rs = Nothing Set db = Nothing CheckEncryptionStatus = status Exit Function ErrorHandler: MsgBox "لا يمكنك استخدام هذا المشروع في الوقت الحالي", vbCritical, "" EncryptAllTablesIndependently EnCodeKey DoCmd.Quit Exit Function End Function Public Sub EncryptAllTablesIndependently(ByVal strKey As String) Dim db As DAO.Database Dim tblName As Variant Dim rs As DAO.Recordset Dim fld As DAO.Field Dim tblList As Collection If Len(strKey) = 0 Then MsgBox "مفتاح التشفير غير صحيح", vbCritical, "" Exit Sub End If Set db = CurrentDb Set tblList = GetAllTables() For Each tblName In tblList Set rs = db.OpenRecordset(tblName, dbOpenDynaset) If Not (rs.EOF And rs.BOF) Then rs.MoveFirst Do Until rs.EOF For Each fld In rs.Fields If fld.Type = dbText Then rs.Edit rs(fld.Name).Value = EncryptDecrypt(Nz(rs(fld.Name), ""), strKey) rs.Update End If Next fld rs.MoveNext Loop End If rs.Close Next tblName End Sub Public Sub SetEncryptionStatus(status As Boolean) Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("EncryptionStatus", dbOpenDynaset) If Not (rs.EOF And rs.BOF) Then rs.MoveFirst rs.Edit rs!status = status rs.Update Else rs.AddNew rs!status = status rs.Update End If rs.Close End Sub Public Sub EncryptOrDecryptTables(ByVal strKey As String, ByVal isEncrypting As Boolean) Dim db As DAO.Database Dim tblName As Variant Dim rs As DAO.Recordset Dim fld As DAO.Field Dim tblList As Collection Dim action As String Set db = CurrentDb Set tblList = GetAllTables() action = IIf(isEncrypting, "تشفير", "فك التشفير") For Each tblName In tblList Set rs = db.OpenRecordset(tblName, dbOpenDynaset) If Not (rs.EOF And rs.BOF) Then rs.MoveFirst Do Until rs.EOF For Each fld In rs.Fields If fld.Type = dbText Then rs.Edit rs(fld.Name).Value = EncryptDecrypt(Nz(rs(fld.Name), ""), strKey) rs.Update End If Next fld rs.MoveNext Loop End If rs.Close Next tblName MsgBox "تمت عملية " & action & " بنجاح", vbInformation, "" End Sub Public Sub HandleEncryptionOnFormOpen() If CheckEncryptionStatus() = True Then Call EncryptOrDecryptTables(EnCodeKey, False) SetEncryptionStatus False End If End Sub Public Sub HandleEncryptionOnFormClose() If CheckEncryptionStatus() = False Then Call EncryptOrDecryptTables(EnCodeKey, True) SetEncryptionStatus True End If End Sub Public Function GetTotalRecordCount() As Long Dim db As DAO.Database Dim tblDef As DAO.TableDef Dim totalCount As Long Dim rs As DAO.Recordset Set db = CurrentDb totalCount = 0 For Each tblDef In db.TableDefs If Left(tblDef.Name, 4) <> "MSys" Then Set rs = db.OpenRecordset(tblDef.Name, dbOpenSnapshot) If Not (rs.EOF And rs.BOF) Then rs.MoveLast totalCount = totalCount + rs.recordCount End If rs.Close End If Next tblDef Set db = Nothing GetTotalRecordCount = totalCount End Function تم تنفيذ الفكرة بطريقتين ، الأولى من خلال الإعتماد على النموذج الرئيسي الذي يفتح به المشروع ( في حدث عند التحميل يتم الغاء التشفير ) وعند زر إغلاق المشروع يوجد حدث لإعادة التشفير لجميع الجداول مرة واحدة وبسرعة مهما كان عدد السجلات . والثانية من خلال نموذج آخر عند النقر على زر Start يبدأ شريط التحميل والذي يعتمد على عدد السجلات في جميع الجداول التي تم تشفيرها بالتقدم من 0 - 100% . وعند اغلاق النموذج يتم اعادة التشفير مرة أخرى . ✔ خطوات الحصول على النتيجة الصحيحة كالآتي :- ✔ انسخ الجدول (EncryptionStatus ) والمديول ( Encryption ) إلى أي مشروع تريده . ✔ تأكد من أن جميع السجلات غير مشفرة . ✔ تأكد من أن حالة الحقل Status هي No . قمت بكتابة الموضوع على عجالة ، وتركت الباب مفتوح للنقاش . Tashfeer 2024.accdb