ابو جودي

46 دقائق مضت, ابوخليل said:

تشبيه حلو  في محله من وجهة نظري .. مع تحفظي على منحي لقب لست اهلا له

انتم مصابيح تنير الطريق وقريبة بين الأيدي واضحة وقوية

والنجوم صحيح لامعة ولكنها ليست كالمصابيح في الإضاءة .. وتحجب غالبا من عوامل كثيرة كالغيوم مثلا

وقفة : آفة العلم النسيان

استاذى الجليل و معلمى القدير و والدى الحبيب 

بالعكس انا للمرة الاولى فى حياتى اختلف مع حضرتك

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

10 دقائق مضت, Foksh said:

هههههههه خفت انت  

ههههههههه طبها لازم اخاف

بس انا برضو قلت انك مصباح بتضوى ضلمات حياتنا بنورك يا عسل ما لنا غنى عنك جميل 

لكن برضو النجوم حاجه تانيه و فى حته تانيه خااااااااااااااااااااالص  

في 14‏/1‏/2025 at 19:42, Foksh said:

انا منتظر التحديث من شهرين يا فؤش أفندى 

22 دقائق مضت, ابوخليل said:

سبحان الله

هذا ما يجول في نفسي واحببت كتابته

ليه بس استاذ فادي ؟؟ نسخ لصق من افكاري 😕

طبعا انتم با استاذى الجليل و معلمى القدير و  والدى الحبيب 

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

فلا وجه شبه اصلا بين المصابيح   والنجوم المتلئلئة  

16 دقائق مضت, Foksh said:

يه يا عم ، هو الواحد ما يعرفش ينام ساعتين هنا بهدوووء 😂 ..

رمضان شهر العمل يا فؤش أفندى مش شهر النوم 

16 دقائق مضت, Foksh said:

رووء كدة وخلينا نركز شوية في الشغل الجامد ده ، وبصراحة الواحد محتاج يركز شوية وهو بكامل قواه البدنية

هو انا بأقول لك شيل الكود واللا بأقولك العب بودى بيلدنج ؟

9 دقائق مضت, ابوخليل said:

( أصل لما بكون صايم بكون تفكيري محدود شوية لحد ما نصلي التراويح ) ، هي دي كل الحكاية لا أكثر ولا أقل 😁 .

هههههههه انا الكود ده تقريبا بأفكر واكتب وأطور فيه من قبل رمضان بحوالى أسبوع وإنقطعت عنه تقريبا أول 3 أيام رمضان ورجعت أكمل تانى وكنت شغال يا فؤش أفندى قبل الفطار وبعد التراويح 

انت بقيت بتتدلع كتير يا فؤش أفندى 

9 دقائق مضت, ابوخليل said:

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

رميت الكود لان والله مكانش فى وقت خلاص وكان لازم اقوم علشان اروح الشغل
ووقت المشاكره كنت لسه منتهى تماما منه تقريبا وجربت وراجعت 70 % من الامثله

بس انا سهلت لكم الدنيا برضو

فى اتنين موديول لكل الامثلة
الاكواد مكتوبه للتجربة مباشرة لو وضعت المجلدات والملفات بالاسماء اللى قلت لكم عليها فى نفس مسار القاعدة

والامثله يا فؤش افندى هتعملها Run  بس 

وبعدين انا ما قلتش حاولوا تفهموا دى خااااااااااالص

اكيد مش هأقولها لكم الصبح وأجى ع المغرب بالكود ده كل واسألكم عملتوا ايه

انا طالب بس مع التجارب للامثلة المختلفة ابداء الرأى 

هل فى اى مشاكل

انا نواتى 64  منتظر لو حد عنده نواة 32 الدنيا تمام معاه واللا فى مشاكل 

انا فى مرحلة عاوز المشاكل 

او لو مفيش مشاكل لو حد حاسس اكواد الاستدعائات فيها تعقيد مثلا يقول 

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

ولأن أنا مقتنع مليون % أن القارئ كالحالب والسامع كالشارب 

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

مش بأقول لك انت بقيت بتتدلع كتيــــر 

يعنى انا افضل ابحث وامحص وافكر واكتب فى الكود بالساعات والايام والاسابيع واخليه يشتغل اتنين فى واحد

وفى الاخر بعد ما يطلع عينى ولا رد ولا تجربه واحده 

اقسم بالله كل كلمه وكل سطر وكل فكرة فى الكود من كتابتى لم ينقل ولم يقتبس منها اى شئ ولا من اى مكان 

كان البحث عبر صفحات ومواقع الانترنت عن بناء اسطر الاوامر فقط  " Command Line "والخاصىة بالتطبيقات لا أكثر من ذلك ولا أقل

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

تقريبا بفضل الله تعالى قمت بالالمام بكل ما يتعلق بالموضوع ليتم التحكم بكل كبيرة وصغيرة

وفى الاخر لم أجد إهتمام حتى الآن  .. انا زعلان 

جالكم قلب 7 ساعات من نشر المضوع ده بالات بدون أى اهتمام

2 ساعات مضت, Lotfy14 said:

حبيبى يا صعيدى يا عسل

والله انت اللى عسل الله يجبر بخاطرك 

---------------------------------------

1 ساعه مضت, Lotfy14 said:

فعلا انا كتبت تاريخ الميلاد ودى كانت غلطة مش مقصوده ولكن المعنى فى بطن الشاعر

اللى هينطبق على تاريخ الميلاد هو هو تاريخ التعيين

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

اما فى حالتك الموضوع مختلف انت سوف تقوم بادخال التاريخ

ابشر ان شاء الله

---------------------------------------

2 ساعات مضت, Lotfy14 said:

انيا : فصل الارقام( المبلغ ) :.

هقولك بص يا سيدى احنا قلنا الرقم مثلا هيبقى ( 3800.00 ) صح كدا

عوزين نفصل الرقم دا ليصبح [ 3800.00 ] فى مربع لوحده والــ [ 00 ] فى مربع اخر

او الرقم الثانى بتاع مثلا اللى هو ( 3500.50 ) يبقى[ 3500 ] فى مربع و الــ [ 50 ] فى مربع اخر

يعنى الرقم الصحيح فى مربع ولو فى رقم بعد العلامة العشرية يبقى فى مربع لوحده

ولو الرقم صحيح من غير علامة عشرية يبقى الخانة الثانية اللى بعد الرقم عبارة عن 00

اعتقد ان الصعيده كدا ملهمش دعوه بالموضوع 😂

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

لكن انت كده سسهلتها خالص شوفت العقل زينه والله الله يفتح عليك

ابشر ان شاء الله

---------------------------------------

2 ساعات مضت, Lotfy14 said:

ثالثا : الترتيب طبعا بيبقى داخل التقرير

انا مش هشتغل على فورم والمفروض ميبقاش على فور

دا بيبقى عباره عن بوتن اقوله فيما معناه اطبعلى كل الناس المؤمن عليهم من غير ما ادخل فى اعداد تقرير

هو التقرير بيحضر نفسة بنفسة لما اختار من البوتن المؤمنين عليهم ذى ما قلت

وبيبقى الترتيب حسب الرقم التامين بس مش بتاريخ ميلاد ولا تاريخ تعيين ولا رقم قومى

اشتغل على الرقم التامينى

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

---------------------------------------

2 ساعات مضت, Lotfy14 said:

عارف انك عبقرى ودى بجد اقسم بالله

خدعوك فقالوا

صدقنى والله هى ماشيه ببركة ربنا 

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

---------------------------------------

2 ساعات مضت, Lotfy14 said:

حبيبى انا تعبك معايا واكيد الواحد بيتعلم منك ومن كل واحد بالمنتدى ومن غير المنتدى واللى فيه

مكنتش وصلت لحاجة فى شغلى بفضلكم بعد ربنا سبحانه وتعاله

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

و إعلم وتيقن أن ما أخطئك لم يكن ليصيبك وما أصابك لم يكن ليخطئك وهذا رزق الله سبحانه وتعالى ياتى فى وقته ويكون فى مضمونه من فضله سبحانه وتعالى 

سبحانك لا علم لنا الا ما علمتنا إنك انت الحكيم العليم و الحمد لله تعالى الذى تتم بنعمته الصالحات  و يارب لك الحمد حمداً كثيرا طيبا طاهر مباركا في يارب لك الحمد كما ينبغى لجلال وجهك و لعظيم سلطانك على كل نعمك التى تمن و تنعم بها علينها من واسع فضلك العظيم

السلام عليكم ورحمة الله تعالى وبركاته

هدية اليوم هى  عبارة عن مكتبة برمجية متكاملة تم كتابتها وتطويرها لتوفير حلول مرنة وقوية لضغط الملفات والمجلدات وفك ضغطها

باستخدام أدوات شائعة مثل WinRAR و7-Zip  لأتمتة عمليات الضغط وفك الضغط للملفات و المجلدات بإحترافيه ومرونه وتحكم شامل

فيما يلي نبذة عن الخصائص والمميزات والإمكانيات العامة للكود :

• يدعم ضغط الملفات وفك ضغطها باستخدام كل من WinRAR و7-Zip مما يتيح للمستخدم اختيار الأداة المناسبة بناء على احتياجاته
• يقبل المدخلات على شكل سلسلة نصية واحدة أو مصفوفة تحتوي على عدة ملفات أو مجلدات
• يحدد تلقائيا مسارات البرامج من سجل النظام أو المسارات الافتراضية مع خيار يدوي كبديل
• يستخدم ترميز Unicode في ملفات التعليق لدعم النصوص العربية وغيرها من اللغات
• يوفر 6 مستويات (من بدون ضغط إلى أقصى ضغط ) للتحكم في التوازن بين السرعة وحجم الملف
• يدعم تقسيم الأرشيف إلى أجزاء بأحجام مختلفة (50 ميجابايت إلى 2 جيجابايت)
• يتيح إضافة كلمة مرور للأرشيفات مع تشفير أسماء الملفات
• أرشيفات ذاتية الاستخراج (SFX): يمكن إنشاء ملفات تنفيذية (exe) لا تحتاج إلى برنامج لفك الضغط
• التعليقات: يدعم إضافة تعليقات نصية للأرشيفات في WinRAR
• إدارة عمليات متعددة: ضغط وفك ضغط عدة ملفات في استدعاء واحد أو عبر حلقات ( مصفوفات )
• يحتوي على معالجة أخطاء شاملة مع رسائل توضيحية (مثل أخطاء المعاملات أو الملفات غير الموجودة)
• التخصيص:يسمح بتحديد اسم الأرشيف - المسار الهدف - ونوع الأرشيف (RAR/ZIP/7z) حسب رغبة المستخدم

سيناريوهات الاستخدام

' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة)
Option Compare Database
' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة
Option Explicit

' تعداد لمستويات الضغط المستخدمة في إنشاء الأرشيفات باستخدام WinRAR (-m) أو 7-Zip (-mx)
Enum EnumCompressionLevel
    CompressionStore = 0       ' بدون ضغط (تخزين الملفات كما هي دون تقليل الحجم، مناسب للسرعة)
    CompressionFastest = 1     ' أقل مستوى ضغط وأسرع أداء (يقلل الحجم قليلاً مع التركيز على السرعة)
    CompressionFast = 2        ' ضغط سريع مع توازن بين السرعة وتقليل الحجم
    CompressionNormal = 3      ' مستوى ضغط عادي (الافتراضي، يناسب معظم الحالات)
    CompressionGood = 4        ' ضغط جيد (توازن محسّن بين الحجم والأداء)
    CompressionMaximum = 5     ' أعلى مستوى ضغط (أقصى تقليل للحجم، لكنه أبطأ في التنفيذ)
End Enum

' تعداد لحجم تقسيم الأرشيف إلى أجزاء عند الإنشاء، القيم بالميجابايت (يُستخدم مع -v في WinRAR/7-Zip)
Enum EnumSplitSizeOption
    SplitNone = 0              ' بدون تقسيم (الأرشيف يبقى ملفًا واحدًا)
    Split50MB = 50             ' تقسيم إلى أجزاء بحجم 50 ميجابايت
    Split100MB = 100           ' تقسيم إلى أجزاء بحجم 100 ميجابايت
    Split200MB = 200           ' تقسيم إلى أجزاء بحجم 200 ميجابايت
    Split500MB = 500           ' تقسيم إلى أجزاء بحجم 500 ميجابايت
    Split1GB = 1000            ' تقسيم إلى أجزاء بحجم 1 جيجابايت
    Split2GB = 2000            ' تقسيم إلى أجزاء بحجم 2 جيجابايت
End Enum

' تعداد لتحديد كيفية التعامل مع الملفات الموجودة أثناء فك الضغط (مع ملاحظة أن OverwritePrompt غير مدعوم في سطر الأوامر)
Enum EnumOverwriteMode
    OverwriteNone = 0          ' لا يتم استبدال الملفات الموجودة (-o- في WinRAR، -aos في 7-Zip)
    OverwritePrompt = 1        ' يطلب تأكيد المستخدم قبل الاستبدال (غير مدعوم في وضع سطر الأوامر)
    OverwriteAll = 2           ' يستبدل جميع الملفات تلقائيًا دون تأكيد (-o+ في WinRAR، -aoa في 7-Zip)
End Enum

' تعداد لتحديد الأداة المستخدمة لإنشاء الأرشيفات وفك ضغطها
Enum EnumArchiveMethod
    WinRAR = 0                 ' استخدام WinRAR لإنشاء أرشيفات RAR/ZIP/SFX وفك ضغطها
    SevenZip = 1               ' استخدام 7-Zip لإنشاء أرشيفات 7z/ZIP/SFX وفك ضغطها (لا يدعم إنشاء RAR)
End Enum

' تعداد لتحديد نوع صيغة الأرشيف الناتج
Enum EnumArchiveType
    ArchiveRAR = 0             ' أرشيف بصيغة RAR (مدعوم فقط مع WinRAR)
    ArchiveZIP = 1             ' أرشيف بصيغة ZIP (مدعوم مع WinRAR و7-Zip)
    Archive7z = 2              ' أرشيف بصيغة 7z (مدعوم فقط مع 7-Zip)
End Enum

' لاحظ: isSFX ليس متغيرًا عامًا بل معلمة في CompressItems لتحديد ما إذا كان الأرشيف ذاتي الاستخراج (SFX)

' متغير عام للتحكم في عرض رسائل النجاح أثناء حلقات الضغط أو فك الضغط
Public IsInLoop As Boolean
' متغير عام لتخزين قائمة مسارات الأرشيفات الناتجة في الحلقات لعرضها في رسالة نجاح واحدة
Public ArchivesList As String


' دالة مساعدة لتحويل مستوى الضغط من EnumCompressionLevel إلى قيمة عددية تتوافق مع خيار -mx في 7-Zip
' المدخل: level - مستوى الضغط من تعداد EnumCompressionLevel
' المخرج: قيمة عددية (0-9) تُستخدم مع -mx لتحديد مستوى الضغط في 7-Zip
Function GetSevenZipCompressionLevel(level As EnumCompressionLevel) As Integer
    Select Case level
        Case CompressionStore
            GetSevenZipCompressionLevel = 0    ' بدون ضغط (-mx=0)
        Case CompressionFastest
            GetSevenZipCompressionLevel = 1    ' أقل ضغط وأسرع (-mx=1)
        Case CompressionFast
            GetSevenZipCompressionLevel = 3    ' ضغط سريع (-mx=3)
        Case CompressionNormal
            GetSevenZipCompressionLevel = 5    ' ضغط عادي (-mx=5، الافتراضي)
        Case CompressionGood
            GetSevenZipCompressionLevel = 7    ' ضغط جيد (-mx=7)
        Case CompressionMaximum
            GetSevenZipCompressionLevel = 9    ' أعلى ضغط (-mx=9)
    End Select
End Function

' دالة مساعدة لتحويل قيم تعداد EnumSplitSizeOption إلى سلسلة نصية تُستخدم مع خيار -v في WinRAR و7-Zip
' المدخل: sizeOption - خيار حجم التقسيم من تعداد EnumSplitSizeOption
' المخرج: سلسلة نصية (مثل "50m" أو "1g") تُضاف إلى -v لتحديد حجم الأجزاء
Function GetSplitSizeString(sizeOption As EnumSplitSizeOption) As String
    Select Case sizeOption
        Case SplitNone
            GetSplitSizeString = ""        ' بدون تقسيم (-v غير موجود)
        Case Split1GB
            GetSplitSizeString = "1g"      ' 1 جيجابايت (-v1g)
        Case Split2GB
            GetSplitSizeString = "2g"      ' 2 جيجابايت (-v2g)
        Case Else
            GetSplitSizeString = CStr(sizeOption) & "m"  ' حجم بالميجابايت (مثل -v50m)
    End Select
End Function

' دالة تتيح للمستخدم تحديد مسار ملف تنفيذي (WinRAR.exe أو 7z.exe) يدويًا عبر مربع حوار اختيار الملفات
' المعاملات:
'   - Method: سلسلة تحدد الأداة المطلوبة ("WinRAR" أو "SevenZip")
' المخرجات:
'   - المسار الكامل للملف التنفيذي المختار أو سلسلة فارغة إذا تم الإلغاء أو حدث خطأ
Function SelectArchivePathManually(Method As String) As String
    On Error GoTo ErrorHandler
    
    Dim fileDialog As Object  ' كائن يمثل مربع حوار اختيار الملفات في Access
    Dim selectedPath As String ' متغير لتخزين المسار المختار
    
    ' التحقق من أن القيمة المدخلة لـ Method صالحة
    If Method <> "WinRAR" And Method <> "SevenZip" Then
        MsgBox "القيمة '" & Method & "' غير صالحة. يجب أن تكون 'WinRAR' أو 'SevenZip'.", vbCritical, "خطأ في الإدخال"
        SelectArchivePathManually = ""
        Exit Function
    End If
    
    ' إعداد مربع حوار لاختيار ملف واحد
    Set fileDialog = Application.fileDialog(3) ' 3 = msoFileDialogFilePicker (اختيار ملف)
    
    With fileDialog
        ' تخصيص إعدادات مربع الحوار بناءً على الأداة المطلوبة
        If Method = "WinRAR" Then
            .Title = "اختر ملف WinRAR.exe"          ' عنوان النافذة
            .Filters.Clear                          ' إزالة أي فلاتر سابقة
            .Filters.Add "WinRAR Executable", "*.exe"  ' فلتر لعرض ملفات .exe فقط
        ElseIf Method = "SevenZip" Then
            .Title = "اختر ملف 7z.exe"             ' عنوان النافذة
            .Filters.Clear                          ' إزالة أي فلاتر سابقة
            .Filters.Add "7Zip Executable", "*.exe"    ' فلتر لعرض ملفات .exe فقط
        End If
        
        .AllowMultiSelect = False ' تفعيل اختيار ملف واحد فقط
        
        ' عرض مربع الحوار ومعالجة اختيار المستخدم
        If .Show = -1 Then  ' -1 تعني أن المستخدم ضغط "فتح"
            selectedPath = .SelectedItems(1) ' استرجاع المسار الكامل للملف المختار
            
            ' التحقق من تطابق اسم الملف مع الأداة المطلوبة
            If Method = "WinRAR" And InStr(1, LCase(selectedPath), "winrar.exe") = 0 Then
                MsgBox "الملف المختار ليس WinRAR.exe. الرجاء اختيار الملف الصحيح.", vbExclamation, "خطأ في الاختيار"
                SelectArchivePathManually = ""
            ElseIf Method = "SevenZip" And InStr(1, LCase(selectedPath), "7z.exe") = 0 Then
                MsgBox "الملف المختار ليس 7z.exe. الرجاء اختيار الملف الصحيح.", vbExclamation, "خطأ في الاختيار"
                SelectArchivePathManually = ""
            Else
                SelectArchivePathManually = selectedPath ' إرجاع المسار إذا كان الملف مطابقًا
            End If
        Else
            ' إذا ألغى المستخدم الاختيار
            MsgBox "لم يتم اختيار أي ملف. تم إلغاء العملية.", vbExclamation, "عملية ملغاة"
            SelectArchivePathManually = ""
        End If
    End With
    
Cleanup:
    ' تحرير كائن مربع الحوار من الذاكرة
    Set fileDialog = Nothing
    Exit Function
    
ErrorHandler:
    ' معالجة الأخطاء المحتملة أثناء تنفيذ الدالة
    MsgBox "حدث خطأ أثناء اختيار الملف: " & Err.Description, vbCritical, "خطأ"
    SelectArchivePathManually = ""
    Resume Cleanup
End Function

' دالة لتحديد مسار الملف التنفيذي (WinRAR.exe أو 7z.exe) تلقائيًا من سجل النظام أو المسارات الافتراضية
' في حالة الفشل، تطلب من المستخدم اختيار المسار يدويًا باستخدام SelectArchivePathManually
' المعاملات:
'   - Method: سلسلة تحدد الأداة المطلوبة ("WinRAR" أو "SevenZip")
' المخرجات:
'   - المسار الكامل للملف التنفيذي أو سلسلة فارغة إذا فشلت العملية
Function DetermineArchivePath(Method As String) As String
    On Error GoTo ErrorHandler
    
    Dim reg As Object         ' كائن للوصول إلى سجل النظام عبر WScript.Shell
    Dim pathFromReg As String ' متغير لتخزين المسار المستخرج من السجل
    Dim defaultPaths As Variant ' مصفوفة تحتوي على المسارات الافتراضية
    Dim i As Integer          ' عداد للحلقة عبر المسارات الافتراضية
    
    ' التحقق من أن القيمة المدخلة لـ Method صالحة
    If Method <> "WinRAR" And Method <> "SevenZip" Then
        MsgBox "القيمة '" & Method & "' غير صالحة. يجب أن تكون 'WinRAR' أو 'SevenZip'.", vbCritical, "خطأ في الإدخال"
        DetermineArchivePath = ""
        Exit Function
    End If
    
    ' إعداد كائن لقراءة مفاتيح السجل
    Set reg = CreateObject("WScript.Shell")
    
    ' البحث عن مسار الأداة بناءً على Method
    If Method = "WinRAR" Then
        ' محاولة استخراج مسار WinRAR من مفاتيح السجل المختلفة
        On Error Resume Next
        pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\WinRAR.exe\") ' مفتاح تطبيقات Windows
        If Err.Number <> 0 Then
            Err.Clear
            pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\WinRAR\exe32") ' مفتاح WinRAR لنظام 32 بت
        End If
        If Err.Number <> 0 Then
            Err.Clear
            pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\WinRAR\exe32") ' مفتاح WinRAR لنظام 64 بت
        End If
        On Error GoTo 0
        
        ' التحقق من وجود الملف في المسار المستخرج
        If pathFromReg <> "" And Dir(pathFromReg) <> vbNullString Then
            DetermineArchivePath = pathFromReg
            Exit Function
        End If
        
        ' البحث في المسارات الافتراضية إذا فشل السجل
        defaultPaths = Array("C:\Program Files\WinRAR\WinRAR.exe", "C:\Program Files (x86)\WinRAR\WinRAR.exe")
        For i = LBound(defaultPaths) To UBound(defaultPaths)
            If Dir(defaultPaths(i)) <> vbNullString Then
                DetermineArchivePath = defaultPaths(i)
                Exit Function
            End If
        Next i
    ElseIf Method = "SevenZip" Then
        ' محاولة استخراج مسار 7-Zip من مفاتيح السجل
        On Error Resume Next
        pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\7-Zip\Path") ' مفتاح 7-Zip لنظام 32 بت
        If Err.Number <> 0 Then
            Err.Clear
            pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\7-Zip\Path") ' مفتاح 7-Zip لنظام 64 بت
        End If
        On Error GoTo 0
        
        ' التحقق من المسار وإكماله باسم الملف إذا لزم الأمر
        If pathFromReg <> "" Then
            If Right(pathFromReg, 1) <> "\" Then pathFromReg = pathFromReg & "\"
            If Dir(pathFromReg & "7z.exe") <> vbNullString Then
                DetermineArchivePath = pathFromReg & "7z.exe"
                Exit Function
            End If
        End If
        
        ' البحث في المسارات الافتراضية إذا فشل السجل
        defaultPaths = Array("C:\Program Files\7-Zip\7z.exe", "C:\Program Files (x86)\7-Zip\7z.exe")
        For i = LBound(defaultPaths) To UBound(defaultPaths)
            If Dir(defaultPaths(i)) <> vbNullString Then
                DetermineArchivePath = defaultPaths(i)
                Exit Function
            End If
        Next i
    End If
    
    ' إذا لم يُعثر على الملف تلقائيًا، طلب الاختيار اليدوي
    MsgBox "لم يتم العثور على " & Method & "! الرجاء تحديد موقعه يدويًا.", vbExclamation, "تحديد مسار " & Method
    DetermineArchivePath = SelectArchivePathManually(Method)
    
Cleanup:
    ' تحرير كائن WScript.Shell من الذاكرة
    Set reg = Nothing
    Exit Function

ErrorHandler:
    ' معالجة الأخطاء المحتملة أثناء البحث عن المسار
    MsgBox "حدث خطأ أثناء تحديد مسار " & Method & ": " & Err.Description, vbCritical, "خطأ"
    DetermineArchivePath = ""
    Resume Cleanup
End Function

' دالة لبناء أمر ضغط الملفات باستخدام WinRAR أو 7-Zip بناءً على المعاملات المحددة
' المعاملات:
'   - sourceFile: الملفات أو المجلدات المراد ضغطها (سلسلة أو مصفوفة)
'   - password: كلمة المرور لتشفير الأرشيف (اختياري)
'   - Method: الأداة المستخدمة (WinRAR أو SevenZip)
'   - archiveType: نوع الأرشيف (RAR، ZIP، 7z)
'   - compressionLevel: مستوى الضغط (من CompressionStore إلى CompressionMaximum)
'   - partSize: حجم تقسيم الأرشيف (من SplitNone إلى Split2GB)
'   - targetPath: مسار حفظ الأرشيف (اختياري، افتراضيًا CurrentProject.Path)
'   - archiveName: اسم الأرشيف (اختياري، افتراضيًا اسم الملف الأول)
'   - isSFX: تحديد ما إذا كان الأرشيف ذاتي الاستخراج (True/False)
'   - commentFile: مسار ملف التعليق (اختياري، مدعوم في WinRAR فقط)
' المخرجات:
'   - سلسلة نصية تمثل أمر الضغط الكامل أو سلسلة فارغة إذا فشل البناء
Function BuildCompressCommand( _
    sourceFile As Variant, _
    password As String, _
    Method As EnumArchiveMethod, _
    archiveType As EnumArchiveType, _
    compressionLevel As EnumCompressionLevel, _
    partSize As EnumSplitSizeOption, _
    targetPath As String, _
    archiveName As String, _
    isSFX As Boolean, _
    commentFile As String) As String
    
    Dim Command As String         ' السلسلة النصية للأمر النهائي
    Dim archiveProgramPath As String ' مسار البرنامج التنفيذي (WinRAR.exe أو 7z.exe)
    Dim fileList As String        ' قائمة الملفات المراد ضغطها
    Dim targetFile As String      ' المسار الكامل للأرشيف الناتج
    Dim fso As Object             ' كائن FileSystemObject للتعامل مع الملفات
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' تحديد مسار البرنامج باستخدام DetermineArchivePath
    archiveProgramPath = DetermineArchivePath(IIf(Method = WinRAR, "WinRAR", "SevenZip"))
    If archiveProgramPath = "" Then Exit Function ' الخروج إذا لم يتم العثور على البرنامج
    
    ' تجهيز قائمة الملفات مع إضافة علامات الاقتباس
    Dim file As Variant
    fileList = ""
    If Not IsArray(sourceFile) Then sourceFile = Array(sourceFile) ' تحويل إلى مصفوفة إذا كان مدخلاً منفردًا
    For Each file In sourceFile
        fileList = fileList & " " & Chr(34) & file & Chr(34)
    Next file
    
    ' تحديد مسار واسم الأرشيف الناتج
    If targetPath = "" Then
        targetFile = CurrentProject.Path & "\" & IIf(archiveName = "", fso.GetBaseName(sourceFile(LBound(sourceFile))), archiveName) & IIf(isSFX, ".exe", IIf(archiveType = ArchiveRAR, ".rar", IIf(archiveType = ArchiveZIP, ".zip", ".7z")))
    Else
        targetFile = targetPath & "\" & IIf(archiveName = "", fso.GetBaseName(sourceFile(LBound(sourceFile))), archiveName) & IIf(isSFX, ".exe", IIf(archiveType = ArchiveRAR, ".rar", IIf(archiveType = ArchiveZIP, ".zip", ".7z")))
    End If
    
    ' بناء الأمر بناءً على الأداة المختارة
    If Method = WinRAR Then
        Command = Chr(34) & archiveProgramPath & Chr(34) & " a -ep1 -m" & compressionLevel ' -ep1 لاستثناء المسارات الأساسية
        If isSFX Then Command = Command & " -sfx" ' إنشاء أرشيف ذاتي الاستخراج
        Command = Command & " " & Chr(34) & targetFile & Chr(34) & fileList
        If password <> "" Then Command = Command & " -p" & password ' إضافة كلمة المرور
        If partSize <> SplitNone Then Command = Command & " -v" & GetSplitSizeString(partSize) ' تقسيم الأرشيف
        If commentFile <> "" And fso.FileExists(commentFile) Then Command = Command & " -z" & Chr(34) & commentFile & Chr(34) ' إضافة ملف التعليق
    ElseIf Method = SevenZip Then
        Command = Chr(34) & archiveProgramPath & Chr(34) & " a -mx=" & GetSevenZipCompressionLevel(compressionLevel) ' تحديد مستوى الضغط
        If isSFX Then Command = Command & " -sfx7z.sfx" ' إنشاء أرشيف ذاتي الاستخراج (يتطلب ملف 7z.sfx)
        Command = Command & " " & Chr(34) & targetFile & Chr(34) & fileList
        If password <> "" Then Command = Command & " -p" & password & " -mhe=on" ' تشفير مع إخفاء أسماء الملفات
        If partSize <> SplitNone Then Command = Command & " -v" & GetSplitSizeString(partSize) ' تقسيم الأرشيف
        ' ملاحظة: 7-Zip لا يدعم إضافة تعليقات مباشرة عبر سطر الأوامر
    End If
    
    BuildCompressCommand = Command
    Set fso = Nothing
End Function

' دالة لإنشاء ملف تعليق مؤقت وإرجاع مساره لاستخدامه مع أرشيفات WinRAR
' المعاملات:
'   - commentLines: سلسلة نصية أو مصفوفة تحتوي على أسطر التعليق
'   - deleteAfterUse: إذا كان True (افتراضي)، يتم حذف الملف بعد الاستخدام؛ إذا كان False، يبقى الملف
' المخرجات:
'   - المسار الكامل لملف التعليق المؤقت
Function CreateCommentFile(commentLines As Variant, Optional deleteAfterUse As Boolean = True) As String
    Dim fso As Object         ' كائن FileSystemObject للتعامل مع الملفات
    Dim tempFile As String    ' مسار الملف المؤقت
    Dim file As Object        ' كائن الملف النصي
    Dim line As Variant       ' متغير لحلقة الكتابة
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' إنشاء اسم ملف مؤقت فريد باستخدام الطابع الزمني
    tempFile = CurrentProject.Path & "\temp_comment_" & Format(Now, "yyyymmddhhnnss") & ".txt"
    
    ' إنشاء الملف بترميز Unicode لدعم النصوص العربية
    Set file = fso.CreateTextFile(tempFile, True, True) ' True الأولى للكتابة فوق الملف، True الثانية لـ Unicode
    If IsArray(commentLines) Then
        ' كتابة أسطر متعددة إذا كان المدخل مصفوفة
        For Each line In commentLines
            file.WriteLine CStr(line)
        Next line
    Else
        ' كتابة سلسلة واحدة إذا لم يكن مصفوفة
        file.WriteLine CStr(commentLines)
    End If
    file.Close
    
    ' إرجاع مسار الملف المؤقت
    CreateCommentFile = tempFile
    
    ' حذف الملف إذا طُلب ذلك مع تجاهل الأخطاء المحتملة (مثل الملف قيد الاستخدام)
    If deleteAfterUse Then
        On Error Resume Next
        fso.DeleteFile tempFile
        On Error GoTo 0
    End If
    
    Set file = Nothing
    Set fso = Nothing
End Function

' دالة لضغط ملفات أو مجلدات باستخدام WinRAR أو 7-Zip مع خيارات متعددة
' المعاملات:
'   - itemsArray: الملفات أو المجلدات المراد ضغطها (سلسلة أو مصفوفة، اختياري)
'   - password: كلمة المرور لتشفير الأرشيف (اختياري، افتراضي "")
'   - Method: الأداة المستخدمة (WinRAR أو SevenZip، افتراضي SevenZip)
'   - archiveType: نوع الأرشيف (RAR، ZIP، 7z، افتراضي Archive7z)
'   - compressionLevel: مستوى الضغط (افتراضي CompressionNormal)
'   - partSize: حجم تقسيم الأرشيف (افتراضي SplitNone)
'   - targetPath: مسار حفظ الأرشيف (اختياري، افتراضي CurrentProject.Path)
'   - archiveName: اسم الأرشيف (اختياري، افتراضي اسم الملف الأول)
'   - isSFX: تحديد ما إذا كان الأرشيف ذاتي الاستخراج (افتراضي False)
'   - commentFile: مسار ملف التعليق (اختياري، مدعوم في WinRAR فقط)
Sub CompressItems( _
    Optional ByVal itemsArray As Variant, _
    Optional ByVal password As String = "", _
    Optional ByVal Method As EnumArchiveMethod = SevenZip, _
    Optional ByVal archiveType As EnumArchiveType = Archive7z, _
    Optional ByVal compressionLevel As EnumCompressionLevel = CompressionNormal, _
    Optional ByVal partSize As EnumSplitSizeOption = SplitNone, _
    Optional ByVal targetPath As String = "", _
    Optional ByVal archiveName As String = "", _
    Optional ByVal isSFX As Boolean = False, _
    Optional ByVal commentFile As String = "")
    On Error GoTo ErrorHandler
    
    Dim Command As String         ' أمر الضغط الناتج من BuildCompressCommand
    Dim fso As Object            ' كائن FileSystemObject للتحقق من الملفات
    Dim file As Variant          ' متغير لحلقة التحقق من الملفات
    Dim archiveFullPath As String ' المسار الكامل للأرشيف الناتج
    Dim isInputArray As Boolean  ' للتحقق مما إذا كان المدخل مصفوفة
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' التحقق من وجود مدخل
    If VarType(itemsArray) = vbEmpty Then
        MsgBox "لم يتم تحديد ملفات أو مجلدات للضغط.", vbExclamation, "خطأ"
        GoTo Cleanup
    End If
    
    ' التحقق من نوع المدخل الأصلي
    isInputArray = IsArray(itemsArray)
    
    If isInputArray Then
        If UBound(itemsArray) < LBound(itemsArray) Then
            MsgBox "المصفوفة فارغة. لم يتم تحديد ملفات أو مجلدات للضغط.", vbExclamation, "خطأ"
            GoTo Cleanup
        End If
    End If
    
    ' تحويل المدخل إلى مصفوفة وفحص وجود الملفات
    If Not isInputArray Then itemsArray = Array(itemsArray)
    For Each file In itemsArray
        Dim fullPath As String
        If Left(file, 1) = "\" Then
            fullPath = CurrentProject.Path & file ' إضافة المسار الأساسي إذا بدأ بـ "\"
        ElseIf InStr(file, "\") = 0 Then
            fullPath = CurrentProject.Path & "\" & file ' إضافة المسار إذا كان اسمًا فقط
        Else
            fullPath = file ' استخدام المسار الكامل كما هو
        End If
        If Not fso.FileExists(fullPath) And Not fso.FolderExists(fullPath) Then
            MsgBox "الملف أو المجلد '" & fullPath & "' غير موجود!", vbCritical, "خطأ"
            GoTo Cleanup
        End If
    Next file
    
    ' استدعاء BuildCompressCommand لبناء الأمر
    Command = BuildCompressCommand( _
        sourceFile:=itemsArray, _
        password:=password, _
        Method:=Method, _
        archiveType:=archiveType, _
        compressionLevel:=compressionLevel, _
        partSize:=partSize, _
        targetPath:=targetPath, _
        archiveName:=archiveName, _
        isSFX:=isSFX, _
        commentFile:=commentFile _
    )
    
    If Command = "" Then
        MsgBox "فشل في إنشاء أمر الضغط.", vbCritical, "خطأ"
        GoTo Cleanup
    End If
    
    ' تنفيذ الأمر باستخدام ShellWait
    ShellWait Command, vbHide ' vbHide لإخفاء نافذة سطر الأوامر
    
    ' تحديد المسار النهائي للأرشيف لعرضه في رسالة النجاح
    If targetPath = "" Then
        archiveFullPath = CurrentProject.Path & "\" & IIf(archiveName = "", fso.GetBaseName(itemsArray(LBound(itemsArray))), archiveName) & IIf(isSFX, ".exe", IIf(archiveType = ArchiveRAR, ".rar", IIf(archiveType = ArchiveZIP, ".zip", ".7z")))
    Else
        archiveFullPath = targetPath & "\" & IIf(archiveName = "", fso.GetBaseName(itemsArray(LBound(itemsArray))), archiveName) & IIf(isSFX, ".exe", IIf(archiveType = ArchiveRAR, ".rar", IIf(archiveType = ArchiveZIP, ".zip", ".7z")))
    End If
    
    ' التحكم في عرض رسالة النجاح بناءً على السياق
    If isInputArray Then
        MsgBox "تم الضغط بنجاح إلى '" & archiveFullPath & "'!", vbInformation, "نجاح"
    ElseIf Not IsInLoop Then
        MsgBox "تم الضغط بنجاح إلى '" & archiveFullPath & "'!", vbInformation, "نجاح"
    Else
        ArchivesList = ArchivesList & archiveFullPath & vbCrLf ' إضافة إلى قائمة الحلقة
    End If
    
Cleanup:
    ' حذف ملف التعليق إذا كان موجودًا
    If commentFile <> "" And fso.FileExists(commentFile) Then fso.DeleteFile commentFile
    Set fso = Nothing
    Exit Sub
    
ErrorHandler:
    Dim errorMsg As String
    If Err.Number = 450 Then
        errorMsg = "خطأ في تمرير المعاملات:" & vbCrLf & _
                  "الترتيب المتوقع:" & vbCrLf & _
                  "1. itemsArray (Variant, اختياري) - الملفات أو المجلدات" & vbCrLf & _
                  "2. password (String, اختياري) - كلمة المرور" & vbCrLf & _
                  "3. Method (EnumArchiveMethod, اختياري) - WinRAR أو SevenZip" & vbCrLf & _
                  "4. archiveType (EnumArchiveType, اختياري) - ArchiveRAR أو ArchiveZIP أو Archive7z" & vbCrLf & _
                  "5. compressionLevel (EnumCompressionLevel, اختياري) - مستوى الضغط" & vbCrLf & _
                  "6. partSize (EnumSplitSizeOption, اختياري) - حجم التقسيم" & vbCrLf & _
                  "7. targetPath (String, اختياري) - مسار الهدف" & vbCrLf & _
                  "8. archiveName (String, اختياري) - اسم الأرشيف" & vbCrLf & _
                  "9. isSFX (Boolean, اختياري) - إنشاء ملف SFX" & vbCrLf & _
                  "10. commentFile (String, اختياري) - مسار ملف التعليق" & vbCrLf & _
                  "تفاصيل الخطأ: " & Err.Description
    Else
        errorMsg = "حدث خطأ أثناء الضغط: " & Err.Description
    End If
    MsgBox errorMsg, vbCritical, "خطأ"
    GoTo Cleanup
End Sub

' دوال مساعدة للحلقات (الضغط)
' دالة مساعدة لبدء حلقة ضغط متعددة وتهيئة المتغيرات العامة
Sub StartCompressionLoop()
    IsInLoop = True   ' تفعيل وضع الحلقة
    ArchivesList = "" ' تهيئة قائمة الأرشيفات
End Sub

' دالة مساعدة لعرض رسالة نجاح موحدة بعد انتهاء حلقة الضغط
Sub ShowCompressionSuccess()
    If IsInLoop And ArchivesList <> "" Then
        MsgBox "تم الضغط بنجاح للملفات التالية:" & vbCrLf & ArchivesList, vbInformation, "نجاح"
    End If
    IsInLoop = False  ' إنهاء وضع الحلقة
    ArchivesList = "" ' إعادة تهيئة القائمة
End Sub

' دالة لفك ضغط الأرشيفات باستخدام WinRAR أو 7-Zip إلى مسار محدد
' المعاملات:
'   - archivePaths: المسارات الكاملة للأرشيفات (سلسلة أو مصفوفة)
'   - destinationPath: مسار الوجهة لفك الضغط
'   - password: كلمة المرور إذا كان الأرشيف مشفرًا (اختياري، افتراضي "")
'   - Method: الأداة المستخدمة (WinRAR أو SevenZip، افتراضي WinRAR)
'   - OverwriteMode: طريقة التعامل مع الملفات الموجودة (OverwriteAll أو OverwriteNone، افتراضي OverwriteAll)
Sub ExtractItems( _
    archivePaths As Variant, _
    destinationPath As String, _
    Optional ByVal password As String = "", _
    Optional ByVal Method As EnumArchiveMethod = WinRAR, _
    Optional ByVal OverwriteMode As EnumOverwriteMode = OverwriteAll)
    On Error GoTo ErrorHandler
    
    Dim Command As String         ' أمر فك الضغط
    Dim archiveProgramPath As String ' مسار البرنامج التنفيذي
    Dim fso As Object            ' كائن FileSystemObject للتحقق من الملفات
    Dim archiveList As String    ' قائمة الأرشيفات المراد فك ضغطها
    Dim archive As Variant       ' متغير لحلقة التحقق
    Dim isInputArray As Boolean  ' للتحقق مما إذا كان المدخل مصفوفة
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' التحقق من وجود البرنامج
    archiveProgramPath = DetermineArchivePath(IIf(Method = WinRAR, "WinRAR", "SevenZip"))
    If archiveProgramPath = "" Or Not fso.FileExists(archiveProgramPath) Then
        MsgBox "تعذر العثور على برنامج فك الضغط المطلوب! تأكد من تثبيته.", vbCritical, "خطأ"
        GoTo Cleanup
    End If
    
    ' التحقق من وجود مدخل
    If VarType(archivePaths) = vbEmpty Then
        MsgBox "لم يتم تحديد أرشيفات لفك الضغط.", vbExclamation, "خطأ"
        GoTo Cleanup
    End If
    
    ' التحقق من نوع المدخل الأصلي
    isInputArray = IsArray(archivePaths)
    
    If isInputArray Then
        If UBound(archivePaths) < LBound(archivePaths) Then
            MsgBox "المصفوفة فارغة. لم يتم تحديد أرشيفات لفك الضغط.", vbExclamation, "خطأ"
            GoTo Cleanup
        End If
    End If
    
    ' تجهيز قائمة الأرشيفات مع إضافة علامات الاقتباس
    archiveList = ""
    If Not isInputArray Then archivePaths = Array(archivePaths)
    For Each archive In archivePaths
        If Not fso.FileExists(archive) Then
            MsgBox "الملف '" & archive & "' غير موجود!", vbCritical, "خطأ"
            GoTo Cleanup
        End If
        archiveList = archiveList & " " & Chr(34) & archive & Chr(34)
    Next archive
    
    ' إنشاء مجلد الوجهة إذا لم يكن موجودًا
    If Dir(destinationPath, vbDirectory) = "" Then
        MkDir destinationPath
    End If
    
    ' بناء أمر فك الضغط بناءً على الأداة
    If Method = WinRAR Then
        Command = Chr(34) & archiveProgramPath & Chr(34) & " x " & archiveList & " " & Chr(34) & destinationPath & Chr(34)
        If password <> "" Then Command = Command & " -p" & password
        Select Case OverwriteMode
            Case OverwriteAll: Command = Command & " -o+"    ' الكتابة فوق الملفات
            Case OverwriteNone: Command = Command & " -o-"   ' تجاهل الملفات الموجودة
            Case OverwritePrompt
                MsgBox "خيار 'OverwritePrompt' غير مدعوم في وضع سطر الأوامر. سيتم استخدام 'OverwriteAll' افتراضيًا.", vbInformation, "تحذير"
                Command = Command & " -o+"
        End Select
    ElseIf Method = SevenZip Then
        Command = Chr(34) & archiveProgramPath & Chr(34) & " x " & archiveList & " -o" & Chr(34) & destinationPath & Chr(34)
        If password <> "" Then Command = Command & " -p" & password
        Select Case OverwriteMode
            Case OverwriteAll: Command = Command & " -aoa"   ' الكتابة فوق الملفات
            Case OverwriteNone: Command = Command & " -aos"  ' تخطي الملفات الموجودة
            Case OverwritePrompt
                MsgBox "خيار 'OverwritePrompt' غير مدعوم في وضع سطر الأوامر. سيتم استخدام 'OverwriteAll' افتراضيًا.", vbInformation, "تحذير"
                Command = Command & " -aoa"
        End Select
    End If
    
    ' تنفيذ الأمر باستخدام ShellWait
    ShellWait Command, vbHide
    
    ' التحكم في عرض رسالة النجاح
    If isInputArray Then
        MsgBox "تم فك الضغط بنجاح إلى '" & destinationPath & "'!", vbInformation, "نجاح"
    ElseIf Not IsInLoop Then
        MsgBox "تم فك الضغط بنجاح إلى '" & destinationPath & "'!", vbInformation, "نجاح"
    Else
        ArchivesList = ArchivesList & archivePaths(LBound(archivePaths)) & vbCrLf ' إضافة إلى قائمة الحلقة
    End If
    
Cleanup:
    Set fso = Nothing
    Exit Sub
    
ErrorHandler:
    Dim errorMsg As String
    If Err.Number = 450 Then
        errorMsg = "خطأ في تمرير المعاملات:" & vbCrLf & _
                  "الترتيب المتوقع:" & vbCrLf & _
                  "1. archivePaths (Variant) - المسارات الكاملة للأرشيفات (سلسلة أو مصفوفة)" & vbCrLf & _
                  "2. destinationPath (String) - المسار الوجهة لفك الضغط" & vbCrLf & _
                  "3. password (String, اختياري) - كلمة المرور" & vbCrLf & _
                  "4. Method (EnumArchiveMethod, اختياري) - WinRAR أو SevenZip" & vbCrLf & _
                  "5. OverwriteMode (EnumOverwriteMode, اختياري) - OverwriteAll أو OverwriteNone" & vbCrLf & _
                  "تفاصيل الخطأ: " & Err.Description
    Else
        errorMsg = "حدث خطأ أثناء فك الضغط: " & Err.Description
    End If
    MsgBox errorMsg, vbCritical, "خطأ"
    GoTo Cleanup
End Sub

' دوال مساعدة للحلقات (فك الضغط)
' دالة مساعدة لبدء حلقة فك ضغط متعددة وتهيئة المتغيرات العامة
Sub StartExtractionLoop()
    IsInLoop = True   ' تفعيل وضع الحلقة
    ArchivesList = "" ' تهيئة قائمة الأرشيفات
End Sub

' دالة مساعدة لعرض رسالة نجاح موحدة بعد انتهاء حلقة فك الضغط
Sub ShowExtractionSuccess()
    If IsInLoop And ArchivesList <> "" Then
        MsgBox "تم فك الضغط بنجاح للملفات التالية:" & vbCrLf & ArchivesList, vbInformation, "نجاح"
    End If
    IsInLoop = False  ' إنهاء وضع الحلقة
    ArchivesList = "" ' إعادة تهيئة القائمة
End Sub




' دالة تستخدم لاختبار
' DetermineArchivePath
' التي تحدد مسار ملفي
' ("WinRAR : WinRAR.exe " أو "SevenZip : 7z.exe")
' تلقائيا أو يدوًا
' يمكن حذفها هى فقط كانت لتجربة الكود والتأكد من جلب مسارات التطبيقات
Sub TestDetermineArchivePath()
    ' الغرض: اختبار دالة DetermineArchivePath لتحديد مسارات WinRAR و7-Zip
    ' المخرجات:
    '   - طباعة المسارات في نافذة Immediate إذا تم العثور عليها
    '   - عرض رسالة إذا لم يتم العثور على الأداة
    
    On Error GoTo ErrorHandler
    
    Dim tools As Variant
    Dim tool As Variant ' يجب أن يكون Variant لاستخدامه في For Each
    Dim archivePath As String
    
    ' قائمة الأدوات للاختبار
    tools = Array("WinRAR", "SevenZip")
    
    ' اختبار كل أداة
    For Each tool In tools
        archivePath = DetermineArchivePath(CStr(tool)) ' تحويل Variant إلى String صراحة
        If archivePath <> "" Then
            Debug.Print "تم العثور على " & tool & " في: " & archivePath
        Else
            MsgBox "لم يتم العثور على " & tool & ".", vbInformation, "نتيجة الاختبار"
        End If
    Next tool
    
    Exit Sub
    
ErrorHandler:
    MsgBox "حدث خطأ أثناء اختبار DetermineArchivePath: " & Err.Description, vbCritical, "خطأ"
    Exit Sub
End Sub

' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة)
Option Compare Database
' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة
Option Explicit

'=======================================================================================================================
'-----------------------------------------------    الثوابت    -----------------------------------------------
'=======================================================================================================================

' ثوابت عامة للتحكم في الانتظار والعمليات
Public Const INFINITE               As Long = &HFFFFFFFF    ' مهلة لا نهائية، تُستخدم مع ShellW للانتظار حتى تنتهي العملية
Public Const STATUS_PENDING         As Long = &H103&        ' 259 - حالة العملية مستمرة
Public Const STILL_ACTIVE           As Long = STATUS_PENDING ' تعني أن العملية لا تزال نشطة
Public Const USER_TIMER_MINIMUM     As Long = &HA&          ' الحد الأدنى للمهلة (10 مللي ثانية)
Public Const USER_TIMER_MAXIMUM     As Long = &H7FFFFFFF    ' الحد الأقصى للمهلة
Public Const PROCESS_HAS_TERMINATED As Long = vbObjectError Or &HDEAD& ' رمز الخطأ عند انتهاء العملية

'=======================================================================================================================
'--------------------------------------------    التعدادات    --------------------------------------------
'=======================================================================================================================

' تعداد للقيم المنطقية (TRUE/FALSE)
Private Enum BOOL
    FALSE_      ' 0 - خطأ
    TRUE_       ' 1 - صحيح
End Enum
#If False Then
    Dim FALSE_, TRUE_
#End If

' تعداد لإعدادات ShellExecuteEx (الأقنعة)
Private Enum SEE_Mask
    SEE_MASK_DEFAULT = &H0                  ' استخدام القيم الافتراضية
    SEE_MASK_NOCLOSEPROCESS = &H40          ' الاحتفاظ بمقبض العملية لمعرفة متى تنتهي
    SEE_MASK_DOENVSUBST = &H200             ' توسيع متغيرات البيئة في المسارات
    SEE_MASK_FLAG_NO_UI = &H400             ' عدم عرض رسائل الخطأ من النظام
    ' ... (يمكن إضافة تعليقات لكل قناع إذا لزم الأمر)
End Enum
#If False Then
    Dim SEE_MASK_DEFAULT, SEE_MASK_NOCLOSEPROCESS, SEE_MASK_DOENVSUBST, SEE_MASK_FLAG_NO_UI
#End If

' تعداد لأنماط عرض النافذة
Private Enum E_ShowCmd
    SW_HIDE = 0             ' إخفاء النافذة وتنشيط نافذة أخرى
    SW_SHOWNORMAL = 1       ' عرض النافذة بحجمها الطبيعي وتنشيطها
    SW_SHOWMINIMIZED = 2    ' تصغير النافذة وتنشيطها
    SW_SHOWMAXIMIZED = 3    ' تكبير النافذة وتنشيطها
    ' ... (يمكن إكمال التعليقات لكل نمط إذا لزم الأمر)
End Enum
#If False Then
    Dim SW_HIDE, SW_SHOWNORMAL, SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED
#End If

' تعداد عام لأنماط النافذة لـ ShellW
Public Enum AppWinStyle
    vbHide = SW_HIDE
    vbShowNormal = SW_SHOWNORMAL
    vbShowMinimized = SW_SHOWMINIMIZED
    vbShowMaximized = SW_SHOWMAXIMIZED
    ' ... (يمكن إكمال التعليقات إذا لزم الأمر)
End Enum
#If False Then
    Dim vbHide, vbShowNormal, vbShowMinimized, vbShowMaximized
#End If

'=======================================================================================================================
'---------------------------------------    تعريف الأنواع    ---------------------------------------
'=======================================================================================================================

' نوع بيانات لتخزين معلومات ShellExecuteEx
Private Type SHELLEXECUTEINFO
    cbSize       As Long      ' حجم الهيكل بالبايت
    fMask        As SEE_Mask  ' الأقنعة لتحديد السلوك (مثل الاحتفاظ بمقبض العملية)
    HWnd         As Long      ' مقبض النافذة الأم (اختياري)
    lpVerb       As String    ' الأمر (مثل "open" أو "print")
    lpFile       As String    ' مسار الملف أو الأمر المراد تنفيذه
    lpParameters As String    ' المعاملات (اختياري)
    lpDirectory  As String    ' دليل العمل (اختياري)
    nShow        As E_ShowCmd ' نمط عرض النافذة
    hInstApp     As Long      ' نتيجة التنفيذ (أكبر من 32 عند النجاح)
    lpIDList     As Long      ' معرف القائمة (غير مستخدم هنا)
    lpClass      As String    ' نوع الملف (غير مستخدم هنا)
    hkeyClass    As Long      ' مفتاح السجل (غير مستخدم هنا)
    dwHotKey     As Long      ' اختصار لوحة المفاتيح (غير مستخدم هنا)
    #If True Then
        hIcon    As Long      ' مقبض الأيقونة (غير مستخدم في الإصدارات الحديثة)
    #Else
        hMonitor As Long      ' مقبض الشاشة (غير مستخدم هنا)
    #End If
    hProcess     As Long      ' مقبض العملية الناتجة
End Type

'=======================================================================================================================
'----------------------------------------    تعريفات API    ----------------------------------------
'=======================================================================================================================

' تعريفات API لنظام 64 بت
#If VBA7 And Win64 Then
'Used only by ShellWait
Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As BOOL, ByVal dwProcessId As Long) As Long

'Used by both ShellWait and ShellW
Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As BOOL
Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As BOOL
Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "User32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As BOOL, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long

'Used by ShellW
Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As BOOL, Optional ByVal lpTimerName As Long) As Long
Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long
Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As BOOL
Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As BOOL) As BOOL
Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As BOOL
Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr)

Dim hProcess As LongPtr

#Else
' تعريفات API لنظام 32 بت
'Used only by ShellWait
Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As BOOL, ByVal dwProcessId As Long) As Long

'Used by both ShellWait and ShellW
Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As BOOL
Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As BOOL
Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "User32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As BOOL, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long

'Used by ShellW
Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As BOOL, Optional ByVal lpTimerName As Long) As Long
Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long
Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As BOOL
Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As BOOL) As BOOL
Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As BOOL
Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long)

Dim hProcess As Long

#End If

'=======================================================================================================================
'----------------------------------------    المتغيرات العامة    ----------------------------------------
'=======================================================================================================================

Public g_ExitDoLoops As Boolean  ' متغير عام للتحكم في إنهاء الحلقات (يُضبط إلى True عند إنهاء البرنامج)

'=======================================================================================================================
'---------------------------------------    المتغيرات الخاصة    ---------------------------------------
'=======================================================================================================================

Private m_Busy1 As Boolean  ' علامة مشغول لـ ShellWait
Private m_Busy2 As Boolean  ' علامة مشغول لـ ShellW

'=======================================================================================================================
'------------------------------------------    الدوال العامة    ------------------------------------------
'=======================================================================================================================

' دالة لتشغيل برنامج والانتظار حتى ينتهي مع السماح بمعالجة الأحداث الأخرى
Public Function ShellWait(ByRef PathName As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus) As Long
    Const PROCESS_QUERY_INFORMATION = &H400&, QS_ALLINPUT = &H4FF&, SYNCHRONIZE = &H100000
    Dim sPath As String ' متغير لتخزين المسار بعد توسيع متغيرات البيئة

    ' التحقق من عدم وجود استدعاء آخر نشط للدالة
    If Not m_Busy1 Then m_Busy1 = True Else Exit Function

    ' توسيع متغيرات البيئة إذا وجدت في المسار
    If InStr(PathName, "%") = 0& Then
        sPath = PathName
    Else
        SysReAllocStringLen VarPtr(sPath), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1&
        ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(sPath), Len(sPath) + 1&
    End If

    ' تشغيل البرنامج والحصول على مقبض العملية
    On Error GoTo 1
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, FALSE_, Shell(sPath, WindowStyle))
    On Error GoTo 0

    If hProcess Then
        sPath = vbNullString
        g_ExitDoLoops = False

        ' الانتظار حتى تنتهي العملية مع السماح بمعالجة الأحداث
        Do While MsgWaitForMultipleObjects(1&, hProcess, FALSE_, INFINITE, QS_ALLINPUT)
            DoEvents
            If g_ExitDoLoops Then Exit Do
        Loop

        ' استرجاع رمز الخروج وإغلاق المقبض
        WindowStyle = GetExitCodeProcess(hProcess, ShellWait): Debug.Assert WindowStyle
        hProcess = CloseHandle(hProcess): Debug.Assert hProcess
    End If

    m_Busy1 = False
    Exit Function

1   m_Busy1 = False ' إعادة تعيين علامة المشغول في حالة الخطأ
End Function

' دالة لتشغيل ملف أو أمر مع خيار الانتظار لمدة محددة
Public Function ShellW(ByRef PathName As String, Optional ByVal WindowStyle As AppWinStyle = vbShowNormal, _
                       Optional ByVal Wait As Long) As Long
    Const MAX_PATH = 260&, QS_ALLINPUT = &H4FF&, WAIT_OBJECT_0 = &H0&
    Dim TimedOut As Boolean, nCount As Long, pHandles As LongPtr, RV As Long, SEI As SHELLEXECUTEINFO

    ' تهيئة الدالة والتحقق من المدخلات
    Err.Clear
    If m_Busy2 Then Exit Function
    If LenB(PathName) Then m_Busy2 = True Else Exit Function

    With SEI
        .cbSize = LenB(SEI)
        .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_DOENVSUBST Or SEE_MASK_FLAG_NO_UI ' إعدادات للاحتفاظ بالمقبض وتوسيع المتغيرات
        .nShow = WindowStyle

        ' توسيع متغيرات البيئة إذا وجدت
        If InStr(PathName, "%") Then
            SysReAllocStringLen VarPtr(.lpFile), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1&
            ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(.lpFile), Len(.lpFile) + 1&
        Else
            .lpFile = PathName
        End If

        ' تبسيط المسار إذا احتوى على "." أو ".."
        If InStr(.lpFile, "\.") <> 0& Or InStr(.lpFile, ".\") <> 0& Then
            If Len(.lpFile) < MAX_PATH Then
                SysReAllocStringLen VarPtr(.lpVerb), , MAX_PATH - 1&
                If PathCanonicalizeW(StrPtr(.lpVerb), StrPtr(.lpFile)) Then
                    SysReAllocString VarPtr(.lpFile), StrPtr(.lpVerb)
                End If
                .lpVerb = vbNullString
            End If
        End If

        ' فصل المعاملات عن المسار
        SysReAllocString VarPtr(.lpParameters), PathGetArgsW(StrPtr(.lpFile))
        If LenB(.lpParameters) Then
            PathRemoveArgsW StrPtr(.lpFile)
            If InStr(.lpParameters, """") Then .lpParameters = Replace(.lpParameters, """", """""""")
        End If

        ' تنفيذ الأمر
        If ShellExecuteExW(VarPtr(SEI)) Then
            ShellW = GetProcessId(.hProcess)

            If Wait Then
                .lpFile = vbNullString
                .lpParameters = vbNullString
                g_ExitDoLoops = False

                If .hProcess Then
                    nCount = 1&
                    pHandles = VarPtr(.hProcess)
                End If

                ' إعداد مؤقت إذا كانت المهلة محددة
                If Wait > INFINITE Then
                    .hIcon = CreateWaitableTimerW
                    If .hIcon Then
                        nCount = nCount + 1&
                        pHandles = VarPtr(.hIcon)
                        Wait = SetWaitableTimer(.hIcon, CCur(-Wait)): Debug.Assert Wait
                    End If
                End If

                ' الانتظار مع معالجة الأحداث
                Do
                    RV = MsgWaitForMultipleObjects(nCount, ByVal pHandles, FALSE_, INFINITE, QS_ALLINPUT)
                    If RV < nCount Then
                        If .hIcon Then
                            TimedOut = RV = 0&
                            RV = CloseHandle(.hIcon): Debug.Assert RV
                        End If
                        Err.Clear
                        Exit Do
                    End If
                    DoEvents
                Loop Until g_ExitDoLoops

                ' استرجاع رمز الخروج إذا انتهت العملية
                If Not (TimedOut Or g_ExitDoLoops) Then
                    RV = GetExitCodeProcess(.hProcess, ShellW): Debug.Assert RV
                    Err = PROCESS_HAS_TERMINATED
                    Err.Description = "Exit Code"
                End If
            End If

            If .hProcess Then RV = CloseHandle(.hProcess): Debug.Assert RV
        End If
    End With

    m_Busy2 = False
End Function

' دالة بسيطة لتشغيل أمر باستخدام WScript.Shell
Public Function ShellWScript(ByRef Command As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus, _
                        Optional ByVal WaitOnReturn As Boolean) As Long
    Dim ws As Object
    Set ws = CreateObject("Wscript.Shell")
    ShellWScript = ws.Run(Command, WindowStyle, WaitOnReturn)
End Function

Option Compare Database
Option Explicit

' وحدة نمطية تحتوي على أمثلة شاملة لضغط وفك ضغط باستخدام WinRAR مع كل الخيارات

' ===========================================================================
' 1. ضغط ملف واحد
' ===========================================================================
' بدون كلمة مرور، مستوى ضغط عادي
Sub CompressSingleFileNoPasswordWinRAR()
    CompressItems "file1.txt", , WinRAR, ArchiveRAR, CompressionNormal
    ' الناتج: file1.rar في CurrentProject.Path
End Sub

' مع كلمة مرور، مستوى ضغط أقصى
Sub CompressSingleFileWithPasswordMaxCompressionWinRAR()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    CompressItems "file1.txt", password, WinRAR, ArchiveRAR, CompressionMaximum
    ' الناتج: file1.rar (مشفر، مضغوط بأقصى مستوى) في CurrentProject.Path
End Sub

' مع تقسيم الأرشيف (Split500MB)
Sub CompressSingleFileWithSplitWinRAR()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    CompressItems "file1.txt", password, WinRAR, ArchiveRAR, CompressionNormal, Split500MB
    ' الناتج: file1.rar مقسم إلى أجزاء بحجم 500 ميجابايت
End Sub

' ذاتي الاستخراج (SFX) مع تعليق
' ضغط مجلد واحد مع تعليق باستخدام متغير لكلمة المرور
Sub CompressSingleFileSFXWithCommentWinRAR()
    Dim commentLines As Variant
    Dim commentFile As String
    Dim password As String
    
    ' تعيين كلمة المرور
    password = "officena"
    
    ' إعداد التعليق باستخدام المتغير
    commentLines = Array( _
        "منتديات أوفيسنا", _
        "www.officena.net", _
        "وقت وتاريخ إنشاء الأرشيف:", _
        Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _
        "كلمة المرور لفك الضغط: " & password, _
        "مع أطيب الأماني: أبو جودى")
    
    commentFile = CreateCommentFile(commentLines, False)
    
    ' استخدام كلمة المرور في الضغط
    CompressItems CurrentProject.Path & "\Folder1", password, WinRAR, ArchiveRAR, CompressionNormal, , , , , commentFile
    ' الناتج: Folder1.rar (مشفر بكلمة المرور "MS-Access(officena)"، مع تعليق) في CurrentProject.Path
End Sub

' ===========================================================================
' 2. فك ضغط ملف واحد
' ===========================================================================
' بدون كلمة مرور، الكتابة فوق الملفات
Sub ExtractSingleFileNoPasswordOverwriteWinRAR()
    ExtractItems CurrentProject.Path & "\file1.rar", CurrentProject.Path & "\Extracted", , WinRAR, OverwriteAll
    ' الناتج: محتويات file1.rar مفكوكة في CurrentProject.Path\Extracted مع الكتابة فوق الملفات
End Sub

' مع كلمة مرور، تجاهل الملفات الموجودة
Sub ExtractSingleFileWithPasswordNoOverwriteWinRAR()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    ExtractItems CurrentProject.Path & "\file1.rar", CurrentProject.Path & "\Extracted", password, WinRAR, OverwriteNone
    ' الناتج: محتويات file1.rar مفكوكة في CurrentProject.Path\Extracted مع تجاهل الملفات الموجودة
End Sub

' ===========================================================================
' 3. ضغط عدة ملفات (كل ملف على حدة)
' ===========================================================================
' بدون كلمة مرور، نوع ZIP
Sub CompressMultipleFilesSeparateNoPasswordZipWinRAR()
    Dim filesArray As Variant
    filesArray = Array(CurrentProject.Path & "\file1.txt", CurrentProject.Path & "\file2.docx", CurrentProject.Path & "\file3.pdf")
    StartCompressionLoop
    Dim filePath As Variant
    For Each filePath In filesArray
        CompressItems CStr(filePath), , WinRAR, ArchiveZIP, CompressionNormal
    Next filePath
    ShowCompressionSuccess
    ' الناتج: file1.zip, file2.zip, file3.zip في CurrentProject.Path
End Sub

' مع كلمة مرور وتعليق
Sub CompressMultipleFilesSeparateWithCommentWinRAR()
    Dim commentLines As Variant
    Dim commentFile As String
    Dim password As String
    
    ' تعيين كلمة المرور
    password = "officena"
    
    ' إعداد التعليق باستخدام المتغير
    commentLines = Array( _
        "منتديات أوفيسنا", _
        "www.officena.net", _
        "وقت وتاريخ إنشاء الأرشيف:", _
        Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _
        "كلمة المرور لفك الضغط: " & password, _
        "مع أطيب الأماني: أبو جودى")
    
    commentFile = CreateCommentFile(commentLines, False)
    Dim filesArray As Variant
    filesArray = Array(CurrentProject.Path & "\file1.txt", CurrentProject.Path & "\file2.docx", CurrentProject.Path & "\file3.pdf")
    StartCompressionLoop
    Dim filePath As Variant
    For Each filePath In filesArray
        CompressItems CStr(filePath), password, WinRAR, ArchiveRAR, CompressionNormal, , , , , commentFile
    Next filePath
    ShowCompressionSuccess
    ' الناتج: file1.rar, file2.rar, file3.rar (مشفرة، مع تعليق) في CurrentProject.Path
End Sub

' ===========================================================================
' 4. فك ضغط عدة ملفات (كل ملف على حدة)
' ===========================================================================
' بدون كلمة مرور
Sub ExtractMultipleFilesSeparateNoPasswordWinRAR()
    Dim filesArray As Variant
    filesArray = Array(CurrentProject.Path & "\file1.rar", CurrentProject.Path & "\file2.rar", CurrentProject.Path & "\file3.rar")
    StartExtractionLoop
    Dim filePath As Variant
    For Each filePath In filesArray
        ExtractItems CStr(filePath), CurrentProject.Path, , WinRAR, OverwriteAll
    Next filePath
    ShowExtractionSuccess
    ' الناتج: محتويات كل ملف مفكوكة في CurrentProject.Path
End Sub

' مع كلمة مرور
Sub ExtractMultipleFilesSeparateWithPasswordWinRAR()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    Dim filesArray As Variant
    filesArray = Array(CurrentProject.Path & "\file1.rar", CurrentProject.Path & "\file2.rar", CurrentProject.Path & "\file3.rar")
    StartExtractionLoop
    Dim filePath As Variant
    For Each filePath In filesArray
        ExtractItems CStr(filePath), CurrentProject.Path, password, WinRAR, OverwriteNone
    Next filePath
    ShowExtractionSuccess
    ' الناتج: محتويات كل ملف مفكوكة في CurrentProject.Path مع تجاهل الموجود
End Sub

' ===========================================================================
' 5. ضغط عدة ملفات في أرشيف واحد
' ===========================================================================
' بدون كلمة مرور، تقسيم 100MB
Sub CompressMultipleFilesOneArchiveWithSplitWinRAR()
    Dim files As Variant
    files = Array("file1.txt", "file2.docx", "file3.pdf")
    CompressItems files, , WinRAR, ArchiveRAR, CompressionNormal, Split100MB, , "CompressedFiles"
    ' الناتج: CompressedFiles.rar مقسم إلى أجزاء بحجم 100 ميجابايت
End Sub

' مع كلمة مرور وتعليق
Sub CompressMultipleFilesOneArchiveWithCommentWinRAR()
    Dim commentLines As Variant
    Dim commentFile As String
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    
    ' إعداد التعليق باستخدام المتغير
    commentLines = Array( _
        "منتديات أوفيسنا", _
        "www.officena.net", _
        "وقت وتاريخ إنشاء الأرشيف:", _
        Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _
        "كلمة المرور لفك الضغط: " & password, _
        "مع أطيب الأماني: أبو جودى")
        
    commentFile = CreateCommentFile(commentLines, False)
    Dim files As Variant
    files = Array("file1.txt", "file2.docx", "file3.pdf")
    CompressItems files, password, WinRAR, ArchiveRAR, CompressionMaximum, , , "CompressedFiles", , commentFile
    ' الناتج: CompressedFiles.rar (مشفر، مع تعليق) في CurrentProject.Path
End Sub

' ===========================================================================
' 6. فك ضغط أرشيف واحد يحتوي على عدة ملفات
' ===========================================================================
' بدون كلمة مرور
Sub ExtractMultipleFilesOneArchiveNoPasswordWinRAR()
    Dim archives As Variant
    archives = Array(CurrentProject.Path & "\CompressedFiles.rar")
    ExtractItems archives, CurrentProject.Path, , WinRAR, OverwriteAll
    ' الناتج: محتويات CompressedFiles.rar مفكوكة في CurrentProject.Path
End Sub

' مع كلمة مرور
Sub ExtractMultipleFilesOneArchiveWithPasswordWinRAR()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    Dim archives As Variant
    archives = Array(CurrentProject.Path & "\CompressedFiles.rar")
    ExtractItems archives, CurrentProject.Path, password, WinRAR, OverwriteNone
    ' الناتج: محتويات CompressedFiles.rar مفكوكة في CurrentProject.Path مع تجاهل الموجود
End Sub

' ===========================================================================
' 7. ضغط مجلد واحد
' ===========================================================================
' مع تعليق
Sub CompressSingleFolderWithCommentWinRAR()
    Dim commentLines As Variant
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    
    ' إعداد التعليق باستخدام المتغير
    commentLines = Array( _
        "منتديات أوفيسنا", _
        "www.officena.net", _
        "وقت وتاريخ إنشاء الأرشيف:", _
        Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _
        "كلمة المرور لفك الضغط: " & password, _
        "مع أطيب الأماني: أبو جودى")
        
    Dim commentFile As String
    commentFile = CreateCommentFile(commentLines, False)
    CompressItems CurrentProject.Path & "\Folder1", password, WinRAR, ArchiveRAR, CompressionNormal, , , , , commentFile
    ' الناتج: Folder1.rar (مشفر، مع تعليق) في CurrentProject.Path
End Sub

' مع تقسيم وSFX
Sub CompressSingleFolderWithSplitSFXWinRAR()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    CompressItems CurrentProject.Path & "\Folder1", password, WinRAR, ArchiveRAR, CompressionNormal, Split1GB, , "Folder1SFX", True
    ' الناتج: Folder1SFX.exe مقسم إلى أجزاء بحجم 1 جيجابايت
End Sub

' ===========================================================================
' 8. ضغط عدة مجلدات (كل مجلد على حدة)
' ===========================================================================
' بدون كلمة مرور
Sub CompressMultipleFoldersNoPasswordWinRAR()
    Dim foldersArray As Variant
    foldersArray = Array(CurrentProject.Path & "\Folder1", CurrentProject.Path & "\Folder2")
    StartCompressionLoop
    Dim folderPath As Variant
    For Each folderPath In foldersArray
        CompressItems CStr(folderPath), , WinRAR, ArchiveRAR, CompressionNormal
    Next folderPath
    ShowCompressionSuccess
    ' الناتج: Folder1.rar, Folder2.rar في CurrentProject.Path
End Sub

' مع كلمة مرور وتعليق
Sub CompressMultipleFoldersWithCommentWinRAR()
    Dim commentLines As Variant
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    
    ' إعداد التعليق باستخدام المتغير
    commentLines = Array( _
        "منتديات أوفيسنا", _
        "www.officena.net", _
        "وقت وتاريخ إنشاء الأرشيف:", _
        Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _
        "كلمة المرور لفك الضغط: " & password, _
        "مع أطيب الأماني: أبو جودى")
        
        Dim commentFile As String
    commentFile = CreateCommentFile(commentLines, False)
    Dim foldersArray As Variant
    foldersArray = Array(CurrentProject.Path & "\Folder1", CurrentProject.Path & "\Folder2")
    StartCompressionLoop
    Dim folderPath As Variant
    For Each folderPath In foldersArray
        CompressItems CStr(folderPath), password, WinRAR, ArchiveRAR, CompressionNormal, , , , , commentFile
    Next folderPath
    ShowCompressionSuccess
    ' الناتج: Folder1.rar, Folder2.rar (مشفرة، مع تعليق) في CurrentProject.Path
End Sub

' ===========================================================================
' 9. فك ضغط مجلد واحد
' ===========================================================================
' بدون كلمة مرور
Sub ExtractSingleFolderNoPasswordWinRAR()
    ExtractItems CurrentProject.Path & "\Folder1.rar", CurrentProject.Path & "\Extracted", , WinRAR, OverwriteAll
    ' الناتج: محتويات Folder1.rar مفكوكة في CurrentProject.Path\Extracted
End Sub

' مع كلمة مرور
Sub ExtractSingleFolderWithPasswordWinRAR()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    ExtractItems CurrentProject.Path & "\Folder1.rar", CurrentProject.Path & "\Extracted", password, WinRAR, OverwriteNone
    ' الناتج: محتويات Folder1.rar مفكوكة في CurrentProject.Path\Extracted مع تجاهل الموجود
End Sub

Option Compare Database
Option Explicit

' وحدة نمطية تحتوي على أمثلة شاملة لضغط وفك ضغط باستخدام 7-Zip مع كل الخيارات

' ===========================================================================
' 1. ضغط ملف واحد
' ===========================================================================
' بدون كلمة مرور، مستوى ضغط عادي
Sub CompressSingleFileNoPasswordSevenZip()
    CompressItems "file1.txt", , SevenZip, Archive7z, CompressionNormal
    ' الناتج: file1.7z في CurrentProject.Path
End Sub

' مع كلمة مرور، مستوى ضغط أقصى
Sub CompressSingleFileWithPasswordMaxCompressionSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    CompressItems "file1.txt", password, SevenZip, Archive7z, CompressionMaximum
    ' الناتج: file1.7z (مشفر، مضغوط بأقصى مستوى) في CurrentProject.Path
End Sub

' مع تقسيم الأرشيف (Split500MB)
Sub CompressSingleFileWithSplitSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    CompressItems "file1.txt", password, SevenZip, Archive7z, CompressionNormal, Split500MB
    ' الناتج: file1.7z مقسم إلى أجزاء بحجم 500 ميجابايت
End Sub

' ذاتي الاستخراج (SFX)
Sub CompressSingleFileSFXSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    CompressItems "file1.txt", password, SevenZip, Archive7z, CompressionNormal, , , "File1SFX", True
    ' الناتج: File1SFX.exe (مشفر) في CurrentProject.Path
End Sub

' ===========================================================================
' 2. فك ضغط ملف واحد
' ===========================================================================
' بدون كلمة مرور، الكتابة فوق الملفات
Sub ExtractSingleFileNoPasswordOverwriteSevenZip()
    ExtractItems CurrentProject.Path & "\file1.7z", CurrentProject.Path & "\Extracted", , SevenZip, OverwriteAll
    ' الناتج: محتويات file1.7z مفكوكة في CurrentProject.Path\Extracted مع الكتابة فوق الملفات
End Sub

' مع كلمة مرور، تجاهل الملفات الموجودة
Sub ExtractSingleFileWithPasswordNoOverwriteSevenZip()
    ExtractItems CurrentProject.Path & "\file1.7z", CurrentProject.Path & "\Extracted", "MyPassword123", SevenZip, OverwriteNone
    ' الناتج: محتويات file1.7z مفكوكة في CurrentProject.Path\Extracted مع تجاهل الملفات الموجودة
End Sub

' ===========================================================================
' 3. ضغط عدة ملفات (كل ملف على حدة)
' ===========================================================================
' بدون كلمة مرور
Sub CompressMultipleFilesSeparateNoPasswordSevenZip()
    Dim filesArray As Variant
    filesArray = Array(CurrentProject.Path & "\file1.txt", CurrentProject.Path & "\file2.docx", CurrentProject.Path & "\file3.pdf")
    StartCompressionLoop
    Dim filePath As Variant
    For Each filePath In filesArray
        CompressItems CStr(filePath), , SevenZip, Archive7z, CompressionNormal
    Next filePath
    ShowCompressionSuccess
    ' الناتج: file1.7z, file2.7z, file3.7z في CurrentProject.Path
End Sub

' مع كلمة مرور وتقسيم
Sub CompressMultipleFilesSeparateWithSplitSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    Dim filesArray As Variant
    filesArray = Array(CurrentProject.Path & "\file1.txt", CurrentProject.Path & "\file2.docx", CurrentProject.Path & "\file3.pdf")
    StartCompressionLoop
    Dim filePath As Variant
    For Each filePath In filesArray
        CompressItems CStr(filePath), password, SevenZip, Archive7z, CompressionNormal, Split100MB
    Next filePath
    ShowCompressionSuccess
    ' الناتج: file1.7z, file2.7z, file3.7z مقسمة إلى أجزاء بحجم 100 ميجابايت
End Sub

' ===========================================================================
' 4. فك ضغط عدة ملفات (كل ملف على حدة)
' ===========================================================================
' بدون كلمة مرور
Sub ExtractMultipleFilesSeparateNoPasswordSevenZip()
    Dim filesArray As Variant
    filesArray = Array(CurrentProject.Path & "\file1.7z", CurrentProject.Path & "\file2.7z", CurrentProject.Path & "\file3.7z")
    StartExtractionLoop
    Dim filePath As Variant
    For Each filePath In filesArray
        ExtractItems CStr(filePath), CurrentProject.Path, , SevenZip, OverwriteAll
    Next filePath
    ShowExtractionSuccess
    ' الناتج: محتويات كل ملف مفكوكة في CurrentProject.Path
End Sub

' مع كلمة مرور
Sub ExtractMultipleFilesSeparateWithPasswordSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    Dim filesArray As Variant
    filesArray = Array(CurrentProject.Path & "\file1.7z", CurrentProject.Path & "\file2.7z", CurrentProject.Path & "\file3.7z")
    StartExtractionLoop
    Dim filePath As Variant
    For Each filePath In filesArray
        ExtractItems CStr(filePath), CurrentProject.Path, password, SevenZip, OverwriteNone
    Next filePath
    ShowExtractionSuccess
    ' الناتج: محتويات كل ملف مفكوكة في CurrentProject.Path مع تجاهل الموجود
End Sub

' ===========================================================================
' 5. ضغط عدة ملفات في أرشيف واحد
' ===========================================================================
' بدون كلمة مرور، تقسيم 100MB
Sub CompressMultipleFilesOneArchiveWithSplitSevenZip()
    Dim files As Variant
    files = Array("file1.txt", "file2.docx", "file3.pdf")
    CompressItems files, , SevenZip, Archive7z, CompressionNormal, Split100MB, , "CompressedFiles"
    ' الناتج: CompressedFiles.7z مقسم إلى أجزاء بحجم 100 ميجابايت
End Sub

' مع كلمة مرور وSFX
Sub CompressMultipleFilesOneArchiveSFXSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    Dim files As Variant
    files = Array("file1.txt", "file2.docx", "file3.pdf")
    CompressItems files, password, SevenZip, Archive7z, CompressionMaximum, , , "CompressedFilesSFX", True
    ' الناتج: CompressedFilesSFX.exe (مشفر) في CurrentProject.Path
End Sub

' ===========================================================================
' 6. فك ضغط أرشيف واحد يحتوي على عدة ملفات
' ===========================================================================
' بدون كلمة مرور
Sub ExtractMultipleFilesOneArchiveNoPasswordSevenZip()
    Dim archives As Variant
    archives = Array(CurrentProject.Path & "\CompressedFiles.7z")
    ExtractItems archives, CurrentProject.Path, , SevenZip, OverwriteAll
    ' الناتج: محتويات CompressedFiles.7z مفكوكة في CurrentProject.Path
End Sub

' مع كلمة مرور
Sub ExtractMultipleFilesOneArchiveWithPasswordSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    Dim archives As Variant
    archives = Array(CurrentProject.Path & "\CompressedFiles.7z")
    ExtractItems archives, CurrentProject.Path, password, SevenZip, OverwriteNone
    ' الناتج: محتويات CompressedFiles.7z مفكوكة في CurrentProject.Path مع تجاهل الموجود
End Sub

' ===========================================================================
' 7. ضغط مجلد واحد
' ===========================================================================
' مع تقسيم وSFX
Sub CompressSingleFolderWithSplitSFXSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    CompressItems CurrentProject.Path & "\Folder1", password, SevenZip, Archive7z, CompressionNormal, Split1GB, , "Folder1SFX", True
    ' الناتج: Folder1SFX.exe مقسم إلى أجزاء بحجم 1 جيجابايت
End Sub

' ===========================================================================
' 8. ضغط عدة مجلدات (كل مجلد على حدة)
' ===========================================================================
' بدون كلمة مرور
Sub CompressMultipleFoldersNoPasswordSevenZip()
    Dim foldersArray As Variant
    foldersArray = Array(CurrentProject.Path & "\Folder1", CurrentProject.Path & "\Folder2")
    StartCompressionLoop
    Dim folderPath As Variant
    For Each folderPath In foldersArray
        CompressItems CStr(folderPath), , SevenZip, Archive7z, CompressionNormal
    Next folderPath
    ShowCompressionSuccess
    ' الناتج: Folder1.7z, Folder2.7z في CurrentProject.Path
End Sub

' مع كلمة مرور وتقسيم
Sub CompressMultipleFoldersWithSplitSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    Dim foldersArray As Variant
    foldersArray = Array(CurrentProject.Path & "\Folder1", CurrentProject.Path & "\Folder2")
    StartCompressionLoop
    Dim folderPath As Variant
    For Each folderPath In foldersArray
        CompressItems CStr(folderPath), password, SevenZip, Archive7z, CompressionNormal, Split500MB
    Next folderPath
    ShowCompressionSuccess
    ' الناتج: Folder1.7z, Folder2.7z مقسمة إلى أجزاء بحجم 500 ميجابايت
End Sub

' ===========================================================================
' 9. فك ضغط مجلد واحد
' ===========================================================================
' بدون كلمة مرور
Sub ExtractSingleFolderNoPasswordSevenZip()
    ExtractItems CurrentProject.Path & "\Folder1.7z", CurrentProject.Path & "\Extracted", , SevenZip, OverwriteAll
    ' الناتج: محتويات Folder1.7z مفكوكة في CurrentProject.Path\Extracted
End Sub

' مع كلمة مرور
Sub ExtractSingleFolderWithPasswordSevenZip()
    Dim password As String
    ' تعيين كلمة المرور
    password = "officena"
    ExtractItems CurrentProject.Path & "\Folder1.7z", CurrentProject.Path & "\Extracted", password, SevenZip, OverwriteNone
    ' الناتج: محتويات Folder1.7z مفكوكة في CurrentProject.Path\Extracted مع تجاهل الموجود
End Sub

27 دقائق مضت, Foksh said:

في الكود الأخير لي ، لا أعتقد أنه يوجد نهاية للترقيم ❗

 

متخافش كودك حلو و جميل   و أنت احلى و أجمل 

يا صديقى العزيز واخى الحبيب انا لم اوجه كلام اليك مطلقا ولا لاى أحد 

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

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

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

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

الان بعد ان تمت الاجابة بشكل عملي اجمالا وتفصيلا

انا لى بعض التعقيبات البسيطه

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

ABC/000001
ABC/000002
ABC/000003
ABC/000004
ABC/000005
ABC/000006
ABC/000007
ABC/000097
ولنفترض انه تم حذف سجلات والتى تبدأ من الرقم 8 الى الى الرقم 97
سوف يكمل بالشكل التالى بدون مشاكل 
ABC/000098
ABC/000099
ABC/000100
ABC/000101
ABC/000102
ABC/000103
ABC/000104
ABC/999997
طيب لنفترض انه تم حذف سجلات أخرى والتى تبدأ من الرقم ABC/000105 الى الى الرقم ABC/999997
سوف يكمل الكود
ABC/999998
ABC/999999
والى هنا تكون نهاية الترقيم طبقا لاختيار عدد 6 منازل للترقيم فى المحاولة التاليه فورا سوف يتوقف الترقيم عن العمل 

لذلك لا أنصح بالوقوع فى هه المعضله التى لابد وحتما سوف تحدث فى وقت ما 

ومشكلة أخرى يمكن أن تحدث مع المعالجة الخاطئة 
عند الوصول الى القيمة القصوى سوف يتم تكرار هذه القيم دائما
يعنى لو افترضنا انه كان عدد المنازل 2 
ABC/01
ABC/02
ABC/03
ABC/04
ABC/05
ABC/06
ABC/07
ABC/08
ABC/09
ABC/10

سوف تتم تكرار القيمة القصوى
ABC/10
ABC/10
ABC/10
ABC/10

لذلك وجب التنويه الى الانتباه عند تعامل المبرمج مع هذه الجزئيــة

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

وكنبذه عن الموضوع والفكرة القادمه ان شاء الله تعالى الدالة التى أنوه عنها كانت فى هذه المشاركة

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

يتبع ......  

اراك تضحك يا @Foksh أفندى 

وعارفك بتضحك ليه : لانه دائما استلهم افكارى منك ومن مشاركاتك الجميله  

16 دقائق مضت, Foksh said:

مساهمتي وتقصيراً لكود @ابو جودي  ،

هههههه طيب مبدئيا وتعالى نقول ليه كودك افضل من الكود الاول والمستخدم فى المرفق : الفرق بينهما

طيب ولأن وقت الجواب كنت صايم وكان وقت الفطار خلاص وكنت مستعجل وبعد قراءة كودك الجميل

كودك افضل  ولكن ايه رايك فى كتابة الكود بهذه الطريقة  

Public Function FlexiBranchSerial(tableName As String, serialField As String, branchCode As String, Optional minDigits As Integer = 2) As String
    On Error GoTo ErrorHandler
    
    ' التحقق من المدخلات
    If Len(Trim(tableName)) = 0 Or Len(Trim(serialField)) = 0 Or Len(Trim(branchCode)) = 0 Then
        FlexiBranchSerial = "خطأ: مدخلات غير صالحة"
        Exit Function
    End If
    If minDigits < 1 Then minDigits = 2 ' ضمان حد أدنى معقول
    
    Dim db As DAO.Database
    Dim maxSerial As Variant
    Dim formatPattern As String
    
    ' إعداد نمط التنسيق بناءً على minDigits
    formatPattern = String(minDigits, "0")
    
    Set db = CurrentDb
    ' استخدام DMax للحصول على أعلى قيمة تسلسلية مع شرط دقيق
    maxSerial = DMax("Val(Left([" & serialField & "], InStr([" & serialField & "], '/') - 1))", tableName, _
                     "[" & serialField & "] LIKE '*/" & branchCode & "'")
    
    ' إذا لم يكن هناك قيمة، ابدأ من 0
    If IsNull(maxSerial) Then maxSerial = 0
    
    ' زيادة الرقم التسلسلي بـ 1
    maxSerial = maxSerial + 1
    
    ' توليد الرقم التسلسلي النهائي
    FlexiBranchSerial = Format(maxSerial, formatPattern) & "/" & branchCode
    
    Set db = Nothing
    Exit Function

ErrorHandler:
    Debug.Print "خطأ في FlexiBranchSerial: " & Err.Number & " - " & Err.Description & " | جدول: " & tableName & ", حقل: " & serialField & ", رمز الفرع: " & branchCode
    FlexiBranchSerial = "خطأ: فشل في توليد الرقم - " & Err.Description
End Function

وبعد مشاركتى للكود الاخير دعنا نضع مقارنه بين الكود الاول لحضرتك يا استاذ @Foksh   والكود الثانى 

26 دقائق مضت, ابوخليل said:

مشاركة مع حبيبنا ابا جودي

 

العفو منكم استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل 
اولا: رمضان كريم و كل عام وانتم بخير  و كل عام و انتم الى الله أقرب 

ثانيا : انتم لا تشاركون مع طلاب العلم بل أنتم تتقدمون كل طلاب العلم و انا قبلهم و أولهم فإذا حضر الماء بطل التيمم

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

39 دقائق مضت, ابوخليل said:

مارأي اخي محمد  @ابو جودي هل نستخدم  Dmax بدلا من ذلك ؟

طبعا وقطعا هى الافضل على الاطلاق مع الترقيم

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

الفرق بين DLast  ,  DCount  ,  DMax مع الترقيم التلقائي وخاصة عند حذف السجلات

1. DLast

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

2. DCount

• تستخدم DCount لحساب عدد السجلات التي تستوفي شرط/شروط 
• لا تعطي أي معلومات عن القيم المخزنة نفسها فقط عدد الإدخالات "السجلات" الموجودة
• مفيدة عندما تحتاج إلى معرفة عدد السجلات المتبقية بعد الحذف أو عدد السجلات الحاليه اما مطلقا أو مع وجود شرط /شروط

3. DMax

• تستخدم DMax لاسترجاع أكبر قيمة في حقل معين سواء كان رقميا أو نصيا
• عند التعامل مع حقل نصي يحتوي على ترقيم تلقائى بتنسيق مثل 1/1000  يجب استخدام DMax مع معالجة إضافية لاستخراج الجزء الرقمي
   

5 ساعات مضت, Lotfy14 said:

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

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

انا اشتغلت على مرفق فى موضوعك الاصلى وانت اللى كنت كاتب تاريخ الميلاد  

5 ساعات مضت, Lotfy14 said:

ولكن عوزك تخلى الموضوع كامل متكامل بجد
الاجر التامين دا بيبقى عبارة ان رقم ثابت وبعلامة عشرية 2

بمعنى الرقم بيبقى مثلا ( 3800.00 ) او ( 3500.50 ) عوزين نبقى نفصل الرقم الصحيح فى مربع والرقم العشرى فى مربع لوحده

فهمنى طبعا

انا صعيدى وفهمى على اد حالى بس هحاول افهم حاضر 

 

5 ساعات مضت, Lotfy14 said:

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

 

طبعا انت تقصد الترتيب ده داخل التقرير صح ؟

 

اتفضل 

ترقيم تلقائي حسب الفرع.accdb

السلام عليكم ورحمة الله وبركاته

اليوم اقدم لك وظيفة :  ( مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ - الإصدار الثانى  )  

باختصار بعد هذا الموضوع : 

 اداة مطهر النصوص المرنه  - FlexiTextSanitizer

الوصف:
هي أداة تهدف إلى تنظيف النصوص العربية (وغيرها) بكفاءة عالية مع دعم واسع للتخصيص.

توفر الدالة الرئيسية خيارات متعددة لمعالجة النصوص بما في ذلك

•  تطبيع الأحرف العربية
• إزالة الحركات 
• التحكم في الأرقام والأحرف الخاصة 
• إضافة أقواس تلقائية حول الأرقام 
• الاحتفاظ بالرموز الرياضية مثل √ و∑

المميزات الرئيسية:

• دعم اللغات:

1. عربية
2. لاتينية
3. أو كلاهما 

• التحكم في الأرقام والرموز:

1. الاحتفاظ بها
2. إزالتها
3. أو إضافة أقواس تلقائية

• معالجة علامات الترقيم:

1. الاحتفاظ بها كلها
2. إزالتها
3.  أو الاكتفاء بالفواصل والنقاط

• دعم الرموز الرياضية:  الاحتفاظ برموز مثل ∞ و≠ في الحالات المحددة

• التطبيع: توحيد الأحرف العربية (مثل تحويل إِ إلى ا).

كيف تعمل؟

المدخلات: نص خام مع خيارات اختيارية (تطبيع - لغة - معالجة - ترقيم)

المعالجة:

تطبيع الأحرف (اختياري)

إزالة الحركات

إضافة أقواس حول الأرقام (إذا طُلب)

تنظيف النص بناءً على نمط محدد

تقليص المسافات

المخرجات: نص نظيف و منسق حسب الخيارات المحددة

الكود داخل الوحدة النمطية العامة
 

' تعداد لتحديد وضع اللغة
Public Enum LanguageMode
    ArabicOnly = 0      ' اللغة العربية فقط
    ArabicAndLatin = 1  ' اللغة العربية واللاتينية
    LatinOnly = 2       ' اللغة اللاتينية فقط
End Enum

' تعداد لتحديد وضع المعالجة
Public Enum ProcessingMode
    KeepAll = 0         ' الاحتفاظ بالأرقام والأحرف الخاصة
    removeNumbers = 1   ' إزالة الأرقام فقط
    KeepNumbersOnly = 2 ' الاحتفاظ بالأرقام وإزالة الأحرف الخاصة
    CleanAll = 3        ' تنظيف كامل (إزالة الأرقام والأحرف الخاصة)
    KeepBrackets = 4    ' الاحتفاظ بالأرقام والأقواس (مع إضافتها تلقائيًا)
    KeepSpecialSymbols = 5 ' الاحتفاظ بالرموز الرياضية والخاصة
End Enum

' تعداد لتحديد معالجة علامات الترقيم
Public Enum punctuationMode
    KeepAllPunctuation = 0  ' الاحتفاظ بجميع علامات الترقيم
    RemoveAllPunctuation = 1 ' إزالة جميع علامات الترقيم
    KeepBasicPunctuation = 2 ' الاحتفاظ فقط بالفواصل والنقاط (, .)
End Enum

' الدالة الرئيسية: FlexiTextSanitizer
Public Function FlexiTextSanitizer(inputText As String, Optional normalize As Boolean = False, _
                                    Optional langMode As LanguageMode = ArabicOnly, _
                                    Optional processMode As ProcessingMode = KeepAll, _
                                    Optional punctuationMode As punctuationMode = KeepAllPunctuation, _
                                    Optional customSpecialChars As String = "()،؛") As String
    On Error GoTo ErrorHandler
    
    If Nz(inputText, "") = "" Then
        FlexiTextSanitizer = ""
        Exit Function
    End If

    Dim sanitizedText As String
    sanitizedText = Trim(inputText)

    ' الخطوة 1: التطبيع إذا طُلب
    If normalize Then
        Dim charReplacementPairs As Variant
        charReplacementPairs = Array( _
            Array(ChrW(1573), ChrW(1575)), _
            Array(ChrW(1571), ChrW(1575)), _
            Array(ChrW(1570), ChrW(1575)), _
            Array(ChrW(1572), ChrW(1608)), _
            Array(ChrW(1574), ChrW(1609)), _
            Array(ChrW(1609), ChrW(1610)), _
            Array(ChrW(1577), ChrW(1607)), _
            Array(ChrW(1705), ChrW(1603)), _
            Array(ChrW(1670), ChrW(1580)))
        Dim pair As Variant
        For Each pair In charReplacementPairs
            sanitizedText = Replace(sanitizedText, pair(0), pair(1))
        Next
    End If

    ' الخطوة 2: إزالة الحركات باستخدام RegExp
    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    regEx.Pattern = "[\u064B-\u0652\u0670]" ' نطاق الحركات العربية
    sanitizedText = regEx.Replace(sanitizedText, "")

    ' إزالة علامة السؤال بشكل افتراضي
    sanitizedText = Replace(sanitizedText, "?", "")

    ' الخطوة 3: إضافة أقواس تلقائية حول الأرقام إذا طُلب (KeepBrackets)
    If processMode = KeepBrackets Then
        regEx.Pattern = "(\b[\u0660-\u0669\u0030-\u0039]+\b)" ' الأرقام العربية واللاتينية
        sanitizedText = regEx.Replace(sanitizedText, "($1)")
    End If

    ' الخطوة 4: بناء نمط الأحرف المسموح بها
    Dim allowedPattern As String
    Select Case langMode
        Case ArabicOnly
            allowedPattern = "\u0621-\u064A" ' الأحرف العربية
        Case ArabicAndLatin
            allowedPattern = "\u0621-\u064A\u0041-\u007A" ' العربية واللاتينية (A-Z, a-z)
        Case LatinOnly
            allowedPattern = "\u0041-\u007A" ' اللاتينية فقط
    End Select

    ' إضافة الأرقام والأحرف الخاصة بناءً على وضع المعالجة
    Select Case processMode
        Case KeepAll
            allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039" & EscapeRegExChars(customSpecialChars)
        Case removeNumbers
            allowedPattern = allowedPattern & EscapeRegExChars(customSpecialChars)
        Case KeepNumbersOnly
            allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039"
        Case CleanAll
            ' لا شيء يُضاف (تنظيف كامل)
        Case KeepBrackets
            allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039\(\)" ' الاحتفاظ بالأرقام والأقواس
        Case KeepSpecialSymbols
            allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039\u2200-\u22FF" ' الأرقام والرموز الرياضية
    End Select

    ' إضافة علامات الترقيم بناءً على وضع المعالجة
    Select Case punctuationMode
        Case KeepAllPunctuation
            allowedPattern = allowedPattern & "!""#$%&'()*+,-./:;<=>?@[\\]^_`{|}~،؛"
        Case RemoveAllPunctuation
            ' لا شيء يُضاف (إزالة كل علامات الترقيم)
        Case KeepBasicPunctuation
            allowedPattern = allowedPattern & ",."
    End Select

    ' إضافة المسافة دائمًا وتطبيق النمط
    regEx.Pattern = "[^" & allowedPattern & "\s]" ' إزالة كل ما هو خارج النطاق
    sanitizedText = regEx.Replace(sanitizedText, "")

    ' الخطوة 5: تقليص المسافات المتعددة إلى واحدة
    regEx.Pattern = "\s+"
    sanitizedText = regEx.Replace(sanitizedText, " ")
    sanitizedText = Trim(sanitizedText)

    ' الخطوة 6: إرجاع النتيجة
    If Len(Trim(Nz(sanitizedText, ""))) = 0 Then
        FlexiTextSanitizer = vbNullString
    Else
        FlexiTextSanitizer = sanitizedText
    End If

    Exit Function

ErrorHandler:
    Debug.Print "خطأ في FlexiTextSanitizer: " & Err.Description
    FlexiTextSanitizer = ""
End Function

' دالة مساعدة: EscapeRegExChars
Private Function EscapeRegExChars(chars As String) As String
    Dim specialChars As Variant
    Dim i As Integer
    
    specialChars = Array("^", "$", ".", "*", "+", "?", "(", ")", "[", "]", "{", "}", "|", "\\", "`", "~", "&", "%", "#", "@", "<", ">")
    
    For i = LBound(specialChars) To UBound(specialChars)
        chars = Replace(chars, specialChars(i), "\" & specialChars(i))
    Next i
    
    EscapeRegExChars = chars
End Function

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

' توثيق الموديول:
' الغرض: هذا الموديول يحتوي على دالة FlexiTextSanitizer لتنظيف النصوص بدقة وسرعة مع دعم مرن للغات (العربية واللاتينية)، الأحرف الخاصة، علامات الترقيم، والرموز الرياضية.
' يستخدم تعدادات (Enums) لتسهيل الاستدعاء وتقليل الأخطاء، ويتيح التحكم الكامل في معالجة النصوص.
'
' سيناريوهات الاستدعاء:
' 1. تنظيف النص مع الاحتفاظ بالأرقام والأحرف الخاصة وعلامات الترقيم بدون تطبيع:
'    FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepAllPunctuation)
'    - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم (5 - 5)"
' 2. تنظيف النص مع إزالة الأرقام بدون تطبيع:
'    FlexiTextSanitizer(inputText, False, ArabicOnly, RemoveNumbers, KeepAllPunctuation)
'    - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم"
' 3. تنظيف النص مع الاحتفاظ بالأرقام فقط مع تطبيع:
'    FlexiTextSanitizer(inputText, True, ArabicOnly, KeepNumbersOnly, KeepAllPunctuation)
'    - مثال الناتج: "اشراف علي بعض الاماكن او المكان رقم 5 - 5"
' 4. تنظيف كامل مع تطبيع وإزالة علامات الترقيم:
'    FlexiTextSanitizer(inputText, True, ArabicOnly, CleanAll, RemoveAllPunctuation)
'    - مثال الناتج: "اشراف علي بعض الاماكن او المكان رقم"
' 5. تنظيف النص مع الاحتفاظ بالأرقام والأقواس (تلقائية) والفواصل والنقاط مع تطبيع:
'    FlexiTextSanitizer(inputText, True, ArabicOnly, KeepBrackets, KeepBasicPunctuation)
'    - مثال الناتج: "اشراف علي, بعض الاماكن او المكان رقم (5).(5)"
' 6. تنظيف النص مع دعم العربية واللاتينية والأحرف الخاصة وعلامات الترقيم:
'    FlexiTextSanitizer(inputText, False, ArabicAndLatin, KeepAll, KeepAllPunctuation, "().,")
'    - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم (5 - 5) Supervision"
' 7. تنظيف النص مع إزالة جميع علامات الترقيم:
'    FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, RemoveAllPunctuation)
'    - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم 5 5"
' 8. تنظيف النص مع الاحتفاظ بالفواصل والنقاط فقط:
'    FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepBasicPunctuation)
'    - مثال الناتج: "إشراف على, بعض الأماكن أو المكان رقم 5.5"
' 9. تنظيف نص يحتوي على علامات ترقيم كثيرة:
'    FlexiTextSanitizer("!!!؟؟؟...،،،:::;;;---___***((()))", False, ArabicOnly, KeepAll, KeepAllPunctuation)
'    - مثال الناتج: "!!!...،،،:::;;;---___***(())"
' 10. تنظيف نص يحتوي على رموز رياضية مع الاحتفاظ بها:
'    FlexiTextSanitizer("√∑∫∏∂∆∞ ≠ ± × ÷", False, ArabicAndLatin, KeepSpecialSymbols, RemoveAllPunctuation)
'    - مثال الناتج: "√∑∫∏∂∆∞ ≠ ± × ÷"
' 11. تطبيع جميع الأشكال الممكنة:
'    FlexiTextSanitizer("إِ، أ، إ، ؤ، ئ، ى، ة، ك، چ", True, ArabicOnly, KeepAll, KeepAllPunctuation)
'    - مثال الناتج: "ا، ا، ا، و، ي، ي، ه، ك، ج"

ولكن ملحوطة صغيرة طبعا وللاسف محرر الاكواد هنا مع الاكسس فقيير جدا بعكس لغات البرمجة الاخرى لا يقبل الرموز لذلك الرموز الرياضية مثل : √∑∫∏∂∆∞ سوف تتغير داخل المحرر الى علامات استفهام

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

' اختبار الدالة مع السيناريوهات المطلوبة
Sub TestFlexiTextSanitizer()
    Dim inputText As String
    inputText = "إِشْرَافٍ      عَلَى? بَعْضِ الْأَمَاكِنِ  أَوْ الْمَكَانِ رَقْمٌ  Supervision of some places or place number 5 - 5"

    Debug.Print "النص الأصلي: " & inputText
    Debug.Print "------------------------------------"

    Debug.Print "السيناريو 1 (تنظيف، الاحتفاظ بالأرقام والأحرف الخاصة، بدون تطبيع):"
    Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepAllPunctuation)
    Debug.Print "------------------------------------"

    Debug.Print "السيناريو 2 (تنظيف، إزالة الأرقام، بدون تطبيع):"
    Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, removeNumbers, KeepAllPunctuation)
    Debug.Print "------------------------------------"

    Debug.Print "السيناريو 3 (تنظيف، الاحتفاظ بالأرقام، مع تطبيع):"
    Debug.Print FlexiTextSanitizer(inputText, True, ArabicOnly, KeepNumbersOnly, KeepAllPunctuation)
    Debug.Print "------------------------------------"

    Debug.Print "السيناريو 4 (تنظيف كامل، مع تطبيع):"
    Debug.Print FlexiTextSanitizer(inputText, True, ArabicOnly, CleanAll, RemoveAllPunctuation)
    Debug.Print "------------------------------------"

    Debug.Print "السيناريو 5 (تنظيف، الاحتفاظ بالأرقام والأقواس، مع تطبيع):"
    Debug.Print FlexiTextSanitizer(inputText, True, ArabicOnly, KeepBrackets, KeepBasicPunctuation)
    Debug.Print "------------------------------------"

    Debug.Print "السيناريو 6 (العربية واللاتينية مع أحرف خاصة مخصصة والاحتفاظ بجميع علامات الترقيم):"
    Debug.Print FlexiTextSanitizer(inputText, False, ArabicAndLatin, KeepAll, KeepAllPunctuation, "().,")
    Debug.Print "------------------------------------"
    
    Debug.Print "السيناريو 7 (العربية فقط، إزالة جميع علامات الترقيم):"
    Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, RemoveAllPunctuation)
    Debug.Print "------------------------------------"
    
    Debug.Print "السيناريو 8 (العربية فقط، الاحتفاظ بالفواصل والنقاط فقط):"
    Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepBasicPunctuation)
    Debug.Print "------------------------------------"
    
    Debug.Print "السيناريو 9 (نص يحتوي على علامات ترقيم كثيرة جدًا):"
    Debug.Print FlexiTextSanitizer("!!!؟؟؟...،،،:::;;;---___***((()))", False, ArabicOnly, KeepAll, KeepAllPunctuation)
    Debug.Print "------------------------------------"
    
    Debug.Print "السيناريو 10 (نص يحتوي على رموز رياضية ورموز خاصة):"
    Debug.Print FlexiTextSanitizer(ChrW(8730) & ChrW(8721) & ChrW(8747) & ChrW(8719) & ChrW(8706) & ChrW(8710) & ChrW(8734) & ChrW(32) & ChrW(8800) & ChrW(32) & ChrW(177) & ChrW(32) & ChrW(215) & ChrW(32) & ChrW(247), False, ArabicAndLatin, KeepSpecialSymbols, RemoveAllPunctuation)
    Debug.Print "------------------------------------"
    
    Debug.Print "السيناريو 11 (تطبيع جميع الأشكال الممكنة):"
    Debug.Print FlexiTextSanitizer("إِ، أ، إ، ؤ، ئ، ى، ة، ك، چ", True, ArabicOnly, KeepAll, KeepAllPunctuation)
    Debug.Print "------------------------------------"
End Sub

السلام عليكم ورحمة الله وبركاته

اولا

16 ساعات مضت, Lotfy14 said:

واكيد ذى ما الاخ kkhalifa1960

افدنى برده وحل مشكلتى على احسن وجه

ده كده كده

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

شكر الله تعالى لهم حسن تحملهم لنا واسال الله تعالى ان يحسن اليهم كما يحسنون الينا والى كل طلاب العلم بدون كلل ولا ملل ... امين امين امين

16 ساعات مضت, Lotfy14 said:

شرح مفصل لكل شئ مشاء الله

اشكرك جدا جزاكم الله خيـرا 

16 ساعات مضت, Lotfy14 said:

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

طيب طلما ان دماغك تاهت شويه صغيرين بس وناوى تفوق وتمشى خطوة خطوه

تعالى نروح الملاهى وخليها تتوه اكثر  

16 ساعات مضت, Lotfy14 said:

احب افهم الفكرة مش بحب اشوف الحل واريح دماغى

عاوزك بقه تفهم الافكار الجديده فى التعديلات الأخيره فى المرفق الجديد هنا

تم فصل كل منطق فى داله منفصله هذا افضل للصيانه وفى اضافة اى تعديلات فى خطوة محدده 

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

ولذلك تم اضافة اجراءات جديده داخل الوحده النمطيه

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

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

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

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

 

مثل ما هو واضح من هذه الصورة

يلا راجع وحلل وتتبع الاكواد ولو وقف معاك حاجه قول 

------------------------------------

مرفق : التحديث الجديد

فصل وتوزيع ارقام الرقم القومى 2.accdb

منذ ساعه, The best said:

لكن السنة اللى بشتغل عليها بتكون بهذه الطريقة 2025/2024 .

 

يعنى انت تقصد ايه ان السنه بالطريقة دى

تقصد العمل لعام 2024 ولعام 2025 معا 
يعنى مثلا النتيجه لـ 
("فبراير", "2024/2025", "أيام_الشهر")
المفروض تكون ايه

انت طلبك مش واضح 

في 8‏/3‏/2025 at 17:00, أحمد العيسى said:

السلام عليكم

أثناء تصفحى لصفحات أوفيسنا عثرت على هذا التطبيق الرائع

ولا أعرف لمن هو بالتحديد من الأعضاء الكرام

وعليكم السلام

مش مهم هو لمين علشان كان واحد غلس 

المهم جرب المرفق ده وفيه اضافات جديده 

Full Control Of Print Report التحكم في الطابعة وخصائصها طباعة التقارير.mdb

2 ساعات مضت, Foksh said:

ولكن انت تعرفني انني أتجنب التوسعات التي قد تُربك صاحب الطلب في إجاباتي 😉 .

انا لم اقدم توسعات 
صاحب الطلب يعتمد على براميتر باللغة العربية 
وكما اوضحت لك 

ممكن شهر 7 بالعربى يتم استخدامه بالاشكال الاتيه
يوليو - يوليه - يولية

وبتثبيت الكود على احدهم سيتوقف الكود مع الباقى

وهكذا مع الايام فى موضوع الهمزات والتاء والهاء المربوطتان 

التوسعه الوحيده التى قمت بها اضافة اختصارات للقاموس لسهولة الاستدعاء او لدعم تعدد الاستدعاء 

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

وفى النهايه هى معلومات قمت بتقديمها اثراء للموضوع يا عسل ولتكون مرجعا لمن يريد فى المستقبل 

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

شوف يا سيدى انا اقصد بالمشاكل مثلا عندك شهر ابريل ممكن يكون أبريل  وشهر يونيه ممكن يكون يونيو 
ده على سبيل المثال وليس الحصر 

خلينا بقه نستخدم القواميس الممتعه فى شغلها ونكتب الداله من خلالها بالشكل ده 

Option Compare Database
Option Explicit

' تهيئة القواميس مرة واحدة فقط لتوفير الأداء
Dim monthsDict As Object
Dim daysDict As Object

' دالة لإنشاء قاموس ديناميكيًا
Public Function CreateDictionary() As Object
    Set CreateDictionary = CreateObject("Scripting.Dictionary")
End Function

' تهيئة القواميس عند بدء التشغيل
Sub InitializeDictionaries()
    If monthsDict Is Nothing Then Set monthsDict = InitializeMonthsDictionary()
    If daysDict Is Nothing Then Set daysDict = InitializeDaysDictionary()
End Sub

Function GetDaysInfo(monthInput As Variant, Optional yearValue As Variant = -1, Optional targetDay As Variant = "MonthDays") As Variant
    Dim MonthNumber As Long
    Dim firstDay As Date
    Dim totalDays As Long
    Dim daysArray(1 To 7) As Long
    Dim currentDate As Date
    Dim result As Variant
    Dim i As Long
    
    ' تهيئة القواميس مرة واحدة
    InitializeDictionaries
    
    '--- تعديل رئيسي: التحقق من السنة ---
    If IsMissing(yearValue) Or yearValue = -1 Then
        yearValue = Year(Date) ' استخدام السنة الحالية إذا لم تُحدد
    Else
        ' التأكد من أن yearValue هو رقم صحيح
        If Not IsNumeric(yearValue) Then
            GetDaysInfo = "خطأ: السنة يجب أن تكون رقمًا"
            Exit Function
        End If
        yearValue = CLng(yearValue)
    End If
    
    ' تعيين السنة الحالية إذا لم تُمرر
    If yearValue = 0 Then yearValue = Year(Date)
    
    ' معالجة إدخال الشهر
    If IsNumeric(monthInput) Then
        MonthNumber = CLng(monthInput)
    Else
        MonthNumber = GetNumberFromDict(monthsDict, monthInput)
    End If
    
    If MonthNumber < 1 Or MonthNumber > 12 Then
        GetDaysInfo = "خطأ في الشهر: " & monthInput & vbCrLf & "الأشهر المتاحة: " & Join(monthsDict.Keys, ", ")
        Exit Function
    End If
    
    ' حساب أيام الشهر
    totalDays = Day(DateSerial(yearValue, MonthNumber + 1, 0))
    firstDay = DateSerial(yearValue, MonthNumber, 1)
    
    ' تهيئة المصفوفة
    For i = 1 To 7
        daysArray(i) = 0
    Next i
    
    ' حساب أيام الأسبوع (الأحد = 1)
    For i = 0 To totalDays - 1
        currentDate = firstDay + i
        daysArray(Weekday(currentDate, vbSunday)) = daysArray(Weekday(currentDate, vbSunday)) + 1
    Next i
    
    ' معالجة طلب اليوم المستهدف
    Select Case True
        Case targetDay = "MonthDays" Or targetDay = "أيام_الشهر"
            result = totalDays
        Case targetDay = "ALL" Or targetDay = "الكل"
            result = daysArray
        Case Else
            Dim dayCode As Long
            dayCode = GetNumberFromDict(daysDict, targetDay)
            If dayCode = 0 Then
                GetDaysInfo = "خطأ في اليوم: " & targetDay & vbCrLf & "الأيام المتاحة: " & Join(daysDict.Keys, ", ")
                Exit Function
            End If
            result = daysArray(dayCode)
    End Select
    
    GetDaysInfo = result
End Function

Function InitializeMonthsDictionary() As Object
    Dim dict As Object
    Set dict = CreateDictionary()
    
    With dict
        ' شهر 1
        .Add "1", 1
        .Add "jan", 1
        .Add "january", 1
        .Add "يناير", 1
        .Add "ينا", 1
        .Add "ين", 1
        
        ' شهر 2
        .Add "2", 2
        .Add "feb", 2
        .Add "february", 2
        .Add "فبراير", 2
        .Add "فبر", 2
        .Add "فب", 2
        
        ' شهر 3
        .Add "3", 3
        .Add "mar", 3
        .Add "march", 3
        .Add "مارس", 3
        .Add "ماس", 3
        .Add "ما", 3
        
        ' شهر 4
        .Add "4", 4
        .Add "apr", 4
        .Add "april", 4
        .Add "أبريل", 4
        .Add "إبريل", 4
        .Add "ابريل", 4
        .Add "ابر", 4
        
        ' شهر 5
        .Add "5", 5
        .Add "may", 5
        .Add "مايو", 5
        .Add "ماي", 5
        
        ' شهر 6
        .Add "6", 6
        .Add "jun", 6
        .Add "june", 6
        .Add "يونية", 6
        .Add "يونيه", 6
        .Add "يونيو", 6
        .Add "يون", 6
        
        ' شهر 7
        .Add "7", 7
        .Add "jul", 7
        .Add "july", 7
        .Add "يوليو", 7
        .Add "يوليه", 7
        .Add "يولية", 7
        .Add "يول", 7
        
        ' شهر 8
        .Add "8", 8
        .Add "aug", 8
        .Add "august", 8
        .Add "أغسطس", 8
        .Add "اغسطس", 8
        .Add "أغس", 8
        
        ' شهر 9
        .Add "9", 9
        .Add "sep", 9
        .Add "september", 9
        .Add "سبتمبر", 9
        .Add "سبت", 9
        
        ' شهر 10
        .Add "10", 10
        .Add "oct", 10
        .Add "october", 10
        .Add "أكتوبر", 10
        .Add "اكتوبر", 10
        .Add "أكت", 10
        
        ' شهر 11
        .Add "11", 11
        .Add "nov", 11
        .Add "november", 11
        .Add "نوفمبر", 11
        .Add "نوف", 11
        
        ' شهر 12
        .Add "12", 12
        .Add "dec", 12
        .Add "december", 12
        .Add "ديسمبر", 12
        .Add "ديس", 12
    End With
    
    Set InitializeMonthsDictionary = dict
End Function

Function InitializeDaysDictionary() As Object
    Dim dict As Object
    Set dict = CreateDictionary()
    
    With dict
        ' الأحد
        .Add "1", 1
        .Add "sun", 1
        .Add "sunday", 1
        .Add "الأحد", 1
        .Add "الاحد", 1
        .Add "أحد", 1
        .Add "احد", 1
        .Add "ح", 1
        
        ' الإثنين
        .Add "2", 2
        .Add "mon", 2
        .Add "monday", 2
        .Add "الإثنين", 2
        .Add "الاثنين", 2
        .Add "إثنين", 2
        .Add "اثنين", 2
        .Add "ن", 2
        
        ' الثلاثاء
        .Add "3", 3
        .Add "tue", 3
        .Add "tuesday", 3
        .Add "الثلاثاء", 3
        .Add "ثلاثاء", 3
        .Add "ث", 3
        
        ' الأربعاء
        .Add "4", 4
        .Add "wed", 4
        .Add "wednesday", 4
        .Add "الأربعاء", 4
        .Add "الاربعاء", 4
        .Add "أربعاء", 4
        .Add "ر", 4
        
        ' الخميس
        .Add "5", 5
        .Add "thu", 5
        .Add "thursday", 5
        .Add "الخميس", 5
        .Add "خميس", 5
        .Add "خ", 5
        
        ' الجمعة
        .Add "6", 6
        .Add "fri", 6
        .Add "friday", 6
        .Add "الجمعة", 6
        .Add "الجمعه", 6
        .Add "جمعة", 6
        .Add "جم", 6
        .Add "ج", 6
        
        ' السبت
        .Add "7", 7
        .Add "sat", 7
        .Add "saturday", 7
        .Add "السبت", 7
        .Add "سبت", 7
        .Add "س", 7
    End With
    
    Set InitializeDaysDictionary = dict
End Function

Function GetNumberFromDict(dict As Object, key As Variant) As Long
    key = LCase(Trim(CStr(key)))
    If dict.Exists(key) Then
        GetNumberFromDict = dict(key)
    Else
        GetNumberFromDict = 0
    End If
End Function

ودى كل نتائج الكود من خلال استعلام

SELECT 
    shr,
    GetDaysInfo([shr], 0, "MonthDays") AS عدد_أيام_الشهر,
    GetDaysInfo([shr], 0, "Sunday") AS عدد_أيام_الأحد,
    GetDaysInfo([shr], 0, "Monday") AS عدد_أيام_الاثنين,
    GetDaysInfo([shr], 0, "Tuesday") AS عدد_أيام_الثلاثاء,
    GetDaysInfo([shr], 0, "Wednesday") AS عدد_أيام_الأربعاء,
    GetDaysInfo([shr], 0, "Thursday") AS عدد_أيام_الخميس,
    GetDaysInfo([shr], 0, "ج") AS عدد_أيام_الجمعة,
    GetDaysInfo([shr], 0, "السبت") AS عدد_أيام_السبت
FROM data_shr;

المميزات فى الكود

دعم كامل للغات: يقبل المدخلات بالعربية والإنجليزية (كاملة ومختصرة)

كفاءة عالية: تهيئة القواميس مرة واحدة فقط

مرونة استثنائية: يقبل حتى الاختصارات غير التقليدية واقصد بذلك
الأشهر: إضافة اختصارات مثل "ينا" (يناير), "فبر" (فبراير), "ابر" (أبريل), "ديس" (ديسمبر)
الأيام: إضافة اختصارات مثل "ح" (الأحد), "ن" (الإثنين), "جم" (الجمعة)

توثيق ذاتي: يعرض جميع الخيارات المتاحة عند حدوث خطأ

شئ مهم كمان:
ثبات النتائج: تم تثبيت بداية الأسبوع على يوم الأحد باستخدام Weekday(currentDate, vbSunday) لتجنب تأثير إعدادات النظام و لحساب الأيام بشكل دقيق

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

SELECT 
    shr,
    GetDaysInfo(10,0,"MonthDays") AS عدد_أيام_الشهر,
    GetDaysInfo("اكتوبر", 0, "ح") AS 2عدد_أيام_الأحد,
    GetDaysInfo("اكتوبر", 0, "أحد") AS 3عدد_أيام_الأحد,
    GetDaysInfo("اكتوبر", 0, "sun") AS 4عدد_أيام_الأحد,
    GetDaysInfo(10, 0, 1) AS 5عدد_أيام_الأحد
FROM data_shr;

السلام عليكم ورحمة الله تعالى وبركاته

كل عام وانتم بخيــر

يأتى شهر الخير ومعه البركات

أقدم اليكم هدية قيمة بكل ما تحمل الكلمة من معنى فى هذا الموضوع من أفكار  وأكواد وفوائد هامة لا غنى عنها مطلقا

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

وهذا هو الموضوع 

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

تعديل وتطوير بعض الاكواد والافكار لاضفاء مرونة واحترافيه وكفائه اكبر 

الفائده : 
امكانية عمل الجداول الاساسية بشكل ديناميكى من خلال الكود دون أدنى تدخل من المستخدم 

الغرض : 
سهول ومرونة وحفاظا على البيانات والاعدادت الاساسية للتطبيق 
 

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

وهذه احد الفوائد العظيمة و الهامة على سبيل المثال فقط وليس الحصر 

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

لنمضى قدما بع هذه المقدمة 

- وحدة نمطية عامة رئيسية باسم : basTablesCreator
الأكواد بداخل الوحدة النمطية

Option Compare Database
Option Explicit

' متغير عام لتخزين الحقول باستخدام القاموس
Public Fields As Object

' تعريف تعداد لأنواع الحقول المتاحة في قاعدة البيانات
Public Enum FieldTypes
    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          ' نوع الحقل: BigInt (عدد صحيح كبير جدًا، 64 بت)
    dbMultipleChoice = 109 ' نوع الحقل: Multiple Choice (حقل متعدد الخيارات)
End Enum

' دالة لإنشاء قاموس جديد عند الحاجة إليه
Public Function CreateDictionary() As Object
    Set CreateDictionary = CreateObject("Scripting.Dictionary")
End Function

' إجراء لإضافة حقل جديد إلى القاموس الذي يحتوي على الحقول المختلفة
Public Sub AddFieldToDictionary(fieldName As String, _
                                fieldType As FieldTypes, _
                                Optional fieldSize As Long = 0, _
                                Optional fieldFormat As String = "", _
                                Optional defaultValue As Variant = Null, _
                                Optional fieldCaption As String = "", _
                                Optional fieldDescription As String = "")
                                
    Dim fieldDict As Object
    Set fieldDict = CreateDictionary()

    With fieldDict
        .Add "Name", fieldName
        .Add "Type", fieldType
        .Add "Size", fieldSize
        .Add "Caption", fieldCaption
        .Add "Description", fieldDescription
        .Add "DefaultValue", defaultValue
        .Add "Format", fieldFormat
    End With

    If Fields Is Nothing Then Set Fields = CreateDictionary()
    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()

    ' التحقق مما إذا كان الجدول موجودًا بالفعل
    If IsTableExist(TableName) Then
        db.TableDefs.Delete TableName
        db.TableDefs.Refresh
    End If

    ' إنشاء كائن 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.Exists("Name") And fieldDict.Exists("Type") Then
            ' إنشاء الحقل
            If fieldDict("Type") <> dbAutoNumber Then
                Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type"))
                
                ' تعيين الحجم إذا كان الحقل نصيًا
                If fieldDict("Type") = dbText Then
                    If fieldDict.Exists("Size") And fieldDict("Size") > 0 Then
                        fld.Size = fieldDict("Size")
                    Else
                        MsgBox "حجم الحقل النصي غير صالح!", vbCritical
                        Exit Sub
                    End If
                End If
            Else
                ' إنشاء حقل AutoNumber
                Set fld = tdf.CreateField(fieldDict("Name"), dbLong)
                fld.Attributes = dbAutoIncrField
            End If

            ' تعيين القيمة الافتراضية إذا كانت مدعومة
            If fieldDict.Exists("DefaultValue") Then
                On Error Resume Next
                fld.defaultValue = fieldDict("DefaultValue")
                On Error GoTo 0
            End If

            ' إضافة الحقل إلى الجدول
            tdf.Fields.Append fld
        Else
            MsgBox "خطأ: بيانات الحقل غير مكتملة!", vbCritical
            Exit Sub
        End If
    Next key

    ' إضافة الجدول إلى قاعدة البيانات
    db.TableDefs.Append tdf
    db.TableDefs.Refresh
End Sub

' دالة لفحص ما إذا كان الجدول مفتوحًا وإغلاقه إذا لزم الأمر
Public Function CloseTableIfNecessary(TableName As String) As Boolean
    On Error Resume Next
    DoCmd.Close acTable, TableName
    CloseTableIfNecessary = (Err.Number = 0)
    On Error GoTo 0
End Function

' هذا الإجراء يقوم بإضافة أو تحديث خصائص الحقول في الجدول
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
                    ' التحقق من أن الحقل ليس من النوع AutoNumber
                    If fieldDict("Type") <> dbAutoNumber 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
                        ' إذا كان الحقل من النوع AutoNumber، لا نقوم بتعيين قيمة افتراضية
                        ' Debug.Print "Skipping defaultValue for AutoNumber field: " & fieldDict("Name")
                    End If
                Else
                    ' إذا كانت القيمة الافتراضية فارغة أو Null، نقوم بإزالة القيمة الحالية
                    If fieldDict("Type") <> dbAutoNumber Then
                        fld.defaultValue = ""
                    End If
                End If
            End If
        End If
    Next key
End Sub

' دالة لبناء شرط البحث
Private Function BuildCriteria(record As Object, uniqueFields As Variant, TableName As String) As String
    Dim criteria As String
    Dim fieldName As String
    Dim fieldValue As Variant
    Dim fieldType As DAO.DataTypeEnum
    Dim fieldIndex As Variant

    ' التحقق من أن record هو قاموس
    If Not TypeOf record Is Object  Or TypeName(record) <> "Dictionary" Then
        BuildCriteria = ""
        Exit Function
    End If

    ' بناء شرط البحث باستخدام الحقول الفريدة
    criteria = ""
    For Each fieldIndex In uniqueFields
        fieldName = Trim(fieldIndex)
        If record.Exists(fieldName) Then
            fieldValue = record(fieldName)

            ' التحقق من أن القيمة ليست Null أو فارغة
            If Not IsNull(fieldValue) And Trim(CStr(fieldValue)) <> "" Then
                If criteria <> "" Then criteria = criteria & " AND "

                ' الحصول على نوع الحقل من الجدول
                fieldType = GetFieldType(TableName, fieldName)

                ' التعامل مع القيم بناءً على نوع الحقل
            ' التعامل مع القيم بناءً على نوع الحقل
            Select Case fieldType
                Case dbText, dbMemo
                    criteria = criteria & "[" & fieldName & "] = '" & Replace(CStr(fieldValue), "'", "''") & "'"
                Case dbInteger, dbLong, dbByte, dbSingle, dbDouble, dbCurrency, dbBigInt
                    criteria = criteria & "[" & fieldName & "] = " & fieldValue
                Case dbBoolean
                    criteria = criteria & "[" & fieldName & "] = " & IIf(fieldValue, -1, 0)
                Case dbDate
                    criteria = criteria & "[" & fieldName & "] = #" & Format(fieldValue, "yyyy-mm-dd hh:mm:ss") & "#"
                Case Else
                    criteria = criteria & "[" & fieldName & "] = '" & Replace(CStr(fieldValue), "'", "''") & "'"
            End Select
            End If
        End If
    Next fieldIndex

    ' إذا لم يتم بناء شرط البحث، يعني أن القاموس فارغ
    If criteria = "" Then
        BuildCriteria = ""
    Else
        BuildCriteria = criteria
    End If
End Function

' للحصول على نوع الحقل
Private Function GetFieldType(TableName As String, fieldName As String) As DAO.DataTypeEnum
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field

    Set db = CurrentDb()
    Set tdf = db.TableDefs(TableName)

    On Error Resume Next
    Set fld = tdf.Fields(fieldName)
    If Err.Number <> 0 Then
        GetFieldType = dbText ' نوع افتراضي إذا لم يتم العثور على الحقل
        Exit Function
    End If
    On Error GoTo 0

    GetFieldType = fld.Type
End Function

' دالة مساعدة لتنسيق القيمة حسب النوع
Private Function FormatFieldValue(value As Variant) As String
    If IsDate(value) Then
        FormatFieldValue = "#" & Format(value, "mm/dd/yyyy hh:nn:ss AM/PM") & "#"
    ElseIf IsNumeric(value) Then
        FormatFieldValue = CStr(value)
    Else
        FormatFieldValue = "'" & Replace(CStr(value), "'", "''") & "'"
    End If
End Function

' دالة لتحديد ما إذا كان الحقل من نوع AutoNumber
Function IsAutoNumberField(fld As DAO.Field) As Boolean
    IsAutoNumberField = (fld.Type = dbAutoNumber)
End Function

' الإجراء الرئيسي لإنشاء أو تحديث الجدول وإدخال البيانات
Public Sub CreateOrModifyTableAndInsertData(TableName As String, Fields As Object, _
                                            Optional records As Collection = Nothing, _
                                            Optional uniqueFieldNames As String = "", _
                                            Optional bAddData As Boolean = False)
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim record As Object
    Dim uniqueFields() As String
    Dim criteria As String

    Set db = CurrentDb()

    '--- 1. إغلاق الجدول إذا كان مفتوحًا ---
    If Not CloseTableIfNecessary(TableName) Then
        MsgBox "لا يمكن تعديل الجدول لأنه مفتوح.", vbExclamation
        Exit Sub
    End If

    '--- 2. إنشاء الجدول إذا لم يوجد ---
    If Not IsTableExist(TableName) Then
        CreateNewTable TableName, Fields
    Else
        '--- 3. تحديث الهيكل فقط إذا كان bAddData = True ---
        If bAddData Then
            Dim tdf As DAO.TableDef
            Set tdf = db.TableDefs(TableName)
            EnsureFieldsExist tdf, Fields
        End If
    End If

    '--- 4. تطبيق خصائص الحقول ---
        SetFieldProperties TableName, Fields

    '--- 5. معالجة البيانات ---
    If bAddData And Not records Is Nothing And uniqueFieldNames <> "" Then
        uniqueFields = Split(uniqueFieldNames, ", ")
    
        Set rs = db.OpenRecordset(TableName, dbOpenDynaset)
    
        For Each record In records
            ' التحقق من أن record هو قاموس
            If TypeOf record Is Object  And TypeName(record) = "Dictionary" Then
                ' بناء شرط البحث مع تمرير اسم الجدول
                criteria = BuildCriteria(record, uniqueFields, TableName)
                ' Debug.Print criteria
                
                ' التحقق من صحة الشرط
                If criteria <> "" Then
                    rs.FindFirst criteria
    
                    If rs.NoMatch Then
                        rs.AddNew
                    Else
                        rs.Edit
                    End If
    
                    ' تحديث القيم
                    Dim key As Variant
                    For Each key In record.Keys
                        If Not IsAutoNumberField(rs.Fields(key)) Then
                            rs(key) = record(key)
                        End If
                    Next key
    
                    rs.Update
                Else
                    ' Debug.Print "Invalid criteria for record. Skipping..."
                End If
            Else
                ' Debug.Print "Element in records is not a valid Dictionary. Skipping..."
            End If
        Next record
    
        rs.Close
    End If
    
    Application.RefreshDatabaseWindow
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
    
    For Each key In Fields.Keys
        Set fieldDict = Fields(key)
        
        ' التحقق من عدم وجود حقل بنفس الاسم
        If Not IsFieldExist(tdf, fieldDict("Name")) Then
            ' إنشاء الحقل بناءً على النوع
            If fieldDict("Type") <> dbAutoNumber Then
                Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type"), fieldDict("Size"))
            Else
                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
        End If
    Next key
End Sub

' دالة مساعدة للتحقق من القيم الفارغة أو Null
Private Function IsEmptyOrNull(value As Variant) As Boolean
    IsEmptyOrNull = IsNull(value) Or Trim(CStr(value)) = ""
End Function

الغرض منها : 
✔ هى التى تحتوى على الجراءات والوظائف الاساسية لعملية إنشاء الجداول والحقول وخصائص الحقول

- وحدة نمطية عامة ثانوية باسم : basTablesInitialization
الاكواد بداخلها 

Option Compare Database
Option Explicit

' متغير لكتابة اسم الحقل/الحقول الفريدة لضمان عدم تكرار السجلات
Dim uniqueFields As String

' هذا الإجراء يقوم بتهيئة الجدول الخاص بتسجيل الأخطاء
Public Sub InitializeTableErrorLog()
    Dim tblName As String
    
    ' اسم جدول تسجيل الأخطاء
    tblName = "tblErrorLog"

    ' إنشاء القاموس لاحتواء الحقول
    Set Fields = CreateDictionary()
    
    ' إضافة الحقول ومعلومات كل حقل:
    ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف)
    AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "الغرض :الترقيم التلقائي"
    AddFieldToDictionary "ErrorDate", dbDate, , "dddd, mmmm dd, yyyy hh:nn:ss AM/PM", "Now()", "وقت حدوث الخطأ", "الغرض :تسجيل وقت و تاريخ حدوث الخطأ"
    AddFieldToDictionary "Source", dbText, 255, "@[red]", , "الإجراء/الوظيفة", "الغرض :اسم الإجراء/الوظيفة/النموذج/الوحده النمطية/التقرير الذي حدث فيه الخطأ"
    AddFieldToDictionary "ErrorNumber", dbLong, , , , "رقم الخطأ", "الغرض :تسجيل رقم الخطأ المرتبط بـ الإجراء/الوظيفة Err.Number"
    AddFieldToDictionary "ErrorDescription", dbText, 255, "@[Blue]", , "وصف الخطأ", "الغرض :تسجيل الوصف التفصيلي للخطأ كما يظهر في: Err.Description"
    AddFieldToDictionary "UserName", dbText, 100, "", , "حدث الخطأ مع المستخدم", "حقل : يحتوى على سجل من: Environ USERNAME"
    AddFieldToDictionary "CallExecutionTrace", dbMemo, , , , "تسلسل تنفيذ الأكواد", "الغرض :تسجيل جميع الإجراءات التي تم تنفيذها قبل حدوث الخطأ، مما يسهل تتبع مصدر المشكلة"
    AddFieldToDictionary "AdditionalInfo", dbText, 255, , , "معلومات إضافيه", "الغرض :تسجيل معلومات إضافية مخصصة يضيفها المطور عند استدعاء قيم متغيرات مهمة عند حدوث الخطأ"

    CreateOrModifyTableAndInsertData tblName, Fields, , , False

End Sub

Public Sub InitializeErrorSettingsTable()
    Dim tblName As String
    
    ' اسم جدول أعدادت الوظيفة المركزية للتعامل مع الأخطاء
    tblName = "tblErrorSettings"

    ' إنشاء القاموس لاحتواء الحقول
    Set Fields = CreateDictionary()

    ' إضافة الحقول ومعلومات كل حقل:
    ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف)
    AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "الغرض :الترقيم التلقائي"
    AddFieldToDictionary "ConfigKey", dbInteger, , , , "رقم فريد للإعداد", "الغرض :تسجيل رقم فريد لكل الإعدادات في النظام للقيم المعرفة"
    AddFieldToDictionary "ConfigValue", dbBoolean, , , False, "قيمة الإعداد", "الغرض :تسجيل القيمة المرتبطة بمفتاح الإعدادات: (تفعيل / تعطيل الإعداد)"
    AddFieldToDictionary "ConfigDescription", dbText, 100, "@[red]", , "وصف الإعداد", "الغرض :تسجيل الوصف والغرض من الإعدادات"
    
    ' إنشاء مجموعة السجلات الافتراضية
    Dim records As New Collection
    
    ' إضافة السجلات
    ' السجل الأول
    Dim record1 As Object, record2 As Object, record3 As Object
    Set record1 = CreateDictionary()
    record1("ConfigKey") = 1
    record1("ConfigValue") = True
    record1("ConfigDescription") = "ErrorLoggingEnabled :التحكم في تفعيل/تعطيل تسجيل الأخطاء في التطبيق في جدول الأخطاء"
    records.Add record1
    
    ' السجل الثانى
    Set record2 = CreateDictionary()
    record2("ConfigKey") = 2
    record2("ConfigValue") = True
    record2("ConfigDescription") = "ShowErrorMessages : التحكم في تفعيل/تعطيل عرض رسائل الخطأ للمستخدم"
    records.Add record2
    
    ' السجل الثالث
    Set record3 = CreateDictionary()
    record3("ConfigKey") = 3
    record3("ConfigValue") = True
    record3("ConfigDescription") = "DebugMode : التحكم في تفعيل/تعطيل وضع التصحيح لتتبع الأخطاء بشكل مفصل في النافذة الفورية"
    records.Add record3

    ' تحديد الحقل/الحقول  - الفريد/الفريدة والتى تمنع عملية تكرار البيانات بإضافة سجلات
    uniqueFields = "ConfigKey"

    ' إنشاء أو تعديل الجدول وإدخال البيانات
    CreateOrModifyTableAndInsertData tblName, Fields, records, uniqueFields, True
End Sub

الغرض منها : 
✔ انشاء الجداول الاجبارية والحقول اللازمة وملئ البيانات 

-------------------------------------------------------------
- وحدة نمطية عامة رئيسية باسم basErrorHandler
الاكواد بداخلها 

Option Compare Database
Option Explicit

Public ProcedureName As String

'### إعدادات التكوين (يمكن إدارتها عبر جدول tblErrorSettings) ###
Private Enum ConfigKey
    ErrorLoggingEnabled = 1
    ShowErrorMessages = 2
    DebugMode = 3
    ErrorLogTable = 4
End Enum

'### الهيكل الأساسي لتسجيل الأخطاء ###
Private Type ErrorInfo
    Source As String
    Number As Long
    Description As String
    User As String
    CallExecutionTrace As String
    recordData As String
End Type

' متغير عام لتخزين سلسلة الاستدعاءات
Public gCallExecutionTrace As Collection

' ثابت خاص لتخزين اسم جدول تسجيل الأخطاء
Private Const TableNameErrorLog As String = "tblErrorLog"

' ثابت خاص لتخزين اسم جدول إعدادات الأخطاء
Private Const TableNameErrorSettings As String = "tblErrorSettings"

'==============================================================================
' الدوال الرئيسية للاستخدام الخارجي
'==============================================================================

' معالجة الخطأ الرئيسية (يمكن استدعاؤها من أي مكان)
Public Sub HandleError(SourceProc As String, Optional ShowMessage As Boolean = True, Optional AdditionalInfo As String = "")
    Dim errInfo As ErrorInfo
    Dim errNum As Long, errDesc As String

    ' حفظ تفاصيل الخطأ قبل أي عمليات أخرى
    errNum = Err.Number
    errDesc = Err.Description

    On Error GoTo ErrorHandlerFailure

    With errInfo
        .Source = SourceProc
        .Number = errNum
        .Description = errDesc
        .User = Environ("USERNAME")
        .CallExecutionTrace = GetCallExecutionTrace()
        .recordData = AdditionalInfo
    End With
    
        InitializeErrorSettingsTable
        InitializeTableErrorLog
       
    ' تسجيل الخطأ إذا كان التسجيل مفعلاً
    If GetConfig(ErrorLoggingEnabled, True) Then
        LogError errInfo
    End If

    ' عرض رسالة الخطأ إذا كان مسموحاً
    If ShowMessage And GetConfig(ShowErrorMessages, True) Then
        ShowErrorMessage errInfo
    End If

    ' تصحيح الأخطاء إذا كان وضع التصحيح مفعلاً
    If GetConfig(DebugMode, False) Then
        DebugPrintError errInfo
    End If

    Exit Sub

ErrorHandlerFailure:
    ' Fallback إذا فشل معالج الخطأ نفسه
    MsgBox "Critical failure in error handler: " & Err.Description, vbCritical
End Sub

'==============================================================================
' الدوال الداخلية
'==============================================================================

' تسجيل الخطأ في قاعدة البيانات
Private Sub LogError(errInfo As ErrorInfo)
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    On Error GoTo LogErrorFailed
    
    Set db = CurrentDb()
    Set rs = db.OpenRecordset(GetConfig(ErrorLogTable, TableNameErrorLog), dbOpenTable, dbAppendOnly)


    With rs
        .AddNew
            !ErrorDate = Now()
            !Source = Left$(errInfo.Source, 255)
            !ErrorNumber = errInfo.Number
            !ErrorDescription = Left$(errInfo.Description, 255)
            !UserName = Left$(errInfo.User, 50)
            !CallExecutionTrace = Left$(errInfo.CallExecutionTrace, 1000)
            !AdditionalInfo = Left$(errInfo.recordData, 255)
        .Update
    End With

Cleanup:
    If Not rs Is Nothing Then rs.Close
    Set rs = Nothing
    Set db = Nothing
    Exit Sub

LogErrorFailed:
    ' Fallback: تسجيل في ملف نصي إذا فشل التسجيل في قاعدة البيانات
    LogToTextFile "ErrorLog_" & Format(Now(), "yyyymmdd") & ".log", errInfo
    Resume Cleanup
End Sub

' عرض رسالة خطأ مخصصة للمستخدم
Private Sub ShowErrorMessage(errInfo As ErrorInfo)
    Dim msg As String
    msg = GetErrorMessage(errInfo.Number) & vbCrLf & _
          "Details: " & errInfo.Description & vbCrLf & _
          "Contact: Technical Support"

    MsgBox msg, vbExclamation, "Error " & errInfo.Number
End Sub

' طباعة تفاصيل الخطأ للنافذة المباشرة (لأغراض التصحيح)
Private Sub DebugPrintError(errInfo As ErrorInfo)
    Debug.Print "=== ERROR DEBUG ==="
    Debug.Print "Time: " & Now()
    Debug.Print "Source: " & errInfo.Source
    Debug.Print "Error " & errInfo.Number & ": " & errInfo.Description
    Debug.Print "User: " & errInfo.User
    Debug.Print "Call ExecutionTrace: " & errInfo.CallExecutionTrace
    Debug.Print "Additional Info: " & errInfo.recordData
    Debug.Print "==================="
End Sub

'==============================================================================
' دوال مساعدة
'==============================================================================

' الحصول على إعدادات النظام من جدول التكوين
Private Function GetConfig(key As ConfigKey, defaultValue As Variant) As Variant
    
    Static configCache As Collection
    Dim rs As DAO.Recordset
    Dim sql As String

    If configCache Is Nothing Then
        Set configCache = New Collection
    End If

    On Error Resume Next
    GetConfig = configCache(CStr(key))
    If Err.Number = 0 Then Exit Function

    sql = "SELECT ConfigValue FROM " & TableNameErrorSettings & " WHERE ConfigKey = " & key
    Set rs = CurrentDb.OpenRecordset(sql)

    If Not rs.EOF Then
        GetConfig = rs!ConfigValue
    Else
        GetConfig = defaultValue
    End If

    configCache.Add GetConfig, CStr(key)
    rs.Close
    Set rs = Nothing
End Function

' الحصول على رسالة خطأ مخصصة
Private Function GetErrorMessage(ErrorNumber As Long) As String
    Select Case ErrorNumber
        Case 3021: GetErrorMessage = "No records found. Please check your data."
        Case 3061: GetErrorMessage = "Missing parameter in query."
        Case 7874: GetErrorMessage = "Invalid file format."
        Case Else: GetErrorMessage = "An unexpected error occurred."
    End Select
End Function


'==============================================================================
' دوال إدارة سلسلة الاستدعاءات/الإجراءات التي تم تنفيذها حتى حدوث الخطأ
' ExecutionTrace
'==============================================================================
Public Sub LogCallExecutionTrace(ProcName As String)
    If gCallExecutionTrace Is Nothing Then Set gCallExecutionTrace = New Collection
    gCallExecutionTrace.Add ProcName
End Sub


Public Sub RemoveFromCallExecutionTrace(ProcName As String)
    If gCallExecutionTrace Is Nothing Then Exit Sub
    If gCallExecutionTrace.count = 0 Then Exit Sub
    
    ' البحث عن آخر تكرار للاسم وإزالته
    Dim i As Integer
    For i = gCallExecutionTrace.count To 1 Step -1
        If gCallExecutionTrace(i) = ProcName Then
            gCallExecutionTrace.Remove i
            Exit For
        End If
    Next i
End Sub

Private Function GetCallExecutionTrace() As String
    Dim i As Integer
    Dim ExecutionTrace As String

    If gCallExecutionTrace Is Nothing Or gCallExecutionTrace.count = 0 Then
        GetCallExecutionTrace = "Call ExecutionTrace Empty"
        Exit Function
    End If

    For i = 1 To gCallExecutionTrace.count
        ExecutionTrace = ExecutionTrace & " > " & gCallExecutionTrace(i)
    Next i

    If Len(ExecutionTrace) > 0 Then
        ExecutionTrace = Mid(ExecutionTrace, 4)
    End If

    GetCallExecutionTrace = ExecutionTrace
End Function

' تسجيل الخطأ في ملف نصي كحل بديل
Private Sub LogToTextFile(FileName As String, errInfo As ErrorInfo)
    Dim fnum As Integer
    fnum = FreeFile()

    Open CurrentProject.Path & "\" & FileName For Append As #fnum
    Print #fnum, "[" & Now() & "] Error " & errInfo.Number & " in " & errInfo.Source
    Print #fnum, "User: " & errInfo.User
    Print #fnum, "Description: " & errInfo.Description
    Print #fnum, "----------------------------------------"
    Close #fnum
End Sub

الغرض والفائدة :

✔ إدارة الأخطاء بطريقة مركزيه منظمة وفعالة
إدارة الأخطاء بشكل موحد: يوفر الكود آلية مركزية للتعامل مع الأخطاء في كافة أجزاء التطبيق

✔ إمكانية تتبع الأخطاء وتخزين تفاصيلها في قاعدة البيانات أو في ملف نصي
التسجيل التلقائي للأخطاء: يقوم بتخزين الأخطاء مع تفاصيلها في قاعدة البيانات مما يسهل تتبعها وتحليلها لاحقًا

✔ تقديم رسائل مخصصة للمستخدم
تخصيص الرسائل: يتيح عرض رسائل خطأ مخصصة للمستخدم مع معلومات إضافية حول الأخطاء التي حدثت

✔ التصحيح والتتبع (Debugging)
 يسمح بتسجيل معلومات التصحيح مثل سلسلة الاستدعاءات (Call Stack) واستخدام أوضاع تصحيح الأخطاء مما يسهل اكتشاف مصدر المشكلة
يساعد المطورين على فهم تفاصيل الخطأ بسرعة بفضل تتبع سلسلة الاستدعاءات بحيث يكون من السهل تحديد أي إجراء أو وظيفة تسببت في الخطأ

✔ المرونة في إدارة التحكم في الإعدادت 
يمكن تخصيص إعدادات الكود مثل تمكين أو تعطيل التسجيل للأخطأء فى الجدول - تمكين أو تعطيل عرض الرسائل - تمكين أو تعطيل وضع التصحيح عبر جدول الإعدادات مما يجعل الحل مرنًا وقابلًا للتكيف دون الحاجة لتغيير الكود نفسه حسب الرغبة✔

✔ وظائف مساعدة
تتضمن الوظائف المساعدة مثل GetConfig التي تسترجع إعدادات النظام من الجدول: tblErrorSettings
و كذلك LogCallExecutionTrace التي تسجل تفاصيل الإجراءات أو الوظائف التي تم استدعاؤها
وكذلك  LogToTextFile لتسجيل الأخطاء في ملف نصي إذا فشل التسجيل في جدول : tblErrorLog 


-------------------------------------------------------------
- وحدة نمطية عامة ثانوية باسم basErrorHandlerTest
   ----   هذه الوحدة النمطية فقط للتجربة ولتوضيح طريقة استخدام الاجراء المركزى الموحد فى تتبع الخطأ يمكن حذفها 
الاكواد بداخلها  والتى يمكن تشغيلها من خلا F5   أو Run  للتجربـــة

'==============================================================================
' مثال مفرد لتجربة الخطأ
'==============================================================================
Public Sub TestProcedure()
    On Error GoTo ErrorHandler
    ProcedureName = "TestProcedure"
    LogCallExecutionTrace ProcedureName
    
    Dim x As Integer
    x = 1 / 0 ' خطأ
    
Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub

ErrorHandler:
    HandleError ProcedureName, AdditionalInfo:="Variable x=" & x
    Resume Cleanup
End Sub

Public Sub TestOpenForm()
    On Error GoTo ErrorHandler
    ProcedureName = "TestOpenForm"
    LogCallExecutionTrace ProcedureName
    
    Dim strFormName As String
    strFormName = "Moh3sam"
    DoCmd.OpenForm strFormName, acNormal   ' خطأ لا يوجد نموذج أصلا بهذا الاسم
    
Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub

ErrorHandler:
    HandleError ProcedureName, AdditionalInfo:="Variable strFormName=" & strFormName
    Resume Cleanup
End Sub




'==============================================================================
' مثال لعدة إجراءات مترابطه لتجربة تتبع مكان حدوث الخطأ تحديدا
' ExecutionTrace
'==============================================================================
Public Sub StartProcess()
    On Error GoTo ErrorHandler
    ProcedureName = "StartProcess"
    LogCallExecutionTrace ProcedureName

    ProcessNumber01

Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub
    
ErrorHandler:
    HandleError ProcedureName
    Resume Cleanup
End Sub

Private Sub ProcessNumber01()
    On Error GoTo ErrorHandler
    ProcedureName = "ProcessNumber01"
    LogCallExecutionTrace ProcedureName

    ProcessNumber02

Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub
    
ErrorHandler:
    HandleError ProcedureName
    Resume Cleanup
End Sub

Private Sub ProcessNumber02()
    On Error GoTo ErrorHandler
    ProcedureName = "ProcessNumber02"
    LogCallExecutionTrace ProcedureName

    ProcessNumber03

Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub
    
ErrorHandler:
    HandleError ProcedureName
    Resume Cleanup
End Sub

Private Sub ProcessNumber03()
    On Error GoTo ErrorHandler
    ProcedureName = "ProcessNumber03"
    LogCallExecutionTrace ProcedureName

    ' خطأ القسمة على صفر
    Dim x As Integer
    x = 1 / 0

Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub
    
ErrorHandler:
    HandleError ProcedureName, AdditionalInfo:="Variable x=" & x
    Resume Cleanup
End Sub

أمثالة تطبيقية :
✔ مثال مفرد :  TestProcedure خطأ عند القسمة على 0
✔ مثال مفرد :  TestOpenForm خطأ عند محاولة فتح نموذج غير موجود 

✔ مثال معقد يعتمد على عدة وظائف لتجربة التتبع : StartProcess

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

-------------------------------
تسهيلا على الجميع
- تم اضافة نموج للتجربة

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

واخيــــرا المرفق 
أتمنى أن تكونوا قد إستمتعتم معنا فى منتدانا الرائـــــــع 

دالة مركزية للتعامل مع الأخطاء.zip

السلام عليكم ورحمة الله تعالى وبركاته

كل عام وانتم بخيــر

يأتى شهر الخير ومعه البركات

ذات مرة شاركت فى موضوع بخصوص فصل الرقم القومى 

وهذا هو الموضوع 

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

ولذلك كتبت اجراء ذكي هههههههههه محدش يضحك  😡 شايفكم
يوفر العديد من العناء والاستعلامات ووجع الراس
ده غير المرونه والــ ...... ما تيجوا نشوف أحسن

اولا : وحدة نمطيه عامة باسم : basDistributeNumeric

الاكواد داخل الوحدة النمطيه هى : 

' إجراء لفحص ما إذا كان النص يحتوي على أرقام فقط
Function IsNumericOnly(ByVal InputString As String) As Boolean
    Dim i As Integer
    Dim char As String
    
    ' التحقق من أن السلسلة ليست فارغة
    If Len(InputString) = 0 Then
        IsNumericOnly = False
        Exit Function
    End If
    
    ' التحقق من أن كل حرف هو رقم فقط
    For i = 1 To Len(InputString)
        char = Mid(InputString, i, 1)
        If Not (char >= "0" And char <= "9") Then
            IsNumericOnly = False
            Exit Function
        End If
    Next i

    ' إذا كانت جميع الأحرف أرقام، ترجع True
    IsNumericOnly = True
End Function

الغرض : التأكد من ان القيمه التى سوف يتم تمريرها هى أرقام

ثم الإجراء الرئيسي : لفصل الأرقام

'  إجراء لفصل و توزيع القيم الرقمية اما فى متغير او عنصر تحكم مثل مربع نص
Public Sub DistributeNumericInput(Optional TargetObject As Object = Nothing, Optional InputValue As Variant, Optional MaxFields As Integer = 14, Optional ControlPrefix As String = "txt")
    Dim Index As Integer
    Dim ControlItem As Control
    Dim TextBoxCollection As Object ' Dictionary لتخزين مربعات النص
    Dim TargetTextBox As Control ' لتعريف كل مربع نص عند التكرار
    Dim NumericString As String
    Dim DictKey As Variant ' لتجنب مشاكل الفهارس عند التعامل مع Dictionary

    ' التحقق من نوع الإدخال ومعالجته
    If TypeName(InputValue) = "TextBox" Then
        If IsNull(InputValue.Value) Or Not IsNumericOnly(InputValue.Value) Then
            MsgBox "الإدخال غير صالح، يرجى إدخال أرقام فقط!", vbExclamation, "خطأ"
            Exit Sub
        End If
        NumericString = InputValue.Value
    ElseIf VarType(InputValue) = vbString Or VarType(InputValue) = vbVariant Then
        If Not IsNumericOnly(InputValue) Then
            MsgBox "الإدخال يجب أن يحتوي على أرقام فقط!", vbExclamation, "خطأ"
            Exit Sub
        End If
        NumericString = InputValue
    Else
        MsgBox "نوع الإدخال غير مدعوم، يرجى إدخال مربع نص أو قيمة رقمية نصية!", vbCritical, "خطأ"
        Exit Sub
    End If

    ' إنشاء قاموس لتخزين مربعات النص ذات البادئة المحددة فقط
    Set TextBoxCollection = CreateObject("Scripting.Dictionary")

    ' البحث عن مربعات النص المناسبة داخل النموذج أو التقرير
    If Not TargetObject Is Nothing Then
        For Each ControlItem In TargetObject.Controls
            ' التأكد من أن العنصر هو مربع نص ويمتلك البادئة المحددة
            If TypeName(ControlItem) = "TextBox" And Left(ControlItem.Name, Len(ControlPrefix)) = ControlPrefix Then
                Index = Val(Mid(ControlItem.Name, Len(ControlPrefix) + 1)) ' استخراج الرقم من اسم مربع النص
                If Index >= 1 And Index <= MaxFields Then
                    TextBoxCollection.Add Index, ControlItem
                End If
            End If
        Next ControlItem
    End If

    ' مسح محتوى مربعات النص إذا كان هناك مربعات متاحة
    If TextBoxCollection.Count > 0 Then
        For Each DictKey In TextBoxCollection.Keys
            TextBoxCollection(DictKey).Value = "" ' مسح القيم
        Next DictKey
    End If

    ' التحقق من توفر عدد كافٍ من مربعات النص
    If TextBoxCollection.Count > 0 And TextBoxCollection.Count < Len(NumericString) Then
        MsgBox "عدد مربعات النص غير كافٍ لعرض كافة الأرقام!", vbExclamation, "خطأ"
        Exit Sub
    End If

    ' توزيع الأرقام على مربعات النص
    For Index = 1 To Len(NumericString)
        If Index > MaxFields Then Exit For
        If TextBoxCollection.Exists(Index) Then
            Set TargetTextBox = TextBoxCollection(Index)
            TargetTextBox.Value = Mid(NumericString, Index, 1)
        Else
            Call PrintDigitInfo(Index, ControlPrefix, NumericString)
        End If
    Next Index
    
    ' تنظيف المتغيرات
    Set TextBoxCollection = Nothing
    Set TargetTextBox = Nothing
End Sub

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

✔ مرونة فائقة : يمكن استدعاء الإجراء دون الحاجة إلى تمرير Target Object إذا لم يكن مطلوبا
✔ دعم إستخدام القيم بشكل مباشر : يمكن استخدامه فقط لمعالجة قيمة رقمية وطباعة النتيجة بدلا من الحاجة إلى نموذج أو تقرير
✔ دعم الاستخدام الأمثل لتعبئة القيم : يمكن استخدامه لمعالجة القيم أو تعبئة مربعات النص حسب الحاجة

✔ الاستدعاء مع نموذج أو تقرير >>--> 
                تحديد النموذج او التقرير الحالي من خلال استخدام : Me
                تمرير اسم العنصر الذى يحتوى على القيم الرقميه " اسم مربع النص"
                لو تم الاكتفاء بذلك سوف يقوم الإجراء بفصل عدد 14 رقم  وهو المستخدم فى الكود اختياريا
                أو يمكن تمرير عدد الارقام الذى تريده حسب الحاجة  و هنا قمة المتعة والمرونه 
                 ثم بعد ذلك تمرر البادئه الخاصة باسماء مربعات النص التى تسبق الارقام
" يعنى مثلا مع الرقم القومى سوف استخدم عدد 14 مربع يبدأ  بالبادئة : txtNatId ثم الرقم من 1 الى الرقم 14 "
فى الاستدعاء التالى مثلا تحصل على فصل وتوزيع 14 أرقام

Call BindTextBoxes(Me, "txtIns", 14, "txtNatId "

أو ممكن بهذا الشكل فى هذه الحاله يتم استخدام الرقم الاختيارى المفضل ضمن الكود وهو 14 

Call BindTextBoxes(Me, "txtIns", , "txtNatId "

*  وماذا لو كان هناك اكثر من رقم مثلما هو موجود فى الموضوع المشار إليه مثل الرقم التأمينى , كود المنشأه ونريد فصلهم بنفس الآليه

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

طيب لاعادة الاستدعاء مع امثلة أخري مثل الرقم التآمينى مثلا
                تحديد النموذج او التقرير الحالي من خلال استخدام : Me
                تمرير اسم العنصر الذى يحتوى على القيم الرقميه " اسم مربع النص"
                لو تم الاكتفاء بذلك سوف يقوم الإجراء بفصل عدد 14 رقم  وهو المستخدم فى الكود اختياريا
                أو يمكن تمرير عدد الارقام الذى تريده حسب الحاجة  و هنا قمة المتعة والمرونه  سوف نستخدم مثلا 10 أرقام
                 ثم بعد ذلك تمرر البادئه الخاصة باسماء مربعات النص التى تسبق الارقام
مثلا مع الرقم التآمينى سوف استخدم عدد 10 مربع يبدأ  بالبادئة : txtIns ثم الرقم من 1 الى الرقم 10"

Call DistributeNumericInput(Me, lngInsuranceID, 10, "txtIns")

وهكذا حسب الحاجة وحسب الرغبه 

*  اذا أردانا التجربة للطباعة داخل النافذة الفورية على سبيل التجربة 

' لتجربة طباعة النتيجة مباشرة في النافذة الفورية
Private Sub PrintDigitInfo(Index As Integer, ControlPrefix As String, NumericString As String)
    Debug.Print "Digit Index " & Format(Index, "00") & " is : >>-> " & ControlPrefix & " " & Mid(NumericString, Index, 1)
End Sub

ونكتب مباشرة فى النافذة الفورية على سبيل المثال :

DistributeNumericInput , "9876543210",5,""

سوف نحصل منها على النتيجة التاليه لفصل الارقام الخمسة الاولى 
Digit Index 01 is : >>->  9
Digit Index 02 is : >>->  8
Digit Index 03 is : >>->  7
Digit Index 04 is : >>->  6
Digit Index 05 is : >>->  5

- طيب لنفترض اناا نريد تنفيذ عملية الفصل والتوزيع فى نموذج مستمر :
 برضو كتبت لكم إجراء ذكى لعمل استعلام ديناميكى 
الكود فى الوحدة النمطيه

' إجراء لإنشاء استعلام ديناميكي بناءً على الحقول المدخلة
Public Function GenerateDynamicSQL(tableName As String, ParamArray RequiredFieldsDistribute() As Variant) As String
    Dim sqlQuery As String
    Dim i As Integer
    Dim fieldName As String
    Dim maxDigits As Integer
    Dim fieldPrefix As String
    Dim fieldInfo As Variant
    
    ' بدء بناء جملة SQL
    sqlQuery = "SELECT " & tableName & ".*, "
    
    ' معالجة كل حقل مطلوب مع عدد الأرقام والبادئة الخاصة به
    For Each fieldInfo In RequiredFieldsDistribute
        fieldName = fieldInfo(0)  ' اسم الحقل
        maxDigits = fieldInfo(1)  ' عدد الأرقام المطلوب توزيعها
        fieldPrefix = fieldInfo(2) ' البادئة المخصصة للحقول
        
        ' إنشاء الحقول المحسوبة لكل رقم في الحقل المطلوب مع البادئة
        For i = 1 To maxDigits
            sqlQuery = sqlQuery & "IIf(IsNull([" & fieldName & "]) OR Len([" & fieldName & "]) < " & i & ", Null, Mid([" & fieldName & "], " & i & ", 1)) AS " & fieldPrefix & i & ", "
        Next i
    Next fieldInfo
    
    ' إزالة الفاصلة الأخيرة لإكمال الجملة بشكل صحيح
    sqlQuery = Left(sqlQuery, Len(sqlQuery) - 2)
    
    ' إضافة جملة FROM
    sqlQuery = sqlQuery & " FROM " & tableName & ";"
    
    ' إرجاع جملة SQL النهائية
    GenerateDynamicSQL = sqlQuery
End Function

الغرض : عمل استعلام ديناميكى بكل سهولة ليكون مصدر بيانات للنموذج المستمر
الفوائد :

✔ مرونة فائقة : تمرير اسم الجدول الذى يحتوى على حقل/حقول الأرقام المراد فصلها وتوزيعها
✔ مرونة فائقة : تمرير اسم (الحقل/حقول) للأرقام وذلك من خلال مصفوفة وفق الإجراء السابق

الكود فى الوحدة النمطيه :

' إجراء للتحقق من وجود عنصر التحكم في النموذج
Private Function ControlExists(frm As Form, ctrlName As String) As Boolean
    On Error Resume Next
    ControlExists = Not (frm.Controls(ctrlName) Is Nothing)
    On Error GoTo 0
End Function

' إجراء لربط مربعات النص بحقول البيانات تلقائيًا
Sub BindTextBoxes(frm As Form, prefix As String, maxDigits As Integer)
    Dim i As Integer
    Dim ctrlName As String
    
    ' تعيين الحقول بناءً على العدد الصحيح لكل نوع
    For i = 1 To maxDigits
        ctrlName = prefix & i
        
        ' التحقق من وجود العنصر قبل تعيين ControlSource
        If ControlExists(frm, ctrlName) Then
            frm.Controls(ctrlName).ControlSource = ctrlName ' الحقل مرتبط مباشرة بالاستعلام
        End If
    Next i
End Sub

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

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

Private Sub Form_Open(Cancel As Integer)
    ' تعريف متغير لتخزين جملة SQL
    Dim sqlStatement As String
    
    ' إنشاء استعلام SQL ديناميكي لجلب البيانات المطلوبة مع توزيع الأرقام في الحقول
    sqlStatement = GenerateDynamicSQL("tblEmployees", _
                                      Array("NationalID", 14, "txtNatId"), _
                                      Array("InsuranceID", 10, "txtIns"), _
                                      Array("OrganizationID", 10, "txtOrg"))

    ' تعيين جملة SQL كمصدر بيانات للنموذج
    Me.RecordSource = sqlStatement
    
    ' إعادة تحميل البيانات بعد تحديث مصدر السجلات
    Me.Requery
End Sub

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

Private Sub Form_Current()
    ' ربط مربعات النصوص ببيانات الهوية القومية (14 خانة)
    Call BindTextBoxes(Me, "txtNatId", 14)
    
    ' ربط مربعات النصوص ببيانات الرقم التأميني (10 خانات)
    Call BindTextBoxes(Me, "txtIns", 10)
    
    ' ربط مربعات النصوص ببيانات كود المنشأة (10 خانات)
    Call BindTextBoxes(Me, "txtOrg", 10)
End Sub

بذلك نضمن فصل وتوزيع الارقام بشكل آلى 
 

* طيب الان لو أردنا عمل الفصل والتوزيع داخل تقرير :
فى تصميم التقرير نقوم بالاعلان عن المتغيرات التاليه

' تعريف متغيرات لتخزين القيم النصية للأرقام
Dim lngNationalID As String
Dim lngInsuranceID As String
Dim lngOrganizationID As String

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

Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
    ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بالرقم القومي
    If Not IsNull(Me!txtNationalID) Then
        lngNationalID = Trim(Me!txtNationalID) ' إزالة المسافات الفارغة من بداية ونهاية النص
    Else
        lngNationalID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات
    End If
    
    ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بالرقم التأميني
    If Not IsNull(Me!txtInsuranceID) Then
        lngInsuranceID = Trim(Me!txtInsuranceID) ' إزالة المسافات الفارغة من بداية ونهاية النص
    Else
        lngInsuranceID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات
    End If

    ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بالرقم القومي
    Call DistributeNumericInput(Me, lngNationalID, 14, "txtNatId")
    
    ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بالرقم التأميني
    Call DistributeNumericInput(Me, lngInsuranceID, 10, "txtIns")
End Sub

Private Sub PageHeaderSection_Format(Cancel As Integer, FormatCount As Integer)
    ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بكود المنشأة
    If Not IsNull(Me!txtOrganizationID) Then
        lngOrganizationID = Trim(Me!txtOrganizationID) ' إزالة المسافات الفارغة من بداية ونهاية النص
    Else
        lngOrganizationID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات
    End If
    
    ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بكود المنشأة
    Call DistributeNumericInput(Me, lngOrganizationID, 10, "txtOrg")
End Sub

---------------------------------------------

صورة توضيحيه من نموذج مفرد


---------------------------------------------
صورة توضيحية من نموذج مستمر


---------------------------------------------
صورة توضيحية من تقرير

واخيــــرا المرفق 
أتمنى أن تكونوا قد إستمتعتم معنا فى منتدانا الرائـــــــع 

فصل و توزيع ارقام الرقم القومى.zip

اتفضل 

 

1.accdb

21 دقائق مضت, Foksh said:

وجزاك الله كل الخير على مجهودك الجميل والكبير حتى تصل لهذه النتيجة ..

جزانا الله واياكم خير الجزاء

21 دقائق مضت, Foksh said:

اسمح لي بسؤال خطر على بالي :-

بما أن الكود يعتمد على مكتبة DAO ؛ هل سيدعم الإصدارات القديمة التي لا تدعم هذه المكتبة !!!

لازم سؤال لولبى ...  ليه الإحراج ده  

شوف يا سيدى 
انا لم استخدم المكتبه المدمجه باضافتها كـ  References فى القاعده 
بناء على ذلك لم اقم بتعريف المتغيرات بهذا الشكل : Dim db As Databaseوالذى يعتمد على المكتبه السابقة فى الاصدارات القديمه

بل قمت بتعريف المتغيرات بالشكل التالى : Dim db As DAO.Database
وهذا يقلل من احتمالية الأخطاء إذا كانت المكتبة مفقودة

اعرف ان الاصدرات الحديثه بدأ من 2013 وما بعده تستخدم DAO المدمج مع محرك ACE (Access Connectivity Engine) وتستبدل محرك Jet القديم

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

ولكن بصراحة الامر يستوجب التجربه للتأكد