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

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

السلام عليكم ورحمة الله وبركاته أشارك معكم اليوم وحدة نمطية متقدمة باسم 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 تمنياتى القلبيــــه بأكبر قدر ممكن من تحصيل المتعة والاستفاده

السلام عليكم ورحمة الله تعالى وبركاته كل عام وانتم بخيــر يأتى شهر الخير ومعه البركات ذات مرة شاركت فى موضوع بخصوص فصل الرقم القومى وهذا هو الموضوع ولكن بصراحه انا معقد بطبعى ولا اهوى الحلول المعتادة والتى تستدعها اعدادها بشكل خاص فى كل مره ولذلك كتبت اجراء ذكي هههههههههه محدش يضحك 😡 شايفكم يوفر العديد من العناء والاستعلامات ووجع الراس ده غير المرونه والــ ...... ما تيجوا نشوف أحسن اولا : وحدة نمطيه عامة باسم : basDistributeNumeric الاكواد داخل الوحدة النمطيه هى : ' إجراء لفحص ما إذا كان النص يحتوي على أرقام فقط Function IsNumericOnly(ByVal InputString As String) As Boolean Dim i As Integer Dim char As String ' التحقق من أن السلسلة ليست فارغة If Len(InputString) = 0 Then IsNumericOnly = False Exit Function End If ' التحقق من أن كل حرف هو رقم فقط For i = 1 To Len(InputString) char = Mid(InputString, i, 1) If Not (char >= "0" And char <= "9") Then IsNumericOnly = False Exit Function End If Next i ' إذا كانت جميع الأحرف أرقام، ترجع True IsNumericOnly = True End Function الغرض : التأكد من ان القيمه التى سوف يتم تمريرها هى أرقام ثم الإجراء الرئيسي : لفصل الأرقام ' إجراء لفصل و توزيع القيم الرقمية اما فى متغير او عنصر تحكم مثل مربع نص Public Sub DistributeNumericInput(Optional TargetObject As Object = Nothing, Optional InputValue As Variant, Optional MaxFields As Integer = 14, Optional ControlPrefix As String = "txt") Dim Index As Integer Dim ControlItem As Control Dim TextBoxCollection As Object ' Dictionary لتخزين مربعات النص Dim TargetTextBox As Control ' لتعريف كل مربع نص عند التكرار Dim NumericString As String Dim DictKey As Variant ' لتجنب مشاكل الفهارس عند التعامل مع Dictionary ' التحقق من نوع الإدخال ومعالجته If TypeName(InputValue) = "TextBox" Then If IsNull(InputValue.Value) Or Not IsNumericOnly(InputValue.Value) Then MsgBox "الإدخال غير صالح، يرجى إدخال أرقام فقط!", vbExclamation, "خطأ" Exit Sub End If NumericString = InputValue.Value ElseIf VarType(InputValue) = vbString Or VarType(InputValue) = vbVariant Then If Not IsNumericOnly(InputValue) Then MsgBox "الإدخال يجب أن يحتوي على أرقام فقط!", vbExclamation, "خطأ" Exit Sub End If NumericString = InputValue Else MsgBox "نوع الإدخال غير مدعوم، يرجى إدخال مربع نص أو قيمة رقمية نصية!", vbCritical, "خطأ" Exit Sub End If ' إنشاء قاموس لتخزين مربعات النص ذات البادئة المحددة فقط Set TextBoxCollection = CreateObject("Scripting.Dictionary") ' البحث عن مربعات النص المناسبة داخل النموذج أو التقرير If Not TargetObject Is Nothing Then For Each ControlItem In TargetObject.Controls ' التأكد من أن العنصر هو مربع نص ويمتلك البادئة المحددة If TypeName(ControlItem) = "TextBox" And Left(ControlItem.Name, Len(ControlPrefix)) = ControlPrefix Then Index = Val(Mid(ControlItem.Name, Len(ControlPrefix) + 1)) ' استخراج الرقم من اسم مربع النص If Index >= 1 And Index <= MaxFields Then TextBoxCollection.Add Index, ControlItem End If End If Next ControlItem End If ' مسح محتوى مربعات النص إذا كان هناك مربعات متاحة If TextBoxCollection.Count > 0 Then For Each DictKey In TextBoxCollection.Keys TextBoxCollection(DictKey).Value = "" ' مسح القيم Next DictKey End If ' التحقق من توفر عدد كافٍ من مربعات النص If TextBoxCollection.Count > 0 And TextBoxCollection.Count < Len(NumericString) Then MsgBox "عدد مربعات النص غير كافٍ لعرض كافة الأرقام!", vbExclamation, "خطأ" Exit Sub End If ' توزيع الأرقام على مربعات النص For Index = 1 To Len(NumericString) If Index > MaxFields Then Exit For If TextBoxCollection.Exists(Index) Then Set TargetTextBox = TextBoxCollection(Index) TargetTextBox.Value = Mid(NumericString, Index, 1) Else Call PrintDigitInfo(Index, ControlPrefix, NumericString) End If Next Index ' تنظيف المتغيرات Set TextBoxCollection = Nothing Set TargetTextBox = Nothing End Sub الغرض : الفصل والتوزيع تم كتابة الإجراء السابق بشكل احترافى ومرن ليمكن استدعاءه بتمرير معاملات اليه بكل مرونه الفوائد : ✔ مرونة فائقة : يمكن استدعاء الإجراء دون الحاجة إلى تمرير Target Object إذا لم يكن مطلوبا ✔ دعم إستخدام القيم بشكل مباشر : يمكن استخدامه فقط لمعالجة قيمة رقمية وطباعة النتيجة بدلا من الحاجة إلى نموذج أو تقرير ✔ دعم الاستخدام الأمثل لتعبئة القيم : يمكن استخدامه لمعالجة القيم أو تعبئة مربعات النص حسب الحاجة ✔ الاستدعاء مع نموذج أو تقرير >>--> تحديد النموذج او التقرير الحالي من خلال استخدام : Me تمرير اسم العنصر الذى يحتوى على القيم الرقميه " اسم مربع النص" لو تم الاكتفاء بذلك سوف يقوم الإجراء بفصل عدد 14 رقم وهو المستخدم فى الكود اختياريا أو يمكن تمرير عدد الارقام الذى تريده حسب الحاجة و هنا قمة المتعة والمرونه ثم بعد ذلك تمرر البادئه الخاصة باسماء مربعات النص التى تسبق الارقام " يعنى مثلا مع الرقم القومى سوف استخدم عدد 14 مربع يبدأ بالبادئة : txtNatId ثم الرقم من 1 الى الرقم 14 " فى الاستدعاء التالى مثلا تحصل على فصل وتوزيع 14 أرقام Call BindTextBoxes(Me, "txtIns", 14, "txtNatId " أو ممكن بهذا الشكل فى هذه الحاله يتم استخدام الرقم الاختيارى المفضل ضمن الكود وهو 14 Call BindTextBoxes(Me, "txtIns", , "txtNatId " * وماذا لو كان هناك اكثر من رقم مثلما هو موجود فى الموضوع المشار إليه مثل الرقم التأمينى , كود المنشأه ونريد فصلهم بنفس الآليه وهذا هو ما دفعنى الى التفكير فى كتابة هذه الإجراءات الذكيه والتى يمكنها التعامل مباشرة بكل سهولة مع اى سلسلة رقميه مهما كان طولها أو اختلفت طيب لاعادة الاستدعاء مع امثلة أخري مثل الرقم التآمينى مثلا تحديد النموذج او التقرير الحالي من خلال استخدام : Me تمرير اسم العنصر الذى يحتوى على القيم الرقميه " اسم مربع النص" لو تم الاكتفاء بذلك سوف يقوم الإجراء بفصل عدد 14 رقم وهو المستخدم فى الكود اختياريا أو يمكن تمرير عدد الارقام الذى تريده حسب الحاجة و هنا قمة المتعة والمرونه سوف نستخدم مثلا 10 أرقام ثم بعد ذلك تمرر البادئه الخاصة باسماء مربعات النص التى تسبق الارقام مثلا مع الرقم التآمينى سوف استخدم عدد 10 مربع يبدأ بالبادئة : txtIns ثم الرقم من 1 الى الرقم 10" Call DistributeNumericInput(Me, lngInsuranceID, 10, "txtIns") وهكذا حسب الحاجة وحسب الرغبه * اذا أردانا التجربة للطباعة داخل النافذة الفورية على سبيل التجربة ' لتجربة طباعة النتيجة مباشرة في النافذة الفورية Private Sub PrintDigitInfo(Index As Integer, ControlPrefix As String, NumericString As String) Debug.Print "Digit Index " & Format(Index, "00") & " is : >>-> " & ControlPrefix & " " & Mid(NumericString, Index, 1) End Sub ونكتب مباشرة فى النافذة الفورية على سبيل المثال : DistributeNumericInput , "9876543210",5,"" سوف نحصل منها على النتيجة التاليه لفصل الارقام الخمسة الاولى Digit Index 01 is : >>-> 9 Digit Index 02 is : >>-> 8 Digit Index 03 is : >>-> 7 Digit Index 04 is : >>-> 6 Digit Index 05 is : >>-> 5 - طيب لنفترض اناا نريد تنفيذ عملية الفصل والتوزيع فى نموذج مستمر : برضو كتبت لكم إجراء ذكى لعمل استعلام ديناميكى الكود فى الوحدة النمطيه ' إجراء لإنشاء استعلام ديناميكي بناءً على الحقول المدخلة Public Function GenerateDynamicSQL(tableName As String, ParamArray RequiredFieldsDistribute() As Variant) As String Dim sqlQuery As String Dim i As Integer Dim fieldName As String Dim maxDigits As Integer Dim fieldPrefix As String Dim fieldInfo As Variant ' بدء بناء جملة SQL sqlQuery = "SELECT " & tableName & ".*, " ' معالجة كل حقل مطلوب مع عدد الأرقام والبادئة الخاصة به For Each fieldInfo In RequiredFieldsDistribute fieldName = fieldInfo(0) ' اسم الحقل maxDigits = fieldInfo(1) ' عدد الأرقام المطلوب توزيعها fieldPrefix = fieldInfo(2) ' البادئة المخصصة للحقول ' إنشاء الحقول المحسوبة لكل رقم في الحقل المطلوب مع البادئة For i = 1 To maxDigits sqlQuery = sqlQuery & "IIf(IsNull([" & fieldName & "]) OR Len([" & fieldName & "]) < " & i & ", Null, Mid([" & fieldName & "], " & i & ", 1)) AS " & fieldPrefix & i & ", " Next i Next fieldInfo ' إزالة الفاصلة الأخيرة لإكمال الجملة بشكل صحيح sqlQuery = Left(sqlQuery, Len(sqlQuery) - 2) ' إضافة جملة FROM sqlQuery = sqlQuery & " FROM " & tableName & ";" ' إرجاع جملة SQL النهائية GenerateDynamicSQL = sqlQuery End Function الغرض : عمل استعلام ديناميكى بكل سهولة ليكون مصدر بيانات للنموذج المستمر الفوائد : ✔ مرونة فائقة : تمرير اسم الجدول الذى يحتوى على حقل/حقول الأرقام المراد فصلها وتوزيعها ✔ مرونة فائقة : تمرير اسم (الحقل/حقول) للأرقام وذلك من خلال مصفوفة وفق الإجراء السابق الكود فى الوحدة النمطيه : ' إجراء للتحقق من وجود عنصر التحكم في النموذج Private Function ControlExists(frm As Form, ctrlName As String) As Boolean On Error Resume Next ControlExists = Not (frm.Controls(ctrlName) Is Nothing) On Error GoTo 0 End Function ' إجراء لربط مربعات النص بحقول البيانات تلقائيًا Sub BindTextBoxes(frm As Form, prefix As String, maxDigits As Integer) Dim i As Integer Dim ctrlName As String ' تعيين الحقول بناءً على العدد الصحيح لكل نوع For i = 1 To maxDigits ctrlName = prefix & i ' التحقق من وجود العنصر قبل تعيين ControlSource If ControlExists(frm, ctrlName) Then frm.Controls(ctrlName).ControlSource = ctrlName ' الحقل مرتبط مباشرة بالاستعلام End If Next i End Sub الفوائد : التأكد من وجود عناصر التحكم اللازمة أجراء لربط الحقول مع العناصر الخاصة بناء على الفصل وذلك لعملية التوزيع وبعد ذلك نقوم بعمل النموذج المستمر ونضع فيه العناصر اللازمة مع ضبط التسميات وفق الكود التى ونستدعى الإجراء السابق فى حدث الفتح للنموذج المستمر لتعين مصدر بيانات النموذج وفق الاستعلام الديناميكى داخل الإجراء الكود فى النموذج المستمر Private Sub Form_Open(Cancel As Integer) ' تعريف متغير لتخزين جملة SQL Dim sqlStatement As String ' إنشاء استعلام SQL ديناميكي لجلب البيانات المطلوبة مع توزيع الأرقام في الحقول sqlStatement = GenerateDynamicSQL("tblEmployees", _ Array("NationalID", 14, "txtNatId"), _ Array("InsuranceID", 10, "txtIns"), _ Array("OrganizationID", 10, "txtOrg")) ' تعيين جملة SQL كمصدر بيانات للنموذج Me.RecordSource = sqlStatement ' إعادة تحميل البيانات بعد تحديث مصدر السجلات Me.Requery End Sub - طبعا عند تغير الاسماء داخل الكود لابد من مطابقتها بالاسماء للعناصر داخل النموذج أو العكس الخطوة التاليه وهى توزيع الارقام التى تم فصلها على مربعات النص الغير منضمه اعتمادا على مصدر البيانات الذى تم انشائه بشكل آالى عند فتح النموذج ويتم ذلك من خلال الستدعاء التالى فى النموذج الكود داخل النموذج فى الحدث الحالى Private Sub Form_Current() ' ربط مربعات النصوص ببيانات الهوية القومية (14 خانة) Call BindTextBoxes(Me, "txtNatId", 14) ' ربط مربعات النصوص ببيانات الرقم التأميني (10 خانات) Call BindTextBoxes(Me, "txtIns", 10) ' ربط مربعات النصوص ببيانات كود المنشأة (10 خانات) Call BindTextBoxes(Me, "txtOrg", 10) End Sub بذلك نضمن فصل وتوزيع الارقام بشكل آلى * طيب الان لو أردنا عمل الفصل والتوزيع داخل تقرير : فى تصميم التقرير نقوم بالاعلان عن المتغيرات التاليه ' تعريف متغيرات لتخزين القيم النصية للأرقام Dim lngNationalID As String Dim lngInsuranceID As String Dim lngOrganizationID As String نقوم بعد ذلك باستدعاء إجراء الفصل والتوزيع حسب مكان مربعات النص اما فى منطقة الرأس أو التفصيل أو ذيل النموذج وفى حدث التنسيق لكل منطقة حسب تواجد المربعات الغير منضمه بها باستدعاء الأجراء بالشكل المباشر الكود داخل التقرير : Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بالرقم القومي If Not IsNull(Me!txtNationalID) Then lngNationalID = Trim(Me!txtNationalID) ' إزالة المسافات الفارغة من بداية ونهاية النص Else lngNationalID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات End If ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بالرقم التأميني If Not IsNull(Me!txtInsuranceID) Then lngInsuranceID = Trim(Me!txtInsuranceID) ' إزالة المسافات الفارغة من بداية ونهاية النص Else lngInsuranceID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات End If ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بالرقم القومي Call DistributeNumericInput(Me, lngNationalID, 14, "txtNatId") ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بالرقم التأميني Call DistributeNumericInput(Me, lngInsuranceID, 10, "txtIns") End Sub Private Sub PageHeaderSection_Format(Cancel As Integer, FormatCount As Integer) ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بكود المنشأة If Not IsNull(Me!txtOrganizationID) Then lngOrganizationID = Trim(Me!txtOrganizationID) ' إزالة المسافات الفارغة من بداية ونهاية النص Else lngOrganizationID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات End If ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بكود المنشأة Call DistributeNumericInput(Me, lngOrganizationID, 10, "txtOrg") End Sub --------------------------------------------- صورة توضيحيه من نموذج مفرد --------------------------------------------- صورة توضيحية من نموذج مستمر --------------------------------------------- صورة توضيحية من تقرير واخيــــرا المرفق أتمنى أن تكونوا قد إستمتعتم معنا فى منتدانا الرائـــــــع فصل و توزيع ارقام الرقم القومى.zip

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

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة : ( مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ - الإصدار الثانى ) باختصار بعد هذا الموضوع : اداة مطهر النصوص المرنه - FlexiTextSanitizer الوصف: هي أداة تهدف إلى تنظيف النصوص العربية (وغيرها) بكفاءة عالية مع دعم واسع للتخصيص. توفر الدالة الرئيسية خيارات متعددة لمعالجة النصوص بما في ذلك تطبيع الأحرف العربية إزالة الحركات التحكم في الأرقام والأحرف الخاصة إضافة أقواس تلقائية حول الأرقام الاحتفاظ بالرموز الرياضية مثل √ و∑ المميزات الرئيسية: دعم اللغات: عربية لاتينية أو كلاهما التحكم في الأرقام والرموز: الاحتفاظ بها إزالتها أو إضافة أقواس تلقائية معالجة علامات الترقيم: الاحتفاظ بها كلها إزالتها أو الاكتفاء بالفواصل والنقاط دعم الرموز الرياضية: الاحتفاظ برموز مثل ∞ و≠ في الحالات المحددة التطبيع: توحيد الأحرف العربية (مثل تحويل إِ إلى ا). كيف تعمل؟ المدخلات: نص خام مع خيارات اختيارية (تطبيع - لغة - معالجة - ترقيم) المعالجة: تطبيع الأحرف (اختياري) إزالة الحركات إضافة أقواس حول الأرقام (إذا طُلب) تنظيف النص بناءً على نمط محدد تقليص المسافات المخرجات: نص نظيف و منسق حسب الخيارات المحددة الكود داخل الوحدة النمطية العامة ' تعداد لتحديد وضع اللغة Public Enum LanguageMode ArabicOnly = 0 ' اللغة العربية فقط ArabicAndLatin = 1 ' اللغة العربية واللاتينية LatinOnly = 2 ' اللغة اللاتينية فقط End Enum ' تعداد لتحديد وضع المعالجة Public Enum ProcessingMode KeepAll = 0 ' الاحتفاظ بالأرقام والأحرف الخاصة removeNumbers = 1 ' إزالة الأرقام فقط KeepNumbersOnly = 2 ' الاحتفاظ بالأرقام وإزالة الأحرف الخاصة CleanAll = 3 ' تنظيف كامل (إزالة الأرقام والأحرف الخاصة) KeepBrackets = 4 ' الاحتفاظ بالأرقام والأقواس (مع إضافتها تلقائيًا) KeepSpecialSymbols = 5 ' الاحتفاظ بالرموز الرياضية والخاصة End Enum ' تعداد لتحديد معالجة علامات الترقيم Public Enum punctuationMode KeepAllPunctuation = 0 ' الاحتفاظ بجميع علامات الترقيم RemoveAllPunctuation = 1 ' إزالة جميع علامات الترقيم KeepBasicPunctuation = 2 ' الاحتفاظ فقط بالفواصل والنقاط (, .) End Enum ' الدالة الرئيسية: FlexiTextSanitizer Public Function FlexiTextSanitizer(inputText As String, Optional normalize As Boolean = False, _ Optional langMode As LanguageMode = ArabicOnly, _ Optional processMode As ProcessingMode = KeepAll, _ Optional punctuationMode As punctuationMode = KeepAllPunctuation, _ Optional customSpecialChars As String = "()،؛") As String On Error GoTo ErrorHandler If Nz(inputText, "") = "" Then FlexiTextSanitizer = "" Exit Function End If Dim sanitizedText As String sanitizedText = Trim(inputText) ' الخطوة 1: التطبيع إذا طُلب If normalize Then Dim charReplacementPairs As Variant charReplacementPairs = Array( _ Array(ChrW(1573), ChrW(1575)), _ Array(ChrW(1571), ChrW(1575)), _ Array(ChrW(1570), ChrW(1575)), _ Array(ChrW(1572), ChrW(1608)), _ Array(ChrW(1574), ChrW(1609)), _ Array(ChrW(1609), ChrW(1610)), _ Array(ChrW(1577), ChrW(1607)), _ Array(ChrW(1705), ChrW(1603)), _ Array(ChrW(1670), ChrW(1580))) Dim pair As Variant For Each pair In charReplacementPairs sanitizedText = Replace(sanitizedText, pair(0), pair(1)) Next End If ' الخطوة 2: إزالة الحركات باستخدام RegExp Dim regEx As Object Set regEx = CreateObject("VBScript.RegExp") regEx.Global = True regEx.Pattern = "[\u064B-\u0652\u0670]" ' نطاق الحركات العربية sanitizedText = regEx.Replace(sanitizedText, "") ' إزالة علامة السؤال بشكل افتراضي sanitizedText = Replace(sanitizedText, "?", "") ' الخطوة 3: إضافة أقواس تلقائية حول الأرقام إذا طُلب (KeepBrackets) If processMode = KeepBrackets Then regEx.Pattern = "(\b[\u0660-\u0669\u0030-\u0039]+\b)" ' الأرقام العربية واللاتينية sanitizedText = regEx.Replace(sanitizedText, "($1)") End If ' الخطوة 4: بناء نمط الأحرف المسموح بها Dim allowedPattern As String Select Case langMode Case ArabicOnly allowedPattern = "\u0621-\u064A" ' الأحرف العربية Case ArabicAndLatin allowedPattern = "\u0621-\u064A\u0041-\u007A" ' العربية واللاتينية (A-Z, a-z) Case LatinOnly allowedPattern = "\u0041-\u007A" ' اللاتينية فقط End Select ' إضافة الأرقام والأحرف الخاصة بناءً على وضع المعالجة Select Case processMode Case KeepAll allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039" & EscapeRegExChars(customSpecialChars) Case removeNumbers allowedPattern = allowedPattern & EscapeRegExChars(customSpecialChars) Case KeepNumbersOnly allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039" Case CleanAll ' لا شيء يُضاف (تنظيف كامل) Case KeepBrackets allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039\(\)" ' الاحتفاظ بالأرقام والأقواس Case KeepSpecialSymbols allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039\u2200-\u22FF" ' الأرقام والرموز الرياضية End Select ' إضافة علامات الترقيم بناءً على وضع المعالجة Select Case punctuationMode Case KeepAllPunctuation allowedPattern = allowedPattern & "!""#$%&'()*+,-./:;<=>?@[\\]^_`{|}~،؛" Case RemoveAllPunctuation ' لا شيء يُضاف (إزالة كل علامات الترقيم) Case KeepBasicPunctuation allowedPattern = allowedPattern & ",." End Select ' إضافة المسافة دائمًا وتطبيق النمط regEx.Pattern = "[^" & allowedPattern & "\s]" ' إزالة كل ما هو خارج النطاق sanitizedText = regEx.Replace(sanitizedText, "") ' الخطوة 5: تقليص المسافات المتعددة إلى واحدة regEx.Pattern = "\s+" sanitizedText = regEx.Replace(sanitizedText, " ") sanitizedText = Trim(sanitizedText) ' الخطوة 6: إرجاع النتيجة If Len(Trim(Nz(sanitizedText, ""))) = 0 Then FlexiTextSanitizer = vbNullString Else FlexiTextSanitizer = sanitizedText End If Exit Function ErrorHandler: Debug.Print "خطأ في FlexiTextSanitizer: " & Err.Description FlexiTextSanitizer = "" End Function ' دالة مساعدة: EscapeRegExChars Private Function EscapeRegExChars(chars As String) As String Dim specialChars As Variant Dim i As Integer specialChars = Array("^", "$", ".", "*", "+", "?", "(", ")", "[", "]", "{", "}", "|", "\\", "`", "~", "&", "%", "#", "@", "<", ">") For i = LBound(specialChars) To UBound(specialChars) chars = Replace(chars, specialChars(i), "\" & specialChars(i)) Next i EscapeRegExChars = chars End Function اضافة توثيق وشرح للكود فى رأس الموديول ليكون مفهوما ولايضاح الية الاستدعاء بالسيناريوهات المختلفة والممكنة وهذا اختياريا يمكن وضعه قبل الكود السابق ' توثيق الموديول: ' الغرض: هذا الموديول يحتوي على دالة FlexiTextSanitizer لتنظيف النصوص بدقة وسرعة مع دعم مرن للغات (العربية واللاتينية)، الأحرف الخاصة، علامات الترقيم، والرموز الرياضية. ' يستخدم تعدادات (Enums) لتسهيل الاستدعاء وتقليل الأخطاء، ويتيح التحكم الكامل في معالجة النصوص. ' ' سيناريوهات الاستدعاء: ' 1. تنظيف النص مع الاحتفاظ بالأرقام والأحرف الخاصة وعلامات الترقيم بدون تطبيع: ' FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepAllPunctuation) ' - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم (5 - 5)" ' 2. تنظيف النص مع إزالة الأرقام بدون تطبيع: ' FlexiTextSanitizer(inputText, False, ArabicOnly, RemoveNumbers, KeepAllPunctuation) ' - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم" ' 3. تنظيف النص مع الاحتفاظ بالأرقام فقط مع تطبيع: ' FlexiTextSanitizer(inputText, True, ArabicOnly, KeepNumbersOnly, KeepAllPunctuation) ' - مثال الناتج: "اشراف علي بعض الاماكن او المكان رقم 5 - 5" ' 4. تنظيف كامل مع تطبيع وإزالة علامات الترقيم: ' FlexiTextSanitizer(inputText, True, ArabicOnly, CleanAll, RemoveAllPunctuation) ' - مثال الناتج: "اشراف علي بعض الاماكن او المكان رقم" ' 5. تنظيف النص مع الاحتفاظ بالأرقام والأقواس (تلقائية) والفواصل والنقاط مع تطبيع: ' FlexiTextSanitizer(inputText, True, ArabicOnly, KeepBrackets, KeepBasicPunctuation) ' - مثال الناتج: "اشراف علي, بعض الاماكن او المكان رقم (5).(5)" ' 6. تنظيف النص مع دعم العربية واللاتينية والأحرف الخاصة وعلامات الترقيم: ' FlexiTextSanitizer(inputText, False, ArabicAndLatin, KeepAll, KeepAllPunctuation, "().,") ' - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم (5 - 5) Supervision" ' 7. تنظيف النص مع إزالة جميع علامات الترقيم: ' FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, RemoveAllPunctuation) ' - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم 5 5" ' 8. تنظيف النص مع الاحتفاظ بالفواصل والنقاط فقط: ' FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepBasicPunctuation) ' - مثال الناتج: "إشراف على, بعض الأماكن أو المكان رقم 5.5" ' 9. تنظيف نص يحتوي على علامات ترقيم كثيرة: ' FlexiTextSanitizer("!!!؟؟؟...،،،:::;;;---___***((()))", False, ArabicOnly, KeepAll, KeepAllPunctuation) ' - مثال الناتج: "!!!...،،،:::;;;---___***(())" ' 10. تنظيف نص يحتوي على رموز رياضية مع الاحتفاظ بها: ' FlexiTextSanitizer("√∑∫∏∂∆∞ ≠ ± × ÷", False, ArabicAndLatin, KeepSpecialSymbols, RemoveAllPunctuation) ' - مثال الناتج: "√∑∫∏∂∆∞ ≠ ± × ÷" ' 11. تطبيع جميع الأشكال الممكنة: ' FlexiTextSanitizer("إِ، أ، إ، ؤ، ئ، ى، ة، ك، چ", True, ArabicOnly, KeepAll, KeepAllPunctuation) ' - مثال الناتج: "ا، ا، ا، و، ي، ي، ه، ك، ج" ولكن ملحوطة صغيرة طبعا وللاسف محرر الاكواد هنا مع الاكسس فقيير جدا بعكس لغات البرمجة الاخرى لا يقبل الرموز لذلك الرموز الرياضية مثل : √∑∫∏∂∆∞ سوف تتغير داخل المحرر الى علامات استفهام والان داله يمكن اضافتها فى نهاية الكود وهى مجرد للتجربة طباعه نتائج التجربه فى النافذة الفوريه ليكون المبرمج مطلعا وملما بالنتائج ' اختبار الدالة مع السيناريوهات المطلوبة Sub TestFlexiTextSanitizer() Dim inputText As String inputText = "إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ Supervision of some places or place number 5 - 5" Debug.Print "النص الأصلي: " & inputText Debug.Print "------------------------------------" Debug.Print "السيناريو 1 (تنظيف، الاحتفاظ بالأرقام والأحرف الخاصة، بدون تطبيع):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 2 (تنظيف، إزالة الأرقام، بدون تطبيع):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, removeNumbers, KeepAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 3 (تنظيف، الاحتفاظ بالأرقام، مع تطبيع):" Debug.Print FlexiTextSanitizer(inputText, True, ArabicOnly, KeepNumbersOnly, KeepAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 4 (تنظيف كامل، مع تطبيع):" Debug.Print FlexiTextSanitizer(inputText, True, ArabicOnly, CleanAll, RemoveAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 5 (تنظيف، الاحتفاظ بالأرقام والأقواس، مع تطبيع):" Debug.Print FlexiTextSanitizer(inputText, True, ArabicOnly, KeepBrackets, KeepBasicPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 6 (العربية واللاتينية مع أحرف خاصة مخصصة والاحتفاظ بجميع علامات الترقيم):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicAndLatin, KeepAll, KeepAllPunctuation, "().,") Debug.Print "------------------------------------" Debug.Print "السيناريو 7 (العربية فقط، إزالة جميع علامات الترقيم):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, RemoveAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 8 (العربية فقط، الاحتفاظ بالفواصل والنقاط فقط):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepBasicPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 9 (نص يحتوي على علامات ترقيم كثيرة جدًا):" Debug.Print FlexiTextSanitizer("!!!؟؟؟...،،،:::;;;---___***((()))", False, ArabicOnly, KeepAll, KeepAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 10 (نص يحتوي على رموز رياضية ورموز خاصة):" Debug.Print FlexiTextSanitizer(ChrW(8730) & ChrW(8721) & ChrW(8747) & ChrW(8719) & ChrW(8706) & ChrW(8710) & ChrW(8734) & ChrW(32) & ChrW(8800) & ChrW(32) & ChrW(177) & ChrW(32) & ChrW(215) & ChrW(32) & ChrW(247), False, ArabicAndLatin, KeepSpecialSymbols, RemoveAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 11 (تطبيع جميع الأشكال الممكنة):" Debug.Print FlexiTextSanitizer("إِ، أ، إ، ؤ، ئ، ى، ة، ك، چ", True, ArabicOnly, KeepAll, KeepAllPunctuation) Debug.Print "------------------------------------" End Sub

السلام عليكم ورحمة الله تعالى وبركاته كل عام وانتم بخيــر يأتى شهر الخير ومعه البركات أقدم اليكم هدية قيمة بكل ما تحمل الكلمة من معنى فى هذا الموضوع من أفكار وأكواد وفوائد هامة لا غنى عنها مطلقا ذات مرة شاركت بكتابة موضوع بخصوص انشاء الجداول واضافة الحقول وخصائصها برمجيا وهذا هو الموضوع واستكمالا لما تم طرحه فى هذا الموضوع السابق الاشارة اليه تعديل وتطوير بعض الاكواد والافكار لاضفاء مرونة واحترافيه وكفائه اكبر الفائده : امكانية عمل الجداول الاساسية بشكل ديناميكى من خلال الكود دون أدنى تدخل من المستخدم الغرض : سهول ومرونة وحفاظا على البيانات والاعدادت الاساسية للتطبيق طيب علشان سامع واحد هناك بيقول ايه يعم ده دا عمل الجدول اسهل واسرع من وجع الدماغ ده هو كلامه صح ... عارف ولكــــن لتوضيح المميزات والآفكار دعونا نمضى فى هذا الموضوع وهذه احد الفوائد العظيمة و الهامة على سبيل المثال فقط وليس الحصر الفكرة كالاتى عمل دالة مركزية للاخطاء داخل الأكواد الفوائد العظيمه من ورائها مرونة فائقة : ✔ إنشاء جداول بشكل ديناميكى لحفظ وتتبع ارقام و وصف و أماكن الأخطاء داخل الإجراءات و زوايا التطبيق المختلفة ..... ✔ إنشاء جداول بشكل ديناميكى للتحكم فى إعدادت التعامل مع الدالة المركزية ✔ إعادة البيانات الاعدادت داخل الجدول اذا تم العبث بها " قسراً " ✔ إعدة الحقول والبيانات اذا تم حذفها" قسراً " ✔ إعادة إنشاء الجداول بشكل ديناميكى مرة أخرى أخرى أذا تم حذفها " قسراً " لنمضى قدما بع هذه المقدمة - وحدة نمطية عامة رئيسية باسم : basTablesCreator الأكواد بداخل الوحدة النمطية Option Compare Database Option Explicit ' متغير عام لتخزين الحقول باستخدام القاموس Public Fields As Object ' تعريف تعداد لأنواع الحقول المتاحة في قاعدة البيانات Public Enum FieldTypes dbBoolean = 1 ' نوع الحقل: Yes/No (قيمة منطقية) dbByte = 2 ' نوع الحقل: Byte (عدد صحيح صغير بين 0 و 255) dbInteger = 3 ' نوع الحقل: Integer (عدد صحيح بين -32,768 و 32,767) dbLong = 4 ' نوع الحقل: Long Integer (عدد صحيح طويل بين -2,147,483,648 و 2,147,483,647) dbCurrency = 5 ' نوع الحقل: Currency (عدد عشري بدقة عالية للحسابات المالية) dbSingle = 6 ' نوع الحقل: Single (عدد عشري بدقة بسيطة) dbDouble = 7 ' نوع الحقل: Double (عدد عشري بدقة مزدوجة) dbDate = 8 ' نوع الحقل: Date/Time (تاريخ ووقت) dbText = 10 ' نوع الحقل: Text (نص عادي يصل إلى 255 حرفًا) dbMemo = 12 ' نوع الحقل: Memo (نص طويل جدًا) dbAutoNumber = 15 ' نوع الحقل: AutoNumber (ترقيم تلقائي) dbBinary = 128 ' نوع الحقل: Binary (بيانات ثنائية صغيرة) dbVarBinary = 205 ' نوع الحقل: OLE Object (بيانات ثنائية كبيرة مثل ملفات OLE) dbAttachment = 101 ' نوع الحقل: Attachment (ملفات مرفقة) dbBigInt = 16 ' نوع الحقل: BigInt (عدد صحيح كبير جدًا، 64 بت) dbMultipleChoice = 109 ' نوع الحقل: Multiple Choice (حقل متعدد الخيارات) End Enum ' دالة لإنشاء قاموس جديد عند الحاجة إليه Public Function CreateDictionary() As Object Set CreateDictionary = CreateObject("Scripting.Dictionary") End Function ' إجراء لإضافة حقل جديد إلى القاموس الذي يحتوي على الحقول المختلفة Public Sub AddFieldToDictionary(fieldName As String, _ fieldType As FieldTypes, _ Optional fieldSize As Long = 0, _ Optional fieldFormat As String = "", _ Optional defaultValue As Variant = Null, _ Optional fieldCaption As String = "", _ Optional fieldDescription As String = "") Dim fieldDict As Object Set fieldDict = CreateDictionary() With fieldDict .Add "Name", fieldName .Add "Type", fieldType .Add "Size", fieldSize .Add "Caption", fieldCaption .Add "Description", fieldDescription .Add "DefaultValue", defaultValue .Add "Format", fieldFormat End With If Fields Is Nothing Then Set Fields = CreateDictionary() Set Fields(fieldName) = fieldDict End Sub ' هذه الدالة تقوم بالتحقق إذا كان الجدول المطلوب موجودًا في قاعدة البيانات Public Function IsTableExist(TableName As String) As Boolean Dim tdf As DAO.TableDef For Each tdf In CurrentDb.TableDefs If tdf.Name = TableName Then IsTableExist = True Exit Function End If Next tdf IsTableExist = False End Function ' هذا الإجراء يقوم بإنشاء الجدول إذا لم يكن موجودًا أو تحديثه إذا كان موجودًا Public Sub CreateNewTable(TableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim fieldDict As Object Dim key As Variant ' الحصول على قاعدة البيانات الحالية Set db = CurrentDb() ' التحقق مما إذا كان الجدول موجودًا بالفعل If IsTableExist(TableName) Then db.TableDefs.Delete TableName db.TableDefs.Refresh End If ' إنشاء كائن TableDef جديد Set tdf = db.CreateTableDef(TableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' إضافة الحقول إلى الجدول For Each key In Fields.Keys ' الحصول على القاموس الخاص بكل حقل Set fieldDict = Fields(key) ' التحقق من صحة البيانات If fieldDict.Exists("Name") And fieldDict.Exists("Type") Then ' إنشاء الحقل If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type")) ' تعيين الحجم إذا كان الحقل نصيًا If fieldDict("Type") = dbText Then If fieldDict.Exists("Size") And fieldDict("Size") > 0 Then fld.Size = fieldDict("Size") Else MsgBox "حجم الحقل النصي غير صالح!", vbCritical Exit Sub End If End If Else ' إنشاء حقل AutoNumber Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField End If ' تعيين القيمة الافتراضية إذا كانت مدعومة If fieldDict.Exists("DefaultValue") Then On Error Resume Next fld.defaultValue = fieldDict("DefaultValue") On Error GoTo 0 End If ' إضافة الحقل إلى الجدول tdf.Fields.Append fld Else MsgBox "خطأ: بيانات الحقل غير مكتملة!", vbCritical Exit Sub End If Next key ' إضافة الجدول إلى قاعدة البيانات db.TableDefs.Append tdf db.TableDefs.Refresh End Sub ' دالة لفحص ما إذا كان الجدول مفتوحًا وإغلاقه إذا لزم الأمر Public Function CloseTableIfNecessary(TableName As String) As Boolean On Error Resume Next DoCmd.Close acTable, TableName CloseTableIfNecessary = (Err.Number = 0) On Error GoTo 0 End Function ' هذا الإجراء يقوم بإضافة أو تحديث خصائص الحقول في الجدول Public Sub SetFieldProperties(TableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim fieldDict As Object Dim key As Variant Dim prop As DAO.Property ' الحصول على قاعدة البيانات الحالية Set db = CurrentDb() ' الحصول على الكائن TableDef للجدول الذي سيتم التحديث فيه Set tdf = db.TableDefs(TableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' استعراض الحقول في القاموس وتحديث خصائصها في الجدول For Each key In Fields.Keys Set fieldDict = Fields(key) ' إذا كان الحقل موجودًا في الجدول، يتم تحديث خصائصه If IsFieldExist(tdf, fieldDict("Name")) Then Set fld = tdf.Fields(fieldDict("Name")) ' إضافة أو تحديث التسمية (Caption) إذا كانت موجودة If fieldDict.Exists("Caption") And fieldDict("Caption") <> "" Then On Error Resume Next fld.Properties.Delete "Caption" ' حذف التسمية الحالية إذا كانت موجودة On Error GoTo 0 ' إضافة التسمية الجديدة fld.Properties.Append fld.CreateProperty("Caption", dbText, fieldDict("Caption")) End If ' إضافة أو تحديث الوصف (Description) إذا كان موجودًا If fieldDict.Exists("Description") And fieldDict("Description") <> "" Then On Error Resume Next fld.Properties.Delete "Description" ' حذف الوصف الحالي إذا كان موجودًا On Error GoTo 0 ' إضافة الوصف الجديد fld.Properties.Append fld.CreateProperty("Description", dbText, fieldDict("Description")) End If ' إضافة أو تحديث التنسيق (Format) إذا كان موجودًا If fieldDict.Exists("Format") And fieldDict("Format") <> "" Then On Error Resume Next fld.Properties.Delete "Format" ' حذف التنسيق الحالي إذا كان موجودًا On Error GoTo 0 ' إضافة التنسيق الجديد fld.Properties.Append fld.CreateProperty("Format", dbText, fieldDict("Format")) End If ' تحديث القيمة الافتراضية (DefaultValue) بشكل صارم If fieldDict.Exists("DefaultValue") Then On Error Resume Next fld.defaultValue = Null ' حذف القيمة الافتراضية الحالية إذا كانت موجودة On Error GoTo 0 ' إضافة القيمة الافتراضية بناءً على نوع الحقل If Not IsNull(fieldDict("DefaultValue")) And Trim(Nz(fieldDict("DefaultValue"), "")) <> "" Then ' التحقق من أن الحقل ليس من النوع AutoNumber If fieldDict("Type") <> dbAutoNumber Then Select Case fieldDict("Type") Case dbText, dbMemo, dbAttachment ' للحقول النصية، نقوم بتحويل القيمة إلى سلسلة fld.defaultValue = CStr(fieldDict("DefaultValue")) Case dbInteger, dbLong, dbBigInt, dbByte ' للحقول العددية، نقوم بتحويل القيمة إلى رقم fld.defaultValue = CStr(Nz(fieldDict("DefaultValue"), 0)) Case dbDate ' للحقول التاريخية، نقوم بتحويل القيمة إلى تنسيق تاريخ fld.defaultValue = Format(Nz(fieldDict("DefaultValue"), Now()), "yyyy-mm-dd hh:mm:ss") Case Else ' لأي نوع آخر، نقوم بتحويل القيمة إلى سلسلة fld.defaultValue = CStr(fieldDict("DefaultValue")) End Select Else ' إذا كان الحقل من النوع AutoNumber، لا نقوم بتعيين قيمة افتراضية ' Debug.Print "Skipping defaultValue for AutoNumber field: " & fieldDict("Name") End If Else ' إذا كانت القيمة الافتراضية فارغة أو Null، نقوم بإزالة القيمة الحالية If fieldDict("Type") <> dbAutoNumber Then fld.defaultValue = "" End If End If End If End If Next key End Sub ' دالة لبناء شرط البحث Private Function BuildCriteria(record As Object, uniqueFields As Variant, TableName As String) As String Dim criteria As String Dim fieldName As String Dim fieldValue As Variant Dim fieldType As DAO.DataTypeEnum Dim fieldIndex As Variant ' التحقق من أن record هو قاموس If Not TypeOf record Is Object Or TypeName(record) <> "Dictionary" Then BuildCriteria = "" Exit Function End If ' بناء شرط البحث باستخدام الحقول الفريدة criteria = "" For Each fieldIndex In uniqueFields fieldName = Trim(fieldIndex) If record.Exists(fieldName) Then fieldValue = record(fieldName) ' التحقق من أن القيمة ليست Null أو فارغة If Not IsNull(fieldValue) And Trim(CStr(fieldValue)) <> "" Then If criteria <> "" Then criteria = criteria & " AND " ' الحصول على نوع الحقل من الجدول fieldType = GetFieldType(TableName, fieldName) ' التعامل مع القيم بناءً على نوع الحقل ' التعامل مع القيم بناءً على نوع الحقل Select Case fieldType Case dbText, dbMemo criteria = criteria & "[" & fieldName & "] = '" & Replace(CStr(fieldValue), "'", "''") & "'" Case dbInteger, dbLong, dbByte, dbSingle, dbDouble, dbCurrency, dbBigInt criteria = criteria & "[" & fieldName & "] = " & fieldValue Case dbBoolean criteria = criteria & "[" & fieldName & "] = " & IIf(fieldValue, -1, 0) Case dbDate criteria = criteria & "[" & fieldName & "] = #" & Format(fieldValue, "yyyy-mm-dd hh:mm:ss") & "#" Case Else criteria = criteria & "[" & fieldName & "] = '" & Replace(CStr(fieldValue), "'", "''") & "'" End Select End If End If Next fieldIndex ' إذا لم يتم بناء شرط البحث، يعني أن القاموس فارغ If criteria = "" Then BuildCriteria = "" Else BuildCriteria = criteria End If End Function ' للحصول على نوع الحقل Private Function GetFieldType(TableName As String, fieldName As String) As DAO.DataTypeEnum Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Set db = CurrentDb() Set tdf = db.TableDefs(TableName) On Error Resume Next Set fld = tdf.Fields(fieldName) If Err.Number <> 0 Then GetFieldType = dbText ' نوع افتراضي إذا لم يتم العثور على الحقل Exit Function End If On Error GoTo 0 GetFieldType = fld.Type End Function ' دالة مساعدة لتنسيق القيمة حسب النوع Private Function FormatFieldValue(value As Variant) As String If IsDate(value) Then FormatFieldValue = "#" & Format(value, "mm/dd/yyyy hh:nn:ss AM/PM") & "#" ElseIf IsNumeric(value) Then FormatFieldValue = CStr(value) Else FormatFieldValue = "'" & Replace(CStr(value), "'", "''") & "'" End If End Function ' دالة لتحديد ما إذا كان الحقل من نوع AutoNumber Function IsAutoNumberField(fld As DAO.Field) As Boolean IsAutoNumberField = (fld.Type = dbAutoNumber) End Function ' الإجراء الرئيسي لإنشاء أو تحديث الجدول وإدخال البيانات Public Sub CreateOrModifyTableAndInsertData(TableName As String, Fields As Object, _ Optional records As Collection = Nothing, _ Optional uniqueFieldNames As String = "", _ Optional bAddData As Boolean = False) Dim db As DAO.Database Dim rs As DAO.Recordset Dim record As Object Dim uniqueFields() As String Dim criteria As String Set db = CurrentDb() '--- 1. إغلاق الجدول إذا كان مفتوحًا --- If Not CloseTableIfNecessary(TableName) Then MsgBox "لا يمكن تعديل الجدول لأنه مفتوح.", vbExclamation Exit Sub End If '--- 2. إنشاء الجدول إذا لم يوجد --- If Not IsTableExist(TableName) Then CreateNewTable TableName, Fields Else '--- 3. تحديث الهيكل فقط إذا كان bAddData = True --- If bAddData Then Dim tdf As DAO.TableDef Set tdf = db.TableDefs(TableName) EnsureFieldsExist tdf, Fields End If End If '--- 4. تطبيق خصائص الحقول --- SetFieldProperties TableName, Fields '--- 5. معالجة البيانات --- If bAddData And Not records Is Nothing And uniqueFieldNames <> "" Then uniqueFields = Split(uniqueFieldNames, ", ") Set rs = db.OpenRecordset(TableName, dbOpenDynaset) For Each record In records ' التحقق من أن record هو قاموس If TypeOf record Is Object And TypeName(record) = "Dictionary" Then ' بناء شرط البحث مع تمرير اسم الجدول criteria = BuildCriteria(record, uniqueFields, TableName) ' Debug.Print criteria ' التحقق من صحة الشرط If criteria <> "" Then rs.FindFirst criteria If rs.NoMatch Then rs.AddNew Else rs.Edit End If ' تحديث القيم Dim key As Variant For Each key In record.Keys If Not IsAutoNumberField(rs.Fields(key)) Then rs(key) = record(key) End If Next key rs.Update Else ' Debug.Print "Invalid criteria for record. Skipping..." End If Else ' Debug.Print "Element in records is not a valid Dictionary. Skipping..." End If Next record rs.Close End If Application.RefreshDatabaseWindow End Sub ' هذه الدالة تقوم بالتحقق من وجود الحقل في الجدول Public Function IsFieldExist(tdf As DAO.TableDef, fieldName As String) As Boolean Dim fld As DAO.Field For Each fld In tdf.Fields If fld.Name = fieldName Then IsFieldExist = True Exit Function End If Next fld IsFieldExist = False End Function ' هذا الإجراء يقوم بإضافة الحقول إلى الجدول إذا لم تكن موجودة Public Sub EnsureFieldsExist(tdf As DAO.TableDef, Fields As Object) Dim fieldDict As Object Dim fld As DAO.Field Dim key As Variant ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub For Each key In Fields.Keys Set fieldDict = Fields(key) ' التحقق من عدم وجود حقل بنفس الاسم If Not IsFieldExist(tdf, fieldDict("Name")) Then ' إنشاء الحقل بناءً على النوع If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type"), fieldDict("Size")) Else Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField ' تعيين الحقل كـ AutoNumber End If ' تعيين القيمة الافتراضية إذا كانت محددة If Not IsNull(fieldDict("DefaultValue")) And fieldDict("DefaultValue") <> "" Then fld.defaultValue = fieldDict("DefaultValue") End If ' إضافة الحقل إلى الجدول tdf.Fields.Append fld End If Next key End Sub ' دالة مساعدة للتحقق من القيم الفارغة أو Null Private Function IsEmptyOrNull(value As Variant) As Boolean IsEmptyOrNull = IsNull(value) Or Trim(CStr(value)) = "" End Function الغرض منها : ✔ هى التى تحتوى على الجراءات والوظائف الاساسية لعملية إنشاء الجداول والحقول وخصائص الحقول - وحدة نمطية عامة ثانوية باسم : basTablesInitialization الاكواد بداخلها Option Compare Database Option Explicit ' متغير لكتابة اسم الحقل/الحقول الفريدة لضمان عدم تكرار السجلات Dim uniqueFields As String ' هذا الإجراء يقوم بتهيئة الجدول الخاص بتسجيل الأخطاء Public Sub InitializeTableErrorLog() Dim tblName As String ' اسم جدول تسجيل الأخطاء tblName = "tblErrorLog" ' إنشاء القاموس لاحتواء الحقول Set Fields = CreateDictionary() ' إضافة الحقول ومعلومات كل حقل: ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف) AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "الغرض :الترقيم التلقائي" AddFieldToDictionary "ErrorDate", dbDate, , "dddd, mmmm dd, yyyy hh:nn:ss AM/PM", "Now()", "وقت حدوث الخطأ", "الغرض :تسجيل وقت و تاريخ حدوث الخطأ" AddFieldToDictionary "Source", dbText, 255, "@[red]", , "الإجراء/الوظيفة", "الغرض :اسم الإجراء/الوظيفة/النموذج/الوحده النمطية/التقرير الذي حدث فيه الخطأ" AddFieldToDictionary "ErrorNumber", dbLong, , , , "رقم الخطأ", "الغرض :تسجيل رقم الخطأ المرتبط بـ الإجراء/الوظيفة Err.Number" AddFieldToDictionary "ErrorDescription", dbText, 255, "@[Blue]", , "وصف الخطأ", "الغرض :تسجيل الوصف التفصيلي للخطأ كما يظهر في: Err.Description" AddFieldToDictionary "UserName", dbText, 100, "", , "حدث الخطأ مع المستخدم", "حقل : يحتوى على سجل من: Environ USERNAME" AddFieldToDictionary "CallExecutionTrace", dbMemo, , , , "تسلسل تنفيذ الأكواد", "الغرض :تسجيل جميع الإجراءات التي تم تنفيذها قبل حدوث الخطأ، مما يسهل تتبع مصدر المشكلة" AddFieldToDictionary "AdditionalInfo", dbText, 255, , , "معلومات إضافيه", "الغرض :تسجيل معلومات إضافية مخصصة يضيفها المطور عند استدعاء قيم متغيرات مهمة عند حدوث الخطأ" CreateOrModifyTableAndInsertData tblName, Fields, , , False End Sub Public Sub InitializeErrorSettingsTable() Dim tblName As String ' اسم جدول أعدادت الوظيفة المركزية للتعامل مع الأخطاء tblName = "tblErrorSettings" ' إنشاء القاموس لاحتواء الحقول Set Fields = CreateDictionary() ' إضافة الحقول ومعلومات كل حقل: ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف) AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "الغرض :الترقيم التلقائي" AddFieldToDictionary "ConfigKey", dbInteger, , , , "رقم فريد للإعداد", "الغرض :تسجيل رقم فريد لكل الإعدادات في النظام للقيم المعرفة" AddFieldToDictionary "ConfigValue", dbBoolean, , , False, "قيمة الإعداد", "الغرض :تسجيل القيمة المرتبطة بمفتاح الإعدادات: (تفعيل / تعطيل الإعداد)" AddFieldToDictionary "ConfigDescription", dbText, 100, "@[red]", , "وصف الإعداد", "الغرض :تسجيل الوصف والغرض من الإعدادات" ' إنشاء مجموعة السجلات الافتراضية Dim records As New Collection ' إضافة السجلات ' السجل الأول Dim record1 As Object, record2 As Object, record3 As Object Set record1 = CreateDictionary() record1("ConfigKey") = 1 record1("ConfigValue") = True record1("ConfigDescription") = "ErrorLoggingEnabled :التحكم في تفعيل/تعطيل تسجيل الأخطاء في التطبيق في جدول الأخطاء" records.Add record1 ' السجل الثانى Set record2 = CreateDictionary() record2("ConfigKey") = 2 record2("ConfigValue") = True record2("ConfigDescription") = "ShowErrorMessages : التحكم في تفعيل/تعطيل عرض رسائل الخطأ للمستخدم" records.Add record2 ' السجل الثالث Set record3 = CreateDictionary() record3("ConfigKey") = 3 record3("ConfigValue") = True record3("ConfigDescription") = "DebugMode : التحكم في تفعيل/تعطيل وضع التصحيح لتتبع الأخطاء بشكل مفصل في النافذة الفورية" records.Add record3 ' تحديد الحقل/الحقول - الفريد/الفريدة والتى تمنع عملية تكرار البيانات بإضافة سجلات uniqueFields = "ConfigKey" ' إنشاء أو تعديل الجدول وإدخال البيانات CreateOrModifyTableAndInsertData tblName, Fields, records, uniqueFields, True End Sub الغرض منها : ✔ انشاء الجداول الاجبارية والحقول اللازمة وملئ البيانات ------------------------------------------------------------- - وحدة نمطية عامة رئيسية باسم basErrorHandler الاكواد بداخلها Option Compare Database Option Explicit Public ProcedureName As String '### إعدادات التكوين (يمكن إدارتها عبر جدول tblErrorSettings) ### Private Enum ConfigKey ErrorLoggingEnabled = 1 ShowErrorMessages = 2 DebugMode = 3 ErrorLogTable = 4 End Enum '### الهيكل الأساسي لتسجيل الأخطاء ### Private Type ErrorInfo Source As String Number As Long Description As String User As String CallExecutionTrace As String recordData As String End Type ' متغير عام لتخزين سلسلة الاستدعاءات Public gCallExecutionTrace As Collection ' ثابت خاص لتخزين اسم جدول تسجيل الأخطاء Private Const TableNameErrorLog As String = "tblErrorLog" ' ثابت خاص لتخزين اسم جدول إعدادات الأخطاء Private Const TableNameErrorSettings As String = "tblErrorSettings" '============================================================================== ' الدوال الرئيسية للاستخدام الخارجي '============================================================================== ' معالجة الخطأ الرئيسية (يمكن استدعاؤها من أي مكان) Public Sub HandleError(SourceProc As String, Optional ShowMessage As Boolean = True, Optional AdditionalInfo As String = "") Dim errInfo As ErrorInfo Dim errNum As Long, errDesc As String ' حفظ تفاصيل الخطأ قبل أي عمليات أخرى errNum = Err.Number errDesc = Err.Description On Error GoTo ErrorHandlerFailure With errInfo .Source = SourceProc .Number = errNum .Description = errDesc .User = Environ("USERNAME") .CallExecutionTrace = GetCallExecutionTrace() .recordData = AdditionalInfo End With InitializeErrorSettingsTable InitializeTableErrorLog ' تسجيل الخطأ إذا كان التسجيل مفعلاً If GetConfig(ErrorLoggingEnabled, True) Then LogError errInfo End If ' عرض رسالة الخطأ إذا كان مسموحاً If ShowMessage And GetConfig(ShowErrorMessages, True) Then ShowErrorMessage errInfo End If ' تصحيح الأخطاء إذا كان وضع التصحيح مفعلاً If GetConfig(DebugMode, False) Then DebugPrintError errInfo End If Exit Sub ErrorHandlerFailure: ' Fallback إذا فشل معالج الخطأ نفسه MsgBox "Critical failure in error handler: " & Err.Description, vbCritical End Sub '============================================================================== ' الدوال الداخلية '============================================================================== ' تسجيل الخطأ في قاعدة البيانات Private Sub LogError(errInfo As ErrorInfo) Dim db As DAO.Database Dim rs As DAO.Recordset On Error GoTo LogErrorFailed Set db = CurrentDb() Set rs = db.OpenRecordset(GetConfig(ErrorLogTable, TableNameErrorLog), dbOpenTable, dbAppendOnly) With rs .AddNew !ErrorDate = Now() !Source = Left$(errInfo.Source, 255) !ErrorNumber = errInfo.Number !ErrorDescription = Left$(errInfo.Description, 255) !UserName = Left$(errInfo.User, 50) !CallExecutionTrace = Left$(errInfo.CallExecutionTrace, 1000) !AdditionalInfo = Left$(errInfo.recordData, 255) .Update End With Cleanup: If Not rs Is Nothing Then rs.Close Set rs = Nothing Set db = Nothing Exit Sub LogErrorFailed: ' Fallback: تسجيل في ملف نصي إذا فشل التسجيل في قاعدة البيانات LogToTextFile "ErrorLog_" & Format(Now(), "yyyymmdd") & ".log", errInfo Resume Cleanup End Sub ' عرض رسالة خطأ مخصصة للمستخدم Private Sub ShowErrorMessage(errInfo As ErrorInfo) Dim msg As String msg = GetErrorMessage(errInfo.Number) & vbCrLf & _ "Details: " & errInfo.Description & vbCrLf & _ "Contact: Technical Support" MsgBox msg, vbExclamation, "Error " & errInfo.Number End Sub ' طباعة تفاصيل الخطأ للنافذة المباشرة (لأغراض التصحيح) Private Sub DebugPrintError(errInfo As ErrorInfo) Debug.Print "=== ERROR DEBUG ===" Debug.Print "Time: " & Now() Debug.Print "Source: " & errInfo.Source Debug.Print "Error " & errInfo.Number & ": " & errInfo.Description Debug.Print "User: " & errInfo.User Debug.Print "Call ExecutionTrace: " & errInfo.CallExecutionTrace Debug.Print "Additional Info: " & errInfo.recordData Debug.Print "===================" End Sub '============================================================================== ' دوال مساعدة '============================================================================== ' الحصول على إعدادات النظام من جدول التكوين Private Function GetConfig(key As ConfigKey, defaultValue As Variant) As Variant Static configCache As Collection Dim rs As DAO.Recordset Dim sql As String If configCache Is Nothing Then Set configCache = New Collection End If On Error Resume Next GetConfig = configCache(CStr(key)) If Err.Number = 0 Then Exit Function sql = "SELECT ConfigValue FROM " & TableNameErrorSettings & " WHERE ConfigKey = " & key Set rs = CurrentDb.OpenRecordset(sql) If Not rs.EOF Then GetConfig = rs!ConfigValue Else GetConfig = defaultValue End If configCache.Add GetConfig, CStr(key) rs.Close Set rs = Nothing End Function ' الحصول على رسالة خطأ مخصصة Private Function GetErrorMessage(ErrorNumber As Long) As String Select Case ErrorNumber Case 3021: GetErrorMessage = "No records found. Please check your data." Case 3061: GetErrorMessage = "Missing parameter in query." Case 7874: GetErrorMessage = "Invalid file format." Case Else: GetErrorMessage = "An unexpected error occurred." End Select End Function '============================================================================== ' دوال إدارة سلسلة الاستدعاءات/الإجراءات التي تم تنفيذها حتى حدوث الخطأ ' ExecutionTrace '============================================================================== Public Sub LogCallExecutionTrace(ProcName As String) If gCallExecutionTrace Is Nothing Then Set gCallExecutionTrace = New Collection gCallExecutionTrace.Add ProcName End Sub Public Sub RemoveFromCallExecutionTrace(ProcName As String) If gCallExecutionTrace Is Nothing Then Exit Sub If gCallExecutionTrace.count = 0 Then Exit Sub ' البحث عن آخر تكرار للاسم وإزالته Dim i As Integer For i = gCallExecutionTrace.count To 1 Step -1 If gCallExecutionTrace(i) = ProcName Then gCallExecutionTrace.Remove i Exit For End If Next i End Sub Private Function GetCallExecutionTrace() As String Dim i As Integer Dim ExecutionTrace As String If gCallExecutionTrace Is Nothing Or gCallExecutionTrace.count = 0 Then GetCallExecutionTrace = "Call ExecutionTrace Empty" Exit Function End If For i = 1 To gCallExecutionTrace.count ExecutionTrace = ExecutionTrace & " > " & gCallExecutionTrace(i) Next i If Len(ExecutionTrace) > 0 Then ExecutionTrace = Mid(ExecutionTrace, 4) End If GetCallExecutionTrace = ExecutionTrace End Function ' تسجيل الخطأ في ملف نصي كحل بديل Private Sub LogToTextFile(FileName As String, errInfo As ErrorInfo) Dim fnum As Integer fnum = FreeFile() Open CurrentProject.Path & "\" & FileName For Append As #fnum Print #fnum, "[" & Now() & "] Error " & errInfo.Number & " in " & errInfo.Source Print #fnum, "User: " & errInfo.User Print #fnum, "Description: " & errInfo.Description Print #fnum, "----------------------------------------" Close #fnum End Sub الغرض والفائدة : ✔ إدارة الأخطاء بطريقة مركزيه منظمة وفعالة إدارة الأخطاء بشكل موحد: يوفر الكود آلية مركزية للتعامل مع الأخطاء في كافة أجزاء التطبيق ✔ إمكانية تتبع الأخطاء وتخزين تفاصيلها في قاعدة البيانات أو في ملف نصي التسجيل التلقائي للأخطاء: يقوم بتخزين الأخطاء مع تفاصيلها في قاعدة البيانات مما يسهل تتبعها وتحليلها لاحقًا ✔ تقديم رسائل مخصصة للمستخدم تخصيص الرسائل: يتيح عرض رسائل خطأ مخصصة للمستخدم مع معلومات إضافية حول الأخطاء التي حدثت ✔ التصحيح والتتبع (Debugging) يسمح بتسجيل معلومات التصحيح مثل سلسلة الاستدعاءات (Call Stack) واستخدام أوضاع تصحيح الأخطاء مما يسهل اكتشاف مصدر المشكلة يساعد المطورين على فهم تفاصيل الخطأ بسرعة بفضل تتبع سلسلة الاستدعاءات بحيث يكون من السهل تحديد أي إجراء أو وظيفة تسببت في الخطأ ✔ المرونة في إدارة التحكم في الإعدادت يمكن تخصيص إعدادات الكود مثل تمكين أو تعطيل التسجيل للأخطأء فى الجدول - تمكين أو تعطيل عرض الرسائل - تمكين أو تعطيل وضع التصحيح عبر جدول الإعدادات مما يجعل الحل مرنًا وقابلًا للتكيف دون الحاجة لتغيير الكود نفسه حسب الرغبة✔ ✔ وظائف مساعدة تتضمن الوظائف المساعدة مثل GetConfig التي تسترجع إعدادات النظام من الجدول: tblErrorSettings و كذلك LogCallExecutionTrace التي تسجل تفاصيل الإجراءات أو الوظائف التي تم استدعاؤها وكذلك LogToTextFile لتسجيل الأخطاء في ملف نصي إذا فشل التسجيل في جدول : tblErrorLog ------------------------------------------------------------- - وحدة نمطية عامة ثانوية باسم basErrorHandlerTest ---- هذه الوحدة النمطية فقط للتجربة ولتوضيح طريقة استخدام الاجراء المركزى الموحد فى تتبع الخطأ يمكن حذفها الاكواد بداخلها والتى يمكن تشغيلها من خلا F5 أو Run للتجربـــة '============================================================================== ' مثال مفرد لتجربة الخطأ '============================================================================== Public Sub TestProcedure() On Error GoTo ErrorHandler ProcedureName = "TestProcedure" LogCallExecutionTrace ProcedureName Dim x As Integer x = 1 / 0 ' خطأ Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName, AdditionalInfo:="Variable x=" & x Resume Cleanup End Sub Public Sub TestOpenForm() On Error GoTo ErrorHandler ProcedureName = "TestOpenForm" LogCallExecutionTrace ProcedureName Dim strFormName As String strFormName = "Moh3sam" DoCmd.OpenForm strFormName, acNormal ' خطأ لا يوجد نموذج أصلا بهذا الاسم Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName, AdditionalInfo:="Variable strFormName=" & strFormName Resume Cleanup End Sub '============================================================================== ' مثال لعدة إجراءات مترابطه لتجربة تتبع مكان حدوث الخطأ تحديدا ' ExecutionTrace '============================================================================== Public Sub StartProcess() On Error GoTo ErrorHandler ProcedureName = "StartProcess" LogCallExecutionTrace ProcedureName ProcessNumber01 Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName Resume Cleanup End Sub Private Sub ProcessNumber01() On Error GoTo ErrorHandler ProcedureName = "ProcessNumber01" LogCallExecutionTrace ProcedureName ProcessNumber02 Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName Resume Cleanup End Sub Private Sub ProcessNumber02() On Error GoTo ErrorHandler ProcedureName = "ProcessNumber02" LogCallExecutionTrace ProcedureName ProcessNumber03 Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName Resume Cleanup End Sub Private Sub ProcessNumber03() On Error GoTo ErrorHandler ProcedureName = "ProcessNumber03" LogCallExecutionTrace ProcedureName ' خطأ القسمة على صفر Dim x As Integer x = 1 / 0 Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName, AdditionalInfo:="Variable x=" & x Resume Cleanup End Sub أمثالة تطبيقية : ✔ مثال مفرد : TestProcedure خطأ عند القسمة على 0 ✔ مثال مفرد : TestOpenForm خطأ عند محاولة فتح نموذج غير موجود ✔ مثال معقد يعتمد على عدة وظائف لتجربة التتبع : StartProcess وهنا تكمن الفائدة عند تشغيل أى إجراء أو مثال من أمثلة الخطأ السابقة - إعداد الجداول اللازمة والاعدادت بشكل الى واعادتها - ظهور الرسائل المخصصة لعرض الأخطاء بشكل موحد - تسجيل الأخطاء داخل الجدول ------------------------------- تسهيلا على الجميع - تم اضافة نموج للتجربة ------------------------------- - عند فتح القاعدة للمرة الاولى لن تجدوا بها اى جداول - بمجرد فتح النموذج والضغط على اى من أزرار تجربة الأخطاء سوف يتم إنشاء الجداول والبيانات الخاصة بالاعدادات - يمكنكم تجربة العبث فى جدول الاعدادت " tblErrorSettings " بتفيير البيانات او حذف احد الحقول أو الجدول نفسه وإعادة التجربة فلن يأثر العبث هذا سلبا على الاعدادت وعمل الجراءات وهذه هى الفائدة من الشق الاول فى الموضوع وهو انشاء الجداول والحقول والبيانات الهامة قسرا واخيــــرا المرفق أتمنى أن تكونوا قد إستمتعتم معنا فى منتدانا الرائـــــــع دالة مركزية للتعامل مع الأخطاء.zip

السلام عليكم ورحمة الله تعالى وبركاته يواجه الكثير من المصممين مشكلة اختلاف اللغة او بمعنى ادق يريد الكثير ان تكون لغة الازرار والتطبيق والرسائل موحدة وهذا ما لا يحدث عندما تكون نسخة الويندوز مثلا انجليزية والتطبيق بمصمم باللغة العربية او حتى يكون التعبير اكثر دقه عندما تختلف لغة واجهة المستخدم فى الويندوز عن اللغة التى يريد المصمم ان تظهر بها كل كبيرة وصغيرة قى التطبيق بما فيها ازرار الرسائل مثال لكى تكون الصورة اكثر وضوحا الرسالة بالعربى وهنا يريد المصمم ان تكون لغة الازرار كذلك بالعربى ولكن لغة واجهة الاستخدام انجليزية وعنوان الزر يظهر تبعا للغة الويندوز تم التغلب عليها مسبقا باستخدام دوال الـ API ولست بصدد الحديث عنها لان بها قيد وهو - شرط لان يتم تغيير اسماء الازرار فى صندوق الرسائل بالاسماء التى يرغب بها المستخدم ان تكوت الخصيصة pop up للنموج = No وهذا فيه تقييد للمصمم وخاصة ان كان يستخدم هذه الخصيصة بالشكل التالى pop up للنموج = Yes وكان الحل البديل هو عمل نموذج للرسائل بدلا من استخدام صندوق الرسائل واعتقد تم عمل ذلك مسبقا فى المنتدى ولكن انا الان اقدمه بافضل اسلوب احترافى واكثر مرونه. لعمل ذلك اولا قم بتصميم نموذج للرسائل واعطه الاسم : frmCustomMessageBox وان اردت تغيير الاسم قم بالتسمية التى تناسبك مع مراعاة تغيير الاسم كذلك فى الكود الذى سوف اقدمه بعد قليل والمستخدم فى الوحدة النمطية العامة الان افتح نموذج الرسائل "frmCustomMessageBox" فى وضع التصميم اضف العناصر التاليه عدد 5 عنصر "Buttons" أزرار أوامر على ان تكون الاسماء للازرار كالتالى : Button0 , Button1 , Button2 , Button3 , Button4 عدد 1 عنصر "Labels" عنوان : على ان يكون اسمه كالتالى : MessageLabel عدد 1 عنصر "Image" صورة : على ان يكون اسمه كالتالى : IconImage والان اضف وحدة نمطية عامة واعطها مثلا الاسم : basCustomMessageBox اضف اليها الكود التالى ' متغير لتخزين رقم الزر الذي تم الضغط عليه في نموذج الرسائل المخصص. Private intPressedButton As Integer ' دالة لعرض صندوق رسائل مخصص ' Parameters: ' - arrMessageLines: مصفوفة تحتوي على أسطر الرسالة. ' - strTitle: عنوان صندوق الرسائل. ' - strButtons: قائمة أزرار مفصولة بفواصل. ' - arrTooltips: مصفوفة تحتوي على تلميحات للأزرار (اختياري). ' - strIconPath: مسار الأيقونة (اختياري). ' Returns: ' - رقم الزر الذي تم الضغط عليه (بدءًا من 0 إلى 4)، أو -1 في حالة حدوث خطأ. Function MsgBx(arrMessageLines As Variant, strTitle As String, strButtons As String, Optional arrTooltips As Variant = Null, Optional strIconPath As String = "") As Integer On Error GoTo ErrorHandler Dim frmCustomMsgBox As Form Dim ctrlCurrent As Control Dim strButtonCaption As Variant Dim intButtonIndex As Integer Dim arrButtonCaptions As Variant Dim strMessage As String Dim strLine As Variant Dim strFormName As String strFormName = "frmCustomMessageBox" ' بناء الرسالة من الأسطر الممررة strMessage = "" For Each strLine In arrMessageLines If strMessage <> "" Then strMessage = strMessage & vbCrLf ' إضافة سطر جديد بين الأسطر End If strMessage = strMessage & strLine Next strLine ' التحقق إذا كان النموذج مفتوحًا If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> 0 Then ' إذا كان النموذج مفتوحًا، فقط استعد المرجع إليه Set frmCustomMsgBox = Forms(strFormName) Else ' إذا لم يكن مفتوحًا، افتحه DoCmd.OpenForm strFormName, acNormal, , , , acHidden Set frmCustomMsgBox = Forms(strFormName) End If ' إعداد خصائص النموذج With frmCustomMsgBox .Caption = strTitle .Controls("MessageLabel").Caption = strMessage ' إظهار التسمية فقط إذا كان هناك نص .Controls("MessageLabel").Visible = (strMessage <> "") ' إضافة الأزرار الجديدة بناءً على strButtons intButtonIndex = 0 arrButtonCaptions = Split(strButtons, ",") For Each strButtonCaption In arrButtonCaptions With .Controls("Button" & intButtonIndex) .Caption = strButtonCaption .Visible = True .OnClick = "=PressedButton(" & intButtonIndex & ")" ' تعيين التلميحات للأزرار إذا تم تمريرها If Not IsNull(arrTooltips) And IsArray(arrTooltips) Then If intButtonIndex <= UBound(arrTooltips) Then .ControlTipText = arrTooltips(intButtonIndex) End If End If End With intButtonIndex = intButtonIndex + 1 Next strButtonCaption ' تعيين الأيقونة إذا كان مسارها موجودًا If strIconPath <> "" Then If Dir(strIconPath) <> "" Then ' إذا كانت الأيقونة موجودة، قم بتعيينها On Error Resume Next ' تجاهل الخطأ إذا حدث .Controls("IconImage").Picture = strIconPath If Err.Number <> 0 Then ' إذا حدث خطأ، أخفي عنصر التحكم .Controls("IconImage").Visible = False Err.Clear Else .Controls("IconImage").Visible = True End If On Error GoTo ErrorHandler ' العودة إلى إدارة الأخطاء العادية Else ' إذا لم تكن الأيقونة موجودة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If Else ' إذا لم يتم تمرير أيقونة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If End With ' إظهار النموذج كمودال DoCmd.OpenForm strFormName, acNormal intPressedButton = -1 ' انتظار المستخدم لتحديد زر Do DoEvents Loop Until intPressedButton > -1 ' إرجاع القيمة وإغلاق النموذج DoCmd.Close acForm, strFormName, acSaveNo MsgBx = intPressedButton Exit Function ErrorHandler: ' إرجاع قيمة تشير إلى فشل العملية MsgBx = -1 MsgBox "حدث خطأ: " & Err.Number & " | " & Err.Description Debug.Print "حدث خطأ: " & Err.Number & " | " & Err.Description Exit Function End Function Function PressedButton(intButtonIndex As Integer) ' تسجيل الرقم الخاص بالزر المضغوط intPressedButton = intButtonIndex End Function والان طريقة الاستدعاء من اى زر امر لهواة الاختصار فى الاكواد من اى نموذج تكون كالتالى ' تعريف متغير لتخزين نتيجة اختيار المستخدم من النافذة المنبثقة Dim Result As Integer Result = MsgBx(Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟"), "تحذير", "نعم,لا", Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء"), "Full-Path\error.png") If Result = 0 Then MsgBox "تم اختيار موافق" ElseIf Result = 1 Then MsgBox "تم اختيار إلغاء" End If ولكن الطريقة الأمثل لسهولة التعديل والاضافة والصيانة فى المستقبل يكون الاستدعاء بالشكل التالى ' تعريف المتغيرات المستخدمة Dim MessageLines As Variant ' تخزين سطور الرسالة (نص رئيسي وفرعي) Dim TitleText As String ' عنوان النافذة المنبثقة Dim ButtonsText As String ' نص الأزرار (مفصولة بفواصل) Dim Result As Integer ' نتيجة اختيار المستخدم Dim IconPath As String ' مسار ملف أيقونة التحذير Dim Tooltips As Variant ' تلميحات توضيحية عند التمرير على الأزرار ' تعيين مسار ملف الأيقونة التحذيرية (يجب التأكد من صحة المسار) IconPath = "Full-Path\error.png" ' تهيئة محتوى الرسالة: MessageLines = Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟") TitleText = "تحذير" ' عنوان النافذة المنبثقة ButtonsText = "نعم,لا" ' خيارات الأزرار (الزر الأول: نعم، الزر الثاني: لا) ' تعيين التلميحات التوضيحية عند تمرير الماوس على الأزرار: ' تلميح للزر الأول (نعم) ' تلميح للزر الثاني (لا) Tooltips = Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء") ' استدعاء الدالة المخصصة لعرض الرسالة: ' محتوى الرسالة -العنوان - اسماء الأزرار - التلميحات - مسار الأيقونة Result = MsgBx(MessageLines, TitleText, ButtonsText, Tooltips, IconPath) ' معالجة النتيجة المرجعة من الدالة: If Result = -1 Then ' حالة الخطأ (-1 تعني فشل في عرض الرسالة) MsgBox "حدث خطأ أثناء عرض الرسالة." ElseIf Result = 0 Then ' الزر الأول (نعم) تم اختياره MsgBox "تم اختيار نعم" ElseIf Result = 1 Then ' الزر الثاني (لا) تم اختياره MsgBox "تم اختيار لا" End If لتكون النتيجة كما بالشكل التالى من النموج بدلا من صندوق الرسائل التقليدى طبعا يمكن تغيير اسماء الازرار عند الاستدعاء من السطر : ButtonsText = "نعم, لا" ليكون مثلا ButtonsText = "موافق , الغاء" وطبعا تغير السطر : MsgBox "تم اختيار نعم" باضافة الكود الذى تريده عند الضغط على الزر انا فقط كتبت الرسالة فى كود الاستدعاء لتوضيح انه سوف يتم تنفيذ الامر ملحوظة : استخدام : Tooltips وهو التلميح عندما يحوم الماوس فوق الازرار فى النموذج اختيارى ممكن عدم استخدامه كذلك استخدام : IconPath وهو مسار لصورة ايقونة تدل على الرسالة اختيارى ممكن عدم استخدامه ولكن طبعا انا كتبت الكود بحيث يوفر اكبر قدر ممكن من المرونه فى تناول او عدم تناول هذه الخصائص لمن يريد تغيير الايقونات مع كل رسالة او تغيير عدد او اسماء الازرار مع كل رسالة وكذلك التلميحات للازرار المستخدمه ملاحطة هامة جدا جدا جدا : لا تنسي اخفاء كل ازرار الاوامر الخمسة فى النموذج الكود سوف يقوم بإعادة اظهار الازرار حسب الاستدعاء تحياتى الحارة CustomMessageBox.zip

السلام عليكم ورحمة الله وبركاته اقدم اليكم مكتبة مرنة وشاملة و متقدمة لإدارة و التعامل مع الملفات والمجلدات قمت بكتابتها بشكل مرن وإحترافي بمعنى الكلمة يحدد ما إذا كان المستخدم سيختار ملفًا أو مجلدًا يحدد شكل الإخراج (المسار الكامل، الاسم فقط، أو الاسم مع الامتداد) تصنيف الملفات حسب نوعها و تصفية الملفات المعروضة اختيار متعدد أو فردي اليكم الأكواد كاملة هديــــة لأخوانى وأحبابى Option Compare Database Option Explicit ' Global variables for file selection and allowed extensions Public IsFolderMode As Boolean ' Toggle folder selection mode Public AllowedExtensions As Collection ' Store allowed file extensions ' Enumeration for File Dialog Types Public Enum FileDialogType FilePicker = 1 ' Dialog for selecting files FolderPicker = 4 ' Dialog for selecting folders End Enum ' Enumeration for processing file path Public Enum FileProcessingMode FullPath = 1 ' Return the full file path NameWithoutExtension = 2 ' Return the file name without extension NameWithExtension = 3 ' Return the file name with extension End Enum ' Enumeration for file categories Public Enum FileCategory AccessFiles = 1 ' Access Database files (accdb, mdb, accda, etc.) ExcelFiles = 2 ' Excel files (xlsx, xls, xlsm, etc.) WordFiles = 3 ' Word files (docx, doc, docm, etc.) ImageFiles = 4 ' Images category (jpg, png, gif, bmp, tiff, etc.) AudioFiles = 5 ' Audio category (mp3, wav, ogg, flac, etc.) VideoFiles = 6 ' Video category (mp4, avi, mov, mkv, etc.) AcrobatFiles = 7 ' Acrobat PDF files (pdf) TextFiles = 8 ' Text files (txt, csv, log, md, etc.) PowerPointFiles = 9 ' PowerPoint files (pptx, ppt, pptm, etc.) CompressedFiles = 10 ' Compressed files (zip, rar, 7z, tar, gz, etc.) CodeFiles = 11 ' Code files (html, css, js, php, py, java, etc.) ExecutableFiles = 12 ' Executable files (exe, bat, cmd, apk, etc.) AllFiles = 13 ' All file types (*.*) End Enum ' Initialize the allowed extensions for a specific file category Sub InitializeExtensions(ByVal Category As FileCategory) Set AllowedExtensions = New Collection Select Case Category ' Access Database files Case AccessFiles AddExtensions Array("accda", "accdb", "accde", "accdr", "accdt", "accdw", "mda", "mdb", "mde", "mdf", "mdw") ' Excel files Case ExcelFiles AddExtensions Array("xlsx", "xls", "xlsm", "xlsb", "xltx", "xltm") ' Word files Case WordFiles AddExtensions Array("docx", "doc", "docm", "dotx", "dotm", "rtf", "odt") ' Image files Case ImageFiles AddExtensions Array("jpg", "jpeg", "png", "gif", "bmp", "tiff", "tif", "ico", "webp", "heif", "heic") ' Audio files Case AudioFiles AddExtensions Array("mp3", "wav", "ogg", "flac", "aac", "m4a", "wma", "alac", "opus", "aiff") ' Video files Case VideoFiles AddExtensions Array("mp4", "avi", "mov", "mkv", "flv", "wmv", "webm", "mpeg", "mpg", "3gp", "ts") ' Acrobat PDF files Case AcrobatFiles AllowedExtensions.Add "pdf" ' Text files Case TextFiles AddExtensions Array("txt", "csv", "log", "md", "rtf") ' PowerPoint files Case PowerPointFiles AddExtensions Array("pptx", "ppt", "ppsx", "pps", "pptm", "potx", "potm") ' Compressed files (Archives) Case CompressedFiles AddExtensions Array("zip", "rar", "7z", "tar", "gz", "tar.gz", "tgz", "xz", "bz2") ' Code files Case CodeFiles AddExtensions Array("html", "css", "js", "php", "py", "java", "cpp", "c", "rb", "swift", "go", "ts") ' Executable files Case ExecutableFiles AddExtensions Array("exe", "bat", "cmd", "msi", "apk", "app", "dmg", "jar") ' All file types Case AllFiles AllowedExtensions.Add "*.*" Case Else MsgBox "Invalid category provided!", vbCritical End Select End Sub ' Add an array of extensions to the AllowedExtensions collection Private Sub AddExtensions(ByVal ExtensionsArray As Variant) Dim Extension As Variant For Each Extension In ExtensionsArray AllowedExtensions.Add Extension Next Extension End Sub ' Display a file or folder dialog and return the selected files Function GetFiles(Optional ByVal Extensions As Collection = Nothing, Optional ByVal SingleFile As Boolean = False) As Collection Dim FileDialog As Object Dim FolderDialog As Object Dim SelectedFiles As New Collection Dim FolderPath As String Dim FilterString As String On Error GoTo ErrorHandler ' Build the file dialog filter FilterString = BuildFilterString(Extensions) If Not IsFolderMode Then ' File selection dialog Set FileDialog = Application.FileDialog(FileDialogType.FilePicker) With FileDialog .Title = "Select File(s)" .AllowMultiSelect = Not SingleFile .Filters.Clear .Filters.Add "Allowed Files", FilterString If .Show = -1 Then AddSelectedFilesToCollection FileDialog, SingleFile, SelectedFiles End If End With Else ' Folder selection dialog Set FolderDialog = Application.FileDialog(FileDialogType.FolderPicker) With FolderDialog .Title = "Select Folder" If .Show = -1 Then FolderPath = .SelectedItems(1) SelectedFiles.Add FolderPath End If End With End If ' Return the selected files or folder If SelectedFiles.Count > 0 Then Set GetFiles = SelectedFiles Else MsgBox "No files or folder selected.", vbExclamation Set GetFiles = Nothing Exit Function End If CleanUp: Set FileDialog = Nothing Set FolderDialog = Nothing Exit Function ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical Resume CleanUp End Function ' Build the file dialog filter string Private Function BuildFilterString(ByVal Extensions As Collection) As String Dim Filter As String Dim Extension As Variant If Not Extensions Is Nothing Then For Each Extension In Extensions Filter = Filter & "*." & Extension & ";" Next Extension If Len(Filter) > 0 Then Filter = Left(Filter, Len(Filter) - 1) Else Filter = "*.*" End If BuildFilterString = Filter End Function ' Add selected files to the collection Private Sub AddSelectedFilesToCollection(ByVal Dialog As Object, ByVal SingleFile As Boolean, ByRef FilesCollection As Collection) Dim Index As Long If SingleFile Then FilesCollection.Add Dialog.SelectedItems(1) Else For Index = 1 To Dialog.SelectedItems.Count FilesCollection.Add Dialog.SelectedItems(Index) Next Index End If End Sub ' Function to check if the file extension is allowed Function IsAllowedExtension(ByVal strExt As String, ByVal colExtensions As Collection) As Boolean Dim varExt As Variant If colExtensions Is Nothing Or colExtensions.Count = 0 Then IsAllowedExtension = True ' Allow all extensions if colExtensions is Nothing or empty Exit Function End If For Each varExt In colExtensions If LCase(strExt) = LCase(varExt) Then IsAllowedExtension = True Exit Function End If Next varExt IsAllowedExtension = False End Function ' Subroutine to select a folder and retrieve all files based on allowed extensions Sub SelectFilesInFolder(ByVal FileCategoryType As FileCategory) Dim SelectedFiles As Collection ' Collection to hold the selected files Dim FolderPath As String ' Folder path selected by the user Dim CurrentFileName As String ' Current file name during folder iteration Dim FileExtension As String ' File extension for the current file Dim FilteredFiles As New Collection ' Collection to hold filtered files Dim FileItem As Variant ' Variable to iterate through filtered files On Error GoTo ErrorHandler ' Handle errors if they occur ' Enable folder selection mode IsFolderMode = True ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a folder Set SelectedFiles = GetFiles(Nothing, False) ' Pass Nothing for extensions as folder mode doesn't filter by type ' Check if a folder was selected If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Get the first (and only) selected folder path FolderPath = SelectedFiles(1) ' Start iterating through all files in the selected folder CurrentFileName = Dir(FolderPath & "\*.*") ' Retrieve the first file in the folder Do While CurrentFileName <> "" ' Extract file extension and convert it to lowercase FileExtension = LCase(Split(CurrentFileName, ".")(UBound(Split(CurrentFileName, ".")))) ' Check if the file extension is allowed and add it to the filtered collection If IsAllowedExtension(FileExtension, AllowedExtensions) Then FilteredFiles.Add FolderPath & "\" & CurrentFileName End If ' Retrieve the next file in the folder CurrentFileName = Dir Loop ' If there are filtered files, display their paths If FilteredFiles.Count > 0 Then For Each FileItem In FilteredFiles Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files found matching the allowed extensions.", vbExclamation End If Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub Sub SelectFolderPath() On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim colFiles As Collection IsFolderMode = True ' Set folder mode to true for folder selection Set colFiles = GetFiles(Nothing, False) ' Pass Nothing for colExtensions as we are dealing with folders On Error Resume Next If Not colFiles Is Nothing And colFiles.Count > 0 Then PrintFilePaths colFiles Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate single file selection with specific extensions Sub SelectSingleFile(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a single file with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, True) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate multiple file selection with specific extensions Sub SelectMultipleFiles(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select multiple files with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to print file paths from a collection Sub PrintFilePaths(ByVal Files As Collection) ' Variable to iterate through filtered files Dim FileItem As Variant ' Check if the collection is valid and contains files If Not Files Is Nothing And Files.Count > 0 Then For Each FileItem In Files Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files were selected or matched the allowed extensions.", vbExclamation End If End Sub ' Subroutine to process file paths, extract name, name without extension, and extension Sub ProcessFilePaths(ByVal colFiles As Collection) ' Variable to iterate through the collection Dim varFilePath As Variant ' Variable to hold the current file path as a string Dim strFilePath As String ' Variables to hold extracted components of the file path Dim fileName As String Dim fileNameWithoutExt As String Dim fileExt As String ' Check if the collection is not empty or Nothing If Not colFiles Is Nothing Then ' Loop through each file path in the collection For Each varFilePath In colFiles ' Assign the current file path to a string variable strFilePath = varFilePath ' Extract the file name from the full path fileName = GetFileNameFromPath(strFilePath) ' Extract the file name without the extension fileNameWithoutExt = GetFileNameWithoutExtension(strFilePath) ' Extract the file extension (including the dot) fileExt = GetFileExtension(strFilePath) ' ' Print the extracted information to the Immediate Window (Ctrl+G in VBA Editor) ' Debug.Print "Full Path: " & varFilePath ' Debug.Print "File Name: " & fileName ' Debug.Print "File Name Without Extension: " & fileNameWithoutExt ' Debug.Print "File Extension: " & fileExt ' Debug.Print "------------------------------" Next varFilePath Else ' Show a message box if the collection is empty or Nothing MsgBox "No files found.", vbInformation End If End Sub ' Function to extract the file name (including extension) from a full file path Function GetFileNameFromPath(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameFromPath = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim pos As Long pos = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If pos = 0 Then pos = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract and return the file name If pos > 0 Then GetFileNameFromPath = Mid(FilePath, pos + 1) ' Return everything after the last separator Else GetFileNameFromPath = FilePath ' If no separator is found, return the full path End If End Function ' Function to extract the file name without its extension from a full file path Function GetFileNameWithoutExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameWithoutExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim posBackslash As Integer posBackslash = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If posBackslash = 0 Then posBackslash = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract the file name (with extension) Dim fileName As String If posBackslash > 0 Then fileName = Mid(FilePath, posBackslash + 1) ' Extract the file name Else fileName = FilePath ' If no separator, the full path is considered the file name End If ' Search for the last dot in the file name to identify the extension Dim posDot As Integer posDot = InStrRev(fileName, ".") ' Find the position of the last dot ' Remove the extension if a dot is found If posDot > 0 Then GetFileNameWithoutExtension = Left(fileName, posDot - 1) ' Return the name without the extension Else GetFileNameWithoutExtension = fileName ' If no dot, return the full file name End If End Function ' Function to extract the file extension (including the dot) from a full file path Function GetFileExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last dot in the file path Dim posDot As Integer posDot = InStrRev(FilePath, ".") ' Find the position of the last dot ' Extract and return the file extension If posDot > 0 Then GetFileExtension = Mid(FilePath, posDot) ' Return everything after (and including) the last dot Else GetFileExtension = "" ' If no dot is found, return an empty string End If End Function ' Subroutine to save file paths or details into a database table ' Parameters: ' - SelectedFiles: Collection of selected file paths. ' - TableName: Name of the database table where data will be saved. ' - FieldName: Name of the field in the table to store the file information. ' - ProcessingMode: Determines how the file paths will be processed before saving. Default is FullPath. Sub SaveFileDetailsToTable(SelectedFiles As Collection, TableName As String, FieldName As String, Optional ByVal ProcessingMode As FileProcessingMode = FullPath) On Error GoTo ErrorHandler ' Handle errors if they occur Dim varFilePath As Variant Dim ProcessedValue As String ' Check if the SelectedFiles collection is valid and contains files If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Loop through each file in the collection For Each varFilePath In SelectedFiles ' Determine how the file path should be processed based on ProcessingMode Select Case ProcessingMode Case FullPath ' Use the full file path as the value to save ProcessedValue = CStr(varFilePath) Case NameWithoutExtension ' Extract and use the file name without its extension ProcessedValue = GetFileNameWithoutExtension(CStr(varFilePath)) Case NameWithExtension ' Extract and use the file name including its extension ProcessedValue = GetFileNameFromPath(CStr(varFilePath)) Case Else ' Default to using the full file path ProcessedValue = CStr(varFilePath) End Select ' Construct the SQL statement to insert the processed value into the specified table and field Dim SQL As String SQL = "INSERT INTO [" & TableName & "] ([" & FieldName & "]) VALUES ('" & Replace(ProcessedValue, "'", "''") & "')" ' Execute the SQL statement to save the data into the database CurrentDb.Execute SQL, dbFailOnError Next varFilePath Else ' Display a message if no files were found in the collection MsgBox "No files found.", vbInformation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Test method to demonstrate saving file details to a table ' This subroutine selects files and saves their names without extensions into a database table Sub TestSaveResults() Dim SelectedFiles As Collection ' Set mode to file selection mode IsFolderMode = False ' Initialize allowed extensions for the specific category (e.g., images in this case) InitializeExtensions ImageFiles ' Prompt the user to select files based on the allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Save the selected file names (without extensions) into the table "tblMedia" in the "fieldName" column SaveFileDetailsToTable SelectedFiles, "tblMedia", "fieldName", NameWithoutExtension End Sub ' Test the functionality of retrieving a folder path Sub TestGetFolderPath() ' Call the Select Folder function to get the folder path SelectFolderPath End Sub ' Test the functionality of selecting files in a folder based on the specified file category Sub TestSelectFilesInFolder() ' Call the SelectFilesInFolder function to select audio files from a folder SelectFilesInFolder AudioFiles End Sub ' Test the functionality of selecting a single file based on the specified file category Sub TestSelectSingleFile() ' Call the SelectSingleFile function to select a single audio file SelectSingleFile AudioFiles End Sub ' Test the functionality of selecting multiple files based on the specified file category Sub TestSelectMultipleFiles() ' Call the SelectMultipleFiles function to select multiple audio files SelectMultipleFiles AudioFiles End Sub

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ غاية فى الروعة ومكتوبة بعناية واحترافية للحصول على اكبر قدر ممكن من الدقة فى الاداء والمرونة فى التناول عند الاستدعاء حيث أن الكود يعالج النصوص العربية بطريقة مرنة مع التركيز على ازالة المسافات وتنظيف النص و إزالة التشكيل و توحيد الاحرف ومعالجتها يعتمد الكود خيارين للعمل (إزالة المسافات أو التطبيع "توحيد الاشكال المختلفة للاحرف" ) مما يجعله قابلاً للتخصيص بناءً على الحاجة على سبيل المثال النص الاصلى والذى نريد معالجته : "تَجْرِبَةُ إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 101" الحالات التى يمكن الحصول عليها من معالجة النص السابق هى ازالة المسافات فقط وتنظيف النص مع الابقاء على الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم 101 ازالة المسافات وتنظيف النص مع الابقاء على الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم 101 ازالة المسافات وتنظيف النص مع ازالة الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم ازالة المسافات فقط وتنظيف النص مع ازالة الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم الكود ' Function: ArabicTextSanitizer ' Purpose: Sanitizes Arabic text by removing non-Arabic characters, optionally normalizing the text, ' removing diacritics (harakat), and optionally removing numeric characters or spaces. ' Parameters: ' inputText (String): The Arabic text to be sanitized. It can contain Arabic characters, non-Arabic characters, ' diacritics, and numeric values. ' normalize (Boolean): Optional. If True, the text will be normalized by replacing specific Arabic characters ' with their standardized equivalents (default is True). ' RemoveNumbers (Boolean): Optional. If True, numeric characters (0-9) will be removed from the text (default is True). ' removeSpaces (Boolean): Optional. If True, all spaces in the text will be removed (default is False). ' Returns: ' String: The sanitized Arabic text with optional normalization, removal of numbers, and spaces. ' ' Example Use Cases: ' 1. Remove spaces only and clean the text while keeping numbers without normalization: ' ' Removes spaces from the text while keeping numbers and without normalizing the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, False, True) ' ' 2. Remove spaces and clean the text while keeping numbers and normalizing: ' ' Normalizes the text and removes spaces, while keeping numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, False, True) ' ' 3. Remove spaces and clean the text while removing numbers and normalizing: ' ' Normalizes the text, removes spaces, and removes numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, True, True) ' ' 4. Remove spaces only and clean the text while removing numbers without normalization: ' ' Removes spaces and numbers, but does not normalize the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, True, True) ' Public Function ArabicTextSanitizer(inputText As String, Optional normalize As Boolean = True, Optional RemoveNumbers As Boolean = True) As String On Error GoTo ErrorHandler ' Ensure the input is valid (non-empty and not null) If Nz(inputText, "") = "" Then ArabicTextSanitizer = "" Exit Function End If ' Initialize the sanitizedText with the trimmed input Dim sanitizedText As String sanitizedText = Trim(inputText) ' Step 1: Normalize the text if requested If normalize Then ' Define character replacement pairs for normalization Dim charReplacementPairs As Variant charReplacementPairs = Array( _ Array(ChrW(1573), ChrW(1575)), _ Array(ChrW(1571), ChrW(1575)), _ Array(ChrW(1570), ChrW(1575)), _ Array(ChrW(1572), ChrW(1608)), _ Array(ChrW(1574), ChrW(1609)), _ Array(ChrW(1609), ChrW(1610)), _ Array(ChrW(1577), ChrW(1607)), _ Array(ChrW(1705), ChrW(1603)), _ Array(ChrW(1670), ChrW(1580))) ' Apply replacements for character normalization Dim pair As Variant For Each pair In charReplacementPairs sanitizedText = Replace(sanitizedText, pair(0), pair(1)) Next ' Step 2: Remove diacritics (harakat) from the text Dim diacritics As String diacritics = ChrW(1600) & ChrW(1611) & ChrW(1612) & ChrW(1613) & ChrW(1614) & ChrW(1615) & ChrW(1616) & ChrW(1617) & ChrW(1618) Dim i As Integer For i = 1 To Len(diacritics) sanitizedText = Replace(sanitizedText, Mid(diacritics, i, 1), "") Next End If ' Step 3: Retain only Arabic characters, spaces, and optionally numbers Dim tempChars() As String Dim charIndex As Long Dim intChar As Integer Dim finalResultText As String ' Iterate through each character in the sanitized text For i = 1 To Len(sanitizedText) intChar = AscW(Mid(sanitizedText, i, 1)) ' Check for Arabic characters (range for Arabic characters and spaces) If intChar = 32 Or _ (intChar >= 1569 And intChar <= 1594) Or _ (intChar >= 1601 And intChar <= 1610) Or _ (intChar >= 1648 And intChar <= 1649) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 ' Optionally, check for numbers if RemoveNumbers is False ElseIf Not RemoveNumbers And (intChar >= 48 And intChar <= 57) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 End If Next ' Step 4: Join the valid characters into a final result text finalResultText = Join(tempChars, "") ' Step 5: Remove extra spaces (multiple consecutive spaces replaced with a single space) finalResultText = Replace(finalResultText, " ", " ") ' Improved space replacement Do While InStr(finalResultText, " ") > 0 finalResultText = Replace(finalResultText, " ", " ") Loop ' Step 6: Remove special characters (if needed) finalResultText = Replace(finalResultText, "*", "") finalResultText = Replace(finalResultText, "#", "") finalResultText = Replace(finalResultText, "@", "") finalResultText = Replace(finalResultText, ",", "") ' Return the sanitized text If Len(Trim(Nz(finalResultText, ""))) = 0 Then ArabicTextSanitizer = vbNullString Else ArabicTextSanitizer = finalResultText End If Exit Function ErrorHandler: Debug.Print "Error in ArabicTextSanitizer: " & Err.Description ArabicTextSanitizer = "" End Function وهذه الوظيفة تبين اشكال وطرق الاستدعاء المختلفة ' Subroutine: TestArabicTextSanitizer ' Purpose: Demonstrates and validates the functionality of the ArabicTextSanitizer function. ' It shows various test cases for sanitizing Arabic text with diacritics, non-Arabic characters, and numbers. Sub TestArabicTextSanitizer() ' Declare input and result variables Dim inputArabicText As String Dim result As String ' Example input text with diacritics, non-Arabic characters, and numbers inputArabicText = "تَجْرِبَةُ * فَاحِصِهِ # @ , لِعَمَلٍ أَلِكَوَّدِ فِىَّ شَتِّيَّ 3ألْإِشْكآل " & _ "إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 5 و الْمَكَانِ رَقْمٌ 100100ِ لمعرفة كيف سيعمل ها ألكود" ' Display the original input Arabic text Debug.Print "Input Arabic Text: " & inputArabicText ' Test case 1: Remove diacritics without normalization ' This case removes diacritics (harakat) without altering normalization or removing numbers result = ArabicTextSanitizer(inputArabicText, False, False) Debug.Print "Filtered Arabic Text (case 1 - Remove diacritics without normalization): " & result ' Test case 2: Normalize and remove diacritics ' This case normalizes the text (e.g., converting similar Arabic characters) and removes diacritics result = ArabicTextSanitizer(inputArabicText, True, False) Debug.Print "Normalized Arabic Text and Removed Diacritics (case 2): " & result ' Test case 3: Remove numbers as well (Optional argument set to True to remove numbers) ' This case normalizes the text and removes both diacritics and numbers result = ArabicTextSanitizer(inputArabicText, True, True) Debug.Print "Text without Numbers and Normalized (case 3): " & result ' Test case 4: Just remove diacritics without normalization or removing numbers ' This case removes diacritics and numbers, but does not normalize the text result = ArabicTextSanitizer(inputArabicText, False, True) Debug.Print "Text without Diacritics and Numbers (case 4): " & result End Sub واخيرا اليكم مرفق للتجربة Arabic Text Sanitizer.accdb

اداة البحث هذه قمت بمحاولة تجميع الافكار فيها بعناية وبترتيبها لمحاولة الوصول الى اقصى درجات الكفائة والمرونة الممكنة اولا : تعرية وتطهير النص والتحكم فى ذلك حسب الحاجة كما سبق التنويه عن هذه الجزئية فى هذا الموضوع ثانيا : التحكم فى اعداد مصادر البيانت :- (مصدر البيانات"جدول /استعلام" - الحقولالبحث المخصصة - امكانية اضافة حقل او اكثر يعتمد على تطهير النصوص ثالثا : آلية البحث بحيث يمكن البحث من خلال ( الكلمة تبدأ بـ - تنتهى بـ - يتضمن الكلمة فى امكان - او متطابق تماما او لو عدد الكلمات كثير يمكن كتابة جزء من كل كلمة فى نفس السجل ولا يشترط الترتيب ) مثال : نريد البحث فى السجل قيمة هذا السجل : 26675 فوزي عبد الحميد ابو الفتوح محمد سعده لو تم اختيار من إعدادت البحث : يحتوى على اكثر من كلمة او جزء من كلمه يفصل بينهم مسافة من إعدادت البحث ثم كتبنا فى مربع البحث : عب فت سع 66 نحصل على النتيجة اثناء كتابة الكود تم عمل جدول باسم : tblSearchSettings بحيث يتم حفظ الاعدادت الخاصة بعملية البحث والفرز والتصفية تم وضع القيم الافتراضية لاجراء عمليات البحث والفرز والتصفية المتعددة على اكمل وجهة فى حالة حذف الجدول الخاص باعدادت البحث كما انها تمثل مرونة قصوى لكل مستخدم على حدى فى حالة استخدام شبكة محلية يستطيع كل مستخدم الاحتفاظ بالاعدادت التى تناسبه دون التأثير على الاخرين اخيرا المرفق واترككم مع التجربة Search Utility V 3.0.2.accdb

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

السلام عليكم ورحمة الله تعالى وبركاته اليوم اقدم لكم هدية صغيرة ولكن النفع من ورائها عظيم جدا قد ينتج عن الكود اخطاء عند كتابة الكود قد نحتاج تتبع نتائج الكود قد محتاج معرفة القيم التى يعيدهها الكود قد نكتب استعلام مثلا زنقطع الاسطر ونضيف متغيرات نمرر منها قيما الى الاستعلام ونريد معرفة كبف سوف يراه الحاسوب فى النهاية وقد وقد و ........ الخ وهناك الكثير والكثير وما ذطرته هو فقط على سبيل المثال وليس الحصر اتتنى فكرة وهى كتابة كود فى موديول ليسهل الامور على مصممى قواعد البيانات فيضفى المرونة فى التعامل وكذا الاحترافية التامة مع هذا الامر وهو استخدام: Debug.Print وحتى لا اطيل عليكم اليكم الاكواد Option Compare Database Option Explicit '********************************************************************** ' Function: DebugPrint ' Purpose: Prints a message to the Immediate Window in the VBA editor and optionally logs it to a file. ' Inputs: ' Message - The message to be printed (String). ' Optional AddNewLine - A Boolean flag to add a new line after printing (default is True). ' Optional Prefix - A string to prefix the message (default is ""). ' Optional Suffix - A string to suffix the message (default is ""). ' Optional LogToFile - A Boolean flag to enable logging to a file (default is False). ' Optional FilePath - The path of the file where the log should be saved (default is ""). ' Returns: Nothing - The function performs a print and/or log operation. ' Notes: ' - The function sends the message to the Immediate Window. ' - If AddNewLine is True, a newline is added after the message. ' - Prefix and Suffix can be used to format the message. ' - LogToFile enables logging the message to a specified file. ' - Error handling is included to manage issues with file operations. '********************************************************************** ' Author: Officena.net , Mohammed Essm , soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub DebugPrint(ByVal Message As String, Optional ByVal AddNewLine As Boolean = True, _ Optional ByVal Prefix As String = "", Optional ByVal Suffix As String = "", _ Optional ByVal LogToFile As Boolean = False, Optional ByVal FilePath As String = "") Dim fullMessage As String Dim fileNum As Integer ' Construct the full message with prefix and suffix fullMessage = Prefix & Message & Suffix ' Print the message to the Immediate Window Debug.Print fullMessage ' Optionally add a newline after printing If AddNewLine Then Debug.Print "" ' Adds an empty line for separation End If ' Log the message to a file if specified If LogToFile And FilePath <> "" Then On Error GoTo ErrorHandler fileNum = FreeFile Open FilePath For Append As #fileNum Print #fileNum, fullMessage Close #fileNum On Error GoTo 0 End If Exit Sub ErrorHandler: ' Handle any errors that occur during file operations Debug.Print "Error occurred while logging to file: " & Err.Description On Error GoTo 0 End Sub ' Example 1: Print a simple message Rem Call DebugPrint("This is a simple message") ' Example 2: Print a message with a prefix and suffix, without adding a new line Rem DebugPrint("Error encountered!", AddNewLine:=False, Prefix:="Error: ", Suffix:=" [Check details]") ' Example 3: Print a message and log it to a file Rem DebugPrint("Logging this message to a file.", LogToFile:=True, FilePath:="C:\path\to\your\logfile.txt") ' Example 4: Print multiple messages with automatic new lines and logging Rem DebugPrint("Starting process...") Rem DebugPrint("Process in progress...") Rem DebugPrint("Process completed successfully!", LogToFile:=True, FilePath:="C:\path\to\your\logfile.txt") '--------------------------------------------------------------------------------------------------------------------------------------- '********************************************************************** ' Subroutine: OpenImmediateWindow ' Purpose: Opens the Immediate Window in the VBA editor and prepares it for input. ' Inputs: None ' Returns: Nothing ' Notes: ' - The Immediate Window is activated and ready for input. ' - This subroutine uses the SendKeys method to send keystrokes. ' - Error handling is included to manage potential issues with SendKeys. '********************************************************************** ' Author: Officena.net , Mohammed Essm , soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Sub OpenImmediateWindow() Dim shell As Object On Error GoTo ErrorHandler ' Create an instance of WScript.Shell to send keystrokes Set shell = CreateObject("WScript.Shell") With shell ' Send Ctrl+G to open the Immediate Window .SendKeys "^g ", True ' Send Tab to navigate if needed .SendKeys "{TAB}", True End With Application.VBE.MainWindow.Visible = True DoEvents 'this frees up the OS to repaint the screen Exit Sub ' Clean up Set shell = Nothing ErrorHandler: ' Handle any errors that occur during SendKeys operations Debug.Print "Error occurred while opening the Immediate Window: " & Err.Description On Error GoTo 0 End Sub '********************************************************************** ' Function: ClearImmediateWindowContent ' Purpose: Clears the content of the Immediate Window in the VBA Editor. ' Details: ' This function searches for an open Immediate Window within the VBE. ' If found, it sends keystrokes to clear the content using the WScript.Shell object. ' Inputs: None ' Returns: Void ' Error Handling: ' Includes basic error handling to inform the user in case of an issue. ' Notes: ' - This function assumes that there is only one Immediate Window open. ' - The function does not create a new Immediate Window if one is not found. '********************************************************************** Public Function ClearImmediateWindowContent() On Error GoTo ErrorHandler Dim totalVBEWindows As Long Dim currentWindowIndex As Long Const IMMEDIATE_WINDOW_TYPE As Long = 5 ' Type constant for Immediate Window Dim shell As Object ' Create an instance of WScript.Shell to send keystrokes Set shell = CreateObject("WScript.Shell") totalVBEWindows = Application.VBE.Windows.Count ' Get the number of open windows ' Iterate through all open windows For currentWindowIndex = 1 To totalVBEWindows ' Check if the current window is the Immediate Window If Application.VBE.Windows.Item(currentWindowIndex).Type = IMMEDIATE_WINDOW_TYPE Then Application.VBE.Windows.Item(currentWindowIndex).SetFocus ' Set focus to the Immediate Window ' Ensure the Immediate Window is active If Application.VBE.ActiveWindow.Type = IMMEDIATE_WINDOW_TYPE Then With shell ' Send Ctrl+G to activate the Immediate Window .SendKeys "^g", True ' Send Ctrl+A to select all content .SendKeys "^a", True ' Send Delete to clear selected content .SendKeys "{DEL}", True ' Send Backspace to ensure content is cleared .SendKeys "{BKSP}", True End With Exit Function ' Exit after clearing the content End If Exit For ' Exit the loop if Immediate Window is found and focused End If Next currentWindowIndex ' Clean up Set shell = Nothing Exit Function ErrorHandler: MsgBox "Error occurred while trying to clear the Immediate Window. Error: " & Err.Description, vbCritical ' Clean up Set shell = Nothing End Function '********************************************************************** ' Function: GetDesktopPath ' Purpose: Returns the path to the Desktop for the current user. ' Details: ' This function retrieves the path to the Desktop folder using Windows API functions. ' Inputs: None ' Returns: String - The full path to the Desktop folder. ' Notes: ' - This function uses Windows API to get the Desktop path. ' - Ensure you have error handling to manage unexpected issues. '********************************************************************** Public Function GetDesktopPath() As String Dim strDesktopPath As String Dim objShell As Object On Error GoTo ErrorHandler ' Create an instance of Shell object Set objShell = CreateObject("Shell.Application") ' Get the Desktop folder path strDesktopPath = objShell.NameSpace(&H10&).Self.Path ' Return the path GetDesktopPath = strDesktopPath Exit Function ErrorHandler: MsgBox "Error occurred while retrieving the Desktop path. Error: " & Err.Description, vbCritical GetDesktopPath = "" End Function بالمناسبة لا داعى للقلق من وجود واستخدام "SendKeys" داخل الاكود لانه تم التعامل معها بحرفية تامة كى لا تأثر على حالة الـ Num Lock ImmediateWindowHelper.accdb

السلام عليكم ورحمة الله تعالى وبركاته المصدر و الموضوع الاساسى : فى هذه المشاركة لأستاذى القدير و معلمى الجليل و والدى الحبيب الاستاذ جعفر ( @jjafferr ) بعد اذن استاذى الجليل و معلمى القدير وحتي تعم الفائدة أقتبس من الموضوع الأساسى بعض المقتطفات و التى هى الأساس : هناك 3 انواع من هذه القوائم : الثابته ، والمؤقته ، والمؤقته التي تحتاج الى كود. الثابته: وهي التي عندما نعملها ، تصبح مستقله عن الكود ، وتُحفظ وتبقى في قاعدة البيانات بعد إغلاقها ، ويمكننا ان نستوردها في قاعدة بيانات اخرى عندما نستورد احد/جميع كائنات قاعدة البيانات الآخرى ، بإستخدام : . ونختارها في النموذج : . او التقرير : هذا مثال لعمل الكود الاساس لعمل قائمة قطع/نسخ/لصق : ومن هنا يبدأ موضوعى المتواضع بإعادة هيكلة وبناء وتطوير وإضافة الاكواد حسب فهمى المتواضع وأفكارى البسيطة والضئيلة الشرح :اولا الاكواد فى الموديول :basCommandBarsConfiguration Option Compare Database Option Explicit ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Constants for button states and control types Public Const BUTTON_STATE_DOWN As Integer = -1 ' BUTTON_STATE_DOWN: Indicates that a button is in a pressed or activated state. ' This value is used to reflect the button's pressed status. Public Const BUTTON_STATE_UP As Integer = 0 ' BUTTON_STATE_UP: Indicates that a button is in its default, unpressed state. ' This value is used to reflect the button's normal, unpressed status. Public Const CONTROL_TYPE_BUTTON As Integer = 1 ' CONTROL_TYPE_BUTTON: Represents a button control type in a command bar or menu. ' Used to add buttons to a command bar or menu with various functionalities. Public Const CONTROL_TYPE_EDIT As Integer = 2 ' CONTROL_TYPE_EDIT: Represents an editable control type, such as a text box. ' Used to add an editable text field to a command bar or menu. Public Const CONTROL_TYPE_COMBOBOX As Integer = 4 ' CONTROL_TYPE_COMBOBOX: Represents a combo box control type in a command bar or menu. ' A combo box allows users to select from a list of predefined options or enter a custom value. Public Const CONTROL_TYPE_POPUP As Integer = 5 ' CONTROL_TYPE_POPUP: Represents a popup menu or sub-menu control type. ' Used to create a dropdown menu or context menu in a command bar. Public Const BAR_TYPE_POPUP As Integer = 5 ' BAR_TYPE_POPUP: Represents a popup menu bar type. ' Used to create a command bar that behaves as a popup menu (e.g., appears on right-click or when invoked). ' Variables for CommandBar and Controls Public commandBar As Object ' Represents the custom command bar (popup menu) object Public commandButton As Object ' Represents each button/control added to the command bar Public commandBarName As String ' Name of the custom command bar Public CtrlFilterPopup As Object ' Represents the popup control for text filters '================================================================================ ' Procedure : AddButtonToCommandBar ' Purpose : Adds a button to a command bar with specified properties. ' Parameters: ' - btn: The button object to be added to the command bar. ' - type: The type of control (button). ' - id: The ID of the button. ' - caption: The caption text for the button. ' - beginGroup (optional): Boolean to indicate if a separator should be added before the button. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to add a button to the command bar Private Sub AddButtonToCommandBar(ByRef controls As Object, _ ByVal controlType As Integer, _ ByVal faceId As Integer, _ ByVal caption As String, _ Optional ByVal beginGroup As Boolean = False) On Error Resume Next Set commandButton = controls.Add(controlType, faceId, , , False) If Not commandButton Is Nothing Then With commandButton .caption = caption .faceId = faceId .beginGroup = beginGroup End With End If On Error GoTo 0 End Sub '================================================================================ ' Procedure : AddFilterControls ' Purpose : Adds filter controls to the provided controls collection in a filter popup. ' Parameters: ' - controls: The controls collection to which the filter controls will be added. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to add filter controls to the filter popup Private Sub AddFilterControls(ByRef controls As Object) With controls .Add CONTROL_TYPE_BUTTON, 10077, , , False .Add CONTROL_TYPE_BUTTON, 10078, , , False .Add CONTROL_TYPE_BUTTON, 10079, , , False .Add CONTROL_TYPE_BUTTON, 12696, , , False .Add CONTROL_TYPE_BUTTON, 10080, , , False .Add CONTROL_TYPE_BUTTON, 10081, , , False .Add CONTROL_TYPE_BUTTON, 10082, , , False .Add CONTROL_TYPE_BUTTON, 10083, , , False .Add CONTROL_TYPE_BUTTON, 12697, , , False .Add CONTROL_TYPE_BUTTON, 10058, , , False .Add CONTROL_TYPE_BUTTON, 10069, , , False .Add CONTROL_TYPE_BUTTON, 10070, , , False End With End Sub '================================================================================ ' Procedure : ClipboardActionsSortFilterCommandBar ' Purpose : Creates and configures a custom command bar with ClipboardActions (cut, copy, paste), sort, and filter options. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to create and configure the copy, sort, and filter command bar Public Sub ClipboardActionsSortFilterCommandBar() On Error GoTo ErrorHandler ' Handle errors ' Define the name of the custom command bar commandBarName = "ClipboardActionsSortFilterCommandBar" ' Ensure this matches the name you are checking ' Delete the existing command bar with the same name, if any On Error Resume Next Set commandBar = CommandBars(commandBarName) If Not commandBar Is Nothing Then commandBar.Delete End If If Err.Number <> 0 Then Err.Clear ' Create a new command bar Set commandBar = CommandBars.Add(Name:=commandBarName, Position:=BAR_TYPE_POPUP, Temporary:=False) With commandBar ' Add buttons to the command bar Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 21, "Cut") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 19, "Copy") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 22, "Paste") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 210, "Sort Ascending", True) Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 211, "Sort Descending") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 640, "Filter By Selection", True) Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 3017, "Filter Excluding Selection") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 605, "Remove Filter/Sort") ' Add Filter For button with a popup menu Set CtrlFilterPopup = .controls.Add(Type:=CONTROL_TYPE_POPUP, Temporary:=False) If Not CtrlFilterPopup Is Nothing Then CtrlFilterPopup.caption = "Text Filters" ' Ensure CtrlFilterPopup is a CommandBarPopup If TypeName(CtrlFilterPopup) = "CommandBarPopup" Then ' Remove any existing controls For Each commandButton In CtrlFilterPopup.controls commandButton.Delete Next commandButton ' Add new controls to CtrlFilterPopup Call AddFilterControls(CtrlFilterPopup.controls) End If End If ' Add Close Form/Report button Set commandButton = .controls.Add(Type:=CONTROL_TYPE_BUTTON, ID:=923, Temporary:=False) If Not commandButton Is Nothing Then commandButton.beginGroup = True commandButton.caption = ChrW(1573) & ChrW(1594) & ChrW(1604) & ChrW(1575) & ChrW(1602) ' Close commandButton.OnAction = "CloseCurrentItem" ' Action to call the CloseCurrentItem subroutine End If End With ' Clean up Set commandBar = Nothing Set commandButton = Nothing Set CtrlFilterPopup = Nothing Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in cmb_Copy_Sort_Filter : " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : ClipboardActionsSortCommandBar ' Purpose : Creates and configures a custom command bar with ClipboardActions (cut, copy, paste), and sorting options. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to create and configure the custom command bar Public Sub ClipboardActionsSortCommandBar() On Error GoTo ErrorHandler ' Handle errors ' Define the name of the custom command bar commandBarName = "ClipboardActionsSortCommandBar" ' Name for the custom command bar ' Delete the existing command bar with the same name, if any On Error Resume Next Set commandBar = CommandBars(commandBarName) If Not commandBar Is Nothing Then commandBar.Delete End If If Err.Number <> 0 Then Err.Clear ' Add a new command bar (popup menu) with the specified name Set commandBar = CommandBars.Add(Name:=commandBarName, Position:=BAR_TYPE_POPUP, Temporary:=False) With commandBar ' Add buttons to the command bar using the new subroutine ' Add Cut button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 21, ChrW(1602) & ChrW(1589)) ' Add Copy button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 19, ChrW(1606) & ChrW(1587) & ChrW(1582)) ' Add Paste button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 22, ChrW(1604) & ChrW(1589) & ChrW(1602)) ' Add Sort Ascending button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 210, ChrW(1578) & ChrW(1585) & ChrW(1578) & ChrW(1610) & ChrW(1576) & ChrW(32) & ChrW(1578) & ChrW(1589) & ChrW(1575) & ChrW(1593) & ChrW(1583) & ChrW(1610), True) ' Add Sort Descending button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 211, ChrW(1578) & ChrW(1585) & ChrW(1578) & ChrW(1610) & ChrW(1576) & ChrW(32) & ChrW(1578) & ChrW(1606) & ChrW(1575) & ChrW(1586) & ChrW(1604) & ChrW(1610), True) ' Add Close Form/Report button Set commandButton = .controls.Add(Type:=CONTROL_TYPE_BUTTON, ID:=923, Temporary:=False) If Not commandButton Is Nothing Then commandButton.beginGroup = True commandButton.caption = ChrW(1573) & ChrW(1594) & ChrW(1604) & ChrW(1575) & ChrW(1602) ' Close commandButton.OnAction = "CloseCurrentItem" ' Action to call the CloseCurrentItem subroutine End If End With ' Clean up Set commandBar = Nothing Set commandButton = Nothing Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in cmb_CustomMenu : " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : ClipboardActionsCommandBar ' Purpose : Creates and configures a custom command bar with ClipboardActions (cut, copy, paste). '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to create and configure the copy command bar Public Sub ClipboardActionsCommandBar() On Error GoTo ErrorHandler ' Handle errors ' Define the name of the custom command bar commandBarName = "ClipboardActionsCommandBar" ' Delete the existing command bar with the same name, if any On Error Resume Next Set commandBar = CommandBars(commandBarName) If Not commandBar Is Nothing Then commandBar.Delete End If If Err.Number <> 0 Then Err.Clear ' Add a new command bar (popup menu) with the specified name Set commandBar = CommandBars.Add(Name:=commandBarName, Position:=BAR_TYPE_POPUP, Temporary:=False) With commandBar ' Add buttons to the command bar Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 21, ChrW(1602) & ChrW(1589)) ' Cut Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 19, ChrW(1606) & ChrW(1587) & ChrW(1582)) ' Copy Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 22, ChrW(1604) & ChrW(1589) & ChrW(1602)) ' Paste End With ' Clean up Set commandBar = Nothing Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in SCM_Copy : " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : ReportContextMenuCommandBar ' Purpose : Creates and configures a custom report command bar with various ' printing, setup, and export options for reports. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to create and configure the custom report command bar Public Sub ReportContextMenuCommandBar() On Error GoTo ErrorHandler ' Handle errors Dim exportSubMenu As Object ' New variable for sub-menu handling ' Define the command bar name commandBarName = "ReportContextMenuCommandBar" ' Delete the existing command bar with the same name, if any On Error Resume Next Set commandBar = CommandBars(commandBarName) If Not commandBar Is Nothing Then commandBar.Delete End If If Err.Number <> 0 Then Err.Clear ' Create the shortcut menu Set commandBar = CommandBars.Add(Name:=commandBarName, Position:=BAR_TYPE_POPUP, Temporary:=False) ' Ensure commandBar was created successfully If commandBar Is Nothing Then MsgBox "Failed to create command bar.", vbExclamation Exit Sub End If With commandBar.controls ' Add the Print command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=2521), CONTROL_TYPE_BUTTON, 2521, "Quick Print") ' Add the Select Pages command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=15948), CONTROL_TYPE_BUTTON, 15948, "Select Pages") ' Add the Page Setup command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=247), CONTROL_TYPE_BUTTON, 247, "Page Setup") ' Add the Email Report as an Attachment command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=2188), CONTROL_TYPE_BUTTON, 2188, "Email Report as an Attachment", True) ' Add the Save as PDF/XPS command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=12499), CONTROL_TYPE_BUTTON, 12499, "Save as PDF/XPS") ' Add Export to Word and Excel commands as sub-items of the PDF/XPS button If .Count >= 5 Then ' Add sub-menu for PDF/XPS button Set exportSubMenu = .Item(5).controls.Add(Type:=CONTROL_TYPE_POPUP, Temporary:=False) exportSubMenu.caption = "Export Options" ' Add Export to Word Set commandButton = exportSubMenu.controls.Add(Type:=CONTROL_TYPE_BUTTON, ID:=11725, Temporary:=False) If Not commandButton Is Nothing Then commandButton.caption = "Export to Word..." commandButton.faceId = 42 End If ' Add Export to Excel Set commandButton = exportSubMenu.controls.Add(Type:=CONTROL_TYPE_BUTTON, ID:=11723, Temporary:=False) If Not commandButton Is Nothing Then commandButton.caption = "Export to Excel…" commandButton.faceId = 263 End If End If ' Add the Close Report command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=923), CONTROL_TYPE_BUTTON, 923, "Close Report", True) End With ' Clean up Set commandBar = Nothing Set commandButton = Nothing Set exportSubMenu = Nothing Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in CreateReportShortcutMenu : " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : CloseCurrentItem ' Purpose : Closes the currently active form or report in the application. If no form ' or report is active, it displays a message to the user. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to close the currently active form or report Public Sub CloseCurrentItem() On Error GoTo ErrorHandler Dim obj As Object Dim activeItemName As String Dim isFormActive As Boolean Dim isReportActive As Boolean ' Check if an active form is open and close it isFormActive = False For Each obj In Forms If obj.Name = Screen.ActiveForm.Name Then activeItemName = obj.Name isFormActive = True Exit For End If Next obj If isFormActive Then DoCmd.Close acForm, activeItemName Exit Sub End If ' Check if an active report is open and close it isReportActive = False For Each obj In Reports If obj.Name = Screen.ActiveReport.Name Then activeItemName = obj.Name isReportActive = True Exit For End If Next obj If isReportActive Then DoCmd.Close acReport, activeItemName Exit Sub End If ' If no form or report is active, display a message MsgBox "There is no active form or report to close.", vbExclamation Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred: " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : DeleteAllCommandBars ' Purpose : Deletes all custom (non-built-in) command bars. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to Deletes all custom command bars. Public Sub DeleteAllCommandBars() On Error GoTo ErrorHandler ' Handle errors Dim i As Integer Dim cmdBar As Object Dim cmdBarsCount As Integer ' Get the count of command bars cmdBarsCount = CommandBars.Count ' Iterate through all command bars in reverse order For i = cmdBarsCount To 1 Step -1 On Error Resume Next ' Ignore errors if they occur during deletion Set cmdBar = CommandBars(i) If Not cmdBar Is Nothing Then ' Check if the command bar is not built-in or default If Not cmdBar.BuiltIn Then cmdBar.Delete Debug.Print "CommandBar '" & cmdBar.Name & "' has been deleted." End If End If On Error GoTo ErrorHandler ' Restore error handling Next i ' Clean up Set cmdBar = Nothing Exit Sub ErrorHandler: ' Display a more specific error message ' MsgBox "An error occurred while trying to delete command bars: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in DeleteAllCommandBars: " & Err.Number & " | " & Err.Description Resume Next End Sub الثوابت : BUTTON_STATE_DOWN: قيمة ثابتة تستخدم للإشارة إلى أن الزر في حالة ضغط أو تفعيل ويستخدم هذا لإظهار حالة الزر عند الضغط عليه BUTTON_STATE_UP: قيمة ثابتة تستخدم للإشارة إلى أن الزر في حالته الطبيعية أو غير المضغوط عليها يستخدم هذا لإظهار حالة الزر عند عدم الضغط عليه CONTROL_TYPE_BUTTON: قيمة ثابتة تستخدم لتمثيل نوع التحكم "زر" في شريط الأوامر : ( قائمة السياق ) CONTROL_TYPE_EDIT: قيمة ثابتة تستخدم لتمثيل نوع التحكم "محرر" مثل صندوق النص يستخدم لإضافة حقل نص قابل للتعديل في شريط الأوامر : ( قائمة السياق ) CONTROL_TYPE_COMBOBOX: قيمة ثابتة تستخدم لتمثيل نوع التحكم "قائمة منسدلة" القائمة المنسدلة تسمح للمستخدمين بالاختيار من قائمة محددة مسبقا أو إدخال قيمة مخصصة CONTROL_TYPE_POPUP: قيمة ثابتة تستخدم لتمثيل نوع التحكم "قائمة منبثقة" أو "قائمة فرعية" تُستخدم لإنشاء قائمة منسدلة أو قائمة سياقية في شريط الأوامر BAR_TYPE_POPUP: قيمة ثابتة تُستخدم لتمثيل نوع شريط الأوامر المنبثق. يُستخدم لإنشاء شريط أدوات يظهر عند النقر بالزر الأيمن أو عند استدعائه -------------- المتغيرات : commandBar: يمثل كائن شريط الأوامر المخصص (قائمة السياق) commandButton: يمثل كل زر/تحكم يتم إضافته إلى شريط الأوامر commandBarName: اسم شريط الأوامر المخصص CtrlFilterPopup: يمثل التحكم المنبثق للفلاتر النصية -------------- الدوال : دالة : AddButtonToCommandBar الغرض: إضافة زر إلى شريط الأوامر مع الخصائص المحددة المعلمات: controls: مجموعة التحكمات التي سيتم إضافة الزر إليها controlType: نوع التحكم (زر في هذه الحالة) faceId: معرف الأيقونة للزر caption: نص التسمية للزر beginGroup (اختياري): منطق لبدء مجموعة جديدة مع الزر، مما يضيف فاصلًا قبله -------------- دالة : AddFilterControls الغرض: إضافة عناصر التحكم بالفلاتر إلى مجموعة التحكمات المحددة في قائمة منبثقة للفلاتر المعلمات: controls: مجموعة التحكمات التي سيتم إضافة عناصر الفلاتر إليها -------------- دالة : ClipboardActionsSortFilterCommandBar الغرض: إنشاء وتكوين شريط أوامر مخصص يتضمن خيارات الحافظة (قص، نسخ، لصق)، والفرز، والفلاتر العملية: إنشاء شريط أوامر جديد ( قائمة السياق ) إضافة أزرار للقص، النسخ، اللصق، الفرز، والفلاتر إضافة قائمة منبثقة للفلاتر النصية إضافة زر لإغلاق النموذج/التقرير -------------- دالة : ClipboardActionsSortCommandBar الغرض: إنشاء وتكوين شريط أوامر جديد ( قائمة السياق ) يتضمن خيارات الحافظة (قص، نسخ، لصق), والفرز العملية: إنشاء شريط أوامر جديد إضافة أزرار للقص، النسخ، اللصق، والفرز إضافة زر لإغلاق النموذج/التقرير -------------- دالة : ClipboardActionsCommandBar الغرض: إنشاء وتكوين شريط أوامر مخصص يتضمن خيارات الحافظة (قص، نسخ، لصق) العملية: إنشاء شريط أوامر جديد إضافة أزرار للقص، النسخ، واللصق -------------- دالة : ReportContextMenuCommandBar الغرض: إنشاء وتكوين شريط أوامر مخصص لقائمة السياق الخاصة بالتقرير، يتضمن خيارات الطباعة، الإعداد، والتصدير العملية: إنشاء شريط أوامر جديد إضافة أزرار لطباعة، اختيار الصفحات، إعداد الصفحة، إرسال التقرير بالبريد الإلكتروني كمرفق، حفظ كـ PDF/XPS إضافة خيارات تصدير إلى Word و Excel كعناصر فرعية لزر PDF/XPS إضافة زر لإغلاق التقرير -------------- دالة : CloseCurrentItem الغرض: إغلاق النموذج أو التقرير النشط حاليا في التطبيق العملية: التحقق مما إذا كان هناك نموذج نشط وإغلاقه التقق مما إذا كان هناك تقرير نشط وإغلاقه -------------- دالة : DeleteAllCommandBars الغرض: حذف جميع أشرطة الأوامر المخصصة (غير المدمجة) في التطبيق العملية: الحصول على عدد أشرطة الأوامر: يتم الحصول على عدد أشرطة الأوامر الحالية باستخدام CommandBars.Count التكرار من آخر شريط أوامر إلى أول شريط أوامر (من النهاية إلى البداية) لضمان عدم حدوث أخطاء أثناء الحذف حذف أشرطة الأوامر: إذا لم يكن الشريط مدمجًا (أي أنه شريط مخصص) يتم حذف الشريط -------------- واخيرا استدعاء الدالة عند تحميل النموذج أو التقرير: استدعاء دالة: Call RoutineNameCustomCommandBar يتم استدعاء دالة مع تغيير RoutineNameCustomCommandBar باسم الدالة الخاصة بإنشاء وتكوين شريط الأوامر المخصص حيث تقوم بإنشاء أو تعديل شريط الأوامر (CommandBar) الخاص بالنموذج أو التقرير تعيين خاصية ShortcutMenuBar: Me.ShortcutMenuBar = RoutineNameCustomCommandBar يتم تعيين خاصية ShortcutMenuBar للنموذج أو التقرير إلى اسم شريط الأوامر الذي تم إنشاؤه أو تعديله أثناء استدعاء الدالة المخصصة بهذه الطريقة يتم ربط شريط الأوامر المخصص بقائمة الاختصارات (shortcut menu) للنموذج أو التقرير الحالي ارقام جميع الصور الموجودة في الاكسس والتى نستخدمها كمعلمة فى faceId معرف الأيقونة للزر المصادر: الموضوع الاساسى فى هذا المنتدى لأستاذى القدير و معلمى الجليل و والدى الحبيب الاستاذ جعفر https://www.officena.net/ib/topic/99557-القائمة-المختصرة-shortcut-menu/#comment-603366 http://dev-soln.com/access-shortcut-right-click-tool/ https://www.experts-exchange.com/articles/12904/Understanding-and-using-CommandBars-Part-II-Creating-your-own.html https://filedb.experts-exchange.com/incoming/2014/02_w06/833359/CommandBars-II.mdb https://www.experts-exchange.com/articles/18341/CommandBars-Part-III-Using-Built-in-Shortcut-Menus.html http://www.skrol29.com/us/vtools.php CommandBarsConfiguration.accdb

السلام عليكم ورحمة الله تعالى وبركاته اخوانى الكرام اساتذتى الاعزاء الموضوع ده بصراحة كان تحدى بينى وبين نفسي تعبت جدا فكرة الموضوع التقليدية هى التعامل بالارقام واسماء العناصر وكتابة الكثير والكثير من الاكواد والزحمة والحسابات و و وبلا بلا بلا بلا... وفى النهاية يبقى التعديل على العمل بالاضافة او التعديل شئ صعب جدا جدا جدا الا انه بفضل الله اقدم اليكم الفكرة الاتية للتجربة اعتمدت فى المقام الاول على ان تكون الاكواد ثابته بحيث يسهل استخدام الفكرة والطريقة ونقلها لاى قاعدة ولكن عجزت عن تحقيق كل شئ برمجيا وتوقفت وعجزت امام نقطة واحدة ووحيدة ولكن تم التغلب بالفهلوة على المشكلة اترك لكم التجربة وباب النقاش مفتوح بعد ذلك ومن يدرى فد اجد حل للمشكلة التى عجزت امامها معكم وعندكم تعديل جديد بتاريخ 31/05/2024 تم تحديث الموضوع باضافة الاصدار الثانى الذى يعتمد كليا على الوحدات النمطية تم حل جميع المشاكل والعقبات برمجيا والتى واجهتنى بالاصدار الاول على الرغم من انه قد تم التغلب عليها وقتها ولكن بحلول غير برمجية الإصدار الأول : expand and collapse button .accdb الإصدار الثاني (المحسن) : expand and collapse button V2.zip

تحويل الوقت والتاريخ المحلى الي التوقيت عن التوقيت العالمي الموحد (UTC) عرض تاريخ و اوقات دول او مدن مختلفة في نفس الوقت بناء على فرق الوقت بينعم ولين التوقيت العالمي الموحد جدول tblTimeZones والذى يتكون من الحقول ShowInForm : اختيار البلدان للعرض في النموذج CountryName : اسماء المدن و البلدان TimeDifference : فرق التوقيت عن التوقيت العالمي الموحد (UTC) الفارق الزمني (بالساعات، مع إشارة "+" أو "-") DaylightSavingTime : التوقيت الصيفي اولا اكواد الوحدة النمطية Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetSystemTimeAPI Lib "kernel32" Alias "GetSystemTime" (lpSystemTime As SYSTEMTIME) As Long #Else Private Declare Function GetSystemTimeAPI Lib "kernel32" Alias "GetSystemTime" (lpSystemTime As SYSTEMTIME) As Long #End If Private Type SYSTEMTIME ' Structure for SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Public Function GetUTC() As Date ' Function to get the current UTC time Dim utctime As Date Dim sysTime As SYSTEMTIME Call GetSystemTime(sysTime) utctime = DateSerial(sysTime.wYear, sysTime.wMonth, sysTime.wDay) + TimeSerial(sysTime.wHour, sysTime.wMinute, sysTime.wSecond) GetUTC = utctime End Function Private Function GetSystemTime(lpSystemTime As SYSTEMTIME) As Long ' Declaration to get system time GetSystemTime = GetSystemTimeAPI(lpSystemTime) End Function هذه الدوال توفر الحصول على الوقت الحالي بالتوقيت العالمي (UTC) SYSTEMTIME هو هيكل يستخدم لتخزين التاريخ والوقت GetSystemTimeAPI هى احد دوال API لـ Windows وظيفتها الحصول على الوقت العالمي (UTC) GetUTC هى دالة تستدعي الدالة GetSystemTimeAPI للحصول على الوقت الحالي بالتوقيت العالمي (UTC) ويتم اعادته كقيمة تاريخ/وقت طيب بعد ذلك الاكواد داخل النموذج النموذج يعرض توقيتات متعددة لدول مختلفة بناء على الاعدادات الموجودة في الجدول tblTimeZone Const FormatDisplayDate As String = "dd/mm/yyyy" Const FormatDisplayTime As String = "hh:mm:ss AM/PM" Const CountDisplayCountry As Integer = 5 Private Sub Form_Load() ' Set the form's timer interval to update every 1 second Me.TimerInterval = 1000 ' Call the function to update times and dates UpdateTimes End Sub Private Sub Form_Timer() ' Call the function to update times and dates when the timer event occurs UpdateTimes End Sub Private Sub UpdateTimes() On Error GoTo ErrorHandler Dim rs As DAO.Recordset Dim utctime As Date Dim i As Integer ' Get the current UTC time utctime = GetUTC() ' Debug.Print "UTC Time: "; utctime ' Open the recordset to fetch data from the tblTimeZones table Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblTimeZones WHERE ShowInForm = True") ' Check if recordset is not empty If Not rs.EOF Then rs.MoveFirst i = 1 ' Loop through each record in the recordset and update the form fields Do While Not rs.EOF And i <= CountDisplayCountry ' Limiting to 5 fields as per your requirement ' Assign values to form fields for each country If FieldExists("txtCountry" & i) Then Me("txtCountry" & i) = rs!CountryName Me("txtTimeDifference" & i) = rs!TimeDifference Me("chkDaylightSavingTime" & i) = rs!DaylightSavingTime ' Adjust time and date based on daylight saving time Dim localTime As Date If rs!DaylightSavingTime Then localTime = DateAdd("h", rs!TimeDifference + 1, utctime) Else localTime = DateAdd("h", rs!TimeDifference, utctime) End If Me("txtTime" & i) = Format(localTime, FormatDisplayTime) Me("txtDate" & i) = Format(localTime, FormatDisplayDate) End If rs.MoveNext i = i + 1 Loop Else ' Display a message if no records found for countries to display 'MsgBox "No countries found to display in the form.", vbExclamation, "No Records" Exit Sub End If ' Close the recordset rs.Close Set rs = Nothing Exit Sub ExitHandler: Exit Sub ErrorHandler: Select Case Err.Number Case 2465 ' Can't find the Object Resume ExitHandler Case Else MsgBox "Error in UpdateTimes: " & Err.Number & vbCrLf & Err.Description, vbExclamation 'Debug.Print Err.Number & " " & Err.Description Resume ExitHandler End Select End Sub Private Function FieldExists(fieldName As String) As Boolean ' Check if a field exists in the form On Error Resume Next FieldExists = (Me(fieldName).Name <> "") On Error GoTo 0 End Function الاعلان عن الثوابت Const FormatDisplayDate : للتحكم فى شكل تسيق التاريخ الذى سوف يتم عرضه Const FormatDisplayTime : للتحكم فى شكل تسيق الوقت الذى سوف يتم عرضه Const CountDisplayCountry : تحديد عدد الدول التى نريد عرض اوقاتها فى النموذج والذى على اساسة ايضا عدد العناصر فى النموذج لهذه البيانات Form_Load: عند تحميل النموذج، يتم تعيين الفاصل الزمني للمؤقت إلى ثانية واحدة ثم يتم استدعاء الدالة UpdateTimes Form_Timer: يتم استدعاء الدالة UpdateTimes كل ثانية لتحديث التوقيتات UpdateTimes وظيفة هذه الدالة هي الحصول على الوقت الحالي بالتوقيت العالمي (UTC) باستخدام الدالة GetUTC فتح مجموعة السجلات من الجدول tblTimeZones لجلب البيانات بناؤ على شرط أن يكون الحقل ShowInForm مضبوطًا على True في حلقة تكرارية يتم تحديث البيانات في العناصر في النموذج بناء على بيانات السجلات مع الأخذ بعين الاعتبار التوقيت الصيفي إذا كان مفعلاً يتم التعامل مع الأخطاء باستخدام كتلة ErrorHandler لضمان عدم تعطل البرنامج بسبب الأخطاء FieldExists: دالة للتحقق مما إذا كان عنصر معين موجودا في النموذج جدول tblTimeZones يحتوي على بيانات عن بلدان مختلفة بما في ذلك فرق التوقيت والتوقيت الصيفي وما إذا كانت البيانات يجب عرضها حيث يتم عرض البلدان المحددة فقط من خلال (ShowInForm = True) في النموذج العناصر فى النموذج كالاتى txtCountry1, txtCountry2, txtCountry3, txtCountry4, txtCountry5 المفروض يتم جلب اسماء البلدان من الجدول هنا ----------------------------------- txtTime1, txtTime2, txtTime3, txtTime4, txtTime5 المفروض يتم عرض التوقيت المحلى لكل بلد هنا ----------------------------------- txtTimeDifference1, txtTimeDifference2, txtTimeDifference3, txtTimeDifference4, txtTimeDifference5 المفروض يتم جلب الفرق في التوقيت لكل بلد هنا ----------------------------------- chkDaylightSavingTime1, chkDaylightSavingTime2, chkDaylightSavingTime3, chkDaylightSavingTime4, chkDaylightSavingTime5 المفروض يتم عرض ان كان التوقيت الصيفي مفعلا ام لا هنا ----------------------------------- txtDate1, txtDate2, txtDate3, txtDate4, txtDate5 المفروض يتم عرض التاريخ طبقا للتوقيت المحلى لكل بلد هنا ----------------------------------- المفروض كل ذلك يحدث من خلال الكود بمجرد فتح النموذج بطريقة الية والشرط طبعا هو جلب البيانات بناء على البلدان المختارة عرض بيناتها من خلال اختيارها من الحقل ShowInForm واخيرا المرفقات المرفق الاول وهو الاساس والذى تم استعراض الافكار والاكواد السابقة طبقا له المرفق الثانى فقط تم اضافة عدد نماذج لساعات على ان تكون نماذج فرعية TimeZones.zip TimeZones UP 2.zip

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

السلام عليكم ورحمة الله وبركاته الموضوع ترفيهي نوعا ما : حنين الى الماضي بصراحة كنت احب هذه اللعبة جدا جدا جدا وانا صغير راودتني فكرة تصميم اللعبة من خلال الاكسس وهذه تجربتي اتمني ان تنال رضاكم PuzzleGame.zip

السلام عليكم ورحمة الله تعالى وبركاته بعد مواجهتى لمشكلة فى هذه النقطة عند التعامل مع ملفات الاكسل بسبب اختلاف النسخ والتنسيق لملفات الاكسل تبعا لاختلاف الاصدارات كانت هذه نتيجة وخلاصة افكاارى لحل مشاكلى اليكم الخطوات 1- انشاء وحدة نمطية عامة ليسهل استدعاء الدوال منها فى شتى زوايا التطبيق واعطائها الاسم التالى basFileUtilityKit بها هذه الكود Option Compare Database Option Explicit ' Enumeration for the types of file dialogs Enum EnumFileDialogType msoFileDialogFilePicker = 1 msoFileDialogFolderPicker = 4 End Enum ' Enumeration for different file extensions Enum EnumFileExtensions AccessFiles ExcelFiles WordFiles PDFFiles TextFiles ImageFiles VideoFiles AudioFiles AllFiles ' You can add additional file extensions as needed here End Enum ' Enumeration for different options related to file paths Enum EnumOptionFile DirectoryWithoutFileName DirectoryWithFileName FileNameWithExtension FileNameWithoutExtension ExtensionOnly End Enum ' Function to open the folder dialog and return the selected folder path Function GetFolderDialog() As String On Error Resume Next Dim folderDialogObject As Object Set folderDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFolderPicker) With folderDialogObject .Title = "Select Folder" .AllowMultiSelect = False .Show End With If folderDialogObject.SelectedItems.Count > 0 Then GetFolderDialog = folderDialogObject.SelectedItems(1) Else ' Handle the case where no folder is selected MsgBox "No folder selected.", vbExclamation GetFolderDialog = "" End If Set folderDialogObject = Nothing On Error GoTo 0 End Function ' Function to open the file dialog and return the selected file path Function GetFileDialog(ByVal EnumFileExtension As EnumFileExtensions) As String On Error Resume Next ' Check if the Microsoft Office Object Library is referenced ' Make sure to go to Tools > References and select the appropriate version ' e.g., "Microsoft Office 16.0 Object Library" for Office 2016 Dim fileDialogObject As Object Set fileDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFilePicker) With fileDialogObject .Title = "Select File" .AllowMultiSelect = False .Filters.Clear ' Adding filters based on the selected file extension Select Case EnumFileExtension Case EnumFileExtensions.AllFiles .Filters.Add "All Files", "*.*" Case EnumFileExtensions.TextFiles .Filters.Add "Text Files", "*.txt" Case EnumFileExtensions.ExcelFiles .Filters.Add "Excel Files", "*.xlsx; *.xls" Case EnumFileExtensions.ImageFiles .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.gif" Case EnumFileExtensions.VideoFiles .Filters.Add "Video Files", "*.mp4; *.avi; *.mov" Case EnumFileExtensions.AudioFiles .Filters.Add "Audio Files", "*.mp3; *.wav; *.ogg" Case EnumFileExtensions.PDFFiles .Filters.Add "PDF Files", "*.pdf" Case EnumFileExtensions.WordFiles .Filters.Add "Word Files", "*.docx; *.doc" Case EnumFileExtensions.AccessFiles .Filters.Add "Word Files", "*.accda , *.accdb,*.accdc , *.accde,*.accdr , *.accdt,*.accdw , *.mda,*.mdb , *.mde,*.mdf , *.mdw" ' You can add additional file extensions as needed here End Select .Show End With If fileDialogObject.SelectedItems.Count > 0 Then GetFileDialog = fileDialogObject.SelectedItems(1) Else ' Handle the case where no file is selected MsgBox "No file selected.", vbExclamation GetFileDialog = "" End If Set fileDialogObject = Nothing Exit Function If Err.Number <> 0 Then Select Case Err.Number Case 3078: Resume Next ' Ignore error if user cancels the file dialog Case 0: Resume Next Case Else ' Call ErrorLog(Err.Number, Error$, strProcessName) End Select ' Clear the error Err.Clear End If End Function ' Function to get the desired option for a file path Function GetFileOption(ByRef strFilePath As String, Optional ByRef EnumOptionFile As EnumOptionFile = DirectoryWithFileName) As String On Error Resume Next Select Case EnumOptionFile Case DirectoryWithoutFileName GetFileOption = Left(strFilePath, InStrRev(strFilePath, "\")) Case DirectoryWithFileName GetFileOption = strFilePath Case FileNameWithExtension GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1) Case ExtensionOnly GetFileOption = Right(strFilePath, Len(strFilePath) - InStrRev(strFilePath, ".")) Case FileNameWithoutExtension GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1, InStrRev(strFilePath, ".") - InStrRev(strFilePath, "\") - 1) End Select On Error GoTo 0 End Function ' Function to get additional information about a file Function GetFileInfo(filePath As String) As String On Error Resume Next Dim fileInfo As String fileInfo = "File Information:" & vbCrLf fileInfo = fileInfo & "Path: " & filePath & vbCrLf fileInfo = fileInfo & "Size: " & FileLen(filePath) & " bytes" & vbCrLf fileInfo = fileInfo & "Created: " & FileDateTime(filePath) & vbCrLf GetFileInfo = fileInfo On Error GoTo 0 End Function شرح الوظائف فى هذه الوحدة النمطية Enumerations توفر طريقة لتعريف مجموعة من الثوابت التي يمكن استخدامها لتحديد أنواع معينة من القيم. EnumFileDialogType هذه الـ Enumeration تستخدم لتحديد نوع مربع الحوار الخاص بالملفات: msoFileDialogFilePicker: لفتح مربع حوار لاختيار الملفات. msoFileDialogFolderPicker: لفتح مربع حوار لاختيار المجلدات. EnumFileExtensions هذه الـ Enumeration تستخدم لتحديد نوع الامتدادات التي يمكن اختيارها من مربع حوار الملفات: AllFiles: جميع الملفات. TextFiles: ملفات النصوص. ExcelFiles: ملفات إكسل. ImageFiles: ملفات الصور. VideoFiles: ملفات الفيديو. AudioFiles: ملفات الصوت. PDFFiles: ملفات PDF. WordFiles: ملفات وورد. EnumOptionFile هذه الـ Enumeration تستخدم لتحديد الخيارات المختلفة المتعلقة بالمسارات: DirectoryWithoutFileName: المسار بدون اسم الملف. DirectoryWithFileName: المسار مع اسم الملف. FileNameWithExtension: اسم الملف مع الامتداد. FileNameWithoutExtension: اسم الملف بدون الامتداد. ExtensionOnly: الامتداد فقط. Functions GetFolderDialog هذه الدالة تفتح مربع حوار لاختيار المجلدات وتعيد المسار الكامل للمجلد الذي تم اختياره. إذا لم يتم اختيار أي مجلد، تعرض رسالة تنبيه وتعيد قيمة فارغة. GetFileDialog هذه الدالة تفتح مربع حوار لاختيار الملفات وتعيد المسار الكامل للملف الذي تم اختياره. يمكنك تحديد نوع الملفات المسموح باختيارها عبر الـ EnumFileExtensions. إذا لم يتم اختيار أي ملف، تعرض رسالة تنبيه وتعيد قيمة فارغة. GetFileOption هذه الدالة تستخدم لتحديد أجزاء معينة من مسار الملف بناءً على القيمة المحددة في الـ EnumOptionFile: DirectoryWithoutFileName: يعيد المسار بدون اسم الملف. DirectoryWithFileName: يعيد المسار مع اسم الملف. FileNameWithExtension: يعيد اسم الملف مع الامتداد. FileNameWithoutExtension: يعيد اسم الملف بدون الامتداد. ExtensionOnly: يعيد الامتداد فقط GetFileInfo هذه الدالة تعيد معلومات حول ملف محدد، بما في ذلك المسار، الحجم، وتاريخ الإنشاء. تعرض هذه المعلومات كجزء من نص مرتجع. ------------------------ 2- انشاء وحدة نمطية عامة ليسهل استدعاء الدوال منها فى شتى زوايا التطبيق واعطائها الاسم التالى basExcelDataImport بها هذه الكود Public Const strTableExcel As String = "tblImportExcel" Function ExcelDataImport(ByRef excelFilePath As String) On Error Resume Next ' Disable error handling temporarily Const xlOpenXMLWorkbook As Long = 51 ' Variables for Excel and Access Dim excelApp As Object Dim excelWorkbook As Object Dim excelOpened As Boolean Dim sourceFileName As String Dim mainDirectory As String Dim convertedExcelFilePath As String ' Check if the Excel file path is provided If Nz(excelFilePath, "") = "" Then Exit Function ' Check if the Excel file exists If Dir(excelFilePath) = "" Then Exit Function ' Extract file information sourceFileName = GetFileOption(excelFilePath, FileNameWithExtension) mainDirectory = GetFileOption(excelFilePath, DirectoryWithoutFileName) convertedExcelFilePath = excelFilePath ' Create Excel application object Set excelApp = CreateObject("Excel.Application") ' Check if Excel application is successfully created If Err.Number <> 0 Then Err.Clear Set excelApp = CreateObject("Excel.Application") excelOpened = False Else excelOpened = True End If ' Reset error handling On Error GoTo 0 ' Set Excel application visibility excelApp.Visible = False ' Open Excel workbook Set excelWorkbook = excelApp.Workbooks.Open(mainDirectory & sourceFileName) ' Save the workbook in xlsx format without displaying alerts excelApp.DisplayAlerts = False excelWorkbook.SaveAs Replace(mainDirectory & sourceFileName, ".xls", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False excelApp.DisplayAlerts = True ' Close the workbook without saving changes excelWorkbook.Close False ' Quit Excel application if it was opened by the function If excelOpened = True Then excelApp.Quit ' Update the source file name with the new extension sourceFileName = sourceFileName & "x" ' Reset file attributes SetAttr mainDirectory & sourceFileName, vbNormal ' Import Excel data into Access table DoCmd.SetWarnings False 'acSpreadsheetTypeExcel8 DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, strTableExcel, mainDirectory & sourceFileName, True ExitFunction: ' Enable system alerts before exiting the function DoCmd.SetWarnings True Exit Function ErrorHandler: ' Handle errors Select Case Err.Number Case 3078: Resume Next ' Ignore error if user cancels the file dialog Case 0: Resume Next Case Else ' Call ErrorLog(Err.Number, Error$, strProcessName) End Select End Function ' Function to delete all records from the specified table Sub DeleteAllRecords(Optional ByRef strTable As String = "") On Error Resume Next If Nz(strTable, "") = "" Then strTable = strTableExcel CurrentDb.Execute "DELETE FROM " & strTable ' Handle errors Select Case Err.Number Case 3078 If strTable = strTableExcel Then Resume Next Else Case Else ' HandleAndLogError strProcessName End Select End Sub شرح الوظائف فى هذه الوحدة النمطية الدالة ExcelDataImport تستورد بيانات من ملف Excel إلى جدول في قاعدة بيانات Access. strTableExcel: ثابت يحدد اسم الجدول في قاعدة بيانات Access الذي سيتم استيراد بيانات Excel إليه. excelFilePath: مسار ملف Excel الذي سيتم استيراد البيانات منه. ------------------------ 3- انشاء نموذج وفى الحدث عند النقر على زر الامر استخدم الكود التالى Private Sub cmdSubmit_Click() ' Get the path of the Excel file Dim strFilePath As String strFilePath = GetFileDialog(EnumFileExtensions.ExcelFiles) ' Check if a file was selected If strFilePath <> "Cancelled" Then ' Show status label Me!lblStatus.Visible = True Me!lblStatus.Caption = "Please wait ... " ' Clear TableData DeleteAllRecords ' Import data from Excel ExcelDataImport strFilePath ' Add Or Update Yor Table ' Hide the status label or reset any visual indicator Me!lblStatus.Visible = False Else ' User canceled the file selection MsgBox "File selection canceled", vbExclamation End If End Sub الان يتبقى عمل الاستعلام اللازم لاضاقة او تحديث وتعديل بياناتك طبقا لجدول الاكسس حسب رغباتك وتطلعاتك واخيرا مرفق قاعدة البيانات ImportFromExel.accdb

السلام عليكم ورحمة الله تعالى وبركاته عندما نتحدث عن توسيط النماذج والتقارير لابد من الأخذ فى الاعتبار ان خاصية PopUp لها تأثير كبير فإن كانت PopUp = True لها أكواد تقوم بعمل التوسيط للنماذج والتقارير داخل الشاشة خاصة ولا تقوم بعملها ان كانت PopUp = False والعكس كذلك واحيانا ننسى ذكر هذا الأمر عند عرض الاكواد والامثلة ولذلك تعمل عند البعض ولا تعمل عند اخرين بل واحيانا اثناء التصميم ننسى هذا الامر ايضا ومن أجل ذلك بعد البحث المرير وترتيب الأفكار بفضل الله تعالى تم دمج الأكواد حتى تعمل تبعا للخاصية PopUp ايما كان اعدادها حتى وان نسى المستخدم ذلك الامر أوحتى إن كان لا يدرى عنه شئ المرفق الاتى ان شاء الله به حل المشكلة تماما طيب ما الفرق بين عمل الاكواد مع خاصية PopUp ان كانت PopUp = True يتم توسيط داخل الشاشة نفسها تبعا لابعاد شاشة العرض نفسها مهما اختلف مقاس الشاشة اما ان كان PopUp = False يتم التوسيط داخل اطار تطبيق الاكس نفسه الاكواد كالاتى اولا كلاس ولابد ان يكون اسم الكلاس clsAutoCenter وان احببتم تغيير الاسم فيجب تعديله فى الاكواد التى تخص الموديول بنفس الاسم الجديد اولا الكلاس : clsAutoCenter '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT 'RECT structure used for API calls. Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI 'POINTAPI structure used for API calls. X As Long Y As Long End Type Private m_hWnd As Long 'Handle of the window. Private m_rctWindow As RECT 'Rectangle describing the sides of the last polled location of the window. Private Const m_ERR_INVALIDHWND = 1 Private Const m_ERR_NOPARENTWINDOW = 2 #If VBA7 Then Private Declare PtrSafe Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As LongPtr) As Long Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As LongPtr, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWndPtr As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare PtrSafe Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare PtrSafe Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As LongPtr) As Long 'Returns the handle of the parent window of the specified window. #Else Private Declare Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long Private Declare Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As Long) As Long 'Returns the handle of the parent window of the specified window. #End If Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String) 'Raises a user-defined error to the calling procedure. Err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc End Sub Private Sub UpdateWindowRect() 'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow. Dim ptCorner As POINTAPI If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then apiGetWindowRect m_hWnd, m_rctWindow 'm_rctWindow now holds window coordinates in screen coordinates. If Not Me.Parent Is Nothing Then 'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Left .Y = m_rctWindow.Top End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Left = ptCorner.X .Top = ptCorner.Y End With 'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Right .Y = m_rctWindow.Bottom End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Right = ptCorner.X .Bottom = ptCorner.Y End With End If Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Sub Public Property Get hWnd() As Long 'Returns the value the user has specified for the window's handle. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then hWnd = m_hWnd Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let hWnd(ByVal lngNewValue As Long) 'Sets the window to use by specifying its handle. 'Only accepts valid window handles. If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then m_hWnd = lngNewValue Else RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle." End If End Property Public Property Get Left() As Long 'Returns the current position (in pixels) of the left edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Left = m_rctWindow.Left Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Left(ByVal lngNewValue As Long) 'Moves the window such that its left edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Top() As Long 'Returns the current position (in pixels) of the top edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Top = m_rctWindow.Top Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Top(ByVal lngNewValue As Long) 'Moves the window such that its top edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Width() As Long 'Returns the current width (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Width = .Right - .Left End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Width(ByVal lngNewValue As Long) 'Changes the width of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Height() As Long 'Returns the current height (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Height = .Bottom - .Top End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Height(ByVal lngNewValue As Long) 'Changes the height of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Get Parent() As clsAutoCenter 'Returns the parent window as a clFormWindow object. 'For forms, this should be the Access MDI window. Dim fwParent As New clsAutoCenter Dim lngHWnd As Long If m_hWnd = 0 Then Set Parent = Nothing ElseIf apiIsWindow(m_hWnd) Then lngHWnd = apiGetParent(m_hWnd) fwParent.hWnd = lngHWnd Set Parent = fwParent Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If Set fwParent = Nothing End Property ثانيا الموديول ولن يفرق اسم الموديول فى شئ '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT X1 As Long Y1 As Long X2 As Long Y2 As Long End Type #If VBA7 Then Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long #Else Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Boolean Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long #End If Private Const WU_LOGPIXELSX = 88 Private Const WU_LOGPIXELSY = 90 ' Call CenterForm(Me) ' Call CenterReport(Me) Sub CenterForm(F As Form) If F.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = F.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf F.PopUp = True Then Dim formWidth As Long, formHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 formAllMarginsHeight = F.WindowHeight - F.Section(acDetail).Height formAllMarginsWidth = F.Width formWidth = formAllMarginsWidth formHeight = formAllMarginsHeight If formHeight < F.WindowHeight Then formHeight = F.WindowHeight End If DoCmd.MoveSize (ScreenWidth - formWidth) / 2, (ScreenHeight - formHeight) / 2, formWidth, formHeight End If End Sub Sub CenterReport(R As Report) If R.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = R.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf R.PopUp = True Then Dim ReportWidth As Long, ReportHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim ReportAllMarginsHeight As Long, ReportAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 ReportAllMarginsHeight = R.WindowHeight - R.Section(acDetail).Height ReportAllMarginsWidth = R.Width ReportWidth = ReportAllMarginsWidth ReportHeight = ReportAllMarginsHeight If ReportHeight < R.WindowHeight Then ReportHeight = R.WindowHeight End If DoCmd.MoveSize (ScreenWidth - ReportWidth) / 2, (ScreenHeight - ReportHeight) / 2, ReportWidth, ReportHeight End If End Sub Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch End Function Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch End Function Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long) Dim R As RECT Dim RetVal As Long #If VBA7 Then Dim hWnd As LongPtr #Else Dim hWnd As Long #End If hWnd = GetDesktopWindow() RetVal = GetWindowRect(hWnd, R) Width = R.X2 - R.X1 Height = R.Y2 - R.Y1 End Sub ويتم استدعاء كود توسيط النماذج من خلال السطر الاتى فى حدث عند الفتح Call CenterForm(Me) ويتم استدعاء كود توسيط التقارير من خلال السطر الاتى فى حدث عند الفتح Call CenterReport(Me) فى حالة كانت PopUp = True يتم توسيط النماذج والتقارير فى وسط شاشة الحاسب الالى تمام تبعا لابعاد الشاشة اما فى حالة PopUp = False يتم توسيط النماذج والتقارير فى داخل اطار برنامج الاكسس نفسه والان اليكم المرفق بالمثال العملى AutoCentre.mdb

السلام عليكم ورحمة الله تعالى وبركاته انا بصدد تصميم قاعدة بيانات فى عملى وتباعا ان شاء الله اضع بين اياديكم خلاصة مجهود وتعليم سنوات اولا تسجيل الاخطاء ومعالجتها اولا موديول باسم : basErrorHandling Public strProcessName As String ' The name of the table where errors are logged Public Const TABLE_ERROR_LOG_NAME As String = "tblErrorLog" ' Subroutine to log errors in the error log table Sub ErrorLog(ByVal intErrorNumber As Integer, ByVal strErrorDescription As String, ByVal strErrorProcessName As String) On Error GoTo Err_ErrorLog Dim strErrorMsg As String strErrorMsg = "Error " & intErrorNumber & ": " & strErrorDescription ' Show a message to the user MsgBox strErrorMsg, vbQuestion, strErrorProcessName ' Log error details in the error log table With CurrentDb.OpenRecordset(TABLE_ERROR_LOG_NAME) .AddNew ![ErrorNumber] = intErrorNumber ![ErrorDescription] = Left$(strErrorDescription, 255) ![ErrorProcessName] = strErrorProcessName ![ErrorDate] = Now() ![userName] = GetLoggedUserName() .Update .Close End With Exit_ErrorLog: Exit Sub Err_ErrorLog: ' Error message in case of an unexpected issue strErrorMsg = "An unexpected situation arose in your program." & vbNewLine strErrorMsg = strErrorMsg & "Please write down the following details:" & vbNewLine & vbNewLine strErrorMsg = strErrorMsg & "Calling Proc: " & strErrorProcessName & vbNewLine strErrorMsg = strErrorMsg & "Error Number " & intErrorNumber & vbNewLine & strErrorDescription & vbNewLine & vbNewLine strErrorMsg = strErrorMsg & "Unable to record because Error " & Err.Number & vbNewLine & Err.Description & vbNewLine strErrorMsg = strErrorMsg & "Occurred at Line: " & Erl MsgBox strErrorMsg, vbCritical, "ErrorLog()" Resume Exit_ErrorLog End Sub ' Subroutine to handle and log errors ' This subroutine checks for errors and logs them using the ErrorLog function. ' It clears the error after logging it. ' Parameters: ' - strProcName: The name of the procedure where the error occurred. Public Sub HandleAndLogError(ByVal strProcName As String) ' Check for errors If Err.Number <> 0 Then ' Handle the error and log it Call ErrorLog(Err.Number, Err.Description, strProcName) ' Clear the error Err.Clear End If End Sub ' Function to get the logged username, or return "N/A" if not available Function GetLoggedUserName() As String On Error Resume Next Dim userName As String userName = Environ("USERNAME") If Err.Number <> 0 Then userName = "N/A" Err.Clear End If On Error GoTo 0 GetLoggedUserName = userName End Function ---------------------------------------------------------------------- ثانيا مويدول باسم : basInitialization ' The name of the table where errors are logged Public Const TABLE_ERROR_LOG_NAME As String = "tblErrorLog" ' Subroutine to initialize the application Sub InitializeApplication() ' Initialize the error log table if it doesn't exist If Not IsErrorLogTableInitialized() Then CreateErrorLogTable End Sub ' Check if the error log table exists and is initialized Function IsErrorLogTableInitialized() As Boolean Dim db As DAO.Database Dim rs As DAO.Recordset ' Use error handling to check if the error log table exists On Error Resume Next Set db = CurrentDb Set rs = db.OpenRecordset(TABLE_ERROR_LOG_NAME) On Error GoTo 0 ' Check if the error log table is initialized (contains necessary fields) If Not rs Is Nothing Then On Error Resume Next rs.MoveFirst IsErrorLogTableInitialized = (Err.Number = 0) And (rs.Fields.Count >= 6) On Error GoTo 0 rs.Close End If Set rs = Nothing Set db = Nothing End Function ' Subroutine to create the error log table Sub CreateErrorLogTable() On Error Resume Next Dim db As DAO.Database Set db = CurrentDb ' Check if the table already exists If Not IsTableExists(TABLE_ERROR_LOG_NAME, db) Then ' Define the SQL code to create the table Dim strSQL As String strSQL = "CREATE TABLE " & TABLE_ERROR_LOG_NAME & " (" & _ "ID AUTOINCREMENT PRIMARY KEY, " & _ "ErrorProcessName TEXT(255), " & _ "ErrorNumber LONG, " & _ "ErrorDescription MEMO, " & _ "ErrorDate DATETIME, " & _ "UserName TEXT(255));" ' Execute the SQL command to create the table directly DoCmd.RunSQL strSQL End If Set db = Nothing On Error GoTo 0 End Sub ' Function to check if a table exists in the database Function IsTableExists(tableName As String, Optional db As DAO.Database) As Boolean ' Use DLookup to check for the existence of the table in MSysObjects On Error Resume Next Set db = IIf(db Is Nothing, CurrentDb, db) IsTableExists = Not IsNull(DLookup("Name", "MSysObjects", "Name='" & tableName & "'")) On Error GoTo 0 End Function وظيفة الموديول هو تهئة ما اريد لقاعدة البيانات البدء به ومن خلاله ---------------------------------------------------------------------- 3- نموذج البداية وليكن الان باسم frmInitialization وفى حدث عند التحميل نضع الكود الاتى Private Sub Form_Load() strProcessName = "Form Load : frmIntialization" On Error Resume Next ' Initialize the application when the startup form is loaded. InitializeApplication ' Add calls to the initialized special functions through which you want the database to be booted ' Or add specify the codes through which you would like to process the data later according to the requirements of your design ' Set the current procedure name (you can adjust the procedure name as needed) If Err.Number <> 0 Then ' Handle the error (display a message) Call ErrorLog(Err, Error$, strProcessName) ' Clear the error Err.Clear End If End Sub النتيجة المرغوب فى الخصول عليها : عند تشغيل القاعدة فى المرة الأولى تنشئ جدول تسجيل الأخطاء من تلقاء نفسها باسم الروتين او الحدث ورقم الخطاء والوصف المتطلبات عند اعداد الاكواد تباعا نمرر اسم الروتين من خلال المتغير strProcessName كما فعلت فى الحدث السابق للنموذج: strProcessName = "Form Load : frmIntialization" لو حدث اى خطأ مستقبلا سوف يتم تسجيله حتى يستطيع مطور النظم او القائم على اعمال صيانة قواعد البيانات او المصمم معرفة مكان حدوث الخطأ الشق الثانى نقوم بعمل الايقاف للاخطا ليستكمل الكود عمله حتى لو وجودت اى اخطاء من خلال : On Error Resume Next بعد كتابة الكود كما نريد وبعد ان ننتهى منه نضع الشرط التالى : If Err.Number <> 0 Then بذلك نضع شرط عند الدوران على الكود لتنفيذه فى حالة وجود خطأ اولا اظهر رسالة الخطأ حتى يعلم المستخدم سبب المشكلة ثم استدعى الدالة لتسجيل هذا الخطأ ويتم ذلك من خلال Call ErrorLog(Err, Error$, strProcessName) الان هذه بداية احترافية وعلى اسس صحيحة ومفيدة للمستقبل ..... يتبع HandleAndLogError.accdb

-تجهيز مجلدات وملف الصوت الخطوة الاولى قم بانشاء مجلد جديد فى مسار قاعدة البيانات الحالى باسم ( Resurce ) الخطوة الثانية قم بفتح المجلد السابق وقم بانشاء مجلد جديد بداخله باسم ( Audio Files ) الخطوة الثالثة قم بنسخ ملف صوت الى المجلد ( Audio Files ) اما بامتداد wav , .mp3. --------------------- -تجهيز قاعدة البيانات الخطوة الاولى قم بانشاء وحدة نمطية باسم ( modPlayAudio ) وقم بلصق الاكواد الاتية فى هذه الوحدة النمطية Option Compare Database Option Explicit #If VBA7 And Win64 Then Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long Private Declare PtrSafe Function playSound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long #Else Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long Private Declare Function playSound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long #End If Const SND_ALIAS_SYSTEMASTERISK As String = "SystemAsterisk" Const SND_ALIAS_SYSTEMDEFAULT As String = "SystemDefault" Const SND_ALIAS_SYSTEMEXCLAMATION As String = "SystemExclamation" Const SND_ALIAS_SYSTEMEXIT As String = "SystemExit" Const SND_ALIAS_SYSTEMHAND As String = "SystemHand" Const SND_ALIAS_SYSTEMQUESTION As String = "SystemQuestion" Const SND_ALIAS_SYSTEMSTART As String = "SystemStart" Const SND_ALIAS_SYSTEMWELCOME As String = "SystemWelcome" Const SND_ALIAS_YouGotMail As String = "MailBeep" ' playsound Params Const SND_LOOP = &H8 Const SND_ALIAS = &H10000 Const SND_NODEFAULT = &H2 ' silence if no sound associated with event Const SND_ASYNC = &H1 ' play async (don't freeze program while sound is playing) Private sMusicFile As String Public soundOn As Boolean Dim mp3Path As String Dim wavPath As String Dim Play As Variant Public Sub Sound_MP3(ByVal File$) sMusicFile = GetShortPath(File) Play = mciSendString("play " & sMusicFile, 0&, 0, 0) If Play <> 0 Then End If End Sub Public Sub Stop_MP3(Optional ByVal FullFile$) Play = mciSendString("close " & sMusicFile, 0&, 0, 0) End Sub Public Function GetShortPath(ByVal strFileName As String) As String Dim lngRes As Long, strPath As String strPath = String$(165, 0) lngRes = GetShortPathName(strFileName, strPath, 164) GetShortPath = Left$(strPath, lngRes) End Function Function IsFile(ByVal fName As String) As Boolean On Error Resume Next IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory) End Function Public Function AudioFilePath() As String AudioFilePath = CurrentProject.Path & "\Resurce\Audio Files\" End Function Public Function PlayFile(ByVal FileName_ As String) Dim Msg As String Msg = ChrW(1578) & ChrW(1571) & ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & ChrW(1608) & ChrW(1580) & _ ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1587) & ChrW(1575) & ChrW(1585) & ChrW(32) & ChrW(40) & ChrW(32) & _ ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(32) & ChrW(47) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & _ ChrW(1578) & ChrW(41) & ChrW(32) & ChrW(1575) & ChrW(1604) & ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(46) & _ ChrW(13) & ChrW(10) & ChrW(1578) & ChrW(1571) & ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & _ ChrW(1608) & ChrW(1580) & ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(40) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & _ ChrW(32) & ChrW(47) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & ChrW(1578) & ChrW(41) & ChrW(32) & _ ChrW(1575) & ChrW(1604) & ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(1601) & ChrW(1609) & ChrW(32) & ChrW(1575) & _ ChrW(1604) & ChrW(1605) & ChrW(1587) & ChrW(1575) & ChrW(1585) & ChrW(32) & ChrW(1575) & ChrW(1604) & ChrW(1605) & _ ChrW(1581) & ChrW(1583) & ChrW(1583) & ChrW(32) & ChrW(46) & ChrW(13) & ChrW(10) & ChrW(1578) & ChrW(1571) & _ ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & ChrW(1575) & ChrW(1587) & ChrW(1605) & _ ChrW(32) & ChrW(32) & ChrW(40) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(32) & ChrW(47) & ChrW(32) & _ ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & ChrW(1578) & ChrW(41) & ChrW(32) & ChrW(1575) & ChrW(1604) & _ ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(46) mp3Path = AudioFilePath & FileName_ & ".mp3" wavPath = AudioFilePath & FileName_ & ".wav" StopFile If IsFile(mp3Path) Then Sound_MP3 (mp3Path): Exit Function If IsFile(wavPath) Then playSound (wavPath), vbNull, SND_ALIAS Or SND_NODEFAULT Or SND_ASYNC: Exit Function If IsFile(mp3Path) = IsFile(wavPath) Then MsgBox (Msg), vbOKOnly + vbMsgBoxRtlReading + vbMsgBoxRight: Exit Function End Function Public Function StopFile() playSound vbNullString, ByVal 0&, SND_NODEFAULT Stop_MP3 (mp3Path) End Function الخطوة الثانية قم بانشاء نموذج باسم ( frmPlayAudio ) الخطوة الثالثة قم بانشاء مربع نص فى النموذج السابق باسم ( txtAudioFileName ) الخطوة الرابعة قم بانشاء زر أمر فى النموذج السابق باسم ( cmdPlay ) وفى حدث عند النقر ضع الكود الاتى soundOn = True: PlayFile (Me.txtAudioFileName) الخطوة الخامسة قم بانشاء زر أمر فى النموذج السابق باسم ( cmdStop ) وفى حدث عند النقر ضع الكود الاتى StopFile الخطوة السادسة فى حدث عند إغلاق النموذج ضع الكود الاتى StopFile الخطوة السابعة بعد حفظ ما سبق افتح النموذج وادخل فى مربع النص ( txtAudioFileName ) اسم ملف الصوت الموجود فى المسار المحدد بدون الامتداد مثلا لو ملف الصوت باسم : MyAudio.mp3 Or MyAudio.wav اسم ملف الصوت فى مربع النص ( txtAudioFileName ) يكون فى الشكل الاتى فقط : MyAudio والان جرب الضغط على زر الامر الخاص بالتشغيل تارة وزر الامر الخاص بالايقاف تارة أخرى طيب ملاحظة مهمه : الطريقة ودوال API هنا تقوم بتشغيل ملفات صوت من النوعين MP3 . WAV <<---< والله دلع شغل فاخر من الأخر تم صياغة الكود بمرونه مطلقة للتعامل مع الملف بغض النظر عن امتداد الملف اه والله زيمبئولك كده مش مصدق ليه مش بئولك شغل فاخر اللى مش عاجبه المسار لملفات الصوت او عاوز يغير مكانها او اسمها طبعا فى الموديول يغير فى الروتين ده على مزاجه AudioFilePath() انا شرحت بالتفصيل الممل اياك حد يقول لى عاوز مرفق أو مش عارف يطبق الشرح

هل من الممكن تصدير المكتبات المستخدمة في المشروع الى جهاز آخر (أثناء عملية التثبيت مثلاً - على فرض أن المشروع تم تحزيمه بدقة ) حتى لو اختلفت فيه نسخة الأوفيس ؟ كون أن المكتبات هي ملفات معظمها Dll .... الخ من صيغ !!

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

السلام عليكم ورحمة الله تعالى وبركاته طبعا لن اضع افكارى صريحة لتطبيق فكرة محددة لا أنوى أن اعطيكم سمكا بل انوى أن أعلمكم الصيد ... لذلك سوف اضع الاكواد والافكار على وجه العموم وعلى سبيل الشرح ليس الا وليدل كل منكم بدلوه فى التطبيق وليستحضر بنات افكاره كما يترأى له 1- الحماية عن طريق اضافة بيانات الحماية فى الريجسترى نستخدم الأكواد الاتية فى وحدة نمطيه التطبيق فى القاعدة المرفقة .. تم وضع بعض التلميحات على الأكواد Public Const MyRegPath As String = "HKEY_CURRENT_USER\Software\Officena.net" Public Const MyRegKey As String = "Judy" Public Const myStringValue As String = "محمد" Public Const myValueData As String = "ابو جودى" 'returns True if the registry key i_RegKey was found 'and False if not Function RegKeyExists(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'try to read the registry key myWS.RegRead i_RegKey 'key was found RegKeyExists = True Exit Function ErrorHandler: 'key was not found RegKeyExists = False End Function Function RegKeyRead(i_RegKey As String) As String Dim myWS As Object On Error Resume Next 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'read key from registry RegKeyRead = myWS.RegRead(i_RegKey) End Function Function RegKeySave(i_RegKey As String, _ i_Value As String, _ Optional i_Type As String = "REG_SZ") Dim myWS As Object 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'write registry key myWS.RegWrite i_RegKey, i_Value, i_Type End Function Function RegKeyDelete(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'delete registry key myWS.RegDelete i_RegKey 'deletion was successful RegKeyDelete = True Exit Function ErrorHandler: 'deletion wasn't successful RegKeyDelete = False End Function يتبع.. القاعدة المرفقة 01-Dealing with the registry.accdb

السلام عليكم ورحمة الله وبركاته التطبيق اهداء الى منتدانا الحبيب ورواد المنتدى العمل حتى يخرج بهذه الصورة يعلم الله وحده الجهد المبذول به اسال الله تعالى ان يتقبل هذا العمل صدقة جارية الى ما شاء الله تعالى ms access becomes an authorized e-invoicing solution provider in Saudi Arabia by www.officena.net Start your e-invoicing journey حسب متطلبات هيئة الزكاة والضريبة والجمارك السعودية يتم قراءة الرمز الناتج ان شاء الله عبر القارىء الرسمي الخاص بالهيئة ( تطبيق جوال ) حمل من هنا : التطبيق الرسمي لهيئة الزكاة والضريبة والجمارك يتم قراءة الرمز الناتج ان شاء الله عبر قارىء خاص ( تطبيق جوال ) حمل من هنا : تطبيق قرائة رمز الاستجابة طبقات لمتطلبات هيئة الزكاة والضريبة والجمارك التطبيق المقدم لكم تمت تجربته وهو متوافق مع النواتين 32 , 64 تم تصميم الاكواد داخل روتين عام ليسهل التعامل معها بكل سهولة ممكنة حاولت جاهدا جمع الاكواد المستخدمة فى موديول ليسهل نقله يتم التعامل مع الروتين باسناد فقط اسماء الحقول من النموذج المستخدم والتى يمكن تغير اسمائها تبعا لتصميمك كالاتى Call CreateInvoice(ID, SellerName, VatNo, TimeStamp, InvoiceWithVat, VatTotal) ID >>-----> اسم الحقل الدال على رقم الفاتورة وهذا ليتم تسمية ملف رمز الاستجابة الناتج بناء عليه SellerName >>-----> اسم الحقل الدال على اسم البائع VatNo >>-----> اسم الحقل الدال على الرقم الضريبي TimeStamp >>-----> اسم الحقل الدال على الوقت وتاريخ انشاء الفاتورة InvoiceWithVat >>-----> اسم الحقل الدال على القيمة الاجمالية للفاتورة VatTotal >>-----> اسم الحقل الدال على القيمة الاجمالية لمبلغ الضريبة فقط بعد تشفير البيانات يتم اسناد الشفرة الى متغير عام باسمstrHashCode والذى من خلاله يت حفظ البيانات المشفرة داخل الجدول تبعا لكل سجل ---------------------------------------------- الية العمل بعد اسناد اسماء الحقول الى الروتين يتم تمرير البيانات من تلك الحقول الى الملف التنفيذى الملحق مع القاعدة والذى بدورة يقوم بانشاء كل من 1- رمز الاستجابة السريع بعد تشفير البيانات طبقا للمطلبات from string to hex to base64 2- انشاء ملف نص به تشفير البيانات بعد ذلك تقوم باقى الاكواد بجلب البيانات المشفرة من ملف النص واسنادها الى المتغير الذى تم تخصيصه لذلك --------------------------------------------- تفاصيل الاكواد داخل الموديول كالتالى الروتين MkDir لعمل المجلدات عند الحاجة دوال الـ API الخاصة بـ ShellWait والمتوافقة مع كلتا النواتان 32 , 64 وتمت التجربة بنجاح على اوفيس 32 تارة واوفيس 64 تارة اخرى بفضل الله بنجاح حيث يتم ارسال البيانات من الحقول الى الملف التنفيذى الملحق من خلال الروتين Shell_n_Wait ليتم انشاء رمز الاستجابة السريع من خلال الروتين الخاص به وهو CreateInvoice وانشاء الملف النصى بجوار الملف التنفيذى فى نفس المسار لالحاق البيانات المشفرة طبقا للمطلبات from string to hex to base64 وبعد ذلك يتم جلب البيانات المشفرة من خلال الروتين ReadFileToText ولابد من استخلاص التشفير من خلال الروتين StripSpChars للاحتفاظ بالنص دون اى زيادات وبعد ذلك يتم الحاق البيانات المشفرة الى المتغير الذى قمت بتخصيصه لذلك وهو يحمل الاسم strHashCode والذى يتم الحاق البيانات من خلاله لكل سجل الى الحقل المخصص به للاحتفاظ بتلك الشفرة حسب طلبات السادة رواد المنتدى الكرام الملف التنفيذى تم عمله من خلال الفيجوال دوت نت ليقوم بتحويل النص طبقا للمطلبات from string to hex to base64 وتم دمج ملفات الـ Dll الخاصة بانشاء رمز الاستجابة بداخل الملف التنفيذى لسهولة التعامل معه من خلال الاكسس ليكون ملف تنفيذى واحد فقط يتم التعامل معه من خلال الـ Command Line دون الحاجة لتثبيت او تسجيل او الاستعانة بأى مكتبات خارجية او حتى ملحقة بالاكسس وذلك لسهولة نقل الموديول الى اى قاعدة دون التقيد باى مكتبات --------------------------------------------- تنبيه هام جدا جدا جدا بجوار قاعدة البيانات فى نفس مسارها مجلد باسم KSA-QR-Tool لايمكن تغيير اسم المجلد والا يحدث خلل وان استدعت الحاجة تغيير الاسم يجب ذلك داخل المدويول يتم كذلك انشاء ملف نصى اليا داخل المجلد KSA-QR-Tool لذلك يجب تحرى الحذر عند محاولة تغيير اسم المجلد داخل الموديول لذلك يرجى عدم محاولة تغير اسم المجلد كذلك داخل المجلد السابق ذكرة الملف التنفيذى KSAQR.exe لا تحاول تغيير اسم الملف لان الاكواد كذلك تتعامل مع هذا الملف من خلال اسمه كذلك لا يمكن نقل المجلد او الملف من مسار قاعدة البيانات الا بالتعديل على الاكواد وفى الختام فضلا وكرما وليس امرا الرجاء الاهتمام بالرد بما يفيد نتيجة تجربتكم الشخصية وتقييم تلك التجربة فلا تبخلوا علينا بذلك... لكم منا خالص الشكر واتمنى لكم تجربة ممتعة ومن يريد طريقتى والتى احبها وافضلها وتعلمتها من استاذى الجليل ومعلمى الجليل الاستاذ @jjafferr بتحميل الملف التنفيذى داخل القاعدة للتأكد دائما من عدم حذفه لا يتردد فى طلب ذلك فقط حاولت تقديم القاعدة بأبسط شكل حتى يقف كل من يريد استخدامها او نقلها الى تطبيقه الخاص على الاكواد المهمة فقط من خلال موديول واحد فقط تيسيرا وتسهيلا عليه وحتى تعم الفائدة هذه الاكواد المستخدمة فى الملف التنفيذى الذى تم انشاؤه من خلال الـ فيجوال دوت نت بناء على رغبة استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل لمن يريد التعلم من اكواد التشفير وبناء على طلب استاذى القدير @ابوآمنة Imports System.Drawing Imports System.IO Imports System.Text Imports QRCoder Module Module1 Sub Main() Try Dim sellerName As String = "" Dim vatNumber As String = "" Dim timeStamp As String = "" Dim invoiceTotal As String = "" Dim vatTotal As String = "" Dim imagePath As String = "" Dim filePath As String = "" If My.Application.CommandLineArgs.Count >= 6 Then sellerName = My.Application.CommandLineArgs(0) vatNumber = My.Application.CommandLineArgs(1) timeStamp = My.Application.CommandLineArgs(2) invoiceTotal = My.Application.CommandLineArgs(3) vatTotal = My.Application.CommandLineArgs(4) imagePath = My.Application.CommandLineArgs(5) filePath = My.Application.CommandLineArgs(6) Else Environment.Exit(0) End If If Not String.IsNullOrEmpty(filePath) Then File.WriteAllText(filePath, String.Join(" ", sellerName, vatNumber, timeStamp, invoiceTotal, vatTotal), Encoding.UTF8) End If End Dim tlvInvoice = CreateInvoice(sellerName, vatNumber, timeStamp, invoiceTotal, vatTotal) Dim qrGenerator As New QRCodeGenerator() Dim qrData As QRCodeData = qrGenerator.CreateQrCode(tlvInvoice, QRCodeGenerator.ECCLevel.Q) Dim qrCode As QRCode = New QRCode(qrData) Dim qrCodeImage As Bitmap = qrCode.GetGraphic(20) qrCodeImage.Save(imagePath) If Not String.IsNullOrEmpty(filePath) Then File.WriteAllText(filePath, tlvInvoice, Encoding.UTF8) End If Catch ex As Exception End Try End Sub Function CreateInvoice(sellerName As String, vatNumber As String, timeStamp As String, invoiceTotal As String, vatTotal As String) As String Dim invoiceHex As String = "" For i = 1 To 5 Dim txt As String = "" Select Case i Case 1 txt = sellerName Case 2 txt = vatNumber Case 3 txt = timeStamp Case 4 txt = invoiceTotal Case 5 txt = vatTotal End Select Dim hexTxt As String = StringToHex(txt) Dim hexLen As String = Hex(Encoding.UTF8.GetBytes(txt).Length) If hexLen.Length = 1 Then hexLen = "0" & hexLen End If invoiceHex = invoiceHex & "0" & i & hexLen & hexTxt Next Return HexToBase64(invoiceHex) End Function Function StringToHex(txt As String) As String Dim b As Byte() = Encoding.UTF8.GetBytes(txt) Return BitConverter.ToString(b).Replace("-", "") End Function Function HexToBase64(txt As String) As String Dim bytes = New Byte((txt.Length \ 2) - 1) {} For i = 0 To bytes.Length - 1 Dim mi = txt.Substring(i * 2, 2) bytes(i) = Convert.ToByte(mi, 16) Next i Return Convert.ToBase64String(bytes) End Function End Module E-Invoicing.zip Ksa Qr 32x 64x 2007 to 2021 _Last Version.zip