نجوم المشاركات

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

اتفضل 1.accdb

اعرض الملف مثال على تصفية فائمة بناء على اخرى بدون كود مثال على تصفية قائمة بناء على ما يتم اختياره فى قائمة اخري بدون كود صاحب الملف محمد طاهر تمت الاضافه 03 أكت, 2011 الاقسام قسم الإكسيل

لا تحتاج لشرح ، تفقد مرفق الأستاذ @ابو جودي ،والمرفق التالي وستعرف الحل البسيط 1.accdb

الحمدلله افتح الملفين هذا البرنامج + البرنامج الخارجي ادخل في البرنامج الخارجي ثم عرض ثم وحدات الماكرو ستجد ماكرو (هو الماكرو الوحيد) اسمه aboeed اضغط تشغيل اختر مسح البيانات وكل شيء سيكون أمامك في ورقة أرشفة بطاقة العمل في انتظار ملاحظاتك تفضل برنامج بطاقة عمل 2025.xlsb

صح ربنا يبارك في عمرك يا أبو جودي

زي كده

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

شكرا جزيلا أخي الفاضل وبارك الله فيك وزادك الله من علمه بحق هذه الأيام المباركة

شكرا جزيلا استاذ @Foksh تمت الإضافة

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

ما شاء الله ، تبارك الرحمن سلمت يمناك لهذا الطرح الممتع ,, وجزاك الله كل الخير على مجهودك الجميل والكبير حتى تصل لهذه النتيجة .. اسمح لي بسؤال خطر على بالي :- بما أن الكود يعتمد على مكتبة DAO ؛ هل سيدعم الإصدارات القديمة التي لا تدعم هذه المكتبة !!!

والان مع الاصدار الجديد ـــــــــــــــــــــــــــــــــــــــــ اولا الاكواد داخل الوحده النمطيه العامة طبعا افضل كتابه الكود ومشاركته تحسبا لوجود اى مشاكل فى المرفقات او التحميل لنعطى مثلا للوحدة النمطية العامة الاسم : basTablesCreator Option Compare Database Option Explicit ' متغير عام لتخزين الحقول باستخدام القاموس Public Fields As Object ' تعريف تعداد لأنواع الحقول المتاحة في قاعدة البيانات Public Enum FieldsTypes dbBoolean = 1 ' نوع الحقل: Yes/No (قيمة منطقية) dbByte = 2 ' نوع الحقل: Byte (عدد صحيح صغير بين 0 و 255) dbInteger = 3 ' نوع الحقل: Integer (عدد صحيح بين -32,768 و 32,767) dbLong = 4 ' نوع الحقل: Long Integer (عدد صحيح طويل بين -2,147,483,648 و 2,147,483,647) dbCurrency = 5 ' نوع الحقل: Currency (عدد عشري بدقة عالية للحسابات المالية) dbSingle = 6 ' نوع الحقل: Single (عدد عشري بدقة بسيطة) dbDouble = 7 ' نوع الحقل: Double (عدد عشري بدقة مزدوجة) dbDate = 8 ' نوع الحقل: Date/Time (تاريخ ووقت) dbText = 10 ' نوع الحقل: Text (نص عادي يصل إلى 255 حرفًا) dbMemo = 12 ' نوع الحقل: Memo (نص طويل جدًا) dbAutoNumber = 15 ' نوع الحقل: AutoNumber (ترقيم تلقائي) dbBinary = 128 ' نوع الحقل: Binary (بيانات ثنائية صغيرة) dbVarBinary = 205 ' نوع الحقل: OLE Object (بيانات ثنائية كبيرة مثل ملفات OLE) dbAttachment = 101 ' نوع الحقل: Attachment (ملفات مرفقة) dbBigInt = 16 ' نوع الحقل: Big Integer (عدد صحيح كبير جدًا، 64 بت) dbMultipleChoice = 109 ' نوع الحقل: Multiple Choice (حقل متعدد الخيارات) End Enum ' دالة لإنشاء قاموس جديد عند الحاجة إليه Public Function CreateDictionary() As Object ' إنشاء قاموس جديد باستخدام "Scripting.Dictionary" Set CreateDictionary = CreateObject("Scripting.Dictionary") End Function ' إجراء لإضافة حقل جديد إلى القاموس الذي يحتوي على الحقول المختلفة Public Sub AddFieldToDictionary(fieldName As String, _ fieldType As FieldsTypes, _ Optional fieldSize As Variant, _ Optional fieldFormat As String = "", _ Optional defaultValue As Variant = Null, _ Optional fieldCaption As String = "", _ Optional fieldDescription As String = "" _ ) ' إنشاء قاموس جديد لتخزين معلومات الحقل Dim fieldDict As Object Set fieldDict = CreateObject("Scripting.Dictionary") ' قاموس لأحجام الحقول الافتراضية بناءً على نوع الحقل Dim defaultFieldSizes As Object Set defaultFieldSizes = CreateObject("Scripting.Dictionary") ' قاموس للتنسيقات الافتراضية بناءً على نوع الحقل Dim defaultFormats As Object Set defaultFormats = CreateObject("Scripting.Dictionary") ' إضافة الأحجام الافتراضية لكل نوع حقل With defaultFieldSizes .Add dbBoolean, 0 ' لا يحتاج Boolean إلى حجم .Add dbByte, 0 ' Byte لا يحتاج إلى حجم .Add dbInteger, 0 ' Integer لا يحتاج إلى حجم .Add dbLong, 0 ' Long لا يحتاج إلى حجم .Add dbCurrency, 0 ' Currency لا يحتاج إلى حجم .Add dbSingle, 0 ' Single لا يحتاج إلى حجم .Add dbDouble, 0 ' Double لا يحتاج إلى حجم .Add dbDate, 0 ' Date/Time لا يحتاج إلى حجم .Add dbText, 255 ' Text: الحجم الافتراضي هو 255 .Add dbMemo, 0 ' Memo لا يحتاج إلى حجم .Add dbBigInt, 0 ' BigInt لا يحتاج إلى حجم .Add dbVarBinary, 0 ' VarBinary لا يحتاج إلى حجم .Add dbNumeric, 0 ' Numeric لا يحتاج إلى حجم .Add dbMultipleChoice, 0 ' Multiple Choice لا يحتاج إلى حجم .Add dbAutoNumber, 0 ' AutoNumber لا يحتاج إلى حجم .Add dbAttachment, 0 ' Attachment لا يحتاج إلى حجم End With ' إضافة التنسيقات الافتراضية لكل نوع حقل With defaultFormats .Add dbBoolean, "Yes/No" ' تنسيق Boolean الافتراضي .Add dbByte, "" ' لا يوجد تنسيق افتراضي لـ Byte .Add dbInteger, "" ' لا يوجد تنسيق افتراضي لـ Integer .Add dbLong, "" ' لا يوجد تنسيق افتراضي لـ Long .Add dbCurrency, "Currency" ' تنسيق Currency الافتراضي .Add dbSingle, "Standard" ' تنسيق Single الافتراضي .Add dbDouble, "Standard" ' تنسيق Double الافتراضي .Add dbDate, "Short Date" ' تنسيق Date/Time الافتراضي .Add dbText, "" ' لا يوجد تنسيق افتراضي لـ Text .Add dbMemo, "" ' لا يوجد تنسيق افتراضي لـ Memo .Add dbBigInt, "" ' لا يوجد تنسيق افتراضي لـ BigInt .Add dbVarBinary, "" ' لا يوجد تنسيق افتراضي لـ VarBinary .Add dbNumeric, "" ' لا يوجد تنسيق افتراضي لـ Numeric .Add dbMultipleChoice, "" ' لا يوجد تنسيق افتراضي لـ Multiple Choice .Add dbAutoNumber, "" ' لا يوجد تنسيق افتراضي لـ AutoNumber .Add dbAttachment, "" ' لا يوجد تنسيق افتراضي لـ Attachment End With ' التحقق من إذا لم يتم تحديد fieldSize، نستخدم القيمة الافتراضية من القاموس If IsMissing(fieldSize) Or isEmpty(fieldSize) Then If defaultFieldSizes.exists(fieldType) Then fieldSize = defaultFieldSizes(fieldType) Else fieldSize = 0 ' إذا لم يكن النوع معروفًا، نستخدم 0 كقيمة افتراضية End If End If ' التحقق من إذا لم يتم تحديد fieldFormat، نستخدم القيمة الافتراضية من القاموس If fieldFormat = "" Then If defaultFormats.exists(fieldType) Then fieldFormat = defaultFormats(fieldType) End If End If ' إضافة الحقول إلى القاموس مع طباعة القيم في النافذة الفورية fieldDict("Name") = fieldName fieldDict("Type") = fieldType fieldDict("Size") = fieldSize fieldDict("Caption") = fieldCaption fieldDict("Description") = fieldDescription fieldDict("DefaultValue") = defaultValue fieldDict("Format") = fieldFormat ' التحقق من إذا كان القاموس فارغًا، وإذا كان كذلك يتم تهيئته باستخدام قاموس جديد If Fields Is Nothing Then Set Fields = CreateObject("Scripting.Dictionary") ' إضافة القاموس الخاص بالحقل إلى القاموس العام باستخدام اسم الحقل كمفتاح Set Fields(fieldName) = fieldDict End Sub ' هذه الدالة تقوم بالتحقق إذا كان الجدول المطلوب موجودًا في قاعدة البيانات Public Function IsTableExist(tableName As String) As Boolean Dim tdf As DAO.TableDef ' استعراض جميع الجداول في قاعدة البيانات For Each tdf In CurrentDb.TableDefs ' إذا كان اسم الجدول يتطابق مع الاسم المطلوب If tdf.Name = tableName Then '(الجدول موجود) إذا تم العثور على الجدول IsTableExist = True Exit Function End If Next tdf '(الجدول غير موجود) إذا لم يتم العثور على الجدول IsTableExist = False End Function ' هذا الإجراء يقوم بإنشاء الجدول إذا لم يكن موجودًا أو تحديثه إذا كان موجودًا Public Sub CreateNewTable(tableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim fieldDict As Object Dim key As Variant ' الحصول على قاعدة البيانات الحالية Set db = CurrentDb() ' إنشاء كائن TableDef لتمثيل الجدول Set tdf = db.CreateTableDef(tableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' إضافة الحقول إلى الجدول For Each key In Fields.Keys ' الحصول على القاموس الخاص بكل حقل Set fieldDict = Fields(key) ' إنشاء حقل جديد في الجدول بناءً على نوع الحقل If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type"), fieldDict("Size")) Else ' إذا كان نوع الحقل هو dbAutoNumber، يتم إنشاء حقل من النوع dbLong مع تعيينه كحقل تلقائي Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField ' تعيين الحقل كـ AutoNumber End If ' تعيين القيمة الافتراضية إذا كانت محددة If Not IsNull(fieldDict("DefaultValue")) And fieldDict("DefaultValue") <> "" Then fld.defaultValue = fieldDict("DefaultValue") End If ' إضافة الحقل إلى الجدول tdf.Fields.Append fld Next key ' إضافة الجدول إلى قاعدة البيانات db.TableDefs.Append tdf End Sub ' هذه الدالة تقوم بالتحقق من وجود الحقل في الجدول Public Function IsFieldExist(tdf As DAO.TableDef, fieldName As String) As Boolean Dim fld As DAO.Field ' استعراض جميع الحقول في الجدول For Each fld In tdf.Fields ' إذا كان اسم الحقل يتطابق مع الاسم المطلوب If fld.Name = fieldName Then ' (الحقل موجود) إذا تم العثور على الحقل IsFieldExist = True Exit Function End If Next fld ' (الحقل غير موجود) إذا لم يتم العثور على الحقل IsFieldExist = False End Function ' هذا الإجراء يقوم بإضافة الحقول إلى الجدول إذا لم تكن موجودة Public Sub EnsureFieldsExist(tdf As DAO.TableDef, Fields As Object) Dim fieldDict As Object Dim fld As DAO.Field Dim key As Variant ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' البحث عن أول حقل من النوع AutoNumber في القاموس For Each key In Fields.Keys Set fieldDict = Fields(key) ' التحقق من عدم وجود حقل بنفس الاسم If Not IsFieldExist(tdf, fieldDict("Name")) Then ' إذا لم يكن الحقل من نوع AutoNumber، يتم إضافته بالخصائص المحددة If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type")) Else ' إذا كان نوع الحقل هو AutoNumber، يتم إنشاء حقل من النوع dbLong مع تعيينه كحقل تلقائي Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField ' تعيين الحقل كـ AutoNumber End If ' إضافة الحقل إلى الجدول tdf.Fields.Append fld End If Next key End Sub ' هذا الإجراء يقوم بإضافة أو تحديث خصائص الحقول في الجدول Public Sub SetFieldProperties(tableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim fieldDict As Object Dim key As Variant Dim prop As DAO.Property ' الحصول على قاعدة البيانات الحالية Set db = CurrentDb() ' الحصول على الكائن TableDef للجدول الذي سيتم التحديث فيه Set tdf = db.TableDefs(tableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' استعراض الحقول في القاموس وتحديث خصائصها في الجدول For Each key In Fields.Keys Set fieldDict = Fields(key) ' إذا كان الحقل موجودًا في الجدول، يتم تحديث خصائصه If IsFieldExist(tdf, fieldDict("Name")) Then Set fld = tdf.Fields(fieldDict("Name")) ' إضافة أو تحديث التسمية (Caption) إذا كانت موجودة If fieldDict.exists("Caption") And fieldDict("Caption") <> "" Then On Error Resume Next fld.Properties.Delete "Caption" ' حذف التسمية الحالية إذا كانت موجودة On Error GoTo 0 ' إضافة التسمية الجديدة fld.Properties.Append fld.CreateProperty("Caption", dbText, fieldDict("Caption")) End If ' إضافة أو تحديث الوصف (Description) إذا كان موجودًا If fieldDict.exists("Description") And fieldDict("Description") <> "" Then On Error Resume Next fld.Properties.Delete "Description" ' حذف الوصف الحالي إذا كان موجودًا On Error GoTo 0 ' إضافة الوصف الجديد fld.Properties.Append fld.CreateProperty("Description", dbText, fieldDict("Description")) End If ' إضافة أو تحديث التنسيق (Format) إذا كان موجودًا If fieldDict.exists("Format") And fieldDict("Format") <> "" Then On Error Resume Next fld.Properties.Delete "Format" ' حذف التنسيق الحالي إذا كان موجودًا On Error GoTo 0 ' إضافة التنسيق الجديد fld.Properties.Append fld.CreateProperty("Format", dbText, fieldDict("Format")) End If ' تحديث القيمة الافتراضية (DefaultValue) بشكل صارم If fieldDict.exists("DefaultValue") Then On Error Resume Next fld.defaultValue = Null ' حذف القيمة الافتراضية الحالية إذا كانت موجودة On Error GoTo 0 ' إضافة القيمة الافتراضية بناءً على نوع الحقل If Not IsNull(fieldDict("DefaultValue")) And Trim(Nz(fieldDict("DefaultValue"), "")) <> "" Then Select Case fieldDict("Type") Case dbText, dbMemo, dbAttachment ' للحقول النصية، نقوم بتحويل القيمة إلى سلسلة fld.defaultValue = CStr(fieldDict("DefaultValue")) Case dbInteger, dbLong, dbBigInt, dbByte ' للحقول العددية، نقوم بتحويل القيمة إلى رقم fld.defaultValue = CStr(Nz(fieldDict("DefaultValue"), 0)) Case dbDate ' للحقول التاريخية، نقوم بتحويل القيمة إلى تنسيق تاريخ fld.defaultValue = Format(Nz(fieldDict("DefaultValue"), Now()), "yyyy-mm-dd hh:mm:ss") Case Else ' لأي نوع آخر، نقوم بتحويل القيمة إلى سلسلة fld.defaultValue = CStr(fieldDict("DefaultValue")) End Select Else ' إذا كانت القيمة الافتراضية فارغة أو Null، نقوم بإزالة القيمة الحالية fld.defaultValue = "" End If End If End If Next key End Sub ' دالة لفحص ما إذا كان الجدول مفتوحًا وإغلاقه إذا لزم الأمر Public Function CloseTableIfNecessary(tableName As String) As Boolean Dim db As DAO.Database Set db = CurrentDb ' حاول إغلاق الجدول إذا كان مفتوحًا On Error Resume Next ' إغلاق الجدول إذا كان مفتوحًا DoCmd.Close acTable, tableName If Err.Number = 0 Then ' إذا تم إغلاق الجدول بنجاح CloseTableIfNecessary = True Else ' إذا فشل في إغلاق الجدول CloseTableIfNecessary = False End If On Error GoTo 0 End Function ' هذا الإجراء يقوم بإنشاء الجدول أو تحديثه وإضافة البيانات إذا كانت موجودة Public Sub CreateOrModifyTable(tableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Set db = CurrentDb() ' إذا لم يكن الجدول موجودًا، نقوم بإنشائه If Not IsTableExist(tableName) Then CreateNewTable tableName, Fields Else ' إذا كان الجدول موجودًا، نقوم بتحديث الحقول فيه Set tdf = db.TableDefs(tableName) EnsureFieldsExist tdf, Fields End If ' إضافة أو تحديث خصائص الحقول SetFieldProperties tableName, Fields ' تحديث نافذة قاعدة البيانات لتظهر التغييرات Application.RefreshDatabaseWindow End Sub ' هذا الإجراء يقوم بإنشاء الجدول أو تحديثه بالإضافة إلى إضافة البيانات إذا كانت موجودة Public Sub CreateOrModifyTableAndInsertData(tableName As String, _ Fields As Object, _ Optional fieldValues As Object, _ Optional bAddData As Boolean = False) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim rst As DAO.Recordset Dim key As Variant Dim fieldValue As Variant Dim fieldName As String Set db = CurrentDb() ' التأكد من إغلاق الجدول قبل التعديل If Not CloseTableIfNecessary(tableName) Then ' في حال كان الجدول مفتوحًا بواسطة مستخدم آخر، نعرض رسالة تحذير MsgBox "لا يمكن تعديل الجدول لأنه مفتوح بواسطة مستخدم آخر.", vbExclamation Exit Sub End If ' إنشاء الجدول أو تحديثه If Not IsTableExist(tableName) Then CreateNewTable tableName, Fields Else Set tdf = db.TableDefs(tableName) EnsureFieldsExist tdf, Fields End If ' إضافة خصائص الحقول SetFieldProperties tableName, Fields ' إضافة البيانات إذا كانت القيمة للعلم صحيحة If bAddData And Not (fieldValues Is Nothing) Then If fieldValues.Count > 0 Then ' فتح مجموعة السجلات للجدول المحدد Set rst = db.OpenRecordset(tableName, dbOpenDynaset) ' التحقق مما إذا كان الجدول فارغًا Dim isEmpty As Boolean isEmpty = (rst.RecordCount = 0) If isEmpty Then ' إذا كان الجدول فارغًا، نضيف سجل جديد rst.AddNew ' إضافة البيانات من القاموس إلى السجل الجديد For Each key In fieldValues.Keys fieldName = key fieldValue = fieldValues(key) rst(fieldName) = fieldValue Next key rst.Update Else ' إذا كان الجدول غير فارغ، نقوم بتحديث السجلات الموجودة rst.MoveFirst For Each key In fieldValues.Keys fieldName = key fieldValue = fieldValues(key) ' التحقق من وجود تغيير في قيمة الحقل قبل التحديث If IsNull(rst(fieldName)) Or Nz(rst(fieldName), "") <> fieldValue Then rst.Edit rst(fieldName) = fieldValue rst.Update End If Next key End If rst.Close End If End If ' تحديث نافذة قاعدة البيانات بعد التعديل Application.RefreshDatabaseWindow End Sub الان الوحدة النمطية الثانويه والخاصة باستدعاء الداول اما لانشاء جدول/جداول فارغه بدون بيانات او انشاء جدول/جداول مع الحاق بيانات اساسية لحقل/حقول الجدول/الجداول لنعطى مثلا للوحدة النمطية العامة الاسم : basTablesInitialization ' هذا الإجراء يقوم بتهيئة البيانات الخاصة بالتصميم (إنشاء الجدول وإضافة البيانات) Public Sub InitializeDesignerTableWithData() Dim fieldValues As Object Dim tblName As String tblName = "UsysTblDesignerInformation" ' اسم الجدول الذي يحتوي على معلومات المصمم Set Fields = CreateDictionary() ' إنشاء القاموس لاحتواء الحقول Set fieldValues = CreateDictionary() ' إنشاء القاموس لاحتواء القيم المرتبطة بالحقول ' إضافة الحقول ومعلومات كل حقل: ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف) AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "حقل :المعرف (التلقائي)" AddFieldToDictionary "DesignerPlatform", dbText, 100, "@[red]", "Officena", "المنصة", "حقل : يحتوى على رابط المنصة" AddFieldToDictionary "FullName", dbText, , , , "الاسم", "حقل : يحتوى على اسم المبرمج" AddFieldToDictionary "Email", dbText, , , , "البريد الإلكتروني", "حقل : يحتوى على البريد الإلكتروني للمبرمج" AddFieldToDictionary "PhoneNumber", dbText, , , , "رقم الهاتف", "حقل : يحتوى على رقم الهاتف للمبرمج" AddFieldToDictionary "DesignSpecialty", dbText, , , , "مجال التخصص", "حقل : يحتوى على مجال التخصص (التخصص الفني أو المهني للمصمم - تصميم واجهات المستخدم (UI) - تصميم تجربة المستخدم (UX) - تطوير البرمجيات الخلفية (Back-End) )" AddFieldToDictionary "PortfolioLink", dbText, , , , "سابقة الأعمال", "حقل : يحتوى على رابط لمعرض سابقة الأعمال للمبرمج - موقع المبومج" AddFieldToDictionary "CreationDate", dbDate, , "dddd, mmmm dd, yyyy hh:nn:ss AM/PM", "Now()", "تاريخ إنشاء السجل", "حقل : يحتوى على تاريخ إنشاء السجل الحالى" ' إضافة القيم الخاصة بكل حقل fieldValues("DesignerPlatform") = "Example Designer Platform™" fieldValues("FullName") = "Example Designer Name" fieldValues("Email") = "example.designer@email.com" fieldValues("PhoneNumber") = "+000 Example Designer Phone Number" fieldValues("DesignSpecialty") = "Example Designer Specialty" fieldValues("PortfolioLink") = "https://example.com/designer-portfolio" fieldValues("CreationDate") = Now ' تعيين تاريخ السجل الحالي ' التأكد من إغلاق الجدول قبل التعديل If Not CloseTableIfNecessary(tblName) Then Exit Sub ' إغلاق الجدول إذا كان مفتوحًا من قبل ' إنشاء الجدول أو تحديثه، بالإضافة إلى إضافة البيانات إذا كانت القيم موجودة CreateOrModifyTableAndInsertData tblName, Fields, fieldValues, True End Sub ' هذا الإجراء يقوم بتهيئة الجدول فقط بدون إضافة البيانات الخاصة بالتصميم Public Sub InitializeDesignerTableStructure() Dim tblName As String tblName = "UsysTblDesignerInformation" ' اسم الجدول الذي يحتوي على معلومات المصمم Set Fields = CreateDictionary() ' إنشاء القاموس لاحتواء الحقول ' إضافة الحقول ومعلومات كل حقل: ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف) AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "حقل :المعرف (التلقائي)" AddFieldToDictionary "DesignerPlatform", dbText, 100, "@[red]", "Officena", "المنصة", "حقل : يحتوى على رابط المنصة" AddFieldToDictionary "FullName", dbText, , , , "الاسم", "حقل : يحتوى على اسم المبرمج" AddFieldToDictionary "Email", dbText, , , , "البريد الإلكتروني", "حقل : يحتوى على البريد الإلكتروني للمبرمج" AddFieldToDictionary "PhoneNumber", dbText, , , , "رقم الهاتف", "حقل : يحتوى على رقم الهاتف للمبرمج" AddFieldToDictionary "DesignSpecialty", dbText, , , , "مجال التخصص", "حقل : يحتوى على مجال التخصص (التخصص الفني أو المهني للمصمم - تصميم واجهات المستخدم (UI) - تصميم تجربة المستخدم (UX) - تطوير البرمجيات الخلفية (Back-End) )" AddFieldToDictionary "PortfolioLink", dbText, , , , "سابقة الأعمال", "حقل : يحتوى على رابط لمعرض سابقة الأعمال للمبرمج - موقع المبومج" AddFieldToDictionary "CreationDate", dbDate, , "dddd, mmmm dd, yyyy hh:nn:ss AM/PM", "Now()", "تاريخ إنشاء السجل", "حقل : يحتوى على تاريخ إنشاء السجل الحالى" ' التأكد من إغلاق الجدول قبل التعديل If Not CloseTableIfNecessary(tblName) Then Exit Sub ' إغلاق الجدول إذا كان مفتوحًا من قبل ' إنشاء الجدول أو تحديثه فقط بدون إضافة البيانات CreateOrModifyTableAndInsertData tblName, Fields, , False ' لا يتم إضافة بيانات هذه المرة End Sub بشكل عام حنى تتضح الرؤيه بشكل مفصل الفكرة هنا هى كتابة دوال لانشاء الجداول الاساسية للتطبيق والتى لا يريد المبرمج لاى احد العبث بها سواء كان فى : اسم الجدول - اسم الحقل - نوع الحقل :خصائص الحقل ( الحجم - التنسيق - القيمه الافتراضيه - التسميه " عنوان الحقل" - الوصف : الذى يظهر دخل الجدول عند وضع التصميم ) حيث يهدف هذا الكود إلى توفير حل برمجي متكامل لإنشاء جداول قواعد البيانات وتحديثها تلقائيًا بناءً على مواصفات الحقول المحددة في قاموس ديناميكي . مما يتيح الكود للمطورين إدارة هيكل الجدول (Structure) وخصائص الحقول (Properties) مثل الاسم، النوع، الحجم، التنسيق (Format)، القيمة الافتراضية (DefaultValue)، العنوان (Caption)، الوصف (Description)، بطريقة آلية ودقيقة إذا تم تغيير أي خاصية يدويًا (مثل الحجم - التنسيق - القيمه الافتراضيه - العنوان - الوصف )، يتم استعادتها إلى القيم الأصلية المحددة في الكود قصرا بشكل صارم عند تشغيل الدالة مرة أخرى فيضمن الكود أن جميع الجداول والحقول تحتوي على نفس المواصفات والقيم المحددة سلفا وبعيدا عن استدعاء الدوال التى تنشئ جداول مع اضافة البيانات فهناك داله تنئ جداول فقط مع التحكم فى الخصائص كما سلف ذكرها بنفس الاليه بدون ملئ اى بيانات داخل الحقول ليضمن المبرمج دائما عدم مسح الجداول الاساسيه او العبث بها مثال سريع: عمل جدول بيانات المصمم ملئ البيانات استدعاء الدالة عند كل تشغيل يضمن عدم العبث بمسح احد الحقول او الجدول او تعديل اسماء او خصائص او قيم الحقول جداول الاعدادات مثل المسارات الاساسية على سبيل المثال وليس الحصر جداول حمل المرفقات الاساسية التتى يتطلب وجودها بشكل اساسى جداول الصلاحيات للمستخدمين مثلا و و و ......... الخ كل ذلك على سبيل المثال وليس الحصر ملحوظه طبعا يمكن استخدام هذه الافكار كلبنه أولى عند محاولة حماية قاعدة البيانات اخيرا اضع مرفقا بين اياديكم للتجربة والاستمتاع انشاء الجداول الاساسية وملئ البيانات V 3.0.2.accdb

تفضل جرب هدا التعديل Option Explicit Sub test() Dim wbDest As Workbook, wbData As Workbook Dim WS As Worksheet, CrWS As Worksheet Dim Irow&, nRow&, xPath$, xFile$, fname As Variant Dim i, j, k As Integer, ShArr As Variant, OnRng, tmps As Range Dim WSIndex As Integer SetApp False xPath = ThisWorkbook.Path fname = Array("رصيد التوكيلات1.xlsx", "رصيد التوكيلات_كفرالشيخ.xlsx", "رصيد التوكيلات_البحيرة.xlsx", _ "رصيد التوكيلات_طنطا.xlsx", "رصيد التوكيلات_المنصورة.xlsx", "رصيد التوكيلات_دكرنس.xlsx", _ "رصيد التوكيلات_دمياط.xlsx", "رصيد التوكيلات_المنوفية.xlsx", "رصيد التوكيلات_الشرقية.xlsx", _ "رصيد التوكيلات_الاسماعيلية.xlsx", "رصيد التوكيلات_بور سعيد.xlsx", "رصيد التوكيلات_السويس.xlsx", _ "رصيد التوكيلات_المقطم.xlsx", "رصيد التوكيلات_مؤسسة الزكاة.xlsx", "رصيد التوكيلات_الجيزة.xlsx", _ "رصيد التوكيلات_القليوبية.xlsx", "رصيد التوكيلات_الفيوم.xlsx", "رصيد التوكيلات_بنى سويف.xlsx", _ "رصيد التوكيلات_المنيا.xlsx", "رصيد التوكيلات_اسيوط.xlsx", "رصيد التوكيلات_سوهاج.xlsx", _ "رصيد التوكيلات_جرجا.xlsx", "رصيد التوكيلات_قنا.xlsx", "رصيد التوكيلات_نجع حمادى.xlsx", _ "رصيد التوكيلات_الغردقة.xlsx", "رصيد التوكيلات_الاقصر.xlsx", "رصيد التوكيلات_اسوان.xlsx", _ "رصيد التوكيلات_ادفو.xlsx") ShArr = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو") Set wbData = ThisWorkbook On Error Resume Next Set wbDest = Workbooks.Open(xPath & "\" & fname(0), ReadOnly:=True) If wbDest Is Nothing Then MsgBox "تعذر العثور على الملف " & fname(0), vbCritical SetApp True Exit Sub End If On Error GoTo 0 For WSIndex = LBound(fname) To UBound(fname) xFile = xPath & "\" & fname(WSIndex) On Error Resume Next Set wbDest = Workbooks.Open(xFile, ReadOnly:=True) If wbDest Is Nothing Then MsgBox "تعذر العثور على الملف " & fname(WSIndex), vbCritical SetApp True Exit Sub End If On Error GoTo 0 For i = LBound(ShArr) To UBound(ShArr) On Error Resume Next Set CrWS = wbData.Sheets(ShArr(i)) On Error GoTo 0 If Not CrWS Is Nothing Then Set WS = Nothing On Error Resume Next Set WS = wbDest.Sheets(ShArr(i)) On Error GoTo 0 If Not WS Is Nothing Then Irow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row If Irow < 4 Then GoTo SkipSheet End If For j = 6 To 19 Set tmps = CrWS.Cells(3, j) For k = 6 To 19 Set OnRng = WS.Cells(3, k) If OnRng.Value = tmps.Value And Not IsEmpty(OnRng.Value) Then For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, k).Value) Then CrWS.Cells(nRow, j).Value = WS.Cells(nRow, k).Value End If Next nRow Exit For End If Next k Next j For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, 2).Value) Then CrWS.Cells(nRow, 2).Value = WS.Cells(nRow, 2).Value End If Next nRow End If End If SkipSheet: Next i SkipFile: wbDest.Close False Next WSIndex MsgBox "تم نقل البيانات من جميع الملفات بنجاح", vbInformation SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End Sub نقل البيانات من مصنفات متعددة.rar

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

جرب المرفق التالي BAR_1.mdb قم بمسح الاقتطاعات السابقة

لا انصحك بهذه الخطوة أخي الكريم ، يعني لو العميل حذف السجل 150 من اصل السجلات 350 ، فسيكون الترتيب = 148 - 149 - 151 - 152 .... إلخ وللأسف لن يتم اضافة الرقم 150 !!!!!!!!

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

السلام عليكم بالرغم انى مش فاهم الموضوع الى الان ومشتت فالتركيز فيه الا انى اعتقد ان مشكلتك فالاسطر التاليه من الكود If Month(Now()) = 3 Then If Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID=" & rstE!EmployeeID & _ " And [Payment_Made]=3000 And [Payment_Month] Between #1/1/" & Year(Now()) & "# And #2/28/" & Year(Now()) & "#"), 0) = 3000 Then rstE.MoveNext GoTo NextEmployee End If End If If Month(Now()) = 7 Then If Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID=" & rstE!EmployeeID & _ " And [Payment_Made]=3000 And [Payment_Month] Between #4/1/" & Year(Now()) & "# And #6/30/" & Year(Now()) & "#"), 0) = 3000 Then rstE.MoveNext GoTo NextEmployee End If End If والسبب فى اعتقادى انك قلت سابقا ممكن يدفع 3000 على مرتين او مره واحده وهنا داله dlookup بتشيك على سجل واحد بناء عالفتره اللى انت محددها وبيكون مساوى ل 3000 يعنى هو دفع 3000 فى شهر 3 او 7 تجاوز الموظف ده وليس مجموع ماتم دفعه 3000 لهذا الموظف وهل الدفع فى خلال العام كله ام فالشهرين اللى قبل 3 و 7 بس

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

نعم صحيح كما تفضل الاخ @أبوبسمله

رابط جروب الواتس أب هنا

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub test() Dim wbDest As Workbook, wbData As Workbook Dim WS As Worksheet, CrWS As Worksheet Dim Irow&, lastCol&, nRow&, xPath$, xFile$, fname$ Dim i, j, k As Integer, ShArr As Variant, OnRng, tmps As Range SetApp False xPath = ThisWorkbook.Path fname = "رصيد التوكيلات1" xFile = xPath & "\" & fname & ".xlsx" If Dir(xFile) = "" Then MsgBox "تعذر العثور على الملف " & fname, vbCritical SetApp True Exit Sub End If Set wbData = ThisWorkbook ShArr = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو") On Error Resume Next Set wbDest = Workbooks.Open(xFile, ReadOnly:=True) If wbDest Is Nothing Then SetApp True Exit Sub End If On Error GoTo 0 For i = LBound(ShArr) To UBound(ShArr) On Error Resume Next Set WS = wbDest.Sheets(ShArr(i)) Set CrWS = wbData.Sheets(ShArr(i)) On Error GoTo 0 If Not WS Is Nothing And Not CrWS Is Nothing Then Irow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row If Irow >= 4 Then For j = 6 To 19 Set tmps = CrWS.Cells(3, j) For k = 6 To 19 Set OnRng = WS.Cells(3, k) If OnRng.Value = tmps.Value And Not IsEmpty(OnRng.Value) Then For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, k).Value) Then CrWS.Cells(nRow, j).Value = WS.Cells(nRow, k).Value End If Next nRow Exit For End If Next k Next j For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, 2).Value) Then CrWS.Cells(nRow, 2).Value = WS.Cells(nRow, 2).Value End If Next nRow End If End If Next i wbDest.Close False Cleanup: SetApp True MsgBox "تم نقل البيانات بنجاح", vbInformation End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End Sub نقل البيانات بين الملفات.rar

إضافةً لذلك ، المرفق لا يحتوي النموذج frm_repot

وعليكم السلام ورحمة الله وبركاته ، إن كنت من متابعي ومنتسبي جروب الواتس أب ؛ فقد تمت الإجابة عن هذا السؤال سابقاً .. مثال بسيط Main (1).accdb

اختيار "القيم الفريدة" تجده هنا ,, هذا الإختيار يستخدم لتصفية النتائج بحيث لا تتكرر القيم في نتائج الإستعلام .

هل جربت التجميع

السلام عليكم استبدل السطر .SortFields.Add Key:=ws.Range("I8:I73"), Order:=xlDescending بهذا السطر .SortFields.Add Key:=ws.Range("I8:I73"), Order:=xlAscending لاحظ الكلمة الاخيرة تغيرت طبعا هذا الترتيب للنطاق I8:I73 بالتوفيق

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

ممكن تفسر أكثر طلبك غير مفهوم !!!!!!!!

استاذ @عالم الهندسة تأخرك في الرد نساني موضوعك يعني لازم اقرأه من الاول ........... انت لازم تحدد العدد الكلي لاستيعاب كل صالة .

جزاك الله خير استادي الفاضل تم حال جميع المشاكل التي كنت اعاني منها في جميخ ملافت اوفيس

من الصورة يبدو أن الخطأ ناتج عن عدم ضبط لغة الترميز Unicode الى اللغة العربية في ويندوز ، لذا أنصحك بمراجعة هذا الموضوع هنا 🤗 .

عند اختيار ملف اكسيل يضهر هاد الخظء هل من برنامج اوفيس او من ملف الذي تم اختياره ؟

بعض الناس متصالح مع نفسه وقانع بما رزقه الله .. والعطاء والبذل سجية تجري في عروقه منحها الله اياه لا نملك له ولأمثاله الا دعواتنا الصادقة له بان يزيده الله علما ورفعه ويبارك له في وقته وماله وأهله وولده

استاذنا العزيز @ابو جودي مشتاقون لك واعمالك الجميلة والرائعة ... بس ياعمي انت حتخرب شغل على المبرمجين 😂 دة عندنا علشان المبرمج يضيف جدول اضافي ...بياخد الشيء الفلاني

كود راااااااائع جدا حبيبنا @ابو جودي ويسهل العمل 🙂 لا يقل جودة عن روائعك اللي عودتنا عليها .... 😊💪

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) كثير منا يبحث عن QR ( رمز إستجابة سريعة ) ولكن ملوّن !! ونستطيع التحكم باللون حسب حاجته !! اليوم بطريقة بسيطة يتم تنفيذها بكل سلاسة سنحقق ذلك . والفائدة على سبيل المثال :- الإبتعاد عن النمط التقليدي اللون الأسود المعروف به رمز الـ QR .. شكل جمالي ملفت لرمز الإستجابة QR .. التمييز بين الأقسام أو الأستخدام للـ QR حسب حاجة المشروع . فمثلاً ( قسم المحاسبة لهم رمز باللون الأزرق ، قسم الصيانة لهم رمز باللون الأسود ، المعلمين رمز باللون الأحمر ..... إلخ . والكثير من الإستخدامات التي لا تخطر ببالي حالياً . تأكد من تثبيت إصدار NET Framework 4.0 أو أعلى على جهازك . تستطيع التحميل من هذا الرابط ، أو بشكل مباشر من هذا الرابط . برنامج ImageMagick . ويمكنك تحميله من رابط الموقع من هذا الرابط ، أو بشكل مباشر من هذا الرابط . ملفات الـ DLL ( zxing.interop.dll ، zxing.dll ، zxing.interop.tlb ) والتي هي مكتبات سيتم إضافتها الى محرر الأكواد VBA في آكسيس لاحقاً طريقة التثبيت والإضافة ( موجودة في الملف المرفق ) . أولا يلزمنا تسجيل المكتبات المستخدمة في المشروع ( وهنا سنستخدم ZXing لتنفيذ مهمتنا ) وطبعاً سنحتاج مكتبة QRCode ، ويجب تسجيلها ليتم إضافتها في آكسيس في مكتبات الـ VBA > Tools > References . فكيف ننفذ هذه الخطوة المهمة . بعد التأكد من تثبيت المستلزمين السابقين :- افتح موجه الأوامر CMD كمسؤول ( Run as Administrator ) . قم بكتابة السطر التالي لتسجيل المكتبة :- cd C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك قم بكتابة السطر التالي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase zxing.interop.dll ومن المفترض أن تظهر معك النتيجة بهذا الشكل :- أما خلاف ذلك فأن عملية تسجيل المكتبة لم تنجح ولن يتم إضافتها إلى محرر الأكواد VBA كما نريد . الآن لاستكمال عملية تسجيل المكتبة وإضافتها الى محرر الأكواد VBA ، نطبق آخر خطوة وهي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase "C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.dll" /tlb:"C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.tlb" --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\ Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك الآن نفتح قاعدة بيانات جديدة ، ونذهب إلى محرر الأكواد ( Tools > References ) ، ونبحث عن المكتبة التالية كما في الصورة :- الآن وبعد إتمام عملية التسجيل للمكتبة المطلوبة وتثبيت المستلزمات السابقة ، نقوم بإنشاء نموذج يحتوي على مربع نص ، وعنصر صورة ، و زر لتنفيذ العملية . ثم نأتي إلى الأكواد ، وما سنحتاجه الآن هو مديول يحتوي على الدالتين التاليتين :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit #If VBA7 Then Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Function Encode_To_QR_Code_To_File(str As String, Optional foregroundColor As String = "black", Optional backgroundColor As String = "white") As String On Error GoTo ErrorHandler Dim writer As IBarcodeWriter Dim qrCodeOptions As QrCodeEncodingOptions Dim filepath As String Dim folderPath As String folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If filepath = folderPath & "\QRCode_" & Format(Now, "yyyyMMdd_hhmmss") & ".png" Set qrCodeOptions = New QrCodeEncodingOptions Set writer = New BarcodeWriter writer.Format = BarcodeFormat_QR_CODE Set writer.Options = qrCodeOptions qrCodeOptions.Height = 200 qrCodeOptions.Width = 200 qrCodeOptions.CharacterSet = "UTF-8" qrCodeOptions.Margin = 1 qrCodeOptions.ErrorCorrection = ErrorCorrectionLevel_H writer.WriteToFile str, filepath, ImageFileFormat_Png If Change_QR_Code_Colors_ImageMagick(filepath, foregroundColor, backgroundColor) Then Encode_To_QR_Code_To_File = filepath Else Encode_To_QR_Code_To_File = "" End If Exit Function ErrorHandler: Encode_To_QR_Code_To_File = "" MsgBox "حدث خطأ أثناء إنشاء QR Code: " & Err.Description, vbCritical, "خطأ" End Function Function Change_QR_Code_Colors_ImageMagick(filepath As String, foregroundColor As String, backgroundColor As String) As Boolean On Error GoTo ErrorHandler Dim batchFilePath As String Dim batchContent As String Dim result As Long If Dir(filepath) = "" Then MsgBox "لم يتم العثور على الملف: " & filepath, vbCritical, "خطأ" Exit Function End If batchContent = "@echo off" & vbCrLf & "magick " & Chr(34) & filepath & Chr(34) & " -fill " & foregroundColor & " -opaque black -fill " & backgroundColor & " -opaque white " & Chr(34) & filepath & Chr(34) batchFilePath = Environ$("temp") & "\ChangeQRColors.bat" Open batchFilePath For Output As #1 Print #1, batchContent Close #1 result = Shell("powershell -Command Start-Process " & Chr(34) & batchFilePath & Chr(34) & " -Verb RunAs", vbHide) DoEvents Sleep 3000 If Dir(filepath) <> "" Then Change_QR_Code_Colors_ImageMagick = True Else Change_QR_Code_Colors_ImageMagick = False End If Kill batchFilePath Exit Function ErrorHandler: Change_QR_Code_Colors_ImageMagick = False MsgBox "حدث خطأ أثناء تغيير ألوان QR Code: " & Err.Description, vbCritical, "خطأ" End Function وفي حدث عند النقر لزر التنفيذ ، الكود التالي :- Private Sub Command20_Click() Dim imagePath As String Dim folderPath As String If IsNull(Me.Text0) Or Me.Text0 = "" Then MsgBox "QR Code الرجاء إدخال نص لإنشاء", vbExclamation, "" Exit Sub End If Dim foregroundColor As String Dim backgroundColor As String foregroundColor = "Blue" backgroundColor = "white" imagePath = Encode_To_QR_Code_To_File(Me.Text0, foregroundColor, backgroundColor) If imagePath <> "" Then Me.Image0.Picture = imagePath MsgBox " بنجاح QR Code تم إنشاء", vbInformation, "" folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" Else MsgBox "فشل في إنشاء QR Code", vbCritical, "" End If End Sub الآن لتغيير ألوان الـ QR كخلفية أو لون الرمز نفسه ، تستطيع التعديل من خلال السطرين التاليين في زر التنفيذ :- foregroundColor = "Blue" <---- هنا لون الرمز نفسه backgroundColor = "white" <---- هنا لون الخلفية وهنا نكون قد وضحنا المطلوب وطريقة تنفيذه خطوة بخطوة .. QrCodeZXing.zip

ومشاركة مع استاذى واخى الحبيب الاستاذ @Foksh طريقتى المتواضعة zint barcode generator V2.zip