ابو جودي

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

طبعا مما لاشك فيه لابد للطالب من الاستئذان توقيرا واجلا للمعلم القدير الجليل حاسس انى اتدبست - او غلطت فى شئ - أو يتم اختبارى وأنا أقلق من هذه الموافق جدا ولكن سوف ادلى بدلوي فإن اخطأت فهذا مني ومن سوء فهمي وتقديري أنا و وقتها تصحون لي خطئي وجزاكم الله عني كل خير وإن أصبت فلقد تعلمت على ايديكم فأنتم أحد الأساتذة العظماء الذين أدين لهم بالفضل بعد رب العزة سبحانه وتعالي سؤالك جدا ممتاز يا أستاذي ويفتح مجالا لفهم أعمق لدالتي Nz وTrim خاصة في سياق التحقق من الحقول الفارغة دعني أوضح حسب فهمى المتواضح الفائدة من استخدام هاتين الدالتين ومتى تكونان ضرورييتان و ما الفرق بين استخدامهما أو عدمهما مع مثال أولا شرح الدالتين: 1- دالة Nz : Nz(Value, ValueIfNull) تستخدم لتحويل قيمة Null إلى قيمة أخرى محددة (مثل "" أو 0 حسب رغبة مطور النظم ) مفيدة جدا عندما تتعامل مع حقل قد يحتوي على Null لأن أي عملية مقارنة مع Null (مثل Null = "") ترجع Null وليس True أو False 2- دالة Trim : Trim(Value) تزيل المسافات البيضاء (Whitespace) من بداية و نهاية السلسلة النصية مثل " abs " أو " abs" أو "abs " تصبح "abc" لا تتعامل مع Null فإذا كانت القيمة هى Null فإن Trim(Null) يظل Null الهدف: تريد التحقق مما إذا كان الحقل (Me.yyy) "فارغا" أم لا "فارغ" قد يعني: Null (لا قيمة على الإطلاق) "" (سلسلة فارغة). " " أو " " (مسافات فقط) ** إذا كان الحقل فارغا بأي من هذه الحالات يتحقق الشرط و إذا كان يحتوي على قيمة فعلية (مثل "abc") لا يتحقق الشرط. سؤال حضرتك : هل استخدام Nz و Trim يضيف ميزة إضافية في هذا السياق أم أن التحقق الأساسي بـ IsNull و = "" كاف؟ 1- بدون Nz و Trim: If Me.xxx <> 0 And (IsNull(Me.yyy) Or Me.yyy = "") Then ' الشرط تحقق Else End If يتحقق الشرط إذا: Me.yyy هو Null Me.yyy هو "" (سلسلة فارغة) لا يتحقق الشرط إذا: Me.yyy يحتوي على مسافات فقط (مثل " " أو " ")، لأن " " <> "" Me.yyy يحتوي على نص (مثل "abc")، وهذا متوقع 2- مع Nz و Trim: If Me.xxx <> 0 And (IsNull(Me.yyy) Or Trim(Nz(Me.yyy, "")) = "") Then ' الشرط تحقق Else End If يتحقق الشرط إذا: Me.yyy هو Null (لأن Nz يحوله إلى "" و Trim("") = "") Me.yyy هو "" (لأن Trim("") = "") Me.yyy هو " " أو " " (لأن Trim(" ") = "") لا يتحقق الشرط إذا: Me.yyy يحتوي على نص فعلي (مثل "abc")، لأن Trim("abc") <> "" الميزة الإضافية لـ Nz و Trim: Nz: يضمن التعامل مع Null بطريقة آمنة مما يمنع أي أخطاء غير متوقعة إذا حاولت مقارنة Null مباشرة في الكود بدون Nz الشرط IsNull(Me.yyy) كاف لكن استخدام Nz يجعل الكود أكثر مرونة إذا أردت لاحقا إجراء عمليات إضافية على القيمة Trim: يضيف القدرة على اعتبار المسافات البيضاء (Whitespace) كقيمة "فارغة" بدون Trim إذا كان Me.yyy = " " »--»» فإن الشرط لن يتحقق لأن " " <> "" الفرق الأساسي: بدون Trim و Nz: لا يعتبر المسافات فقط (" ") فارغة مع Trim و Nz: يعتبر المسافات فقط فارغة بالإضافة إلى Null و "" الأمثلة العملبة : 1- الكود بدون Nz و Trim Me.xxx = 5 , Me.yyy = Null → "الشرط تحقق" Me.xxx = 5 , Me.yyy = "" → "الشرط تحقق" Me.xxx = 5 , Me.yyy = " " → "الشرط لم يتحقق" (لأن " " <> "") "Me.xxx = 5 , Me.yyy = "abc → "الشرط لم يتحقق" 2- الكود مع Nz و Trim Me.xxx = 5 , Me.yyy = Null → "الشرط تحقق" Me.xxx = 5 , Me.yyy = "" → "الشرط تحقق" Me.xxx = 5 , Me.yyy = " " → "الشرط تحقق" (لأن Trim(" ") = "") "Me.xxx = 5 , Me.yyy = "abc → "الشرط لم يتحقق" الخلاصة: إذا كان مطور النظم لا يهتم بالمسافات (مثل " " ) ويتعتبرها قيمة غير فارغة فالكود الأبسط بدون Nz و Trim كاف إذا كان مطور النظم يريد أن تعتبر المسافات فارغة (مثل " " ) فاستخدام Trim و Nz يعطي ميزة إضافية إذا نستخلص مما سبق أن Trim و Nz يجعلان الكود أكثر شمولية للتعامل مع جميع حالات "الفراغ" ( Null , سلسلة فارغة , مسافات فقط ) مما يجعله أكثر مرونة إذا كانت البيانات غير متسقة أو تحتوي على إدخالات غير متوقعة مثل المسافات

و مشاركه مع استاذى القدير و معلمى الجليل الاستاذ @ابو عارف وطبعا بعد إذنه اضافة بسيطه If Me.xxx <> 0 And (IsNull(Me.yyy) Or Trim(Nz(Me.yyy, "")) = "") Then ' هنا نكتب الحدث Else End If Nz(Me.yyy, ""): يحول Null إلى "" Trim(...) = "": يتحقق إذا كانت النتيجة بعد إزالة المسافات فارغة مما يغطي Null , "" , " "

طيب الحل فى المشاركة السابقة كنت قمت به اجتهادا قبل فترة من الزمن ولكن لم اكن على دراية كاملة بالتفاصيل آنذاك وذلك كان فى بداية الشروع لسن هذا القانون و بكل صراحة انا وضعت الحل اولا قبل محاولة فتح الاكسل اصلا بناء على دراية سابقة ولكن استوقفتنى هذه الجملة عند مراجعتى للموضوع بعد نشر الحل الاول بالمشاركة السابقة و بعد فتح الاكسل وبعد وضع الحل فى المشاركة وبالاخص بعد كســر الحماية عن ملف الاكسل وبعد التركيز اكتشفت انه هناك شرط أخر ايضا ليس فقط عام الميلاد المستخرج من تاريخ الميلاد ولكن العام مع الشهر وبعد البحث على الانترنت وعن القانون الذى لم أكن اعرف رقمه حصلت على التالى * ملاحظة هامة : الجدول السابق لا يوضح صراحة سن التقاعد للمواليد قبل 1 يوليو 1971 لذلك سوف أفترض أنهم يخرجون على المعاش في سن 60 عاما وهو السن التقليدي قبل تطبيق الزيادة التدريجية لذلك سوف أقوم ببعض التعديلات للتناسب مع كل الشروط السابقة الكود الجديد Public Function GetRetirementInfo(birthDate As Variant, Optional showDetails As Boolean = False) As String Dim retirementAge As Integer Dim retirementDate As Date Dim remainingYears As Integer Dim remainingMonths As Integer Dim remainingDays As Integer Dim result As String Dim currentDate As Date Dim tempDate As Date ' التحقق من تاريخ الميلاد If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "يرجى إدخال تاريخ ميلاد صالح" Else birthDate = CDate(birthDate) ' تحديد سن التقاعد بناءً على تاريخ الميلاد If birthDate < DateSerial(1971, 7, 1) Then retirementAge = 60 ElseIf birthDate < DateSerial(1972, 7, 1) Then retirementAge = 61 ElseIf birthDate < DateSerial(1973, 7, 1) Then retirementAge = 62 ElseIf birthDate < DateSerial(1974, 7, 1) Then retirementAge = 63 ElseIf birthDate < DateSerial(1975, 7, 1) Then retirementAge = 64 Else retirementAge = 65 End If ' حساب تاريخ التقاعد retirementDate = DateAdd("yyyy", retirementAge, birthDate) If showDetails Then currentDate = Date ' حساب السنوات المتبقية remainingYears = DateDiff("yyyy", currentDate, retirementDate) tempDate = DateAdd("yyyy", remainingYears, currentDate) If tempDate > retirementDate Then remainingYears = remainingYears - 1 tempDate = DateAdd("yyyy", remainingYears, currentDate) End If ' حساب الأشهر المتبقية remainingMonths = 0 While DateAdd("m", 1, tempDate) <= retirementDate remainingMonths = remainingMonths + 1 tempDate = DateAdd("m", 1, tempDate) Wend ' حساب الأيام المتبقية remainingDays = DateDiff("d", tempDate, retirementDate) ' تجميع النتيجة result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "سن التقاعد: " & retirementAge & vbCrLf & _ "تاريخ التقاعد: " & retirementDate & vbCrLf & _ "السنوات المتبقية: " & remainingYears & vbCrLf & _ "الأشهر المتبقية: " & remainingMonths & vbCrLf & _ "الأيام المتبقية: " & remainingDays Else result = "تاريخ التقاعد: " & retirementDate End If End If GetRetirementInfo = result End Function و يتم استدعاء الكود بأحد الطريقتين تمام كما تم مع الكود السابق الاولى للحصول على تاريخ التقاعد فقط GetRetirementInfo([Emp_BirthDate]) الثانية : بيانات شاملة GetRetirementInfo([Emp_BirthDate],True) وبهذا تكون هذه القاعده الجديده بهذا الكود وفق المعايير الصحيحه طبقا للقانون وأخيرا المرفق سن التقاعد (3).accdb

اتفضل ده الكود فى الوحده النمطيه التى تحمل اسم : basRetirementInfo Option Compare Database Option Explicit Public Function GetRetirementInfo(birthDate As Variant, Optional showDetails As Boolean = False) As String Dim retirementAge As Integer Dim retirementDate As Date Dim remainingYears As Integer Dim remainingMonths As Integer Dim remainingDays As Integer Dim retirementYear As Integer Dim result As String ' التحقق من أن تاريخ الميلاد ليس فارغًا If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "يرجى إدخال تاريخ ميلاد صالح" Else birthDate = CDate(birthDate) ' تحديد سن التقاعد بناءً على سنة الميلاد Select Case Year(birthDate) Case Is < 1972 retirementAge = 60 Case Is < 1974 retirementAge = 61 Case Is < 1976 retirementAge = 62 Case Is < 1978 retirementAge = 63 Case Is < 1980 retirementAge = 64 Case Else retirementAge = 65 End Select ' حساب تاريخ التقاعد retirementDate = DateAdd("yyyy", retirementAge, birthDate) retirementYear = Year(retirementDate) If showDetails Then ' حساب السنوات والأشهر والأيام المتبقية حتى التقاعد remainingYears = IIf(DateDiff("yyyy", Date, retirementDate) < 0, 0, DateDiff("yyyy", Date, retirementDate)) remainingMonths = IIf(DateDiff("m", Date, retirementDate) < 0, 0, DateDiff("m", Date, retirementDate)) remainingDays = IIf(DateDiff("d", Date, retirementDate) < 0, 0, DateDiff("d", Date, retirementDate)) ' إعداد النتيجة مع كل التفاصيل result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "سن التقاعد: " & retirementAge & vbCrLf & _ "تاريخ التقاعد: " & retirementDate & vbCrLf & _ "سنة التقاعد: " & retirementYear & vbCrLf & _ "السنوات المتبقية: " & remainingYears & vbCrLf & _ "الأشهر المتبقية: " & remainingMonths & vbCrLf & _ "الأيام المتبقية: " & remainingDays Else ' إعداد النتيجة لتاريخ التقاعد فقط result = retirementDate End If End If ' إرجاع النتيجة GetRetirementInfo = result End Function بيتم استدعاء الكود بأحد الطريقتين الاولى للحصول على تاريخ التقاعد فقط GetRetirementInfo([Emp_BirthDate]) الثانية : بيانات شاملة GetRetirementInfo([Emp_BirthDate],True) طبعا مفيش دلع اكتر من كده ... شغل فاخر من الاخر وطبعا انت جايب لنا ملف اكسل مقفول وده يا سيدى ملف الاكسل مفتوح حذفت لك الحمايه من عليه علشان تقدر تشوف المعادلات بس ركز علشان المعادلات ما تخرب منك بدون ما تشعر داخل الاكسل برنامج حساب سن المعاش 2.xlsx سن التقاعد 2.accdb

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

اثراء للموضوع دى داله معدله ومحدثه لـما يعرف بـ ShellWait أو Shell_n_Wait فى هذا الموضوع

السلام عليكم ورحمة الله وبركاته أشارك معكم اليوم وحدة نمطية متقدمة باسم basShellExecutor تهدف إلى توفير حلول مرنة وفعالة لتنفيذ الأوامر والملفات في بيئة Windows مع تحكم دقيق بالعمليات تم تصميم هذه الوحدة لتلبية احتياجات المطورين المختلفة والمتنوعة وتعرف او شائعه لدى المطورين باسم : ShellWait ولكن تم اعادة هيكلة وتطوير الوظائف بشكل احترافى لاضفاء أكبر قدر ممكن من الفاعليه والمرونة والكفائه وتعدد الاستخدمات ودعم تنوع الخيارات الممكنه بقدر الإمكان مميزات الكود المرونة: يدعم تنفيذ الأوامر بثلاث طرق (انتظار غير محدود , مهلة زمنية محددة , تنفيذ بسيط) مما يجعله متعدد الاستخدامات الاستجابة: يستخدم " DoEvents " لضمان استجابة واجهة المستخدم أثناء الانتظار مما يمنع تجمد التطبيق التحكم الدقيق: يتيح إنهاء الحلقات يدويا عبر متغير عام (g_TerminateLoops) ويمنع التداخل بين الاستدعاءات باستخدام (m_IsExecuting) التوافق: توافق تعريفات API مع أنظمة 32 بت و64 بت معالجة الأخطاء: يوفر معالجة أخطاء قوية مع رسائل واضحة لتسهيل التصحيح التنظيم: مقسم إلى أقسام واضحة (ثوابت , تعريفات , دوال) مع تعليقات عربية شاملة لتسهيل الصيانة والفهم وظيفة الكود تتيح وحدة basShellExecutor تشغيل الأوامر والملفات بثلاث طرق مختلفة مع القدرة على التحكم في وقت التنفيذ و معالجة الأحداث والتقاط النتائج الدوال الرئيسية هي: ExecuteAndWait: الغرض: تنفيذ أمر أو تشغيل ملف والانتظار حتى اكتماله مع استجابة مستمرة لواجهة المستخدم الاستخدام: مثالي للعمليات التي تحتاج إلى إكمال كامل قبل المتابعة (مثل فتح برنامج وانتظار إغلاقه) ExecuteWithTimeout: الغرض: تنفيذ أمر أو تشغيل ملف مع مهلة زمنية مع إمكانية إنهاء العملية إذا تجاوزت الحد الاستخدام: ممناسب للعمليات ذات الوقت المحدود أو التي قد تتوقف (مثل محاولة استخدام أدوات خارجية) ExecuteWScript: الغرض: تنفيذ أمر بسيط باستخدام " WScript.Shell " مع خيار الانتظار الاستخدام: مفيد للمهام السريعة دون تعقيد على سبيل المثال (مثل تشغيل أوامر CMD) ExecuteWScriptCapture (اختياري): الغرض: تنفيذ أمر والتقاط ناتجه النصي للاستخدام البرمجي الاستخدام: مثالي لتحليل نتائج الأوامر (مثل قوائم الملفات من " dir " ) اسم الوحدة النمطية العامة : basShellExecutor الكود : ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit '======================================================================================================================= '------ الثوابت Public Const PROCESS_TIMEOUT_INFINITE As Long = &HFFFFFFFF Public Const PROCESS_STILL_ACTIVE As Long = &H103 Public Const PROCESS_TERMINATED As Long = vbObjectError Or &HDEAD Public Const MAX_PATH_LENGTH As Long = 260 Public Const QS_ALL_INPUT As Long = &H4FF Private Const ERR_NO_COMMAND As Long = vbObjectError Or 1001 Private Const ERR_EXECUTING As Long = vbObjectError Or 1002 Private Const ERR_EXECUTION_FAILED As Long = vbObjectError Or 1003 Private Const ERR_TERMINATION_FAILED As Long = vbObjectError Or 1004 Private Const SHELL_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SHELL_MASK_DOENVSUBST As Long = &H200 Private Const SHELL_MASK_SUPPRESS_ERRORS As Long = &H400 Private Const PROCESS_QUERY_INFO As Long = &H400 Private Const PROCESS_SYNCHRONIZE As Long = &H100000 Private Const PROCESS_TERMINATE As Long = &H1 Private Const ERROR_ACCESS_DENIED As Long = 5 '======================================================================================================================= '------ التعدادات Public Enum ShellWindowStyle WindowHidden = 0 WindowNormal = 1 WindowMinimized = 2 WindowMaximized = 3 WindowNoActivate = 4 End Enum '======================================================================================================================= '------ الأنواع المخصصة #If VBA7 Then Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As LongPtr Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As LongPtr ItemListPointer As LongPtr ClassName As String ClassKeyHandle As LongPtr HotKey As Long IconHandle As LongPtr ProcessHandle As LongPtr End Type #Else Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As Long Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As Long ItemListPointer As Long ClassName As String ClassKeyHandle As Long HotKey As Long IconHandle As Long ProcessHandle As Long End Type #End If '======================================================================================================================= '------ تعريفات API #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr ' فتح مقبض العملية Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long ' إغلاق مقبض العملية 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 Long ' جلب رمز الخروج للعملية Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, 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 ' إعادة تخصيص حجم السلسلة Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr ' إنشاء مؤقت قابل للانتظار Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long ' جلب معرف العملية Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long ' تبسيط المسار Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr ' استخراج المعاملات من المسار Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long ' تنفيذ أمر عبر Shell 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) ' إزالة المعاملات من المسار Private Declare PtrSafe Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long ' فتح مقبض العملية Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long ' إغلاق مقبض العملية Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long ' إنشاء مؤقت قابل للانتظار Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long ' جلب معرف العملية Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long ' تبسيط المسار Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long ' استخراج المعاملات من المسار Private Declare 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 Long) As Long ' ضبط المؤقت Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long ' تنفيذ أمر عبر Shell Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long ' إعادة تخصيص السلسلة Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) ' إزالة المعاملات من المسار Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #End If '======================================================================================================================= '------ المتغيرات العامة و الخاصة Public g_TerminateLoops As Boolean ' متغير للتحكم في إنهاء الحلقات يدويًا Private m_IsExecuting As Boolean ' علامة لمنع التداخل أثناء التنفيذ '======================================================================================================================= '------------------------------------------- الدوال العامة ' تشغيل أمر والانتظار حتى ينتهي مع استجابة الواجهة Public Function ExecuteAndWait(ByVal CommandLine As String, _ Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, _ Optional ByVal RunAsAdmin As Boolean = False, _ Optional ByVal MaxWaitMs As Long = PROCESS_TIMEOUT_INFINITE) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteAndWait", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ' توسيع متغيرات البيئة ExpandedPath = ExpandEnvVars(CommandLine) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر: " & CommandLine End If ProcessHandle = .ProcessHandle End With startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If MaxWaitMs <> PROCESS_TIMEOUT_INFINITE Then If (GetTickCount - startTime) > MaxWaitMs Then Debug.Print "تجاوز الحد الأقصى للانتظار: " & MaxWaitMs & " ميلي ثانية" Exit Do End If End If Loop ExecuteAndWait = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteAndWait", Err.Description End Function ' دالة لتنفيذ أمر مع مهلة زمنية اختيارية وخيار التشغيل كمسؤول Public Function ExecuteWithTimeout(Command As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long, Optional ByVal RunAsAdmin As Boolean = False, Optional RetryCount As Long = 0) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long Dim RetryIndex As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ExpandedPath = ExpandEnvVars(Command) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If For RetryIndex = 0 To RetryCount With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then If RetryIndex = RetryCount Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteWithTimeout", "فشل في تنفيذ الأمر بعد " & RetryCount + 1 & " محاولات: " & Command End If Else ProcessHandle = .ProcessHandle Exit For End If End With Next RetryIndex startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If TimeoutMs > 0 Then If (GetTickCount - startTime) > TimeoutMs Then If TerminateProcess(ProcessHandle, PROCESS_TERMINATED) = 0 Then Debug.Print "فشل في إنهاء العملية بعد تجاوز المهلة" End If ExitCode = PROCESS_TERMINATED Exit Do End If End If If g_TerminateLoops Then Exit Do Loop ExecuteWithTimeout = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteWithTimeout", Err.Description End Function ' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار Public Function ExecuteWScript(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal WaitForCompletion As Boolean = False) As Long Dim WScriptShell As Object On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") ExecuteWScript = WScriptShell.Run(CommandLine, WindowStyle, WaitForCompletion) Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description Err.Raise Err.Number, "ExecuteWScript", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function ' دالة محسنة لتشغيل أمر باستخدام WScript.Shell والتقاط الناتج Public Function ExecuteWScriptCapture(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal) As String Dim WScriptShell As Object Dim ShellExec As Object Dim Output As String On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") Set ShellExec = WScriptShell.Exec(CommandLine) Do While ShellExec.Status = 0 DoEvents Loop Output = ShellExec.StdOut.ReadAll ExecuteWScriptCapture = Output Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description ExecuteWScriptCapture = "" Err.Raise Err.Number, "ExecuteWScriptCapture", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function '======================================================================================================================= '------ الدوال المساعدة ' دالة لتوسيع متغيرات البيئة في سلسلة (مثل %windir%) Private Function ExpandEnvVars(ByVal Path As String) As String Dim Buffer As String Dim Length As Long If InStr(Path, "%") Then Length = ExpandEnvironmentStringsW(StrPtr(Path), 0, 0) If Length > 0 Then Buffer = String$(Length - 1, vbNullChar) If ExpandEnvironmentStringsW(StrPtr(Path), StrPtr(Buffer), Length) Then ExpandEnvVars = Left$(Buffer, Length - 1) Else Debug.Print "فشل توسيع متغيرات البيئة، يتم إرجاع المسار الأصلي: " & Path ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If End Function ' دالة لتبسيط المسار (مثل حل النقاط . و ..) Private Function CanonicalizePath(ByVal Path As String) As String Dim TempPath As String If InStr(Path, "\.") Or InStr(Path, ".\") Then If Len(Path) < MAX_PATH_LENGTH Then TempPath = String$(MAX_PATH_LENGTH - 1, vbNullChar) If PathCanonicalizeW(StrPtr(TempPath), StrPtr(Path)) Then CanonicalizePath = Left$(TempPath, InStr(TempPath, vbNullChar) - 1) Else Debug.Print "فشل تبسيط المسار، يتم إرجاع المسار الأصلي: " & Path CanonicalizePath = Path End If Else CanonicalizePath = Path End If Else CanonicalizePath = Path End If End Function ' دالة لاستخراج المعاملات من المسار Private Function ExtractArguments(ByRef Path As String) As String SysReAllocString VarPtr(ExtractArguments), PathGetArgsW(StrPtr(Path)) If LenB(ExtractArguments) Then PathRemoveArgsW StrPtr(Path) If InStr(ExtractArguments, """") Then ExtractArguments = Replace(ExtractArguments, """", """""") End If End Function ' دالة مساعدة لاستخراج اسم العملية من الأمر Private Function ExtractProcessName(ByVal CommandLine As String) As String Dim Parts() As String Dim FirstPart As String If Left(CommandLine, 1) = """" Then FirstPart = Mid(CommandLine, 2, InStr(2, CommandLine, """") - 2) Else Parts = Split(CommandLine, " ") FirstPart = Parts(0) End If ExtractProcessName = Mid(FirstPart, InStrRev(FirstPart, "\") + 1) End Function ' دالة لإنهاء عملية باستخدام WMI بناءً على اسم العملية Public Function KillProcess(sProcessName As String, Optional sHost As String = ".") As Boolean On Error GoTo Error_Handler Dim oWMI As Object Dim sWMIQuery As String Dim oCols As Object Dim oCol As Object Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2") sWMIQuery = "SELECT Name FROM Win32_Process" Set oCols = oWMI.ExecQuery(sWMIQuery) For Each oCol In oCols If LCase(sProcessName) = LCase(oCol.Name) Then oCol.Terminate End If Next oCol KillProcess = True Error_Handler_Exit: On Error Resume Next Set oCol = Nothing Set oCols = Nothing Set oWMI = Nothing Exit Function Error_Handler: Debug.Print "خطأ في KillProcess: " & Err.Description & " - رقم الخطأ: " & Err.Number KillProcess = False Resume Error_Handler_Exit End Function وأخيــــرا الامثلة : '======================================================================================================================= '------ أمثلة الاستدعاء ' مثال لاستدعاء ExecuteAndWait ' يفتح Notepad وينتظر إغلاقه Sub TestExecuteAndWait() Dim ExitCode As Long On Error Resume Next ExitCode = ExecuteAndWait("notepad.exe C:\test.txt", WindowNormal) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "رمز الخروج: " & ExitCode Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout ' يفتح الحاسبة وينتظر 5 ثوانٍ كحد أقصى Sub TestExecuteWithTimeout() Dim ProcessId As Long On Error Resume Next ProcessId = ExecuteWithTimeout("paint.exe", WindowMaximized, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript ' يشغل أمر dir في CMD وينتظر النتيجة Sub TestExecuteWScript() Dim Result As Long On Error Resume Next Result = ExecuteWScript("cmd.exe /c dir", WindowNormal, True) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript مع إبقاء النافذة مفتوحة Sub TestExecuteWScript_KeepOpen() Dim Result As Long ' استخدام /k بدلاً من /c لإبقاء نافذة CMD مفتوحة بعد تنفيذ الأمر On Error Resume Next Result = ExecuteWScript("cmd.exe /k dir", WindowNormal, False) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout لتشغيل CMD Sub TestExecuteWithTimeoutCMD() Dim ProcessId As Long ' تشغيل CMD مع أمر dir وانتظار 5 ثوانٍ كحد أقصى On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout مع RunAsAdmin وإعادة المحاولة Sub TestExecuteWithTimeoutAdmin() Dim ProcessId As Long ' تشغيل CMD كمسؤول وانتظار 5 ثوانٍ كحد أقصى مع محاولتين On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000, True, 2) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScriptCapture Sub TestExecuteWScriptCapture() Dim CommandOutput As String ' تنفيذ أمر dir والتقاط الناتج On Error Resume Next CommandOutput = ExecuteWScriptCapture("cmd.exe /c dir") Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "ناتج الأمر:" & vbCrLf & CommandOutput Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub تمنياتى القلبيــــه بأكبر قدر ممكن من تحصيل المتعة والاستفاده

وايضا يمكنكم تجربة الكود فى هذا المرفق مع تغير المسار الرئيسي لمجلد حفظ الصور داخل الكود Public Function MainFolderpath() MainFolderpath = "\\192.168.85.70\hr-app\ScanFile\" End Function ScanerSettings.accdb

اولا المشكله كانت بسبب استخدام الكود بدون تمرير المسار الكامل وكانت هذه هى الفكرة الاخيرة التى كنت اطمح فى الوصول اليها طبعا هذا المسار نسبى لانه فى مسار قاعدة البيانات وكانت المشكلة فى الكود الرئيسي :BuildCompressCommand بحمد الله قمت بحل المشكله : تم تعديل الاكواد فى رأس الموضوع , وكذلك تمت اضافة المرفق فى رأس الموضوع اعتذر على التأخير فى الرد عليكم وعلى التأخير فى وضع المرفق للاسف فى الوقت الراهن لن استطيع التجربه لذلك ارجو منكم التجربه وافاتى فقط بالاكواد التى تشتمل على اى مشاكل أو أخطاء شكرا لك من القلب يا استاذ @Moosak الان تم اضافة المرفق فى رأس الموضوع وهنا ايضا OfficenaZip.zip

طيب ع العموم اتفضل دى التعديلات النهائيه بكل اللى طلبته تم تعديل واضافة الدوال اللازمة داخل الوحدة النمطية الكود النهائى والاخيـــــــــر Option Compare Database Option Explicit ' متغير عام لتخزين بيانات الحقول المستخدمة في آخر استعلام SQL Private StoredFieldsInfo As Variant ' التحقق مما إذا كانت السلسلة تحتوي على أرقام فقط Public Function IsNumericOnly(ByVal InputString As String, Optional AllowDecimal As Boolean = False, Optional AllowNegative As Boolean = False) As Boolean On Error Resume Next Dim CleanString As String CleanString = Trim(InputString) If CleanString = "" Or Not IsNumeric(CleanString) Then Exit Function If Not AllowDecimal And InStr(CleanString, ".") > 0 Then Exit Function If Not AllowNegative And Left(CleanString, 1) = "-" Then Exit Function If InStr(CleanString, " ") > 0 Then Exit Function IsNumericOnly = True End Function ' التحقق من صحة الإدخال الرقمي مع حد أقصى للطول Private Function ValidateNumericInput(InputValue As Variant, ByRef ErrorMessage As String, Optional MaxLength As Integer = 0, Optional AllowDecimal As Boolean = False) As String On Error Resume Next If IsEmpty(InputValue) Or IsNull(InputValue) Or Len(Trim(InputValue)) = 0 Then ValidateNumericInput = "" Exit Function End If Dim InputStr As String InputStr = CStr(InputValue) If Not IsNumericOnly(InputStr, AllowDecimal) Then ErrorMessage = "يرجى إدخال أرقام فقط" & IIf(AllowDecimal, " (يمكن أن تحتوي على فاصلة عشرية)!", "!") Exit Function End If If MaxLength > 0 And Len(InputStr) > MaxLength Then ErrorMessage = "الإدخال يتجاوز الحد الأقصى (" & MaxLength & " أرقام)!" Exit Function End If ValidateNumericInput = InputStr End Function ' توزيع الأرقام داخل مربعات النصوص Private Sub DistributeDigits(TextBoxCollection As Collection, NumericString As String) ' التحقق من أن الإدخال الرقمي ليس فارغًا If Trim(NumericString & "") = "" Then Dim i As Integer For i = 1 To TextBoxCollection.Count TextBoxCollection(i).Value = "" Next i Exit Sub End If For i = 1 To TextBoxCollection.Count If i <= Len(NumericString) Then TextBoxCollection(i).Value = Mid(NumericString, i, 1) Else TextBoxCollection(i).Value = "" End If Next i End Sub ' توزيع الأرقام العشرية (الجزء الصحيح والعشري) Private Sub DistributeDecimal(TextBoxCollection As Collection, NumericString As String) On Error Resume Next ' التحقق من أن الإدخال الرقمي ليس فارغًا If Trim(NumericString & "") = "" Then Dim i As Integer For i = 1 To TextBoxCollection.Count TextBoxCollection(i).Value = "" Next i Exit Sub End If Dim parts() As String parts = Split(NumericString, ".") If TextBoxCollection.Count >= 1 Then TextBoxCollection(1).Value = Nz(parts(0), "") ' الجزء الصحيح If TextBoxCollection.Count >= 2 Then TextBoxCollection(2).Value = Nz(parts(1), "00") ' الجزء العشري (افتراضي 00) End Sub ' جمع مربعات النصوص Private Function CollectTextBoxes(TargetObject As Object, ControlPrefix As String, MaxFields As Integer) As Collection Dim i As Integer, ctrl As Control Set CollectTextBoxes = New Collection For i = 1 To MaxFields On Error Resume Next Set ctrl = TargetObject.Controls(ControlPrefix & i) If Not ctrl Is Nothing Then CollectTextBoxes.Add ctrl On Error GoTo 0 Next i End Function ' توزيع الإدخال الرقمي على مربعات النصوص مع خيار فصل الأرقام العشرية Public Sub DistributeNumericInput(Optional TargetObject As Object = Nothing, Optional InputValue As Variant, _ Optional ControlPrefix As String = "", Optional MaxFields As Integer = 0, _ Optional SplitDecimal As Boolean = False) On Error GoTo ErrorHandler ' التحقق من القيم الفارغة If IsEmpty(InputValue) Or IsNull(InputValue) Or Trim(InputValue & "") = "" Then ' إعادة تهيئة مربعات النصوص إلى فارغة Dim TextBoxes As Collection Set TextBoxes = CollectTextBoxes(TargetObject, ControlPrefix, MaxFields) Dim i As Integer For i = 1 To TextBoxes.Count TextBoxes(i).Value = "" Next i Exit Sub End If Dim ValidInput As String, ErrorMessage As String ValidInput = ValidateNumericInput(InputValue, ErrorMessage, MaxFields, SplitDecimal) If ValidInput = "" Then If ErrorMessage <> "" Then MsgBox ErrorMessage, vbExclamation, "خطأ في الإدخال" Exit Sub End If If MaxFields = 0 Then MaxFields = IIf(SplitDecimal, 2, Len(ValidInput)) If TargetObject Is Nothing Then Debug.Print "الإدخال الموزع: " & ValidInput Exit Sub End If Set TextBoxes = CollectTextBoxes(TargetObject, ControlPrefix, MaxFields) If SplitDecimal Then If TextBoxes.Count < 2 Then MsgBox "عدد مربعات النصوص (" & TextBoxes.Count & ") أقل من المطلوب (2) للأرقام العشرية!", vbExclamation, "خطأ" Exit Sub End If DistributeDecimal TextBoxes, ValidInput Else If TextBoxes.Count < Len(ValidInput) Then MsgBox "عدد مربعات النصوص (" & TextBoxes.Count & ") أقل من طول الإدخال (" & Len(ValidInput) & ")!", vbExclamation, "خطأ" Exit Sub End If DistributeDigits TextBoxes, ValidInput End If Exit Sub ErrorHandler: MsgBox "خطأ في توزيع الإدخال: " & Err.Description, vbCritical, "خطأ" End Sub ' التحقق من صحة الرقم القومي Private Function ValidateNationalID(NationalID As Variant, ByRef ErrorMessage As String) As String On Error Resume Next Dim InputStr As String InputStr = Trim(Nz(NationalID, "")) If InputStr = "" Or Not IsNumericOnly(InputStr) Or Len(InputStr) <> 14 Then ErrorMessage = "يجب إدخال رقم قومي صحيح مكون من 14 رقمًا!" Exit Function End If ValidateNationalID = InputStr End Function ' استخراج تاريخ الميلاد من الرقم القومي بصيغة YYYY-MM-DD Public Function ExtractBirthDateFromID(NationalID As Variant) As String On Error GoTo ErrorHandler Dim ValidInput As String, YearPart As String, MonthPart As String, DayPart As String, CenturyCode As String, ErrorMessage As String ValidInput = ValidateNationalID(NationalID, ErrorMessage) If ValidInput = "" Then ExtractBirthDateFromID = "خطأ: " & ErrorMessage Exit Function End If CenturyCode = Mid(ValidInput, 1, 1) YearPart = Mid(ValidInput, 2, 2) MonthPart = Mid(ValidInput, 4, 2) DayPart = Mid(ValidInput, 6, 2) Select Case CenturyCode Case "2": YearPart = "19" & YearPart Case "3": YearPart = "20" & YearPart Case "4": YearPart = "21" & YearPart Case Else: ExtractBirthDateFromID = "خطأ: رمز القرن غير صالح!" Exit Function End Select If Not IsDate(YearPart & "/" & MonthPart & "/" & DayPart) Then ExtractBirthDateFromID = "خطأ: تاريخ ميلاد غير صالح!" Exit Function End If If CDate(YearPart & "-" & MonthPart & "-" & DayPart) > Date Then ExtractBirthDateFromID = "خطأ: تاريخ الميلاد في المستقبل!" Exit Function End If ExtractBirthDateFromID = YearPart & "-" & MonthPart & "-" & DayPart Exit Function ErrorHandler: ExtractBirthDateFromID = "خطأ: " & Err.Description End Function ' توزيع تاريخ الميلاد في 3 مربعات نص (السنة - الشهر - اليوم) Public Sub DistributeBirthDateFromID(Optional TargetObject As Object = Nothing, Optional NationalID As Variant, Optional ControlPrefix As String = "") On Error GoTo ErrorHandler Dim BirthDate As String, TextBoxes As Collection BirthDate = ExtractBirthDateFromID(NationalID) If Left(BirthDate, 5) = "خطأ" Then MsgBox BirthDate, vbExclamation, "خطأ في الرقم القومي" Exit Sub End If If TargetObject Is Nothing Then Debug.Print "السنة: " & Left(BirthDate, 4) Debug.Print "الشهر: " & Mid(BirthDate, 6, 2) Debug.Print "اليوم: " & Right(BirthDate, 2) Exit Sub End If Set TextBoxes = CollectTextBoxes(TargetObject, ControlPrefix, 3) If TextBoxes.Count < 3 Then MsgBox "عدد مربعات النص غير كافٍ! (مطلوب 3)", vbExclamation, "خطأ" Exit Sub End If TextBoxes(1).Value = Left(BirthDate, 4) TextBoxes(2).Value = Mid(BirthDate, 6, 2) TextBoxes(3).Value = Right(BirthDate, 2) Exit Sub ErrorHandler: MsgBox "خطأ في توزيع تاريخ الميلاد: " & Err.Description, vbCritical, "خطأ" End Sub ' دالة اختبار لطباعة تاريخ الميلاد Public Sub TestPrintDistributeBirthDate(NationalID As Variant) Dim BirthDate As String BirthDate = ExtractBirthDateFromID(NationalID) If Left(BirthDate, 5) = "خطأ" Then Debug.Print BirthDate Else Debug.Print "تجربة الطباعة للرقم القومي: " & NationalID Debug.Print "تاريخ الميلاد: " & BirthDate End If End Sub ' إنشاء استعلام SQL ديناميكي Public Function GenerateDynamicSQL(tableName As String, ParamArray RequiredFieldsDistribute() As Variant) As String On Error GoTo ErrorHandler Dim sqlQuery As String, i As Integer, j As Integer, fieldName As String, MaxDigits As Integer, fieldPrefix As String If Trim(tableName) = "" Or UBound(RequiredFieldsDistribute) < 0 Then GenerateDynamicSQL = "خطأ: الجدول أو الحقول غير محددة" Exit Function End If StoredFieldsInfo = RequiredFieldsDistribute sqlQuery = "SELECT " & tableName & ".*, " For i = LBound(RequiredFieldsDistribute) To UBound(RequiredFieldsDistribute) fieldName = RequiredFieldsDistribute(i)(0) MaxDigits = RequiredFieldsDistribute(i)(1) fieldPrefix = RequiredFieldsDistribute(i)(2) For j = 1 To MaxDigits sqlQuery = sqlQuery & "IIf(IsNull([" & fieldName & "]) OR Len([" & fieldName & "]) < " & j & ", Null, Mid([" & fieldName & "], " & j & ", 1)) AS " & fieldPrefix & j & ", " Next j Next i sqlQuery = Left(sqlQuery, Len(sqlQuery) - 2) & " FROM " & tableName & ";" GenerateDynamicSQL = sqlQuery Exit Function ErrorHandler: GenerateDynamicSQL = "خطأ: " & Err.Description End Function ' حذف مصادر البيانات من الحقول غير المستخدمة Public Sub ClearUnusedTextBoxes(frm As Form) On Error GoTo ErrorHandler Dim ctl As Control, i As Integer, Prefix As String, MaxDigits As Integer If IsEmpty(StoredFieldsInfo) Or Not IsArray(StoredFieldsInfo) Then Exit Sub For i = LBound(StoredFieldsInfo) To UBound(StoredFieldsInfo) Prefix = StoredFieldsInfo(i)(2) MaxDigits = StoredFieldsInfo(i)(1) For Each ctl In frm.Controls If TypeName(ctl) = "TextBox" And ctl.Name Like Prefix & "*" Then Dim num As Integer num = Val(Mid(ctl.Name, Len(Prefix) + 1)) If num > MaxDigits Then ctl.ControlSource = "" End If Next ctl Next i Exit Sub ErrorHandler: Debug.Print "خطأ في ClearUnusedTextBoxes: " & Err.Description End Sub ' استخراج أجزاء التاريخ (سنة، شهر، يوم) من تاريخ مدخل Public Function ExtractDateParts(ByVal InputDate As Variant, ByRef ErrorMessage As String) As Variant On Error GoTo ErrorHandler Dim DateParts(1 To 3) As String Dim TempDate As Date ' تهيئة المصفوفة بقيم افتراضية فارغة DateParts(1) = "" DateParts(2) = "" DateParts(3) = "" ' حالة الحقل الفارغ If IsEmpty(InputDate) Or IsNull(InputDate) Or Trim(InputDate & "") = "" Then ExtractDateParts = DateParts ' إرجاع أجزاء فارغة Exit Function End If ' حالة الإدخال غير الصحيح If Not IsDate(InputDate) Then ErrorMessage = "تنسيق التاريخ غير صحيح!" Exit Function End If ' تحويل إلى تاريخ TempDate = CDate(InputDate) ' (اختياري) التحقق من أن التاريخ ليس في المستقبل ' If TempDate > Date Then ' ErrorMessage = "التاريخ لا يمكن أن يكون في المستقبل!" ' Exit Function ' End If ' تعبئة الأجزاء بتنسيق صحيح DateParts(1) = Format(Year(TempDate), "0000") DateParts(2) = Format(Month(TempDate), "00") DateParts(3) = Format(Day(TempDate), "00") ExtractDateParts = DateParts Exit Function ErrorHandler: ErrorMessage = "خطأ غير متوقع: " & Err.Description ExtractDateParts = Array("", "", "") ' إرجاع قيم فارغة مع رسالة خطأ End Function ' توزيع أجزاء التاريخ على مربعات النصوص Public Sub DistributeDateParts(Optional TargetObject As Object = Nothing, Optional InputDate As Variant, _ Optional ControlPrefix As String = "DatePart") On Error GoTo ErrorHandler Dim DateParts As Variant, TextBoxes As Collection Dim ErrorMessage As String DateParts = ExtractDateParts(InputDate, ErrorMessage) If Not IsArray(DateParts) Then MsgBox ErrorMessage, vbExclamation, "خطأ في التاريخ" Exit Sub End If If TargetObject Is Nothing Then Debug.Print "السنة: " & DateParts(1) Debug.Print "الشهر: " & DateParts(2) Debug.Print "اليوم: " & DateParts(3) Exit Sub End If Set TextBoxes = CollectTextBoxes(TargetObject, ControlPrefix, 3) If TextBoxes.Count < 3 Then MsgBox "يجب توفير 3 مربعات نصية للتوزيع!", vbExclamation, "خطأ" Exit Sub End If TextBoxes(1).Value = DateParts(1) ' السنة TextBoxes(2).Value = DateParts(2) ' الشهر TextBoxes(3).Value = DateParts(3) ' اليوم Exit Sub ErrorHandler: MsgBox "خطأ في التوزيع: " & Err.Description, vbCritical, "خطأ" End Sub ' دالة اختبار باستخدام DateSerial Public Sub TestPrintDistributeDate() Dim InputDate As Date Dim parts As Variant Dim ErrorMessage As String ' إنشاء التاريخ باستخدام DateSerial لتجنب الغموض InputDate = DateSerial(2025, 5, 9) ' 9 May 2025 (السنة، الشهر، اليوم) parts = ExtractDateParts(InputDate, ErrorMessage) If IsArray(parts) Then Debug.Print "السنة: " & parts(1) ' 2025 Debug.Print "الشهر: " & parts(2) ' 05 Debug.Print "اليوم: " & parts(3) ' 09 Else Debug.Print "خطأ: " & ErrorMessage End If End Sub فصل وتوزيع ارقام الرقم القومى 3.accdb

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

السلام عليكم ورحمة الله تعالى وبركاته اليكم هديه اخرى ولكن الحق أحق أن يتبع كل الشكر و التقدير لاستاذى الجليل ومعلمى القدير و اخى الحبيب الاستاذ @Foksh على موضوع : ⭐ هدية ~ تغيير لغة النظام في Unicode⭐ قمت بعمل تحديثات جذرية فى هيكل وبناء الكود المميزات : عدم الاعتماد على وسيط بانشاء ملف فى مسار محدد لتمرير اومر الاعدادات ثم حذفه بعد تمرريرها وتطبيقها اضافة نموذج جديد للتحكم فى اختيار وتنسيق الوقت والتاريخ بشكل فورى امكانيه اضافة تخطيط لوحات مفاتيح للغات مختلفة حسب الحاجة والرغبه امكانية حذف تخطيط لغة/لغات لوحات مفاتيح من مربع القيم باختيار مفرد او متعدد لاكثر من لغة التخلص من تخطيطات لوحات المفاتيح المزعجة وحذفها بسهوله و التى قد تصادف العديد عند استخدام قواعد بيانات تعديل التنسيق للوقت والتاريخ او اضافة تخطيط لغة مفاتيح او حذفها لا يتطلب اعادة التشغيل مطلقا امكانية نقل النماذج لاى قاعدة للعمل فورا بدون اى تعديلات تذكر واخيـــــــــــــر المرفق اتمنى لكم تجربة ممتعة LanguageCheck V3.0.1.accdb

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

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

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

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

رمضان شهر العمل يا فؤش أفندى مش شهر النوم هو انا بأقول لك شيل الكود واللا بأقولك العب بودى بيلدنج ؟ هههههههه انا الكود ده تقريبا بأفكر واكتب وأطور فيه من قبل رمضان بحوالى أسبوع وإنقطعت عنه تقريبا أول 3 أيام رمضان ورجعت أكمل تانى وكنت شغال يا فؤش أفندى قبل الفطار وبعد التراويح انت بقيت بتتدلع كتير يا فؤش أفندى رميت الكود لان والله مكانش فى وقت خلاص وكان لازم اقوم علشان اروح الشغل ووقت المشاكره كنت لسه منتهى تماما منه تقريبا وجربت وراجعت 70 % من الامثله بس انا سهلت لكم الدنيا برضو فى اتنين موديول لكل الامثلة الاكواد مكتوبه للتجربة مباشرة لو وضعت المجلدات والملفات بالاسماء اللى قلت لكم عليها فى نفس مسار القاعدة والامثله يا فؤش افندى هتعملها Run بس وبعدين انا ما قلتش حاولوا تفهموا دى خااااااااااالص اكيد مش هأقولها لكم الصبح وأجى ع المغرب بالكود ده كل واسألكم عملتوا ايه انا طالب بس مع التجارب للامثلة المختلفة ابداء الرأى هل فى اى مشاكل انا نواتى 64 منتظر لو حد عنده نواة 32 الدنيا تمام معاه واللا فى مشاكل انا فى مرحلة عاوز المشاكل او لو مفيش مشاكل لو حد حاسس اكواد الاستدعائات فيها تعقيد مثلا يقول بالرغم والله دى اسهل حاجه قدرت اوصلها او بمعنى أدق ده افضل واسهل طريقه للاستدعاء خطرت على بالى جالت بأفكارى المحدوده ولأن أنا مقتنع مليون % أن القارئ كالحالب والسامع كالشارب أنتم هنا فى محل الشارب الذى يأخذ العمل بكل جماله ورنقه وبهائه بسهوله و بدون جهد وعناء من كثرة الأفكار وتداخلها والصراعات مع النفس فيكون من السهل عليكم رؤية مالم تراه عينى أنا مش بأقول لك انت بقيت بتتدلع كتيــــر

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

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

السلام عليكم ورحمة الله تعالى وبركاته هدية اليوم هى عبارة عن مكتبة برمجية متكاملة تم كتابتها وتطويرها لتوفير حلول مرنة وقوية لضغط الملفات والمجلدات وفك ضغطها باستخدام أدوات شائعة مثل WinRAR و7-Zip لأتمتة عمليات الضغط وفك الضغط للملفات و المجلدات بإحترافيه ومرونه وتحكم شامل فيما يلي نبذة عن الخصائص والمميزات والإمكانيات العامة للكود : يدعم ضغط الملفات وفك ضغطها باستخدام كل من WinRAR و7-Zip مما يتيح للمستخدم اختيار الأداة المناسبة بناء على احتياجاته يقبل المدخلات على شكل سلسلة نصية واحدة أو مصفوفة تحتوي على عدة ملفات أو مجلدات يحدد تلقائيا مسارات البرامج من سجل النظام أو المسارات الافتراضية مع خيار يدوي كبديل يستخدم ترميز Unicode في ملفات التعليق لدعم النصوص العربية وغيرها من اللغات يوفر 6 مستويات (من بدون ضغط إلى أقصى ضغط ) للتحكم في التوازن بين السرعة وحجم الملف يدعم تقسيم الأرشيف إلى أجزاء بأحجام مختلفة (50 ميجابايت إلى 2 جيجابايت) يتيح إضافة كلمة مرور للأرشيفات مع تشفير أسماء الملفات أرشيفات ذاتية الاستخراج (SFX): يمكن إنشاء ملفات تنفيذية (exe) لا تحتاج إلى برنامج لفك الضغط التعليقات: يدعم إضافة تعليقات نصية للأرشيفات في WinRAR إدارة عمليات متعددة: ضغط وفك ضغط عدة ملفات في استدعاء واحد أو عبر حلقات ( مصفوفات ) يحتوي على معالجة أخطاء شاملة مع رسائل توضيحية (مثل أخطاء المعاملات أو الملفات غير الموجودة) التخصيص:يسمح بتحديد اسم الأرشيف - المسار الهدف - ونوع الأرشيف (RAR/ZIP/7z) حسب رغبة المستخدم سيناريوهات الاستخدام ضغط التقارير أو المستندات الكبيرة وتوزيعها بسهولة إنشاء أرشيفات محمية بكلمة مرور أو ذاتية الاستخراج لمشاركة الملفات دمج الكود في تطبيقات إدارية لتبسيط عمليات النسخ الاحتياطي أو الأرشفة نقاط القوة سهولة الاستخدام: يمكن تصميم واجهة بسيطة مع معاملات اختيارية ذات قيم افتراضية منطقية الأداء: يعتمد على أدوات مثبتة مثل WinRAR و7-Zip لضمان السرعة والكفاءة التوثيق: الاهتمام بالتعليقات الشاملة داخل الكود لتسهيل فهم الكود وصيانته القيود النظرية يتطلب تثبيت WinRAR أو 7-Zip مسبقا بعض الميزات (مثل التعليقات) مدعومة فقط في WinRAR مبدئيا الأفكار والأكواد حتى الآن قيد التجربــــــه من أجل ذلك : فى حال وقوع اى مشاكل عند التجارب برجاء إخبارى فورا .. ولكم جزيل الشكر وأخيـــــــــرا الكــــــــــــــود الكود داخل وحده نمطية عامة باسم : basArchiveUtility ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit ' تعريف تعداد لمستويات الضغط المدعومة Enum EnumCompressionLevel CompressionNone = 0 ' بدون ضغط (تخزين فقط) CompressionFastest = 1 ' أسرع ضغط (حجم أكبر، سرعة عالية) CompressionFast = 3 ' ضغط سريع (توازن بين السرعة والحجم) CompressionNormal = 5 ' ضغط عادي (الافتراضي في معظم الأدوات) CompressionMaximum = 7 ' ضغط أقصى (حجم أصغر، أبطأ) CompressionUltra = 9 ' ضغط فائق (أقصى تقليص للحجم، أبطأ جدًا) End Enum ' تعريف تعداد لخيارات تقسيم حجم الأرشيف لدعم تقسيم الملفات الكبيرة Enum EnumSplitSizeOption ' بدون تقسيم (أرشيف واحد) SplitNone = 0 ' تقسيم إلى أجزاء بحجم 50 ميجابايت Split50MB = 50 ' تقسيم إلى أجزاء بحجم 100 ميجابايت Split100MB = 100 ' تقسيم إلى أجزاء بحجم 200 ميجابايت Split200MB = 200 ' تقسيم إلى أجزاء بحجم 500 ميجابايت Split500MB = 500 ' تقسيم إلى أجزاء بحجم 1 جيجابايت Split1GB = 1000 ' تقسيم إلى أجزاء بحجم 2 جيجابايت Split2GB = 2000 End Enum ' تعريف تعداد لأوضاع الكتابة فوق الملفات الموجودة مسبقًا Enum EnumOverwriteMode ' عدم الكتابة فوق الملفات (تجاهل العملية إذا وجد الملف) OverwriteNone = 0 ' طلب تأكيد من المستخدم عند وجود ملف OverwritePrompt = 1 ' الكتابة فوق جميع الملفات الموجودة تلقائيًا OverwriteAll = 2 End Enum ' تعريف تعداد لتحديد أداة الأرشفة المستخدمة Enum EnumArchiveMethod ' استخدام WinRAR كأداة ضغط WinRAR = 0 ' استخدام 7-Zip كأداة ضغط SevenZip = 1 End Enum ' تعريف تعداد لأنواع الأرشيف المدعومة Enum EnumArchiveType ' أرشيف بصيغة RAR (شائعة الاستخدام مع WinRAR) ArchiveRAR = 0 ' أرشيف بصيغة ZIP (صيغة قياسية مدعومة على نطاق واسع) ArchiveZIP = 1 ' أرشيف بصيغة 7z (صيغة مفتوحة المصدر توفر ضغطًا عاليًا مع 7-Zip) Archive7z = 2 ' أرشيف بصيغة TAR (يستخدم عادة في أنظمة Unix/Linux لتجميع الملفات بدون ضغط) ArchiveTAR = 3 ' أرشيف بصيغة GZ (Gzip، ضغط فعال لملف واحد) ArchiveGZ = 4 ' أرشيف بصيغة BZIP2 (ضغط قوي مشابه لـ GZ ولكن بكفاءة أعلى في بعض الحالات) ArchiveBZ2 = 5 ' أرشيف بصيغة XZ (صيغة حديثة توفر ضغطًا عاليًا، مدعومة بواسطة 7-Zip وأدوات أخرى) ArchiveXZ = 6 ' أرشيف بصيغة ISO (صورة قرص مضغوطة، يمكن التعامل معها بواسطة أدوات مثل 7-Zip أو WinRAR) ArchiveISO = 7 ' أرشيف بصيغة CAB (صيغة Microsoft Cabinet، تُستخدم في ملفات التثبيت) ArchiveCAB = 8 ' أرشيف بصيغة Z (صيغة ضغط قديمة، لا تزال مدعومة في بعض الأدوات) ArchiveZ = 9 ' أرشيف بصيغة LZH (صيغة ضغط يابانية قديمة، مدعومة بواسطة WinRAR وغيرها) ArchiveLZH = 10 ' أرشيف بصيغة ARJ (صيغة ضغط قديمة، لا تزال مدعومة بواسطة بعض الأدوات مثل WinRAR) ArchiveARJ = 11 End Enum ' متغير عام للتحكم في حالة الحلقات (مثل السماح بإيقاف عملية متكررة) Public IsInLoop As Boolean ' متغير عام لتخزين قائمة بالأرشيفات الناتجة (مثل مسارات الملفات المضغوطة) Public ArchivesList As String ' تعريف متغيرات عامة ثابتة لتخزين مسارات الأدوات المختارة يدويًا ' تحافظ على القيمة طوال جلسة تشغيل قاعدة البيانات Private m_WinRARPath As String ' مسار WinRAR المختار يدويًا Private m_SevenZipPath As String ' مسار 7-Zip المختار يدويًا ' دالة مساعدة لتحويل مستوى الضغط إلى تنسيق WinRAR (مثل -m0 إلى -m5) Function GetWinRARCompressionLevel(compressionLevel As EnumCompressionLevel) As String Select Case compressionLevel Case CompressionNone: GetWinRARCompressionLevel = "-m0" ' بدون ضغط Case CompressionFastest: GetWinRARCompressionLevel = "-m1" ' أسرع ضغط Case CompressionFast: GetWinRARCompressionLevel = "-m2" ' ضغط سريع Case CompressionNormal: GetWinRARCompressionLevel = "-m3" ' ضغط عادي Case CompressionMaximum: GetWinRARCompressionLevel = "-m5" ' ضغط أقصى Case CompressionUltra: GetWinRARCompressionLevel = "-m5" ' ضغط فائق (WinRAR لا يدعم 9) End Select End Function ' دالة مساعدة لتحويل مستوى الضغط إلى تنسيق 7-Zip (مثل mx0 إلى mx9) Function Get7ZipCompressionLevel(compressionLevel As EnumCompressionLevel) As String Select Case compressionLevel Case CompressionNone: Get7ZipCompressionLevel = "-mx0" ' بدون ضغط Case CompressionFastest: Get7ZipCompressionLevel = "-mx1" ' أسرع ضغط Case CompressionFast: Get7ZipCompressionLevel = "-mx3" ' ضغط سريع Case CompressionNormal: Get7ZipCompressionLevel = "-mx5" ' ضغط عادي Case CompressionMaximum: Get7ZipCompressionLevel = "-mx7" ' ضغط أقصى Case CompressionUltra: Get7ZipCompressionLevel = "-mx9" ' ضغط فائق End Select End Function ' دالة مساعدة لتحديد نوع الأرشيف لـ 7-Zip (مثل "zip"، "7z"، إلخ) Function Get7ZipArchiveType(ArchiveType As EnumArchiveType) As String Select Case ArchiveType Case ArchiveRAR: Get7ZipArchiveType = "rar" ' نوع RAR Case ArchiveZIP: Get7ZipArchiveType = "zip" ' نوع ZIP Case Archive7z: Get7ZipArchiveType = "7z" ' نوع 7z Case ArchiveTAR: Get7ZipArchiveType = "tar" ' نوع TAR Case ArchiveGZ: Get7ZipArchiveType = "gzip" ' نوع GZ Case ArchiveBZ2: Get7ZipArchiveType = "bzip2" ' نوع BZIP2 Case ArchiveXZ: Get7ZipArchiveType = "xz" ' نوع XZ Case ArchiveISO: Get7ZipArchiveType = "iso" ' نوع ISO Case ArchiveCAB: Get7ZipArchiveType = "cab" ' نوع CAB Case ArchiveZ: Get7ZipArchiveType = "z" ' نوع Z Case ArchiveLZH: Get7ZipArchiveType = "lzh" ' نوع LZH Case ArchiveARJ: Get7ZipArchiveType = "arj" ' نوع ARJ End Select End Function ' دالة لإرجاع امتداد الملف بناءً على نوع الأرشيف المحدد في EnumArchiveType Function GetArchiveExtension(ArchiveType As EnumArchiveType) As String Select Case ArchiveType Case ArchiveRAR: GetArchiveExtension = ".rar" ' امتداد لأرشيف RAR Case ArchiveZIP: GetArchiveExtension = ".zip" ' امتداد لأرشيف ZIP Case Archive7z: GetArchiveExtension = ".7z" ' امتداد لأرشيف 7z Case ArchiveTAR: GetArchiveExtension = ".tar" ' امتداد لأرشيف TAR Case ArchiveGZ: GetArchiveExtension = ".gz" ' امتداد لأرشيف GZ (Gzip) Case ArchiveBZ2: GetArchiveExtension = ".bz2" ' امتداد لأرشيف BZIP2 Case ArchiveXZ: GetArchiveExtension = ".xz" ' امتداد لأرشيف XZ Case ArchiveISO: GetArchiveExtension = ".iso" ' امتداد لأرشيف ISO Case ArchiveCAB: GetArchiveExtension = ".cab" ' امتداد لأرشيف CAB Case ArchiveZ: GetArchiveExtension = ".z" ' امتداد لأرشيف Z Case ArchiveLZH: GetArchiveExtension = ".lzh" ' امتداد لأرشيف LZH Case ArchiveARJ: GetArchiveExtension = ".arj" ' امتداد لأرشيف ARJ End Select End Function ' دالة لتحويل خيار تقسيم الحجم من تعداد EnumSplitSizeOption إلى سلسلة متوافقة مع أوامر 7-Zip أو WinRAR ' المدخل: خيار التقسيم من نوع EnumSplitSizeOption ' المخرج: سلسلة نصية تمثل حجم التقسيم (مثل "1g" أو "500m") أو سلسلة فارغة إذا لم يكن هناك تقسيم Function GetSplitSizeString(sizeOption As EnumSplitSizeOption) As String Select Case sizeOption Case SplitNone: GetSplitSizeString = "" ' بدون تقسيم Case Split50MB: GetSplitSizeString = "50m" ' 50 ميجابايت Case Split100MB: GetSplitSizeString = "100m" ' 100 ميجابايت Case Split200MB: GetSplitSizeString = "200m" ' 200 ميجابايت Case Split500MB: GetSplitSizeString = "500m" ' 500 ميجابايت Case Split1GB: GetSplitSizeString = "1g" ' 1 جيجابايت Case Split2GB: GetSplitSizeString = "2g" ' 2 جيجابايت End Select End Function ' دالة للتحقق من صحة المسار (عدم وجود أحرف غير قانونية أو تعقيدات غير مرغوبة) ' المدخل: سلسلة تمثل المسار المراد التحقق منه ' المخرج: قيمة منطقية (True إذا كان المسار صالحًا، False إذا كان غير صالح) Function IsValidPath(filePath As String) As Boolean On Error GoTo ErrorHandler ' تعريف الأحرف غير القانونية في مسارات Windows Dim invalidChars As String invalidChars = "\/:*?""<>|" ' متغير للتنقل عبر الأحرف غير القانونية Dim i As Integer ' فحص كل حرف غير قانوني في المسار For i = 1 To Len(invalidChars) ' إذا وُجد حرف غير قانوني، أنهِ الدالة وأرجع False If InStr(filePath, Mid(invalidChars, i, 1)) > 0 Then Exit Function Next i ' التحقق من أن المسار لا يحتوي على ".." (لمنع التنقل غير المرغوب) وأنه غير فارغ IsValidPath = (InStr(filePath, "..\") = 0) And (Len(filePath) > 0) Exit Function ErrorHandler: ' في حالة حدوث خطأ (مثل قيمة غير صالحة لـ filePath)، أرجع False IsValidPath = False End Function ' دالة لتنظيف المدخلات من الأحرف غير المرغوبة التي قد تسبب مشاكل في تنفيذ الأوامر ' المدخل: سلسلة نصية تحتاج إلى تنظيف ' المخرج: سلسلة نصية منقاة من الأحرف المحددة Function SanitizeInput(inputString As String) As String ' إزالة علامات الاقتباس المزدوجة لمنع مشاكل في بناء الأوامر SanitizeInput = Replace(inputString, """", "") ' إزالة رمز "&" لمنع تنفيذ أوامر متتالية غير مقصودة SanitizeInput = Replace(SanitizeInput, "&", "") ' إزالة رمز "|" لمنع توجيه الأوامر بشكل غير متوقع SanitizeInput = Replace(SanitizeInput, "|", "") End Function ' دالة للسماح للمستخدم باختيار مسار أداة الأرشفة يدويًا باستخدام نافذة حوار الملفات ' المدخل: اسم الأداة ("WinRAR" أو "SevenZip") ' المخرج: مسار الملف التنفيذي المختار (مثل "WinRAR.exe" أو "7z.exe")، أو سلسلة فارغة إذا فشل الاختيار Function SelectArchivePathManually(Method As String) As String On Error GoTo ErrorHandler ' التحقق من صحة المدخل للتأكد من أنه إما "WinRAR" أو "SevenZip" If Method <> "WinRAR" And Method <> "SevenZip" Then MsgBox "قيمة غير صالحة: " & Method, vbCritical ' عرض رسالة خطأ إذا كان المدخل غير صالح Exit Function ' الخروج من الدالة إذا لم يكن المدخل صحيحًا End If ' إنشاء كائن نافذة حوار الملفات للسماح للمستخدم باختيار ملف تنفيذي Dim fileDialog As Object Set fileDialog = Application.fileDialog(3) ' نوع 3 يمثل نافذة اختيار الملفات With fileDialog ' تعيين عنوان النافذة بناءً على الأداة المطلوبة لتوجيه المستخدم .Title = IIf(Method = "WinRAR", "اختر WinRAR.exe", "اختر 7z.exe") ' مسح أي فلاتر سابقة لضمان عرض الفلتر الجديد فقط .Filters.Clear ' إضافة فلتر لعرض الملفات التنفيذية (*.exe) فقط لتسهيل الاختيار .Filters.Add "Executable", "*.exe" ' منع اختيار أكثر من ملف واحد لضمان اختيار ملف واحد فقط .AllowMultiSelect = False ' عرض نافذة الحوار والتحقق مما إذا ضغط المستخدم على "موافق" (-1) If .Show = -1 Then ' تخزين المسار المختار من العنصر الأول (والوحيد) في قائمة العناصر المختارة Dim selectedPath As String selectedPath = .SelectedItems(1) ' التحقق من أن الملف المختار يتطابق مع الأداة المطلوبة (WinRAR.exe أو 7z.exe) If (Method = "WinRAR" And InStr(LCase(selectedPath), "winrar.exe") = 0) Or _ (Method = "SevenZip" And InStr(LCase(selectedPath), "7z.exe") = 0) Then MsgBox "الملف غير صحيح!", vbExclamation ' عرض تحذير إذا لم يكن الملف المختار صحيحًا Exit Function ' الخروج إذا كان الملف غير مطابق End If ' إرجاع المسار المختار إذا كان صالحًا SelectArchivePathManually = selectedPath End If End With Exit Function ErrorHandler: ' معالجة أي خطأ يحدث أثناء تنفيذ الدالة (مثل فشل إنشاء نافذة الحوار) MsgBox "خطأ في اختيار المسار: " & Err.Description, vbCritical End Function ' دالة اختيارية لإعادة تعيين المسارات المخزنة (يمكن استدعاؤها عند الحاجة) Public Sub ResetArchivePaths() m_WinRARPath = "" ' إعادة تعيين مسار WinRAR المخزن m_SevenZipPath = "" ' إعادة تعيين مسار 7-Zip المخزن End Sub ' دالة لتحديد مسار أداة الأرشفة تلقائيًا من السجل أو المسارات الافتراضية، مع الرجوع إلى الاختيار اليدوي المخزن إذا لزم الأمر ' المدخل: اسم الأداة ("WinRAR" أو "SevenZip") ' المخرج: مسار الملف التنفيذي للأداة (مثل "WinRAR.exe" أو "7z.exe")، أو سلسلة فارغة إذا فشل التحديد Function DetermineArchivePath(Method As String) As String On Error GoTo ErrorHandler ' التحقق من صحة المدخل للتأكد من أنه إما "WinRAR" أو "SevenZip" If Method <> "WinRAR" And Method <> "SevenZip" Then MsgBox "قيمة غير صالحة: " & Method, vbCritical ' عرض رسالة خطأ إذا كان المدخل غير صالح Exit Function ' الخروج إذا كان المدخل غير صالح End If ' التحقق مما إذا كان المسار مخزنًا مسبقًا في المتغير العام المناسب If Method = "WinRAR" And m_WinRARPath <> "" Then DetermineArchivePath = m_WinRARPath ' إرجاع المسار المخزن لـ WinRAR إذا كان موجودًا Exit Function ElseIf Method = "SevenZip" And m_SevenZipPath <> "" Then DetermineArchivePath = m_SevenZipPath ' إرجاع المسار المخزن لـ 7-Zip إذا كان موجودًا Exit Function End If ' إنشاء كائن للوصول إلى السجل (Registry) لاستخراج المسارات المثبتة Dim reg As Object Dim p As Variant ' متغير للتنقل عبر المسارات الافتراضية Set reg = CreateObject("WScript.Shell") Dim pathFromReg As String ' متغير لتخزين المسار المستخرج من السجل If Method = "WinRAR" Then ' محاولة استخراج مسار WinRAR من السجل باستخدام مفاتيح مختلفة On Error Resume Next ' تعطيل معالجة الأخطاء للتعامل مع مفاتيح غير موجودة pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\WinRAR.exe\") If Err.Number <> 0 Then pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\WinRAR\exe32") If Err.Number <> 0 Then pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\WinRAR\exe32") On Error GoTo 0 ' إعادة تفعيل معالجة الأخطاء ' التحقق مما إذا تم العثور على مسار صالح في السجل وأن الملف موجود If pathFromReg <> "" And Dir(pathFromReg) <> "" Then m_WinRARPath = pathFromReg ' تخزين المسار في المتغير العام لـ WinRAR DetermineArchivePath = pathFromReg ' إرجاع المسار المستخرج Exit Function End If ' فحص المسارات الافتراضية لـ WinRAR إذا لم يتم العثور على المسار في السجل Dim defaultPaths defaultPaths = Array("C:\Program Files\WinRAR\WinRAR.exe", "C:\Program Files (x86)\WinRAR\WinRAR.exe") For Each p In defaultPaths If Dir(p) <> "" Then m_WinRARPath = p ' تخزين المسار في المتغير العام لـ WinRAR DetermineArchivePath = p ' إرجاع المسار الافتراضي الصالح Exit Function End If Next p ElseIf Method = "SevenZip" Then ' محاولة استخراج مسار 7-Zip من السجل باستخدام مفاتيح مختلفة On Error Resume Next ' تعطيل معالجة الأخطاء للتعامل مع مفاتيح غير موجودة pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\7-Zip\Path") If Err.Number <> 0 Then pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\7-Zip\Path") On Error GoTo 0 ' إعادة تفعيل معالجة الأخطاء ' التحقق من المسار وإضافة "7z.exe" إذا كان المسار صالحًا If pathFromReg <> "" Then If Right(pathFromReg, 1) <> "\" Then pathFromReg = pathFromReg & "\" ' التأكد من وجود "\" في نهاية المسار If Dir(pathFromReg & "7z.exe") <> "" Then m_SevenZipPath = pathFromReg & "7z.exe" ' تخزين المسار في المتغير العام لـ 7-Zip DetermineArchivePath = pathFromReg & "7z.exe" ' إرجاع المسار الكامل Exit Function End If End If ' فحص المسارات الافتراضية لـ 7-Zip إذا لم يتم العثور على المسار في السجل defaultPaths = Array("C:\Program Files\7-Zip\7z.exe", CurrentProject.Path & "\7-Zip64\7z.exe", "C:\Program Files (x86)\7-Zip\7z.exe", CurrentProject.Path & "\7-Zip86\7z.exe") For Each p In defaultPaths If Dir(p) <> "" Then m_SevenZipPath = p ' تخزين المسار في المتغير العام لـ 7-Zip DetermineArchivePath = p ' إرجاع المسار الافتراضي الصالح Exit Function End If Next p End If ' إذا فشلت جميع الطرق التلقائية، استدعاء الاختيار اليدوي وتخزين النتيجة Dim manualPath As String manualPath = SelectArchivePathManually(Method) ' استدعاء الدالة للاختيار اليدوي If manualPath <> "" Then If Method = "WinRAR" Then m_WinRARPath = manualPath ' تخزين المسار اليدوي لـ WinRAR في المتغير العام ElseIf Method = "SevenZip" Then m_SevenZipPath = manualPath ' تخزين المسار اليدوي لـ 7-Zip في المتغير العام End If DetermineArchivePath = manualPath ' إرجاع المسار المختار يدويًا End If Exit Function ErrorHandler: ' معالجة أي خطأ يحدث أثناء تنفيذ الدالة (مثل فشل الوصول إلى السجل) MsgBox "خطأ في تحديد المسار: " & Err.Description, vbCritical End Function ' دالة لإنشاء ملف نصي مؤقت يحتوي على تعليقات (سطر واحد أو عدة أسطر) مع خيار الحذف بعد الاستخدام ' المدخل: ' - commentLines: نص أو مصفوفة من النصوص تمثل التعليقات المراد كتابتها في الملف ' - deleteAfterUse: قيمة منطقية اختيارية (True افتراضيًا) لتحديد ما إذا كان سيتم حذف الملف بعد إنشائه ' المخرج: مسار الملف النصي المؤقت الذي تم إنشاؤه ' دالة لإنشاء ملف تعليقات مؤقت وإرجاع مساره Function CreateCommentFile(commentLines As Variant) As String Dim fso As Object Dim tempFile As String Dim file As Object Dim line As Variant Set fso = CreateObject("Scripting.FileSystemObject") tempFile = CurrentProject.Path & "\temp_comment.txt" Set file = fso.CreateTextFile(tempFile, True, True) 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 ' إرجاع المسار بدون حذف Set file = Nothing Set fso = Nothing End Function ' دالة لبناء أمر ضغط الملفات/المجلدات بناءً على الخيارات المحددة باستخدام WinRAR أو 7-Zip ' المدخلات: ' - sourceFile: ملف أو مصفوفة ملفات/مجلدات للضغط (قد تكون مسارات نسبية أو مطلقة) ' - password: كلمة المرور لتشفير الأرشيف (اختياري) ' - Method: أداة الضغط (WinRAR أو SevenZip) من EnumArchiveMethod ' - archiveType: نوع الأرشيف (RAR، ZIP، 7z، إلخ) من EnumArchiveType ' - compressionLevel: مستوى الضغط من EnumCompressionLevel ' - partSize: حجم التقسيم (إن وجد) من EnumSplitSizeOption ' - targetPath: مسار حفظ الأرشيف (اختياري، يُستخدم المشروع الحالي إذا لم يُحدد) ' - archiveName: اسم الأرشيف (اختياري، يُشتق من الملف الأصلي إذا لم يُحدد) ' - isSFX: تحديد ما إذا كان الأرشيف سيكون تنفيذيًا ذاتيًا (Self-Extracting) ' - commentFile: مسار ملف التعليقات (اختياري) ' - deleteOriginals: حذف الملفات الأصلية بعد الضغط ' المخرج: سلسلة نصية تمثل الأمر الكامل للضغط 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, _ Optional ByVal deleteOriginals As Boolean = True) 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 للتعامل مع الملفات Dim file As Variant ' متغير للتنقل عبر الملفات في المصفوفة Dim fullFilePath As String ' المسار الكامل لكل ملف/مجلد ' On Error GoTo ErrorHandler ' إنشاء كائن FileSystemObject للتحقق من الملفات والمسارات Set fso = CreateObject("Scripting.FileSystemObject") '--- معالجة المسارات النسبية --- fileList = "" ' تهيئة قائمة الملفات ' تحويل المدخل إلى مصفوفة إذا لم يكن كذلك لتسهيل المعالجة If Not IsArray(sourceFile) Then sourceFile = Array(sourceFile) ' معالجة كل ملف/مجلد في المصفوفة For Each file In sourceFile ' تحديد المسار الكامل بناءً على كونه نسبيًا أو مطلقًا If InStr(file, ":\") = 0 And InStr(file, "\\") = 0 Then ' مسار نسبي (لا يحتوي على محرك أقراص أو مسار شبكة) If Left(file, 1) = "\" Then ' يبدأ بـ "\" (مثل \folder\file.txt)، يُضاف إلى مسار المشروع مباشرة fullFilePath = CurrentProject.Path & file Else ' مسار نسبي عادي (مثل folder\file.txt)، يُضاف مع فاصل "\" fullFilePath = CurrentProject.Path & "\" & file End If Else ' مسار مطلق (مثل C:\...\file.txt)، يُستخدم كما هو fullFilePath = file End If ' التحقق من وجود الملف أو المجلد في المسار المحدد If Not fso.FileExists(fullFilePath) And Not fso.FolderExists(fullFilePath) Then MsgBox "المسار غير موجود: " & fullFilePath, vbCritical Exit Function ' الخروج إذا لم يكن المسار موجودًا End If ' إضافة المسار المنظف إلى قائمة الملفات مع إحاطته بعلامات اقتباس fileList = fileList & " """ & SanitizeInput(fullFilePath) & """" Next file '--- تحديد مسار الأرشيف الناتج --- If targetPath = "" Then ' إذا لم يُحدد مسار الهدف، استخدام مسار المشروع الحالي targetPath = CurrentProject.Path End If '--- بناء اسم الأرشيف --- targetFile = targetPath & "\" & _ IIf(archiveName = "", fso.GetBaseName(sourceFile(LBound(sourceFile))), archiveName) & _ IIf(isSFX, ".exe", _ IIf(ArchiveType = ArchiveRAR, ".rar", _ IIf(ArchiveType = ArchiveZIP, ".zip", ".7z"))) ' الشرح: ' - إذا لم يُحدد اسم الأرشيف، يُشتق من اسم الملف الأول (بدون الامتداد) ' - إذا كان SFX، يُستخدم امتداد ".exe"، وإلا يُحدد الامتداد بناءً على نوع الأرشيف (RAR، ZIP، 7z) '--- التحقق من صحة الأداة --- archiveProgramPath = DetermineArchivePath(IIf(Method = WinRAR, "WinRAR", "SevenZip")) If archiveProgramPath = "" Then Exit Function ' الخروج إذا لم يتم العثور على الأداة '--- بناء الأمر بناءً على الأداة --- If Method = WinRAR Then ' بناء أمر WinRAR Command = """" & archiveProgramPath & """ a -ep1 -m" & compressionLevel ' - "a": إضافة الملفات إلى الأرشيف ' - "-ep1": استبعاد المسار الأساسي من الأسماء داخل الأرشيف ' - "-m": تحديد مستوى الضغط (0-5) Command = Command & IIf(isSFX, " -sfx", "") ' إضافة خيار SFX إذا تم تحديده Command = Command & " """ & targetFile & """" & fileList ' إضافة مسار الأرشيف وقائمة الملفات Command = Command & IIf(password <> "", " -p" & SanitizeInput(password), "") ' إضافة كلمة المرور إذا وُجدت Command = Command & IIf(partSize <> SplitNone, " -v" & GetSplitSizeString(partSize), "") ' إضافة خيار التقسيم إذا تم تحديده Command = Command & IIf(commentFile <> "" And fso.FileExists(commentFile), " -z""" & commentFile & """", "") ' إضافة ملف التعليقات إذا وُجد Command = Command & IIf(deleteOriginals, " -df", "") ' حذف الملفات الأصلية بعد الضغط إذا تم تحديده ElseIf Method = SevenZip Then ' بناء أمر 7-Zip Command = """" & archiveProgramPath & """ a -mx=" & Get7ZipCompressionLevel(compressionLevel) ' - "a": إضافة الملفات إلى الأرشيف ' - "-mx=": تحديد مستوى الضغط (0-9) باستخدام دالة GetSevenZipCompressionLevel Command = Command & IIf(isSFX, " -sfx7z.sfx", "") ' إضافة خيار SFX باستخدام ملف 7z.sfx Command = Command & " """ & targetFile & """" & fileList ' إضافة مسار الأرشيف وقائمة الملفات Command = Command & IIf(password <> "", " -p" & SanitizeInput(password) & " -mhe=on", "") ' إضافة كلمة المرور مع تشفير الأسماء Command = Command & IIf(partSize <> SplitNone, " -v" & GetSplitSizeString(partSize), "") ' إضافة خيار التقسيم إذا تم تحديده Command = Command & IIf(deleteOriginals, " -sdel", "") ' حذف الملفات الأصلية بعد الضغط إذا تم تحديده End If ' إرجاع الأمر النهائي BuildCompressCommand = Command Exit Function ' 'ErrorHandler: ' ' معالجة الأخطاء وعرض رسالة في حالة حدوث مشكلة (مثل مسار غير صالح أو فشل إنشاء الكائن) ' MsgBox "خطأ في بناء الأمر: " & Err.Description, vbCritical End Function ' إجراء لضغط العناصر (ملفات أو مجلدات) باستخدام WinRAR أو 7-Zip بناءً على الخيارات المحددة ' المدخلات (جميعها اختيارية): ' - itemsArray: ملف أو مصفوفة ملفات/مجلدات للضغط ' - password: كلمة المرور لتشفير الأرشيف (افتراضي: فارغ) ' - Method: أداة الضغط (افتراضي: SevenZip) ' - archiveType: نوع الأرشيف (افتراضي: Archive7z) ' - compressionLevel: مستوى الضغط (افتراضي: CompressionNormal) ' - partSize: حجم التقسيم (افتراضي: SplitNone) ' - targetPath: مسار حفظ الأرشيف (افتراضي: فارغ، يُستخدم المشروع الحالي) ' - archiveName: اسم الأرشيف (افتراضي: فارغ، يُشتق من الملف الأصلي) ' - isSFX: تحديد ما إذا كان الأرشيف تنفيذيًا ذاتيًا (افتراضي: False) ' - commentFile: مسار ملف التعليقات (افتراضي: فارغ) ' - deleteOriginals: حذف الملفات الأصلية بعد الضغط (افتراضي: False) ' إجراء لضغط العناصر باستخدام WinRAR أو 7-Zip بناءً على الخيارات المحددة ' إجراء لضغط العناصر باستخدام WinRAR أو 7-Zip بناءً على الخيارات المحددة ' إجراء لضغط العناصر باستخدام WinRAR أو 7-Zip بناءً على الخيارات المحددة 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 = "", _ Optional ByVal deleteOriginals As Boolean = False) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") On Error GoTo ErrorHandler If VarType(itemsArray) = vbEmpty Then MsgBox "لم يتم تحديد عناصر للضغط!", vbExclamation Exit Sub End If ' تحويل itemsArray إلى مصفوفة إذا كان سلسلة نصية واحدة Dim items As Variant If Not IsArray(itemsArray) Then items = Array(itemsArray) Else items = itemsArray End If ' التحقق من وجود الملفات قبل الضغط Dim i As Long Dim fullPath As String For i = LBound(items) To UBound(items) ' إذا كان المسار نسبيًا، أضف CurrentProject.Path If InStr(items(i), ":\") = 0 And InStr(items(i), "\\") = 0 Then fullPath = CurrentProject.Path & "\" & items(i) Else fullPath = items(i) End If If Not fso.FileExists(fullPath) And Not fso.FolderExists(fullPath) Then MsgBox "الملف أو المجلد غير موجود: " & fullPath, vbExclamation Exit Sub End If ' تحديث المسار في المصفوفة ليكون مطلقًا items(i) = fullPath Next i Dim archiveProgramPath As String archiveProgramPath = DetermineArchivePath(IIf(Method = WinRAR, "WinRAR", "SevenZip")) If archiveProgramPath = "" Then Exit Sub ' بناء المسار الكامل للأرشيف الناتج Dim archiveFullPath As String Dim baseName As String baseName = fso.GetBaseName(items(LBound(items))) ' استخدام أول عنصر بعد التأكد من المسار archiveFullPath = IIf(targetPath = "", CurrentProject.Path, targetPath) & "\" & _ IIf(archiveName = "", baseName, archiveName) & _ IIf(isSFX, ".exe", GetArchiveExtension(ArchiveType)) Dim Command As String If Method = WinRAR Then Command = """" & archiveProgramPath & """ a -ep1 """ & archiveFullPath & """ " & JoinArchivePaths(items) Command = Command & IIf(password <> "", " -p" & SanitizeInput(password), "") Command = Command & " " & GetWinRARCompressionLevel(compressionLevel) Command = Command & IIf(partSize <> SplitNone, " -v" & GetSplitSizeString(partSize), "") Command = Command & IIf(isSFX, " -sfx", "") Command = Command & IIf(commentFile <> "" And fso.FileExists(commentFile), " -z""" & commentFile & """", "") Command = Command & IIf(deleteOriginals, " -df", "") If ArchiveType = ArchiveXZ Or ArchiveType = ArchiveBZ2 Then MsgBox "WinRAR لا يدعم نوع الأرشيف المحدد: " & ArchiveType, vbExclamation Exit Sub End If ElseIf Method = SevenZip Then Command = """" & archiveProgramPath & """ a """ & archiveFullPath & """ " & JoinArchivePaths(items) Command = Command & IIf(password <> "", " -p" & SanitizeInput(password), "") Command = Command & " " & Get7ZipCompressionLevel(compressionLevel) Command = Command & IIf(partSize <> SplitNone, " -v" & GetSplitSizeString(partSize), "") Command = Command & IIf(isSFX, " -sfx", "") Command = Command & IIf(commentFile <> "" And fso.FileExists(commentFile), " -scc""" & commentFile & """", "") Command = Command & IIf(deleteOriginals, " -sdel", "") Command = Command & " -t" & Get7ZipArchiveType(ArchiveType) End If If Command = "" Then Exit Sub ' تنفيذ الأمر باستخدام ExecuteAndWait مع الانتظار حتى اكتمال العملية ' ExecuteAndWait Command, WindowHidden, True ' Command: السلسلة التي تحتوي على الأمر الكامل (مثل: """C:\Program Files\7-Zip\7z.exe"" a ""C:\output.rar"" ""C:\input.txt""") ' WindowHidden: تحديد نمط النافذة لتكون مخفية (0) أثناء التنفيذ لعدم إظهار واجهة البرنامج ' True: تشغيل الأمر بصلاحيات المسؤول (RunAsAdmin) لضمان الوصول إلى الملفات المحمية إذا لزم الأمر ' تنفيذ الأمر باستخدام ExecuteWithTimeout مع التحكم في المهلة الزمنية ExecuteWithTimeout Command, WindowHidden, 0, True ' Command: السلسلة التي تحتوي على الأمر الكامل (مثل: """C:\Program Files\7-Zip\7z.exe"" x ""C:\archive.rar"" -o""C:\destination""") ' WindowHidden: تحديد نمط النافذة لتكون مخفية (0) أثناء التنفيذ للحفاظ على تجربة مستخدم نظيفة ' 0: المهلة الزمنية بالمللي ثانية (0 تعني الانتظار إلى ما لا نهاية حتى اكتمال العملية) ' True: تشغيل الأمر كمسؤول (RunAsAdmin) If Not IsInLoop Then MsgBox "تم الضغط بنجاح إلى: " & archiveFullPath, vbInformation Else ArchivesList = ArchivesList & archiveFullPath & vbCrLf End If On Error Resume Next If commentFile <> "" And fso.FileExists(commentFile) Then fso.DeleteFile commentFile On Error GoTo 0 Set fso = Nothing Exit Sub ErrorHandler: MsgBox "خطأ في الضغط: " & Err.Description, vbCritical LogError "CompressItems Error: " & Err.Description Set fso = Nothing End Sub ' إجراء لفك ضغط الأرشيفات باستخدام WinRAR أو 7-Zip بناءً على الخيارات المحددة ' المدخلات: ' - archivePaths: مسار أو مصفوفة مسارات للأرشيفات المراد فك ضغطها ' - destinationPath: مسار الوجهة لفك الضغط ' - password: كلمة المرور لفك تشفير الأرشيف (اختياري، افتراضي: فارغ) ' - Method: أداة فك الضغط (افتراضي: WinRAR) ' - OverwriteMode: وضع الكتابة فوق الملفات الموجودة (افتراضي: OverwriteAll) ' - deleteArchive: حذف الأرشيف بعد فك الضغط (افتراضي: False) ' إجراء لفك ضغط الأرشيفات باستخدام WinRAR أو 7-Zip بناءً على الخيارات المحددة ' إجراء لفك ضغط الأرشيفات باستخدام WinRAR أو 7-Zip بناءً على الخيارات المحددة ' إجراء لفك ضغط الأرشيفات باستخدام WinRAR أو 7-Zip بناءً على الخيارات المحددة 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, _ Optional ByVal deleteArchive As Boolean = False) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") On Error GoTo ErrorHandler If VarType(archivePaths) = vbEmpty Then MsgBox "لم يتم تحديد أرشيفات!", vbExclamation Exit Sub End If ' تحويل archivePaths إلى مصفوفة إذا كان سلسلة نصية واحدة Dim archives As Variant If Not IsArray(archivePaths) Then archives = Array(archivePaths) Else archives = archivePaths End If ' التحقق من وجود الأرشيفات قبل فك الضغط Dim i As Long Dim fullPath As String For i = LBound(archives) To UBound(archives) ' إذا كان المسار نسبيًا، أضف CurrentProject.Path If InStr(archives(i), ":\") = 0 And InStr(archives(i), "\\") = 0 Then fullPath = CurrentProject.Path & "\" & archives(i) Else fullPath = archives(i) End If If Not fso.FileExists(fullPath) Then MsgBox "الأرشيف غير موجود: " & fullPath, vbExclamation Exit Sub End If ' تحديث المسار في المصفوفة ليكون مطلقًا archives(i) = fullPath Next i ' التحقق من وجود مسار الوجهة وإنشاؤه إذا لم يكن موجودًا If Not fso.FolderExists(destinationPath) Then fso.CreateFolder destinationPath End If Dim archiveProgramPath As String archiveProgramPath = DetermineArchivePath(IIf(Method = WinRAR, "WinRAR", "SevenZip")) If archiveProgramPath = "" Then Exit Sub Dim Command As String If Method = WinRAR Then Command = """" & archiveProgramPath & """ x " & JoinArchivePaths(archives) & " """ & destinationPath & """" Command = Command & IIf(password <> "", " -p" & SanitizeInput(password), "") Command = Command & IIf(OverwriteMode = OverwriteAll, " -o+", IIf(OverwriteMode = OverwritePrompt, "", " -o-")) Command = Command & IIf(deleteArchive, " -df", "") ElseIf Method = SevenZip Then Command = """" & archiveProgramPath & """ x " & JoinArchivePaths(archives) & " -o""" & destinationPath & """" Command = Command & IIf(password <> "", " -p" & SanitizeInput(password), "") Command = Command & IIf(OverwriteMode = OverwriteAll, " -aoa", IIf(OverwriteMode = OverwritePrompt, "", " -aos")) Command = Command & IIf(deleteArchive, " -sdel", "") End If ' تنفيذ الأمر باستخدام ExecuteAndWait مع الانتظار حتى اكتمال العملية ' ExecuteAndWait Command, WindowHidden, True ' Command: السلسلة التي تحتوي على الأمر الكامل (مثل: """C:\Program Files\7-Zip\7z.exe"" a ""C:\output.rar"" ""C:\input.txt""") ' WindowHidden: تحديد نمط النافذة لتكون مخفية (0) أثناء التنفيذ لعدم إظهار واجهة البرنامج ' True: تشغيل الأمر بصلاحيات المسؤول (RunAsAdmin) لضمان الوصول إلى الملفات المحمية إذا لزم الأمر ' تنفيذ الأمر باستخدام ExecuteWithTimeout مع التحكم في المهلة الزمنية ExecuteWithTimeout Command, WindowHidden, 0, True ' Command: السلسلة التي تحتوي على الأمر الكامل (مثل: """C:\Program Files\7-Zip\7z.exe"" x ""C:\archive.rar"" -o""C:\destination""") ' WindowHidden: تحديد نمط النافذة لتكون مخفية (0) أثناء التنفيذ للحفاظ على تجربة مستخدم نظيفة ' 0: المهلة الزمنية بالمللي ثانية (0 تعني الانتظار إلى ما لا نهاية حتى اكتمال العملية) ' True: تشغيل الأمر كمسؤول (RunAsAdmin) If Not IsInLoop Then MsgBox "تم فك الضغط بنجاح إلى: " & destinationPath, vbInformation Else ArchivesList = ArchivesList & destinationPath & vbCrLf End If Set fso = Nothing Exit Sub ErrorHandler: MsgBox "خطأ في فك الضغط: " & Err.Description, vbCritical LogError "ExtractItems Error: " & Err.Description Set fso = Nothing End Sub ' دالة لدمج مسارات الأرشيفات في سلسلة واحدة مع إحاطة كل مسار بعلامات اقتباس ' المدخل: ' - archivePaths: مسار واحد أو مصفوفة من مسارات الأرشيفات ' المخرج: سلسلة نصية تحتوي على المسارات مفصولة بمسافات ومحاطة بعلامات اقتباس (مثل: "path1" "path2") Function JoinArchivePaths(archivePaths As Variant) As String ' تعريف متغير لتخزين النتيجة النهائية Dim Result As String ' متغير للتنقل عبر عناصر المصفوفة Dim p As Variant ' تحويل المدخل إلى مصفوفة إذا لم يكن كذلك لتسهيل المعالجة If Not IsArray(archivePaths) Then archivePaths = Array(archivePaths) ' تكرار على كل مسار في المصفوفة For Each p In archivePaths ' إضافة المسار المنظف إلى النتيجة مع إحاطته بعلامات اقتباس وفاصل مسافة Result = Result & " """ & SanitizeInput(CStr(p)) & """" ' - SanitizeInput: تنظيف المسار من الأحرف غير المرغوبة ' - CStr: تحويل المسار إلى سلسلة نصية Next p ' إرجاع السلسلة الناتجة (بدون مسافة إضافية في البداية) JoinArchivePaths = Result End Function ' إجراء لتسجيل الأخطاء في ملف نصي بمسار المشروع الحالي ' المدخل: ' - errorMessage: رسالة الخطأ المراد تسجيلها Sub LogError(errorMessage As String) ' تعريف مسار ملف السجل (ErrorLog.txt في مسار المشروع الحالي) Dim logFile As String logFile = CurrentProject.Path & "\ErrorLog.txt" ' فتح الملف في وضع الإضافة (Append) برقم قناة #1 Open logFile For Append As #1 ' كتابة التاريخ/الوقت الحالي ورسالة الخطأ في الملف مع فاصل سطر Print #1, Now & " - " & errorMessage ' إغلاق الملف لضمان حفظ التغييرات Close #1 End Sub ' إجراء لعرض نافذة تعليمات بسيطة تحتوي على إرشادات حول استخدام الكود Sub ShowHelp() ' عرض رسالة تحتوي على تعليمات أساسية حول الإجراءات والتعدادات MsgBox "التعليمات:" & vbCrLf & _ "1. CompressItems: لضغط الملفات" & vbCrLf & _ "2. ExtractItems: لفك الضغط" & vbCrLf & _ "3. استخدام التعدادات لتحديد الخيارات" & vbCrLf & _ "راجع التعليقات في الكود للمزيد من التفاصيل", vbInformation ' - vbCrLf: فاصل سطر لتنسيق النص ' - vbInformation: رمز أيقونة المعلومات في نافذة الرسالة End Sub '################################################## '# دوال مساعدة للحلقات (الضغط وفك الضغط) '################################################## ' إجراء لبدء حلقة ضغط متعددة وتهيئة المتغيرات العامة Sub StartCompressionLoop() ' تعيين المتغير العام IsInLoop إلى True للإشارة إلى أن العملية تعمل داخل حلقة IsInLoop = True ' تفعيل وضع الحلقة ' تهيئة المتغير العام ArchivesList كسلسلة فارغة لتخزين قائمة الأرشيفات الناتجة ArchivesList = "" ' تهيئة قائمة الأرشيفات End Sub ' إجراء لعرض رسالة نجاح موحدة بعد انتهاء حلقة الضغط Sub ShowCompressionSuccess() ' التحقق مما إذا كان الإجراء في وضع حلقة وما إذا كانت قائمة الأرشيفات تحتوي على بيانات If IsInLoop And ArchivesList <> "" Then ' عرض رسالة نجاح تحتوي على قائمة الأرشيفات المضغوطة MsgBox "تم الضغط بنجاح للملفات التالية:" & vbCrLf & ArchivesList, vbInformation, "نجاح" ' - vbCrLf: فاصل سطر لتنسيق القائمة ' - vbInformation: رمز أيقونة المعلومات ' - "نجاح": عنوان النافذة End If ' تعطيل وضع الحلقة بعد الانتهاء IsInLoop = False ' إنهاء وضع الحلقة ' إعادة تهيئة قائمة الأرشيفات كسلسلة فارغة للاستخدام المستقبلي ArchivesList = "" ' إعادة تهيئة القائمة End Sub ' إجراء لبدء حلقة فك ضغط متعددة وتهيئة المتغيرات العامة Sub StartExtractionLoop() ' تعيين المتغير العام IsInLoop إلى True للإشارة إلى أن العملية تعمل داخل حلقة IsInLoop = True ' تفعيل وضع الحلقة ' تهيئة المتغير العام ArchivesList كسلسلة فارغة لتخزين قائمة مسارات الوجهة ArchivesList = "" ' تهيئة قائمة الأرشيفات End Sub ' إجراء لعرض رسالة نجاح موحدة بعد انتهاء حلقة فك الضغط Sub ShowExtractionSuccess() ' التحقق مما إذا كان الإجراء في وضع حلقة وما إذا كانت قائمة الأرشيفات تحتوي على بيانات If IsInLoop And ArchivesList <> "" Then ' عرض رسالة نجاح تحتوي على قائمة مسارات الوجهة التي تم فك الضغط إليها MsgBox "تم فك الضغط بنجاح للملفات التالية:" & vbCrLf & ArchivesList, vbInformation, "نجاح" ' - vbCrLf: فاصل سطر لتنسيق القائمة ' - 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 الكود مرتبط بـ : ExecuteWith الغرض: تشغيل برنامج والانتظار حتى ينتهي مع السماح بمعالجة الأحداث الأخرى الكود داخل وحده نمطيه عامة باسم : basShellExecutor ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit '======================================================================================================================= '------ الثوابت Public Const PROCESS_TIMEOUT_INFINITE As Long = &HFFFFFFFF Public Const PROCESS_STILL_ACTIVE As Long = &H103 Public Const PROCESS_TERMINATED As Long = vbObjectError Or &HDEAD Public Const MAX_PATH_LENGTH As Long = 260 Public Const QS_ALL_INPUT As Long = &H4FF Private Const ERR_NO_COMMAND As Long = vbObjectError Or 1001 Private Const ERR_EXECUTING As Long = vbObjectError Or 1002 Private Const ERR_EXECUTION_FAILED As Long = vbObjectError Or 1003 Private Const ERR_TERMINATION_FAILED As Long = vbObjectError Or 1004 Private Const SHELL_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SHELL_MASK_DOENVSUBST As Long = &H200 Private Const SHELL_MASK_SUPPRESS_ERRORS As Long = &H400 Private Const PROCESS_QUERY_INFO As Long = &H400 Private Const PROCESS_SYNCHRONIZE As Long = &H100000 Private Const PROCESS_TERMINATE As Long = &H1 Private Const ERROR_ACCESS_DENIED As Long = 5 '======================================================================================================================= '------ التعدادات Public Enum ShellWindowStyle WindowHidden = 0 WindowNormal = 1 WindowMinimized = 2 WindowMaximized = 3 WindowNoActivate = 4 End Enum '======================================================================================================================= '------ الأنواع المخصصة #If VBA7 Then Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As LongPtr Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As LongPtr ItemListPointer As LongPtr ClassName As String ClassKeyHandle As LongPtr HotKey As Long IconHandle As LongPtr ProcessHandle As LongPtr End Type #Else Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As Long Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As Long ItemListPointer As Long ClassName As String ClassKeyHandle As Long HotKey As Long IconHandle As Long ProcessHandle As Long End Type #End If '======================================================================================================================= '------ تعريفات API #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr ' فتح مقبض العملية Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long ' إغلاق مقبض العملية 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 Long ' جلب رمز الخروج للعملية Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, 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 ' إعادة تخصيص حجم السلسلة Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr ' إنشاء مؤقت قابل للانتظار Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long ' جلب معرف العملية Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long ' تبسيط المسار Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr ' استخراج المعاملات من المسار Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long ' تنفيذ أمر عبر Shell 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) ' إزالة المعاملات من المسار Private Declare PtrSafe Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long ' فتح مقبض العملية Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long ' إغلاق مقبض العملية Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long ' إنشاء مؤقت قابل للانتظار Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long ' جلب معرف العملية Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long ' تبسيط المسار Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long ' استخراج المعاملات من المسار Private Declare 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 Long) As Long ' ضبط المؤقت Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long ' تنفيذ أمر عبر Shell Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long ' إعادة تخصيص السلسلة Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) ' إزالة المعاملات من المسار Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #End If '======================================================================================================================= '------ المتغيرات العامة و الخاصة Public g_TerminateLoops As Boolean ' متغير للتحكم في إنهاء الحلقات يدويًا Private m_IsExecuting As Boolean ' علامة لمنع التداخل أثناء التنفيذ '======================================================================================================================= '------------------------------------------- الدوال العامة ' تشغيل أمر والانتظار حتى ينتهي مع استجابة الواجهة Public Function ExecuteAndWait(ByVal CommandLine As String, _ Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, _ Optional ByVal RunAsAdmin As Boolean = False, _ Optional ByVal MaxWaitMs As Long = PROCESS_TIMEOUT_INFINITE) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteAndWait", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ' توسيع متغيرات البيئة ExpandedPath = ExpandEnvVars(CommandLine) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر: " & CommandLine End If ProcessHandle = .ProcessHandle End With startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If MaxWaitMs <> PROCESS_TIMEOUT_INFINITE Then If (GetTickCount - startTime) > MaxWaitMs Then Debug.Print "تجاوز الحد الأقصى للانتظار: " & MaxWaitMs & " ميلي ثانية" Exit Do End If End If Loop ExecuteAndWait = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteAndWait", Err.Description End Function ' دالة لتنفيذ أمر مع مهلة زمنية اختيارية وخيار التشغيل كمسؤول Public Function ExecuteWithTimeout(Command As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long, Optional ByVal RunAsAdmin As Boolean = False, Optional RetryCount As Long = 0) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long Dim RetryIndex As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ExpandedPath = ExpandEnvVars(Command) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If For RetryIndex = 0 To RetryCount With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then If RetryIndex = RetryCount Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteWithTimeout", "فشل في تنفيذ الأمر بعد " & RetryCount + 1 & " محاولات: " & Command End If Else ProcessHandle = .ProcessHandle Exit For End If End With Next RetryIndex startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If TimeoutMs > 0 Then If (GetTickCount - startTime) > TimeoutMs Then If TerminateProcess(ProcessHandle, PROCESS_TERMINATED) = 0 Then Debug.Print "فشل في إنهاء العملية بعد تجاوز المهلة" End If ExitCode = PROCESS_TERMINATED Exit Do End If End If If g_TerminateLoops Then Exit Do Loop ExecuteWithTimeout = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteWithTimeout", Err.Description End Function ' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار Public Function ExecuteWScript(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal WaitForCompletion As Boolean = False) As Long Dim WScriptShell As Object On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") ExecuteWScript = WScriptShell.Run(CommandLine, WindowStyle, WaitForCompletion) Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description Err.Raise Err.Number, "ExecuteWScript", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function ' دالة محسنة لتشغيل أمر باستخدام WScript.Shell والتقاط الناتج Public Function ExecuteWScriptCapture(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal) As String Dim WScriptShell As Object Dim ShellExec As Object Dim Output As String On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") Set ShellExec = WScriptShell.Exec(CommandLine) Do While ShellExec.Status = 0 DoEvents Loop Output = ShellExec.StdOut.ReadAll ExecuteWScriptCapture = Output Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description ExecuteWScriptCapture = "" Err.Raise Err.Number, "ExecuteWScriptCapture", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function '======================================================================================================================= '------ الدوال المساعدة ' دالة لتوسيع متغيرات البيئة في سلسلة (مثل %windir%) Private Function ExpandEnvVars(ByVal Path As String) As String Dim Buffer As String Dim Length As Long If InStr(Path, "%") Then Length = ExpandEnvironmentStringsW(StrPtr(Path), 0, 0) If Length > 0 Then Buffer = String$(Length - 1, vbNullChar) If ExpandEnvironmentStringsW(StrPtr(Path), StrPtr(Buffer), Length) Then ExpandEnvVars = Left$(Buffer, Length - 1) Else Debug.Print "فشل توسيع متغيرات البيئة، يتم إرجاع المسار الأصلي: " & Path ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If End Function ' دالة لتبسيط المسار (مثل حل النقاط . و ..) Private Function CanonicalizePath(ByVal Path As String) As String Dim TempPath As String If InStr(Path, "\.") Or InStr(Path, ".\") Then If Len(Path) < MAX_PATH_LENGTH Then TempPath = String$(MAX_PATH_LENGTH - 1, vbNullChar) If PathCanonicalizeW(StrPtr(TempPath), StrPtr(Path)) Then CanonicalizePath = Left$(TempPath, InStr(TempPath, vbNullChar) - 1) Else Debug.Print "فشل تبسيط المسار، يتم إرجاع المسار الأصلي: " & Path CanonicalizePath = Path End If Else CanonicalizePath = Path End If Else CanonicalizePath = Path End If End Function ' دالة لاستخراج المعاملات من المسار Private Function ExtractArguments(ByRef Path As String) As String SysReAllocString VarPtr(ExtractArguments), PathGetArgsW(StrPtr(Path)) If LenB(ExtractArguments) Then PathRemoveArgsW StrPtr(Path) If InStr(ExtractArguments, """") Then ExtractArguments = Replace(ExtractArguments, """", """""") End If End Function ' دالة مساعدة لاستخراج اسم العملية من الأمر Private Function ExtractProcessName(ByVal CommandLine As String) As String Dim Parts() As String Dim FirstPart As String If Left(CommandLine, 1) = """" Then FirstPart = Mid(CommandLine, 2, InStr(2, CommandLine, """") - 2) Else Parts = Split(CommandLine, " ") FirstPart = Parts(0) End If ExtractProcessName = Mid(FirstPart, InStrRev(FirstPart, "\") + 1) End Function ' دالة لإنهاء عملية باستخدام WMI بناءً على اسم العملية Public Function KillProcess(sProcessName As String, Optional sHost As String = ".") As Boolean On Error GoTo Error_Handler Dim oWMI As Object Dim sWMIQuery As String Dim oCols As Object Dim oCol As Object Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2") sWMIQuery = "SELECT Name FROM Win32_Process" Set oCols = oWMI.ExecQuery(sWMIQuery) For Each oCol In oCols If LCase(sProcessName) = LCase(oCol.Name) Then oCol.Terminate End If Next oCol KillProcess = True Error_Handler_Exit: On Error Resume Next Set oCol = Nothing Set oCols = Nothing Set oWMI = Nothing Exit Function Error_Handler: Debug.Print "خطأ في KillProcess: " & Err.Description & " - رقم الخطأ: " & Err.Number KillProcess = False Resume Error_Handler_Exit End Function اوامر الاستدعاء المختلفة : سوف نقوم بعمل وحده نمطيه عامه لتجربة : WinRAR اسم الوحده النمطيه : basArchiveExamplesWinRAR ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit ' وحدة نمطية تحتوي على أمثلة شاملة لضغط وفك ضغط باستخدام WinRAR مع كل الخيارات ' =========================================================================== ' 1. ضغط ملف واحد ' =========================================================================== ' بدون كلمة مرور، مستوى ضغط عادي Sub CompressSingleFileNoPasswordWinRAR() CompressItems "file1.txt", , WinRAR, ArchiveZIP, CompressionNormal ' الناتج: file1.rar في CurrentProject.Path End Sub ' مع كلمة مرور، مستوى ضغط أقصى Sub CompressSingleFileWithPasswordMaxCompressionWinRAR() Dim password As String ' تعيين كلمة المرور password = "officena" CompressItems "file1.txt", password, WinRAR, ArchiveZIP, 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) ' استخدام كلمة المرور في الضغط CompressItems "Folder1", password, WinRAR, ArchiveRAR, CompressionNormal, , , , True, commentFile ' الناتج: Folder1.rar (مشفر بكلمة المرور "MS-Access(officena)"، مع تعليق) في CurrentProject.Path End Sub ' =========================================================================== ' 2. فك ضغط ملف واحد ' =========================================================================== ' بدون كلمة مرور، الكتابة فوق الملفات Sub ExtractSingleFileNoPasswordOverwriteWinRAR() ExtractItems CurrentProject.Path & "\file1.zip", CurrentProject.Path & "\Extracted", , WinRAR, OverwriteAll ' الناتج: محتويات file1.rar مفكوكة في CurrentProject.Path\Extracted مع الكتابة فوق الملفات End Sub ' مع كلمة مرور، تجاهل الملفات الموجودة Sub ExtractSingleFileWithPasswordNoOverwriteWinRAR() Dim password As String ' تعيين كلمة المرور password = "officena" ExtractItems CurrentProject.Path & "\file1.zip", 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) Dim filesArray As Variant filesArray = Array("file1.txt", "file2.docx", "file3.pdf", "Folder1", "Folder2") 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) 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) 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) 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 سوف نقوم بعمل وحده نمطيه عامه لتجربة : 7Zip اسم الوحده النمطيه : basArchiveExamples7Zip ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) 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("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 وأخيــــر وحده نمطيه عامة لضغط قاعدة البيانات الحاليه( الأمامية أو الخلفيه أو الأمامية والخلفية معا أو القاعدة الحاليه فقط ان لم تكن منقسمه ) اسم الوحدة النمطية : basCompressDatabase الكود ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit ' تعداد لتحديد نوع القاعدة المراد ضغطها Enum EnumDatabaseType FrontEndOnly = 0 ' ضغط القاعدة الحالية (Front-End) فقط BackEndOnly = 1 ' ضغط القاعدة الخلفية (Back-End) فقط BothFrontAndBack = 2 ' ضغط القاعدة الحالية والخلفية معًا End Enum ' دالة لضغط قاعدة البيانات الحالية و/أو الخلفية بناءً على الخيارات ' المدخلات: ' - dbType: نوع القاعدة المراد ضغطها (Front-End، Back-End، أو الاثنين) ' - archiveName: اسم الأرشيف الناتج (اختياري، لو فارغ بيستخدم اسم القاعدة) ' - targetPath: مسار حفظ الأرشيف (اختياري، لو فارغ بيستخدم مسار القاعدة) ' - Method: أداة الضغط (WinRAR أو SevenZip، افتراضي SevenZip) ' - ArchiveType: نوع الأرشيف (افتراضي Archive7z) ' - compressionLevel: مستوى الضغط (افتراضي CompressionNormal) ' - password: كلمة المرور لتشفير الأرشيف (اختياري) ' - commentFile: مسار ملف التعليقات لإضافته إلى الأرشيف (اختياري) ' دالة لضغط قاعدة البيانات الحالية و/أو الخلفية بناءً على الخيارات ' المدخلات: ' - dbType: نوع القاعدة المراد ضغطها (Front-End، Back-End، أو الاثنين) ' - archiveName: اسم الأرشيف الناتج (اختياري، لو فارغ بيستخدم اسم القاعدة) ' - targetPath: مسار حفظ الأرشيف (اختياري، لو فارغ بيستخدم مسار القاعدة) ' - Method: أداة الضغط (WinRAR أو SevenZip، افتراضي SevenZip) ' - ArchiveType: نوع الأرشيف (افتراضي Archive7z) ' - compressionLevel: مستوى الضغط (افتراضي CompressionNormal) ' - password: كلمة المرور لتشفير الأرشيف (اختياري) ' - commentFile: مسار ملف التعليقات لإضافته إلى الأرشيف (اختياري) ' - showHelp: عرض تعليمات قبل الضغط إذا كان True (افتراضي False) ' دالة لضغط قاعدة البيانات الحالية و/أو الخلفية بناءً على الخيارات ' المدخلات: ' - dbType: نوع القاعدة المراد ضغطها (إجباري: FrontEndOnly, BackEndOnly, BothFrontAndBack) ' - archiveName: اسم الأرشيف الناتج (اختياري، لو فارغ بيستخدم اسم القاعدة) ' - targetPath: مسار حفظ الأرشيف (اختياري، لو فارغ بيستخدم مسار القاعدة) ' - Method: أداة الضغط (اختياري: WinRAR أو SevenZip، افتراضي SevenZip) ' - ArchiveType: نوع الأرشيف (اختياري، افتراضي Archive7z) ' - compressionLevel: مستوى الضغط (اختياري، افتراضي CompressionNormal) ' - password: كلمة المرور لتشفير الأرشيف (اختياري) ' - commentFile: مسار ملف التعليقات لإضافته إلى الأرشيف (اختياري) Sub CompressDatabase( _ ByVal dbType As EnumDatabaseType, _ Optional ByVal archiveName As String = "", _ Optional ByVal targetPath As String = "", _ Optional ByVal Method As EnumArchiveMethod = SevenZip, _ Optional ByVal ArchiveType As EnumArchiveType = Archive7z, _ Optional ByVal compressionLevel As EnumCompressionLevel = CompressionNormal, _ Optional ByVal password As String = "", _ Optional ByVal commentFile As String = "") Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") On Error GoTo ErrorHandler ' التحقق من صحة dbType If dbType < FrontEndOnly Or dbType > BothFrontAndBack Then MsgBox "خطأ: نوع القاعدة (dbType) غير صحيح!", vbExclamation ShowHelp Exit Sub End If ' متغيرات لتخزين مسارات القاعدة Dim frontEndPath As String Dim backEndPath As String Dim tempFrontEndPath As String Dim tempBackEndPath As String ' الحصول على مسار القاعدة الحالية (Front-End) frontEndPath = CurrentDb.Name ' مثل: "C:\Users\YourUser\Documents\FrontEnd.accdb" ' الحصول على مسار القاعدة الخلفية (Back-End) إذا كانت موجودة backEndPath = GetBackEndPath() ' تحديد المسارات المؤقتة في مجلد Temp tempFrontEndPath = Environ$("TEMP") & "\" & fso.GetFileName(frontEndPath) If backEndPath <> "" Then tempBackEndPath = Environ$("TEMP") & "\" & fso.GetFileName(backEndPath) End If ' تحديد مسار واسم الأرشيف الناتج Dim finalTargetPath As String finalTargetPath = IIf(targetPath = "", fso.GetParentFolderName(frontEndPath), targetPath) ' معالجة حسب نوع القاعدة المطلوب Select Case dbType Case FrontEndOnly ' ضغط القاعدة الحالية فقط fso.CopyFile frontEndPath, tempFrontEndPath, True Dim frontEndArchiveName As String frontEndArchiveName = IIf(archiveName = "", fso.GetBaseName(frontEndPath), archiveName) & GetArchiveExtension(ArchiveType) Dim uniqueFrontEndArchive As String uniqueFrontEndArchive = GenerateUniqueFileName(finalTargetPath, frontEndArchiveName) CompressItems tempFrontEndPath, password, Method, ArchiveType, compressionLevel, SplitNone, finalTargetPath, fso.GetBaseName(uniqueFrontEndArchive), , commentFile If fso.FileExists(tempFrontEndPath) Then fso.DeleteFile tempFrontEndPath Case BackEndOnly ' ضغط القاعدة الخلفية فقط If backEndPath = "" Then MsgBox "لا توجد قاعدة خلفية مرتبطة!", vbExclamation Exit Sub End If fso.CopyFile backEndPath, tempBackEndPath, True Dim backEndArchiveName As String backEndArchiveName = IIf(archiveName = "", fso.GetBaseName(backEndPath), archiveName) & GetArchiveExtension(ArchiveType) Dim uniqueBackEndArchive As String uniqueBackEndArchive = GenerateUniqueFileName(finalTargetPath, backEndArchiveName) CompressItems tempBackEndPath, password, Method, ArchiveType, compressionLevel, SplitNone, finalTargetPath, fso.GetBaseName(uniqueBackEndArchive), , commentFile If fso.FileExists(tempBackEndPath) Then fso.DeleteFile tempBackEndPath Case BothFrontAndBack ' ضغط القاعدتين معًا If backEndPath = "" Then MsgBox "لا توجد قاعدة خلفية، سيتم ضغط القاعدة الحالية فقط!", vbInformation fso.CopyFile frontEndPath, tempFrontEndPath, True Dim singleArchiveName As String singleArchiveName = IIf(archiveName = "", fso.GetBaseName(frontEndPath) & "_Full", archiveName) & GetArchiveExtension(ArchiveType) Dim uniqueSingleArchive As String uniqueSingleArchive = GenerateUniqueFileName(finalTargetPath, singleArchiveName) CompressItems tempFrontEndPath, password, Method, ArchiveType, compressionLevel, SplitNone, finalTargetPath, fso.GetBaseName(uniqueSingleArchive), , commentFile If fso.FileExists(tempFrontEndPath) Then fso.DeleteFile tempFrontEndPath Else fso.CopyFile frontEndPath, tempFrontEndPath, True fso.CopyFile backEndPath, tempBackEndPath, True Dim bothFiles(1) As String bothFiles(0) = tempFrontEndPath bothFiles(1) = tempBackEndPath Dim bothArchiveName As String bothArchiveName = IIf(archiveName = "", fso.GetBaseName(frontEndPath) & "_Full", archiveName) & GetArchiveExtension(ArchiveType) Dim uniqueBothArchive As String uniqueBothArchive = GenerateUniqueFileName(finalTargetPath, bothArchiveName) CompressItems bothFiles, password, Method, ArchiveType, compressionLevel, SplitNone, finalTargetPath, fso.GetBaseName(uniqueBothArchive), , commentFile If fso.FileExists(tempFrontEndPath) Then fso.DeleteFile tempFrontEndPath If fso.FileExists(tempBackEndPath) Then fso.DeleteFile tempBackEndPath End If End Select Set fso = Nothing Exit Sub ErrorHandler: MsgBox "خطأ في ضغط قاعدة البيانات: " & Err.Description, vbCritical LogError "CompressDatabase Error: " & Err.Description ShowHelp ' عرض التعليمات عند حدوث أي خطأ ' تنظيف الملفات المؤقتة في حالة الخطأ If fso.FileExists(tempFrontEndPath) Then fso.DeleteFile tempFrontEndPath If fso.FileExists(tempBackEndPath) Then fso.DeleteFile tempBackEndPath Set fso = Nothing End Sub ' دالة مساعدة للحصول على مسار القاعدة الخلفية من الجداول المرتبطة Private Function GetBackEndPath() As String On Error GoTo ErrorHandler Dim tdf As DAO.TableDef Dim db As DAO.Database Set db = CurrentDb ' فحص الجداول المرتبطة For Each tdf In db.TableDefs If Len(tdf.Connect) > 0 Then ' إذا كان الجدول مرتبطًا ' استخراج المسار من خاصية Connect Dim connectString As String connectString = tdf.Connect If InStr(connectString, "DATABASE=") > 0 Then GetBackEndPath = Mid(connectString, InStr(connectString, "DATABASE=") + 9) Exit Function End If End If Next tdf ' إذا لم يتم العثور على قاعدة خلفية GetBackEndPath = "" Exit Function ErrorHandler: GetBackEndPath = "" End Function ' توليد اسم ملف فريد Public Function GenerateUniqueFileName(Folderpath As String, Filename As String) As String Dim baseName As String Dim extension As String Dim counter As Integer Dim uniqueName As String baseName = Left(Filename, InStrRev(Filename, ".") - 1) extension = Mid(Filename, InStrRev(Filename, ".")) uniqueName = Folderpath & "\" & Filename counter = 1 Do While Dir(uniqueName) <> "" uniqueName = Folderpath & "\" & baseName & " (" & counter & ")" & extension counter = counter + 1 Loop GenerateUniqueFileName = uniqueName End Function ' إجراء لتسجيل الأخطاء في ملف نصي بمسار المشروع الحالي Sub LogError(errorMessage As String) Dim logFile As String logFile = CurrentProject.Path & "\ErrorLog.txt" Open logFile For Append As #1 Print #1, Now & " - " & errorMessage Close #1 End Sub ' إجراء لعرض نافذة تعليمات تحتوي على تعريف الباراميترات Sub ShowHelp() MsgBox "تعليمات CompressDatabase:" & vbCrLf & _ "الباراميترات:" & vbCrLf & _ "- dbType (إجباري): نوع القاعدة المراد ضغطها" & vbCrLf & _ " * FrontEndOnly: ضغط القاعدة الحالية فقط" & vbCrLf & _ " * BackEndOnly: ضغط القاعدة الخلفية فقط" & vbCrLf & _ " * BothFrontAndBack: ضغط القاعدتين معًا" & vbCrLf & _ "- archiveName (اختياري): اسم الأرشيف، لو فارغ يستخدم اسم القاعدة" & vbCrLf & _ "- targetPath (اختياري): مسار الحفظ، لو فارغ يستخدم مسار القاعدة" & vbCrLf & _ "- Method (اختياري): أداة الضغط (WinRAR أو SevenZip)، افتراضي SevenZip" & vbCrLf & _ "- ArchiveType (اختياري): نوع الأرشيف (مثل Archive7z, ArchiveZIP)، افتراضي Archive7z" & vbCrLf & _ "- compressionLevel (اختياري): مستوى الضغط (مثل CompressionNormal)، افتراضي CompressionNormal" & vbCrLf & _ "- password (اختياري): كلمة المرور للتشفير" & vbCrLf & _ "- commentFile (اختياري): مسار ملف التعليقات" & vbCrLf & _ "ملاحظات: راجع التعدادات (EnumDatabaseType, EnumArchiveMethod, EnumArchiveType, EnumCompressionLevel) في الكود", vbInformation End Sub Sub TestCompressDatabase() 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) ' ضغط القاعدة الحالية فقط CompressDatabase FrontEndOnly, , , WinRAR, ArchiveZIP, CompressionMaximum, password, commentFile '' ' ضغط القاعدة الخلفية فقط (لو موجودة) '' CompressDatabase BackEndOnly, "MyBackend", "", WinRAR, ArchiveRAR '' ' الناتج: C:\Backups\MyBackend.zip '' '' ' ضغط القاعدتين معًا '' CompressDatabase BothFrontAndBack, "FullBackup", "", WinRAR, ArchiveRAR, CompressionMaximum '' ' الناتج: C:\Backups\FullBackup.7z يحتوي على الـ Front-End والـ Back-End (لو موجود) End Sub فى انتظار آرائكم بشغف انا كتبت اكواد التجربة على اعتبار وجود المجلدات والملفات فى مسار قاعدة البيانات على ان يكون اسماء المجلدات كالتالى : Folder1 Folder2 واسماء الملفات كالتالى : file1.txt file2.docx file3.pdf طبعا يمكنكم تغيير اسماء وأماكن المجلدات والمسارات فى اكواد التجربه كما يحلو لكم ولكن قد أكون أخطأت فى أى شئ بسبب كبر الكود وتشعبه لذلك فى انتظار مراجعتكم وآرائكم ان شاء الله التحديثات الأخيــــره فى حالة التعامل مع البرامج المحموله امكانيه تحديد مسار التطبيق مره واحده فقط طوال الجلسة الحاليه اضافة نسخ محمولة مختلفة الانويه فى مسار القاعدة ل 7-zip ودعم الكود للعمل من خلالهما مباشرة فى حالة عدم التسطيب دعم اضافى لانواع الارشيف المختلفه والتعامل مع الانواع بمرونه اكبر اضافة وظائف لضغط قاعدة البيانات الحلفيه سواء كانت امامية فقط أو امامية وخلفيه لكل واحده على حده او كلاهما معا مع اسم فريد للاحتفاظ بالنسخ القديمه المضغوطة بتعداد متزايد اتمنى لكم تجربة ممتعة وأخيـــــــــــرا المرفق كلمة مرور فك الضغط للمرفق : officena OfficenaZip V2.zip

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

الان بعد ان تمت الاجابة بشكل عملي اجمالا وتفصيلا انا لى بعض التعقيبات البسيطه انا افضل ان كان هناك جزء ثابت يكون فى الجهة اليسرى وليس فى الجهة اليمنى <<---< هذا افضل من وجهة نظرى انا لا افضل استخدام التسيق الذى يحدد عد منازل الترقيم لانه مثلا لو افترضنا انه تم التعامل على ان عدد منازل الترقيم سوف يكون 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 أفندى وعارفك بتضحك ليه : لانه دائما استلهم افكارى منك ومن مشاركاتك الجميله

هههههه طيب مبدئيا وتعالى نقول ليه كودك افضل من الكود الاول والمستخدم فى المرفق : الفرق بينهما المعيار الكود الأول الكود الثاني طريقة الاستعلام يستخدم Recordset مع SELECT TOP 1 ... ORDER BY لجلب أعلى قيمة. يستخدم DMax للحصول على أعلى قيمة مباشرة. الأداء أبطأ نسبيًا لأنه يفتح Recordset ويتعامل مع البيانات يدويًا. أسرع لأن DMax يعمل على مستوى المحرك دون الحاجة إلى فتح Recordset. الدقة دقيق إذا كان النمط ثابتًا (XX/CCCC)، لكنه قد يفشل إذا كان هناك بيانات غير متوقعة. دقيق بنفس القدر، مع تحكم أفضل في شرط البحث باستخدام Right. المرونة أقل مرونة لأنه يعتمد على LIKE وتحليل النص يدويًا. أكثر مرونة لأن DMax يسمح بتخصيص الشرط بسهولة. معالجة الأخطاء جيدة، لكن يمكن تحسينها بإضافة تفاصيل الخطأ. جيدة، لكن قد تفشل إذا كان تعبير DMax معقدًا جدًا. الكفاءة في الذاكرة يستهلك ذاكرة أكثر بسبب Recordset. أقل استهلاكًا لأنه لا يفتح كائنات إضافية. طيب ولأن وقت الجواب كنت صايم وكان وقت الفطار خلاص وكنت مستعجل وبعد قراءة كودك الجميل كودك افضل ولكن ايه رايك فى كتابة الكود بهذه الطريقة 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 والكود الثانى المعيار الكود الأول الكود الثاني طريقة الاستعلام يستخدم QueryDef مع استعلام SQL يدوي لجلب أعلى قيمة باستخدام Max. يستخدم DMax للحصول على أعلى قيمة مباشرة. الأداء أبطأ نسبيًا بسبب إنشاء QueryDef وفتح Recordset في كل استدعاء. أسرع لأن DMax يعمل مباشرة على مستوى محرك قاعدة البيانات دون كائنات إضافية. الدقة دقيق، لكن شرط LIKE '*branchCode' قد يتطابق مع قيم غير مرغوبة (مثل "X/1000Y"). أكثر دقة بسبب شرط LIKE '*/branchCode' الذي يضمن النمط الصحيح. المرونة أقل مرونة (تنسيق ثابت "00"). أكثر مرونة بفضل minDigits لتخصيص عدد الأرقام (مثل "001" أو "0001"). معالجة الأخطاء أساسية، تفتقر إلى تفاصيل الخطأ. أفضل، تتضمن رقم الخطأ والوصف والمدخلات لتسهيل التصحيح. الكفاءة في الذاكرة يستهلك ذاكرة أكثر بسبب QueryDef وRecordset. أقل استهلاكًا لأنه يعتمد على DMax فقط. التحقق من المدخلات أقل دقة (Trim(tableName & serialField & branchCode) قد يفشل إذا كان أحد الحقول فارغًا ولكن الباقي ليس كذلك). أكثر دقة (يتحقق من كل حقل على حدة). تحياتى لكل اساتذتى العظماء