Debug Ace

لو عندك نسخة مفتوحة افتحها على الجهاز الذى يحتوى على المشكلة هذه لو فتحت بدون مشاكل اذا لا يوجد دوال API ولا تحتاج الى تعديل اى أكواد فقط تحتاج الى عمل نسخة مشفرة من اوفيس بنواة 64 بيت فالنسخ المشفرة لا تعمل مطلقا الا على اصدار النواة التى تم تشفيرها من خلاله وفى هذه الحاالة من يمكلك 64 بيت يعمل بالنسخة المبينة فى التشفير على نواة الاوفيس 64 ومن يملك 32 بيت يعمل بالنسخة المبينة فى التشفير على نواة الاوفيس 32

نعم طالما انك تملك القاعدة الاصلية مفتوحة المصدر يمكن تعديل كل الاكواد لتتوافق وتتكامل مع النواتان 32 , 64

وهذا تماما ما كنت انتظره عندما يتم تشفير قواعد البيانات الى mde أو Accde لا يمكن تعديل الاكواد بداخلها ومن اجل ذلك ان كنت تملك القاعدة الاصلية مفتوحة بدون تشفير اى mdb او accdb فقط فى هذه الحالة يمكن تعديل او تطوير او اضافة اكواد

لما المرفق ينزل نرد وفقا للمرفق يا سيد معلش احنا لسه هواة بنتعلم

ارفق قاعدتك ليتم تعديل الاكواد لتدعم العمل مع النواتان

تم تعريفه كـ String فارغ مما يعني فتح التقرير بدون أي فلتر (كل البيانات) وظيفته: DoCmd.OpenReport repName, acViewNormal, , ftrName WhereCondition — شرط SQL لتصفية البيانات أمثلة عملية: فتح التقرير بدون فلتر (كل البيانات) ftrName = "" فلترة بمدينة معينة ftrName = "City = 'Cairo'" فلترة بتاريخ ftrName = "OrderDate = #" & Date & "#" فلترة بـ ID من النموذج ftrName = "CustomerID = " & Me.txtCustomerID في هذا الكود تحديدا ftrName معرف لكنه فارغ >>--> يعني التقرير يفتح بكل البيانات بدون تصفية إذا كنت تريد تصفية التقارير قم بوضعه باسناد البيانات التى تريدها الى المتغير حسب نوع البيانات قبل الحلقة: استخدم احد الفلاتر التى قمت بشرحها لك سابقا كأمثلة عملية قبل الحلقة مباشرة

وفى هذا الموضوع تم التطرق الى هذه الجزئية ايضا وقمت بالشرح والتفنيد ولكن تحول الحساب الى اسم زائر ولا اعرف السب هههههههههههههه

ههههههه صعبتها علي يا رجل مش عارف الـ : Demo ده هيصعب الموضوع اكثر واللا ايه حاولت جمع كل ما خطر على بالى فيما يخص حروف البدل Option Compare Database Option Explicit Private Function L1(Optional n As Integer = 50) As String L1 = String(n, "-") End Function Private Function L2(Optional n As Integer = 50) As String L2 = String(n, "=") End Function ' ============================================================ ' STEP 0 : إنشاء الجداول التجريبية (شغلها مرة واحدة فقط) ' ============================================================ Public Sub Create_Demo_Tables() If MsgBox("هيتم مسح الجداول القديمة، متأكد؟", vbYesNo) = vbNo Then Exit Sub Dim db As DAO.Database Dim ins As String Dim i As Integer Dim emp As Variant Dim prd As Variant Set db = CurrentDb On Error Resume Next db.Execute "DROP TABLE Employees_Demo" db.Execute "DROP TABLE Products_Demo" On Error GoTo 0 db.Execute "CREATE TABLE Employees_Demo (" & _ "EmpID AUTOINCREMENT PRIMARY KEY, " & _ "EmpName TEXT(50), Email TEXT(80), " & _ "Phone TEXT(20), City TEXT(40))" db.Execute "CREATE TABLE Products_Demo (" & _ "ProdID AUTOINCREMENT PRIMARY KEY, " & _ "ProdName TEXT(60), Code TEXT(10), " & _ "Category TEXT(30))" ' -- بيانات الموظفين -------------------------------------- ins = "INSERT INTO Employees_Demo (EmpName,Email,Phone,City) VALUES " emp = Array( _ "('Mohamed Ali' ,'m.ali@company.com' ,'010-1234567','Cairo' )", _ "('Mona Samy' ,'mona.s@company.com' ,'011-2345678','Alexandria' )", _ "('Ahmed Hassan' ,'a.hassan@company.com','012-3456789','Giza' )", _ "('Sara Ahmed' ,'sara.a@company.com' ,'010-4567890','Cairo' )", _ "('Omar Khaled' ,'omar.k@company.com' ,'015-5678901','Mansoura' )", _ "('Layla Nour' ,'l.nour@company.com' ,'011-6789012','Alexandria' )", _ "('Mariam Fady' ,'mariam@company.com' ,'010-7890123','Cairo' )", _ "('Youssef Basel' ,'y.basel@company.com' ,'012-8901234','Giza' )", _ "('Aya Mohamed' ,'aya.m@company.com' ,'015-9012345','Mansoura' )", _ "('Khaled Samy' ,'k.samy@company.com' ,'010-0123456','Cairo' )", _ "('Amira Hassan' ,'amira.h@company.com' ,'011-1122334','Alexandria' )", _ "('Rami Adel' ,'rami.a@company.com' ,'012-2233445','Giza' )", _ "('Dina Nabil' ,'dina.n@company.com' ,'015-3344556','Suez' )", _ "('Sami Waly' ,'sami.w@company.com' ,'010-4455667','Cairo' )", _ "('Hana Emad' ,'hana.e@company.com' ,'011-5566778','Alexandria' )") For i = LBound(emp) To UBound(emp) db.Execute ins & emp(i) Next i ' -- بيانات المنتجات -------------------------------------- ins = "INSERT INTO Products_Demo (ProdName,Code,Category) VALUES " prd = Array( _ "('Laptop Pro 15' ,'LP-001','Electronics' )", _ "('Laptop Air 13' ,'LA-002','Electronics' )", _ "('Samsung Galaxy S24' ,'SG-003','Phones' )", _ "('Samsung Galaxy A54' ,'SG-004','Phones' )", _ "('Apple iPhone 15' ,'AI-005','Phones' )", _ "('50% Discount Card' ,'DC-006','Offers' )", _ "('Headphone Bass Pro' ,'HP-007','Audio' )", _ "('Monitor 27 inch' ,'MO-008','Electronics' )", _ "('Keyboard Wireless' ,'KB-009','Accessories' )", _ "('Mouse Optical Pro' ,'MS-010','Accessories' )") For i = LBound(prd) To UBound(prd) db.Execute ins & prd(i) Next i Debug.Print L2(50) Debug.Print " تم إنشاء الجداول وإدخال البيانات بنجاح ?" Debug.Print L2(50) Set db = Nothing End Sub ' ============================================================ ' دالة مساعدة : طباعة نتائج أي Recordset كجدول ' ============================================================ Private Sub PrintRS(rs As DAO.Recordset, sTitle As String, sSQL As String) Dim i As Integer Dim sRow As String Dim iCount As Integer Debug.Print "" Debug.Print " " & sTitle Debug.Print " SQL : " & sSQL Debug.Print " " & L1(50) ' أسماء الأعمدة sRow = " " For i = 0 To rs.fields.Count - 1 sRow = sRow & PadRight(rs.fields(i).name, 22) Next i Debug.Print sRow Debug.Print " " & String(rs.fields.Count * 22, "-") ' الصفوف iCount = 0 Do While Not rs.EOF sRow = " " For i = 0 To rs.fields.Count - 1 sRow = sRow & PadRight(Nz(rs.fields(i).Value, "NULL"), 22) Next i Debug.Print sRow iCount = iCount + 1 rs.MoveNext Loop Debug.Print " " & L1(50) Debug.Print " >>--> عدد النتائج : " & iCount & " صف" End Sub ' دالة محاذاة النص Private Function PadRight(s As Variant, n As Integer) As String Dim str As String str = CStr(Nz(s, "NULL")) If Len(str) >= n Then PadRight = Left(str, n - 1) & " " Else PadRight = str & Space(n - Len(str)) End If End Function ' ============================================================ ' SECTION 1 : * Wildcard (يعادل % في SQL Server) ' ============================================================ Public Sub Section1_Star_Wildcard() Dim db As DAO.Database Dim rs As DAO.Recordset Dim sql As String Set db = CurrentDb Debug.Print "": Debug.Print L2(55) Debug.Print " SECTION 1 : * Wildcard — أي عدد من الحروف" Debug.Print " ملاحظة : * في Access = % في SQL Server" Debug.Print L2(55) sql = "SELECT EmpID,EmpName,Email,City FROM Employees_Demo WHERE EmpName LIKE 'M*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[1-A] EmpName LIKE 'M*' <<--< يبدأ الاسم بحرف M", sql): rs.Close sql = "SELECT EmpID,EmpName,City FROM Employees_Demo WHERE EmpName LIKE '*Hassan' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[1-B] EmpName LIKE '*Hassan' <<--< ينتهي بـ Hassan", sql): rs.Close sql = "SELECT EmpID,EmpName,Email FROM Employees_Demo WHERE EmpName LIKE '*Ali*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[1-C] EmpName LIKE '*Ali*' <<--< يحتوي على Ali في أي مكان", sql): rs.Close sql = "SELECT EmpName,Email FROM Employees_Demo WHERE Email LIKE '*@company.com' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[1-D] Email LIKE '*@company.com' <<--< كل إيميلات الشركة", sql): rs.Close sql = "SELECT EmpName,Phone,City FROM Employees_Demo WHERE Phone LIKE '010*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[1-E] Phone LIKE '010*' <<--< أرقام تبدأ بـ 010", sql): rs.Close Set db = Nothing End Sub ' ============================================================ ' SECTION 2 : ? Wildcard (يعادل _ في SQL Server) ' ============================================================ Public Sub Section2_Question_Wildcard() Dim db As DAO.Database Dim rs As DAO.Recordset Dim sql As String Set db = CurrentDb Debug.Print "": Debug.Print L2(55) Debug.Print " SECTION 2 : ? Wildcard — حرف واحد بالضبط" Debug.Print " ملاحظة : ? في Access = _ في SQL Server" Debug.Print L2(55) sql = "SELECT EmpID,EmpName,City FROM Employees_Demo WHERE EmpName LIKE '?a*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[2-A] EmpName LIKE '?a*' <<--< الحرف الثاني من الاسم هو a", sql): rs.Close sql = "SELECT EmpID,EmpName,City FROM Employees_Demo WHERE EmpName LIKE '???? *' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[2-B] EmpName LIKE '???? *' <<--< الاسم الأول 4 حروف بالضبط", sql): rs.Close sql = "SELECT EmpName,Phone FROM Employees_Demo WHERE Phone LIKE '0??-*' ORDER BY Phone" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[2-C] Phone LIKE '0??-*' <<--< كود تليفون 3 أرقام يبدأ بـ 0", sql): rs.Close sql = "SELECT ProdName,Code,Category FROM Products_Demo WHERE Code LIKE 'L?-0??' ORDER BY Code" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[2-D] Code LIKE 'L?-0??' <<--< كود يبدأ بـ L + حرف + -0 + رقمان", sql): rs.Close Set db = Nothing End Sub ' ============================================================ ' SECTION 3 : [ ] Wildcard (قائمة حروف محددة) ' ============================================================ Public Sub Section3_CharList_Wildcard() Dim db As DAO.Database Dim rs As DAO.Recordset Dim sql As String Set db = CurrentDb Debug.Print "": Debug.Print L2(55) Debug.Print " SECTION 3 : [قائمة] Wildcard — حرف من قائمة محددة" Debug.Print " ملاحظة : [abc] تعني أي حرف من a أو b أو c" Debug.Print L2(55) sql = "SELECT EmpName,Email,City FROM Employees_Demo WHERE EmpName LIKE '[AMS]*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[3-A] EmpName LIKE '[AMS]*' <<--< يبدأ بـ A أو M أو S", sql): rs.Close sql = "SELECT EmpName,City FROM Employees_Demo WHERE EmpName LIKE '[A-M]*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[3-B] EmpName LIKE '[A-M]*' <<--< يبدأ بحرف من A حتى M", sql): rs.Close sql = "SELECT EmpName,City FROM Employees_Demo WHERE EmpName LIKE '[!A-M]*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[3-C] EmpName LIKE '[!A-M]*' <<--< لا يبدأ بحرف من A حتى M", sql): rs.Close Set db = Nothing End Sub ' ============================================================ ' SECTION 4 : NOT LIKE ' ============================================================ Public Sub Section4_Not_Like() Dim db As DAO.Database Dim rs As DAO.Recordset Dim sql As String Set db = CurrentDb Debug.Print "": Debug.Print L2(55) Debug.Print " SECTION 4 : NOT LIKE — استبعاد النمط" Debug.Print L2(55) sql = "SELECT EmpName,City,Phone FROM Employees_Demo WHERE City NOT LIKE 'Cairo' ORDER BY City" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[4-A] City NOT LIKE 'Cairo' <<--< موظفون ليسوا في القاهرة", sql): rs.Close sql = "SELECT EmpName,Email FROM Employees_Demo WHERE Email NOT LIKE '?.*@*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[4-B] Email NOT LIKE '?.*@*' <<--< إيميلات لا تبدأ بـ x.x@", sql): rs.Close Set db = Nothing End Sub ' ============================================================ ' SECTION 5 : AND / OR مع LIKE ' ============================================================ Public Sub Section5_Combined() Dim db As DAO.Database Dim rs As DAO.Recordset Dim sql As String Set db = CurrentDb Debug.Print "": Debug.Print L2(55) Debug.Print " SECTION 5 : AND / OR — شروط LIKE متعددة" Debug.Print L2(55) sql = "SELECT EmpName,Email,City FROM Employees_Demo WHERE EmpName LIKE 'A*' OR EmpName LIKE 'M*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[5-A] LIKE 'A*' OR LIKE 'M*' <<--< يبدأ بـ A أو M", sql): rs.Close sql = "SELECT EmpName,Email,City FROM Employees_Demo WHERE City LIKE 'Cairo' AND Email LIKE '*.*@*' ORDER BY EmpName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[5-B] Cairo AND Email LIKE '*.*@*' <<--< قاهرة + إيميل بنقطة", sql): rs.Close sql = "SELECT ProdName,Code,Category FROM Products_Demo WHERE Category LIKE 'Electronics' AND (ProdName LIKE '*Pro*' OR ProdName LIKE '*Air*') ORDER BY ProdName" Set rs = db.OpenRecordset(sql) Call PrintRS(rs, "[5-C] Electronics + (Pro OR Air) <<--< لابتوبات متقدمة", sql): rs.Close Set db = Nothing End Sub ' ============================================================ ' SECTION 6 : ملخص إحصائي ' ============================================================ Public Sub Section6_Summary() Dim db As DAO.Database Dim rs As DAO.Recordset Dim patterns As Variant Dim descriptions As Variant Dim i As Integer Set db = CurrentDb Debug.Print "": Debug.Print L2(55) Debug.Print " SECTION 6 : ملخص — كل الأنماط ونتائجها" Debug.Print L2(55): Debug.Print "" patterns = Array( _ "SELECT COUNT(*) FROM Employees_Demo WHERE EmpName LIKE 'M*'", _ "SELECT COUNT(*) FROM Employees_Demo WHERE EmpName LIKE '*Hassan'", _ "SELECT COUNT(*) FROM Employees_Demo WHERE EmpName LIKE '*Ali*'", _ "SELECT COUNT(*) FROM Employees_Demo WHERE EmpName LIKE '?a*'", _ "SELECT COUNT(*) FROM Employees_Demo WHERE Phone LIKE '010*'", _ "SELECT COUNT(*) FROM Employees_Demo WHERE City NOT LIKE 'Cairo'", _ "SELECT COUNT(*) FROM Employees_Demo WHERE EmpName LIKE '[A-M]*'") descriptions = Array( _ "EmpName LIKE 'M*' يبدأ بـ M", _ "EmpName LIKE '*Hassan' ينتهي بـ Hassan", _ "EmpName LIKE '*Ali*' يحتوي على Ali", _ "EmpName LIKE '?a*' الحرف الثاني a", _ "Phone LIKE '010*' تليفون 010", _ "City NOT LIKE 'Cairo' مش قاهرة", _ "EmpName LIKE '[A-M]*' من A إلى M") Debug.Print " " & PadRight("النمط", 46) & "النتائج" Debug.Print " " & L1(55) For i = LBound(patterns) To UBound(patterns) Set rs = db.OpenRecordset(patterns(i)) Debug.Print " " & PadRight(descriptions(i), 46) & rs.fields(0).Value & " صف" rs.Close Next i Debug.Print " " & L1(55) Debug.Print "": Debug.Print L2(55) Debug.Print "WILDCARDS — Microsoft Access VBA Demo انتهى — كل الأمثلة اتنفذت بنجاح في" Debug.Print L2(55) Set db = Nothing End Sub ' ============================================================ ' RUN ALL : شغل كل الأقسام دفعة واحدة ' ============================================================ Public Sub Run_All_Examples() Create_Demo_Tables Debug.Print "": Debug.Print L2(50) Debug.Print " LIKE & WILDCARDS — Microsoft Access VBA Demo" Debug.Print L2(50) Call Section1_Star_Wildcard Call Section2_Question_Wildcard Call Section3_CharList_Wildcard Call Section4_Not_Like Call Section5_Combined Call Section6_Summary End Sub رموز الـ Wildcards الرمز المعنى مثال النتيجة * أي عدد من الحروف (0 أو أكثر) LIKE 'M*' Mohamed, Mona, Mariam ? حرف واحد بالضبط LIKE '?a*' Rami, Layla, Hana # رقم واحد بالضبط (0-9) LIKE '01#-*' 010-, 011-, 012- [قائمة] حرف من قائمة محددة LIKE '[AMS]*' Ahmed, Mona, Sara [A-Z] حرف من نطاق LIKE '[A-M]*' Ahmed, Hana, Layla [!قائمة] أي حرف خارج القائمة LIKE '[!A-M]*' Omar, Rami, Sami أشكال الاستخدام -- يبدأ بـ M WHERE EmpName LIKE 'M*' -- ينتهي بـ Hassan WHERE EmpName LIKE '*Hassan' -- يحتوي على Ali في أي مكان WHERE EmpName LIKE '*Ali*' -- الاسم الأول 4 حروف بالضبط WHERE EmpName LIKE '???? *' -- استبعاد نمط معين WHERE City NOT LIKE 'Cairo' -- شرطان معا WHERE City LIKE 'Cairo' AND Email LIKE '*.*@*' الكود المرفق الكود يحتوي على 6 أقسام عملية كاملة مع جدول تجريبى : القسم المحتوى Create_Demo_Tables إنشاء جداول وبيانات تجريبية Section1 * Wildcard — أي عدد من الحروف Section2 ? Wildcard — حرف واحد بالضبط Section3 [] Wildcard — قائمة حروف Section4 NOT LIKE — استبعاد النمط Section5 AND / OR مع LIKE Section6 ملخص إحصائي للنتائج وفى نهاية الكود اجراء عام : Run_All_Examples لطباعة نتائج كل الاقسام فى النافذة الفورية

اتفضل Private Sub cmdPrint_Click() On Error GoTo Err_Handler Dim idx As Variant Dim repName As String Dim ftrName As String If L3.ItemsSelected.Count = 0 Then MsgBox "لا يوجد مطبوعات قد تم اختيارها", vbInformation + vbMsgBoxRight, "تنبيه" Exit Sub End If For Each idx In L3.ItemsSelected repName = "تقرير_" & L3.ItemData(idx) DoCmd.OpenReport repName, acViewNormal, , ftrName Next idx Exit_Handler: Exit Sub Err_Handler: Select Case Err.Number Case 2501 ' المستخدم ألغى الطباعة Resume Next Case Else MsgBox "خطأ " & Err.Number & ":" & vbCrLf & Err.Description, vbExclamation, "خطأ" Resume Exit_Handler End Select End Sub

اهلا استاذ سعيد جدا بمرورك واسعدتنى كلماتك واكثر ما اسعدنى هو اعجابك بهذا الجنون

اكيد هتعرف لما تتواصل معهم الالية

https://learn.microsoft.com/en-us/answers/questions/4884176/get-to-vba-code-in-access-split-database خدمة EverythingAccess.com: حسب البحث اعتقد انهم متخصصون في تحويل ACCDE إلى ACCDB كامل مع VBA ولكن سوف يطلبون إثبات الملكية

الاصدار الجديد نزولا على راى أخى : أحمد ساري استخدام عنوان الحقل للعرض وان لم يكن موجود يتم استخدام اسم الحقل UniversalSearch Pro v2.02.accdb.zip

حلوة الفكرة احييك اخى ابشر

الفكرة الجديدة عمل اكثر من نموذج بحث فى قاعدة البيانات نموذج اعدادت بحث للتحكم فى نماذج البحث المختلفة يتم من خلالة عمل ما يلى: تحديد اسم نموذج البحث تحديد مصدر بيانات نموذج البحث سواء كان جدول او استعلان من مربع قيم تحديد حقل او اكثر من حقل لاجراء عملية البحث داخل البيانات لهذا الحقل/الحقول المختارة تطبيق تلوين نتائج البحث ثورة فكرية فى عمل محرك بحث متقدم متعدد الاستخدامات بطرق بحث مختلفة فى النهاية سعدت جدا جدا جدا بالاطلاع على كنز الافكار الموجودة فى المنتدى والقيام بعملية تطويره هذه الافكار فى انتظار ارائكم بالرد بعد التجربة UniversalSearch Pro v2.01.accdb

وااااااااااااااااو بعد نشر هذا الموضوع ظهر لى فى اخر الموضوع محتوى مشابه وبتصفح الموضوعات تصارعت بعض الافكار فى ذهنى ومن أجل ذلك : انتظروا فكرة جديدة قريبا ان شاء الله تخرج الى النور والتى سوف تجمع كل الافكار من الموضوعات المشابهة مع الافكار الموجودة فى هذه المشاركة المتواضعة مع اضافة بعض اللمسات البسيطة هذا المنتدى ملئ بالروائع و الكنوز حقا

الفكرو المجنونة فى هذا الموضوع

بحث متعدد امكانية اختيار حقل او حقول بحث من خلال كود مركزى فى وحدة نمطية لتطبيق فكرة البحث فى اكثر من نموذج أقدم لكم وحدة نمطية عامة جاهزة للاستخدام تحول اى نموذج إلى محرك بحث تفاعلى بمميزات احترافية تدعم: البحث فوري أثناء الكتابة (Search As You Type) تلوين HTML للكلمات المطابقة للنتائج بلون أحمر <font color=red> بحث متعدد الحقول بحث متعدد الكلمات دعم كامل للحالات المتقدمة "ط" ← تلوين "ط" في كل الحقول "ط ر ة" ← تلوين "ط" + "ر" + "ة" مع فلتر AND "ط " ← مسافة محفوظة (تلوين فقط) Backspace/Delete ← فلتر يتجدد النقر المزدوج - Double Click ← مسح فورى بحث بدون نتائج ← رسالة + إلغاء فى حالة عدم وجود نتائج الوحدة النمطية العامة مثلا باسم : modMultipleSearchHighlights Option Compare Database Option Explicit Private Const CTRL_PREFIX As String = "txt" Public Sub InitUniversalSearch(frm As Form, fieldNames As String) On Error GoTo ErrHandler Dim arr() As String: arr = Split(fieldNames, ",") Dim i As Integer, fld As String For i = 0 To UBound(arr) fld = Trim(arr(i)) frm.Controls(CTRL_PREFIX & fld).ControlSource = "=[" & fld & "]" Next i Exit Sub ErrHandler: MsgBox "خطأ في InitUniversalSearch: " & Err.Number & " - " & Err.Description & vbCrLf & "الحقل: " & CTRL_PREFIX & fld, vbCritical, "خطأ في البحث" End Sub Public Sub UpdateSearch(txtBox As TextBox, frm As Form, fieldNames As String) On Error GoTo ErrHandler Dim searchValue As String Dim currentPos As Long searchValue = txtBox.text currentPos = Len(searchValue) If Len(searchValue) = 0 Then ResetAllHighlights frm, fieldNames frm.FilterOn = False ElseIf Right(searchValue, 1) = " " Then ApplyHighlightsOnly frm, fieldNames, searchValue Else ApplyHighlightsOnly frm, fieldNames, searchValue frm.Filter = BuildFilterSQL(fieldNames, searchValue) frm.FilterOn = True If frm.Recordset.RecordCount = 0 Then MsgBox "لا توجد نتائج لـ """ & searchValue & """" & vbCrLf & "عدد السجلات: 0", vbInformation, "نتائج البحث" frm.FilterOn = False End If End If Dim wasFocused As Boolean: wasFocused = (Screen.ActiveControl.name = txtBox.name) txtBox.SetFocus txtBox.SelStart = currentPos txtBox.SelLength = 0 If Not wasFocused Then Screen.PreviousControl.SetFocus Exit Sub ErrHandler: Select Case Err.Number Case 2185 Debug.Print "UpdateSearch 2185 ignored: " & Err.Description Resume Next Case 2474, 6139 Debug.Print "UpdateSearch ignored: " & Err.Number & " - " & Err.Description Resume Next Case Else Debug.Print "UpdateSearch Error: " & Err.Number & " - " & Err.Description MsgBox "خطأ في البحث: " & Err.Number & vbCrLf & Err.Description, vbCritical Resume ExitHandler End Select Resume Next ExitHandler: End Sub Private Function ReplaceMultiple(inputText As String) As String Dim result As String: result = inputText result = Replace(result, "'", "''") result = Replace(result, "[", "[[]") result = Replace(result, "?", "[?]") result = Replace(result, "*", "[*]") result = Replace(result, """", """""") ReplaceMultiple = result End Function Private Sub ApplyHighlightsOnly(frm As Form, fieldNames As String, searchText As String) Dim arr() As String: arr = Split(fieldNames, ",") Dim words() As String: words = Split(searchText, " ") Dim i As Integer, w As Integer, fld As String Dim ctrl As Control, expr As String, safeWord As String On Error GoTo ErrHandler Application.Echo False For i = 0 To UBound(arr) fld = Trim(arr(i)) Set ctrl = frm.Controls(CTRL_PREFIX & fld) On Error Resume Next Do While ctrl.FormatConditions.Count > 0 ctrl.FormatConditions(1).Delete Loop On Error GoTo ErrHandler expr = "Nz([" & fld & "], """")" For w = 0 To UBound(words) If Len(Trim(words(w))) > 0 Then safeWord = ReplaceMultiple(Trim(words(w))) expr = "Replace(" & expr & ",""" & safeWord & """,""<font color=red>" & safeWord & "</font>"")" End If Next w ctrl.ControlSource = "=IIf(Len(" & expr & ")>0, " & expr & ", """")" Next i Application.Echo True Exit Sub ErrHandler: Application.Echo True Debug.Print "ApplyHighlightsOnly Error: " & Err.Number & " - " & Err.Description & " (Field: " & fld & ")" End Sub Private Sub ResetAllHighlights(frm As Form, fieldNames As String) Dim arr() As String: arr = Split(fieldNames, ",") Dim i As Integer, fld As String, ctrl As Control On Error GoTo ErrHandler Application.Echo False For i = 0 To UBound(arr) fld = Trim(arr(i)) Set ctrl = frm.Controls(CTRL_PREFIX & fld) On Error Resume Next Do While ctrl.FormatConditions.Count > 0 ctrl.FormatConditions(1).Delete Loop On Error GoTo ErrHandler ctrl.ControlSource = "=[" & fld & "]" Next i Application.Echo True Exit Sub ErrHandler: Application.Echo True Debug.Print "ResetAllHighlights Error: " & Err.Number & " - " & Err.Description End End Sub Private Function BuildFilterSQL(fieldNames As String, searchText As String) As String On Error GoTo ErrHandler Dim arrFields() As String: arrFields = Split(fieldNames, ",") Dim words() As String: words = Split(searchText, " ") Dim conditions As String, i As Integer, w As Integer Dim wordCond As String, safeWord As String For w = 0 To UBound(words) If Len(Trim(words(w))) > 0 Then safeWord = ReplaceMultiple(Trim(words(w))) wordCond = "" For i = 0 To UBound(arrFields) If i > 0 Then wordCond = wordCond & " OR " wordCond = wordCond & "[" & Trim(arrFields(i)) & "] Like '*" & safeWord & "*'" Next i If Len(conditions) > 0 Then conditions = conditions & " AND " conditions = conditions & "(" & wordCond & ")" End If Next w BuildFilterSQL = IIf(Len(conditions) = 0, "", conditions) Exit Function ErrHandler: BuildFilterSQL = "" Debug.Print "BuildFilterSQL Error: " & Err.Number & " - " & Err.Description End Function إعدادات النموذج المطلوبة مربع نص البحث باسم : txtSearch مربعات نص الحقول المطلوب البحث بداخلها : يجب ان تكون غير منضمة : Unbound يجب ان تكون Rich Text يجب ان تكون بنفس اسم الحقل تماما وتسبقها البادئة : txt فمثلا فى المرفق الحقول المطلوب البحث بداخلها كانت باسم :item_na, class_no اذن اسماء مربعات النص فى النموذج لتلك الحقول سوف تكون بالاسماء: txtitem_na, txtclass_no مصدر بيانات النموذج (Record Source) :اسم الجدول او استعلام للجدول عادى Query/Table الاكواد المطلوبة فى النموذج ثابت لادراج اسماء الحقول المراد البحث بداخلها مثل Private Const strUniversalfieldNames As String = "item_na,class_no" وفى حدث تحميل النموذج Private Sub Form_Load() InitUniversalSearch Me, strUniversalfieldNames End Sub أحداث مربع النص الخاص بالبحث : txtSearch يمكن استخدام حدث عند التغيير (Change) أو حدث بعد التحديث (AfterUpdate) ولكن الافضل فى السرعة والاداء خاصة مع كثرة عدد السجلات او عند استخدام التطبيق فى شبكة محلية لضمان الكفائة فى الاداء والسرعة يفضل استخدام الكود التالى فى حدث بعد التحديث (AfterUpdate) UpdateSearch Me.txtSearch, Me, strUniversalfieldNames ولكن انا فقط فى المرفق استخدمت حدث عند التغيير لرؤية النتيجة فورية فقط وبعد ذلك يمكن عمل زر امر لعمل مسح للفلاتر ولمربع النص او كود فى حدث النقر المزدوج لمربع البحث : txtSearch Me.txtSearch.Value = "" UpdateSearch Me.txtSearch, Me, strUniversalfieldNames واخيرا المرفق Search Highlights.accdb

ابشر وانتظر فكرة مجنونة

ايون استاذ انا فاهم مقصد حضرتك تماما جدا جدا جدا ومن اجل ذلك اوضحت كل نقطة بالتفصيل والتوضيح مش لحضرتك انا فقط اخذت الاقتباس نقطة بنقطة لعمل التوضيح الشافى وانا اعلم وادرى تماما مقصدك والله وحضرتك استاذ وما انا الا طالب علم مجتهد اتعلم منكم استاذ الغلط منى انا فى البداية بعدم التوضيح والشرح بسبب ضيق وقتى وقلت فى نفسي ان وقت الشرح سوف يأتى تباعا مع تجارب رواد المنتدى وتشريح التطبيق ووضعه تحت المجهر كسل منى

اولا: فى عدد 2 مستخدمين سوبر ادمن لا تنطبق عليهم صلاحيات واذونات المجموعات وهم s Deve والبيانات و كلمات السر لهم كما هى موضحة فى الكود ''--- ثوابت الدخول الخاصة Public Const cnstStrSuperUser As String = "s" Public Const cnstStrSuperPass As String = "s" Public Const cnstStrDevelopersUser As String = "Deva" Public Const cnstStrDevelopersPass As String = "d" طيب بما ان صاحب الافكار كل تفكيره كان ينحصر فى حصول الجميع على الافكار على طبق من ذهب لم يحاول اخفاء الاسم وكلمات مرور سوبر ادمن بكلمات مرور بطريقة مشفرة وكذلك لم يحاول اضافة طبقات تعمية مختلفة على الاكواد لان الهدف نشر العلم والمعرفة والافكار الالية ووجهة النظر كانت فى هذه النقطة كالاتى عدد 2 مستخدم سوبر ادمن لا تنطبق عليهم اى صلاحيات احدهم واضح وله بيانات داخل جدول المستخدمين المستخدم : Deve اما الاخر هو المستخدم : s والذى يعمل بدون وجود اى بيانات له داخل الجدول اى انه مستخدم شبح لا وجود له فى الجدول وغير مرئى ولا يمكن تعديل كلمة المرور له نعم من يريد اضافة التحقق من الصلاحيات لاى نموذج فقط يستطيع اضافة الحدث التالى فقط Private Sub Form_Open(Cancel As Integer) If Not funCheckPermissions(Me) Then Cancel = True End Sub أو كما فى التقرير Private Sub Report_Open(Cancel As Integer) If Not funCheckPermissions(Me) Then Cancel = True: Exit Sub End Sub طيب تم رفع المرفق كما هو حتى بالاكواد والافكار التى تم تعطيلها اثناء التطوير وبدون اضافة اكواد التحقق باستثناء النموذج : frmTestPer وكذلك التقرير : rptTest حتى انه تم استخدام كلمة Test للتأكيد على انها التى تخص التجربة ولذلك فقط تم وضح اكواد التحقق بداخلهم المرفق متاح للجميع مفتوح لمن يريد تعديل او تغيير اى شئ وفى توضيح كمان صغير مهم فى شاشة تسجيل الدخول لو لاحظت فى وضع التصميم توجد ازرار مخفية وهة المؤطرة باللون الاصفر تعمل فقط عندما تتم استخدام بيانات اى مستخدم سوبر ادمن بحيث تمكنه من فتح نماذج محددة دون فتح النظام بالكامل يستطيع مطور النظم تعديلها كما يحلو له تقدمت فى بداية كلامى ان العمل هدية وتم مشاركتها بعد اخذ الاذن من صاحب العمل ولكن تقريبا انا قمت بفحص العمل تقريبا بشكل شبه شامل من وجهة نظرى المتواضعة العمل يقترب فى الافكار والتطبيق من درجة الامتياز لانه يمكن مدير النظام من عمل الصلاحيات مرة واحدة لمجموعات العمل او حتى اضافة مجموعة واحدة فى المستقبل وتحديد الاذونات والصلاحيات المطلوبة لها ولكن بمجرد اضافة المستخدمين ايا كان العدد للمستخدمين لن يضطر لتحديد الاذونات والصلاحيات لكل مستخدم جديد فقط تحديد مجموعة العمل للمستخدم تنطبق عليها الاذونات والصلاحيات الخاصة بهذه المجموعة كما انه يمكن نقل المستخدم مستقبلا من مجموعة الى اخرى بسهولة وبذلك سوف ينطبق عليه صلاحيات واذونات المجموعة الجديدة فورا و فورا حتى لو كان المستخدم كان فى جلسة العمل نفسها التى كانت تعتمد الصلاحيات والاذونات للمجموعة القديمة حتى لو ينهى المستخدم جلسة العمل السابقة ويدء جلسة عمل جديدة لم اقم بتجربة هذه النقطة ولكن هذا ما بدا لى عندما قمت بتحيليل العمل ومن افضل ما اعجبنى فى العمل هو هذه الشاشة والأكثر من رائعة سهولة اختيار النماذج والتقارير وتوضيح كل منهم بنوعه من المراد تطبيق الصلاحيات عليها او التى لم يتم اختيارها لتطبيق الصلاحيات الفكرة والية العمل والمرونة بصراحة ممتازة جدا جدا جدا اجمل الامنيات بالاستمتاع بالتجربة

SaadPermissionsLast-2.zip لا شكر على واجب مرفقكم بعد التعديل

وحتى يظهر الاختلاف بشكل جيد قم بتجربة المرفق التالى سوف تجد انه تتم عملية الاخفاء من ماكر لا يتم عملية الاستدعاء داخل كل نموذج فى حالة عدم ضبط خاصية : Pop Up =Yes لن يختفى النموذج ويظل الاكسس عالق فى الخلفية بل سوف تتم استعادة الاطار فورا بشكل تلقائى حاول تفتح النموذج رقم 3 من زر الامر : Switch To Form3 ثم اذهب الى النموذج الاول وقم بتطبيق عملية الاخفاء وقم بالتبديل بين النموذجين الاول والثانى لن تحدث اى مشاكل Hide Access Frame.accdb

هلا ومليون هلا طب شوف المرفق ده استاذ ممكن الاستدعاء لاخفاء الاطار من ماكرو AutoExec او فى النموذج الاول للفتح ولا يتم استدعاء اخفاء اطار الاكسس فى كل نموذج يتم فتحة SaadPermissionsLast-2.zip

معذرة اصل انا لم اجد خط مرسوم علشان امشى عليه ولم اجد من يرسم لى الخط الاكواد موجودة ومشروح كل شئ اللى عاوز ينفذ يقراء يفهم وينفذ اللى مش عاوز براحته هو الخسران وكل شخص بيتعلم من جميع التجارب الناجحة والغير ناجحة