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

السلام عليكم ورحمة الله وبركاته أشارك معكم اليوم وحدة نمطية متقدمة باسم 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 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) With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = ExpandedPath .Arguments = ExtractArguments(.filePath) .filePath = CanonicalizePath(.filePath) If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر" 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(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long = 0, Optional ByVal RunAsAdmin As Boolean = False, Optional ByVal RetryCount As Integer = 0) As Long Dim wsh As Object Dim ProcessId As Long Dim Result As Long Dim ProcessName As String On Error GoTo ErrorHandler If LenB(CommandLine) = 0 Then Err.Raise vbObjectError + 1, "ExecuteWithTimeout", "لم يتم تحديد أمر للتنفيذ" Exit Function ElseIf m_IsExecuting Then Err.Raise vbObjectError + 2, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ" Exit Function End If m_IsExecuting = True ' استخراج اسم العملية من الأمر ProcessName = ExtractProcessName(CommandLine) Set wsh = CreateObject("WScript.Shell") ' تنفيذ الأمر باستخدام WScript.Shell.Run If TimeoutMs > 0 Then ' تنفيذ الأمر دون انتظار ومراقبة المهلة Result = wsh.Run(IIf(RunAsAdmin, "cmd /c start /b """" ", "") & CommandLine, WindowStyle, False) ' الانتظار مع مهلة Dim StartTime As Double StartTime = Timer Do While Timer - StartTime < TimeoutMs / 1000 DoEvents Loop ' إذا انتهت المهلة، أنهِ العملية باستخدام KillProcess If Timer - StartTime >= TimeoutMs / 1000 Then If KillProcess(ProcessName) Then Debug.Print "تم إنهاء العملية بنجاح باستخدام WMI: " & ProcessName Else Debug.Print "فشل في إنهاء العملية: " & ProcessName End If End If ExecuteWithTimeout = Result ' لا يوجد PID حقيقي من WScript.Shell، نرجع رمز النتيجة Else ' تنفيذ الأمر مع الانتظار Result = wsh.Run(IIf(RunAsAdmin, "cmd /c start /b """" ", "") & CommandLine, WindowStyle, True) ExecuteWithTimeout = Result ' رمز الخروج End If Cleanup: m_IsExecuting = False Set wsh = Nothing Exit Function ErrorHandler: Debug.Print "خطأ في ExecuteWithTimeout: " & Err.Description & " - رقم الخطأ: " & Err.Number GoTo Cleanup End Function ' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار ' ترجع رمز النتيجة من WScript 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 ' كائن WScript.Shell ' إنشاء كائن WScript.Shell وتنفيذ الأمر 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 ' كائن WScript.Shell للتعامل مع الأوامر Dim ShellExec As Object ' كائن التنفيذ لالتقاط الناتج Dim Output As String ' متغير لتخزين الناتج النصي للأمر On Error GoTo ErrorHandler ' إنشاء كائن WScript.Shell Set WScriptShell = CreateObject("WScript.Shell") ' تنفيذ الأمر باستخدام Exec لالتقاط الناتج Set ShellExec = WScriptShell.Exec(CommandLine) ' الانتظار حتى انتهاء العملية وقراءة الناتج Do While ShellExec.Status = 0 ' 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%) ' ترجع السلسلة بعد التوسيع مع دعم الإصدارات القديمة من Windows Private Function ExpandEnvVars(ByVal Path As String) As String Dim Buffer As String Dim Length As Long If InStr(Path, "%") Then ' إذا كان المسار يحتوي على متغيرات بيئة، قم بتوسيعها مع ضمان دعم Unicode 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 تمنياتى القلبيــــه بأكبر قدر ممكن من تحصيل المتعة والاستفاده

السلام عليكم ورحمة الله تعالى وبركاته هدية اليوم هى عبارة عن مكتبة برمجية متكاملة تم كتابتها وتطويرها لتوفير حلول مرنة وقوية لضغط الملفات والمجلدات وفك ضغطها باستخدام أدوات شائعة مثل 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 ' تعداد لمستويات الضغط المستخدمة في إنشاء الأرشيفات باستخدام WinRAR (-m) أو 7-Zip (-mx) Enum EnumCompressionLevel CompressionStore = 0 ' بدون ضغط (تخزين الملفات كما هي دون تقليل الحجم، مناسب للسرعة) CompressionFastest = 1 ' أقل مستوى ضغط وأسرع أداء (يقلل الحجم قليلاً مع التركيز على السرعة) CompressionFast = 2 ' ضغط سريع مع توازن بين السرعة وتقليل الحجم CompressionNormal = 3 ' مستوى ضغط عادي (الافتراضي، يناسب معظم الحالات) CompressionGood = 4 ' ضغط جيد (توازن محسّن بين الحجم والأداء) CompressionMaximum = 5 ' أعلى مستوى ضغط (أقصى تقليل للحجم، لكنه أبطأ في التنفيذ) End Enum ' تعداد لحجم تقسيم الأرشيف إلى أجزاء عند الإنشاء، القيم بالميجابايت (يُستخدم مع -v في WinRAR/7-Zip) Enum EnumSplitSizeOption SplitNone = 0 ' بدون تقسيم (الأرشيف يبقى ملفًا واحدًا) Split50MB = 50 ' تقسيم إلى أجزاء بحجم 50 ميجابايت Split100MB = 100 ' تقسيم إلى أجزاء بحجم 100 ميجابايت Split200MB = 200 ' تقسيم إلى أجزاء بحجم 200 ميجابايت Split500MB = 500 ' تقسيم إلى أجزاء بحجم 500 ميجابايت Split1GB = 1000 ' تقسيم إلى أجزاء بحجم 1 جيجابايت Split2GB = 2000 ' تقسيم إلى أجزاء بحجم 2 جيجابايت End Enum ' تعداد لتحديد كيفية التعامل مع الملفات الموجودة أثناء فك الضغط (مع ملاحظة أن OverwritePrompt غير مدعوم في سطر الأوامر) Enum EnumOverwriteMode OverwriteNone = 0 ' لا يتم استبدال الملفات الموجودة (-o- في WinRAR، -aos في 7-Zip) OverwritePrompt = 1 ' يطلب تأكيد المستخدم قبل الاستبدال (غير مدعوم في وضع سطر الأوامر) OverwriteAll = 2 ' يستبدل جميع الملفات تلقائيًا دون تأكيد (-o+ في WinRAR، -aoa في 7-Zip) End Enum ' تعداد لتحديد الأداة المستخدمة لإنشاء الأرشيفات وفك ضغطها Enum EnumArchiveMethod WinRAR = 0 ' استخدام WinRAR لإنشاء أرشيفات RAR/ZIP/SFX وفك ضغطها SevenZip = 1 ' استخدام 7-Zip لإنشاء أرشيفات 7z/ZIP/SFX وفك ضغطها (لا يدعم إنشاء RAR) End Enum ' تعداد لتحديد نوع صيغة الأرشيف الناتج Enum EnumArchiveType ArchiveRAR = 0 ' أرشيف بصيغة RAR (مدعوم فقط مع WinRAR) ArchiveZIP = 1 ' أرشيف بصيغة ZIP (مدعوم مع WinRAR و7-Zip) Archive7z = 2 ' أرشيف بصيغة 7z (مدعوم فقط مع 7-Zip) End Enum ' لاحظ: isSFX ليس متغيرًا عامًا بل معلمة في CompressItems لتحديد ما إذا كان الأرشيف ذاتي الاستخراج (SFX) ' متغير عام للتحكم في عرض رسائل النجاح أثناء حلقات الضغط أو فك الضغط Public IsInLoop As Boolean ' متغير عام لتخزين قائمة مسارات الأرشيفات الناتجة في الحلقات لعرضها في رسالة نجاح واحدة Public ArchivesList As String ' دالة مساعدة لتحويل مستوى الضغط من EnumCompressionLevel إلى قيمة عددية تتوافق مع خيار -mx في 7-Zip ' المدخل: level - مستوى الضغط من تعداد EnumCompressionLevel ' المخرج: قيمة عددية (0-9) تُستخدم مع -mx لتحديد مستوى الضغط في 7-Zip Function GetSevenZipCompressionLevel(level As EnumCompressionLevel) As Integer Select Case level Case CompressionStore GetSevenZipCompressionLevel = 0 ' بدون ضغط (-mx=0) Case CompressionFastest GetSevenZipCompressionLevel = 1 ' أقل ضغط وأسرع (-mx=1) Case CompressionFast GetSevenZipCompressionLevel = 3 ' ضغط سريع (-mx=3) Case CompressionNormal GetSevenZipCompressionLevel = 5 ' ضغط عادي (-mx=5، الافتراضي) Case CompressionGood GetSevenZipCompressionLevel = 7 ' ضغط جيد (-mx=7) Case CompressionMaximum GetSevenZipCompressionLevel = 9 ' أعلى ضغط (-mx=9) End Select End Function ' دالة مساعدة لتحويل قيم تعداد EnumSplitSizeOption إلى سلسلة نصية تُستخدم مع خيار -v في WinRAR و7-Zip ' المدخل: sizeOption - خيار حجم التقسيم من تعداد EnumSplitSizeOption ' المخرج: سلسلة نصية (مثل "50m" أو "1g") تُضاف إلى -v لتحديد حجم الأجزاء Function GetSplitSizeString(sizeOption As EnumSplitSizeOption) As String Select Case sizeOption Case SplitNone GetSplitSizeString = "" ' بدون تقسيم (-v غير موجود) Case Split1GB GetSplitSizeString = "1g" ' 1 جيجابايت (-v1g) Case Split2GB GetSplitSizeString = "2g" ' 2 جيجابايت (-v2g) Case Else GetSplitSizeString = CStr(sizeOption) & "m" ' حجم بالميجابايت (مثل -v50m) End Select End Function ' دالة تتيح للمستخدم تحديد مسار ملف تنفيذي (WinRAR.exe أو 7z.exe) يدويًا عبر مربع حوار اختيار الملفات ' المعاملات: ' - Method: سلسلة تحدد الأداة المطلوبة ("WinRAR" أو "SevenZip") ' المخرجات: ' - المسار الكامل للملف التنفيذي المختار أو سلسلة فارغة إذا تم الإلغاء أو حدث خطأ Function SelectArchivePathManually(Method As String) As String On Error GoTo ErrorHandler Dim fileDialog As Object ' كائن يمثل مربع حوار اختيار الملفات في Access Dim selectedPath As String ' متغير لتخزين المسار المختار ' التحقق من أن القيمة المدخلة لـ Method صالحة If Method <> "WinRAR" And Method <> "SevenZip" Then MsgBox "القيمة '" & Method & "' غير صالحة. يجب أن تكون 'WinRAR' أو 'SevenZip'.", vbCritical, "خطأ في الإدخال" SelectArchivePathManually = "" Exit Function End If ' إعداد مربع حوار لاختيار ملف واحد Set fileDialog = Application.fileDialog(3) ' 3 = msoFileDialogFilePicker (اختيار ملف) With fileDialog ' تخصيص إعدادات مربع الحوار بناءً على الأداة المطلوبة If Method = "WinRAR" Then .Title = "اختر ملف WinRAR.exe" ' عنوان النافذة .Filters.Clear ' إزالة أي فلاتر سابقة .Filters.Add "WinRAR Executable", "*.exe" ' فلتر لعرض ملفات .exe فقط ElseIf Method = "SevenZip" Then .Title = "اختر ملف 7z.exe" ' عنوان النافذة .Filters.Clear ' إزالة أي فلاتر سابقة .Filters.Add "7Zip Executable", "*.exe" ' فلتر لعرض ملفات .exe فقط End If .AllowMultiSelect = False ' تفعيل اختيار ملف واحد فقط ' عرض مربع الحوار ومعالجة اختيار المستخدم If .Show = -1 Then ' -1 تعني أن المستخدم ضغط "فتح" selectedPath = .SelectedItems(1) ' استرجاع المسار الكامل للملف المختار ' التحقق من تطابق اسم الملف مع الأداة المطلوبة If Method = "WinRAR" And InStr(1, LCase(selectedPath), "winrar.exe") = 0 Then MsgBox "الملف المختار ليس WinRAR.exe. الرجاء اختيار الملف الصحيح.", vbExclamation, "خطأ في الاختيار" SelectArchivePathManually = "" ElseIf Method = "SevenZip" And InStr(1, LCase(selectedPath), "7z.exe") = 0 Then MsgBox "الملف المختار ليس 7z.exe. الرجاء اختيار الملف الصحيح.", vbExclamation, "خطأ في الاختيار" SelectArchivePathManually = "" Else SelectArchivePathManually = selectedPath ' إرجاع المسار إذا كان الملف مطابقًا End If Else ' إذا ألغى المستخدم الاختيار MsgBox "لم يتم اختيار أي ملف. تم إلغاء العملية.", vbExclamation, "عملية ملغاة" SelectArchivePathManually = "" End If End With Cleanup: ' تحرير كائن مربع الحوار من الذاكرة Set fileDialog = Nothing Exit Function ErrorHandler: ' معالجة الأخطاء المحتملة أثناء تنفيذ الدالة MsgBox "حدث خطأ أثناء اختيار الملف: " & Err.Description, vbCritical, "خطأ" SelectArchivePathManually = "" Resume Cleanup End Function ' دالة لتحديد مسار الملف التنفيذي (WinRAR.exe أو 7z.exe) تلقائيًا من سجل النظام أو المسارات الافتراضية ' في حالة الفشل، تطلب من المستخدم اختيار المسار يدويًا باستخدام SelectArchivePathManually ' المعاملات: ' - Method: سلسلة تحدد الأداة المطلوبة ("WinRAR" أو "SevenZip") ' المخرجات: ' - المسار الكامل للملف التنفيذي أو سلسلة فارغة إذا فشلت العملية Function DetermineArchivePath(Method As String) As String On Error GoTo ErrorHandler Dim reg As Object ' كائن للوصول إلى سجل النظام عبر WScript.Shell Dim pathFromReg As String ' متغير لتخزين المسار المستخرج من السجل Dim defaultPaths As Variant ' مصفوفة تحتوي على المسارات الافتراضية Dim i As Integer ' عداد للحلقة عبر المسارات الافتراضية ' التحقق من أن القيمة المدخلة لـ Method صالحة If Method <> "WinRAR" And Method <> "SevenZip" Then MsgBox "القيمة '" & Method & "' غير صالحة. يجب أن تكون 'WinRAR' أو 'SevenZip'.", vbCritical, "خطأ في الإدخال" DetermineArchivePath = "" Exit Function End If ' إعداد كائن لقراءة مفاتيح السجل Set reg = CreateObject("WScript.Shell") ' البحث عن مسار الأداة بناءً على Method If Method = "WinRAR" Then ' محاولة استخراج مسار WinRAR من مفاتيح السجل المختلفة On Error Resume Next pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\WinRAR.exe\") ' مفتاح تطبيقات Windows If Err.Number <> 0 Then Err.Clear pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\WinRAR\exe32") ' مفتاح WinRAR لنظام 32 بت End If If Err.Number <> 0 Then Err.Clear pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\WinRAR\exe32") ' مفتاح WinRAR لنظام 64 بت End If On Error GoTo 0 ' التحقق من وجود الملف في المسار المستخرج If pathFromReg <> "" And Dir(pathFromReg) <> vbNullString Then DetermineArchivePath = pathFromReg Exit Function End If ' البحث في المسارات الافتراضية إذا فشل السجل defaultPaths = Array("C:\Program Files\WinRAR\WinRAR.exe", "C:\Program Files (x86)\WinRAR\WinRAR.exe") For i = LBound(defaultPaths) To UBound(defaultPaths) If Dir(defaultPaths(i)) <> vbNullString Then DetermineArchivePath = defaultPaths(i) Exit Function End If Next i ElseIf Method = "SevenZip" Then ' محاولة استخراج مسار 7-Zip من مفاتيح السجل On Error Resume Next pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\7-Zip\Path") ' مفتاح 7-Zip لنظام 32 بت If Err.Number <> 0 Then Err.Clear pathFromReg = reg.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\7-Zip\Path") ' مفتاح 7-Zip لنظام 64 بت End If On Error GoTo 0 ' التحقق من المسار وإكماله باسم الملف إذا لزم الأمر If pathFromReg <> "" Then If Right(pathFromReg, 1) <> "\" Then pathFromReg = pathFromReg & "\" If Dir(pathFromReg & "7z.exe") <> vbNullString Then DetermineArchivePath = pathFromReg & "7z.exe" Exit Function End If End If ' البحث في المسارات الافتراضية إذا فشل السجل defaultPaths = Array("C:\Program Files\7-Zip\7z.exe", "C:\Program Files (x86)\7-Zip\7z.exe") For i = LBound(defaultPaths) To UBound(defaultPaths) If Dir(defaultPaths(i)) <> vbNullString Then DetermineArchivePath = defaultPaths(i) Exit Function End If Next i End If ' إذا لم يُعثر على الملف تلقائيًا، طلب الاختيار اليدوي MsgBox "لم يتم العثور على " & Method & "! الرجاء تحديد موقعه يدويًا.", vbExclamation, "تحديد مسار " & Method DetermineArchivePath = SelectArchivePathManually(Method) Cleanup: ' تحرير كائن WScript.Shell من الذاكرة Set reg = Nothing Exit Function ErrorHandler: ' معالجة الأخطاء المحتملة أثناء البحث عن المسار MsgBox "حدث خطأ أثناء تحديد مسار " & Method & ": " & Err.Description, vbCritical, "خطأ" DetermineArchivePath = "" Resume Cleanup End Function ' دالة لبناء أمر ضغط الملفات باستخدام WinRAR أو 7-Zip بناءً على المعاملات المحددة ' المعاملات: ' - sourceFile: الملفات أو المجلدات المراد ضغطها (سلسلة أو مصفوفة) ' - password: كلمة المرور لتشفير الأرشيف (اختياري) ' - Method: الأداة المستخدمة (WinRAR أو SevenZip) ' - archiveType: نوع الأرشيف (RAR، ZIP، 7z) ' - compressionLevel: مستوى الضغط (من CompressionStore إلى CompressionMaximum) ' - partSize: حجم تقسيم الأرشيف (من SplitNone إلى Split2GB) ' - targetPath: مسار حفظ الأرشيف (اختياري، افتراضيًا CurrentProject.Path) ' - archiveName: اسم الأرشيف (اختياري، افتراضيًا اسم الملف الأول) ' - isSFX: تحديد ما إذا كان الأرشيف ذاتي الاستخراج (True/False) ' - commentFile: مسار ملف التعليق (اختياري، مدعوم في WinRAR فقط) ' المخرجات: ' - سلسلة نصية تمثل أمر الضغط الكامل أو سلسلة فارغة إذا فشل البناء Function BuildCompressCommand( _ sourceFile As Variant, _ password As String, _ Method As EnumArchiveMethod, _ archiveType As EnumArchiveType, _ compressionLevel As EnumCompressionLevel, _ partSize As EnumSplitSizeOption, _ targetPath As String, _ archiveName As String, _ isSFX As Boolean, _ commentFile As String) As String Dim Command As String ' السلسلة النصية للأمر النهائي Dim archiveProgramPath As String ' مسار البرنامج التنفيذي (WinRAR.exe أو 7z.exe) Dim fileList As String ' قائمة الملفات أو المجلدات المراد ضغطها Dim targetFile As String ' المسار الكامل للأرشيف الناتج Dim fso As Object ' كائن FileSystemObject للتعامل مع الملفات والمجلدات Dim file As Variant Dim fullFilePath As String ' متغير لتخزين المسار الكامل لكل عنصر Set fso = CreateObject("Scripting.FileSystemObject") ' تحديد مسار البرنامج باستخدام DetermineArchivePath archiveProgramPath = DetermineArchivePath(IIf(Method = WinRAR, "WinRAR", "SevenZip")) If archiveProgramPath = "" Then Exit Function ' الخروج إذا لم يتم العثور على البرنامج ' تجهيز قائمة الملفات أو المجلدات مع تحويل المسارات النسبية إلى مسارات كاملة fileList = "" If Not IsArray(sourceFile) Then sourceFile = Array(sourceFile) ' تحويل إلى مصفوفة إذا كان مدخلاً منفردًا For Each file In sourceFile ' إذا كان المسار نسبيًا (لا يحتوي على ":\" أو "\\")، أضف CurrentProject.Path If InStr(file, ":\") = 0 And InStr(file, "\\") = 0 Then fullFilePath = CurrentProject.Path & "\" & file Else fullFilePath = file End If ' التحقق من وجود الملف أو المجلد If fso.FileExists(fullFilePath) Or fso.FolderExists(fullFilePath) Then fileList = fileList & " " & Chr(34) & fullFilePath & Chr(34) Else Debug.Print "العنصر غير موجود: " & fullFilePath End If Next file ' إذا لم يتم العثور على أي عناصر صالحة، أخرج سلسلة فارغة If fileList = "" Then Exit Function ' تحديد مسار واسم الأرشيف الناتج If targetPath = "" Then targetFile = CurrentProject.Path & "\" & IIf(archiveName = "", fso.GetBaseName(sourceFile(LBound(sourceFile))), archiveName) & IIf(isSFX, ".exe", IIf(archiveType = ArchiveRAR, ".rar", IIf(archiveType = ArchiveZIP, ".zip", ".7z"))) Else targetFile = targetPath & "\" & IIf(archiveName = "", fso.GetBaseName(sourceFile(LBound(sourceFile))), archiveName) & IIf(isSFX, ".exe", IIf(archiveType = ArchiveRAR, ".rar", IIf(archiveType = ArchiveZIP, ".zip", ".7z"))) End If ' بناء الأمر بناءً على الأداة المختارة If Method = WinRAR Then Command = Chr(34) & archiveProgramPath & Chr(34) & " a -ep1 -m" & compressionLevel If isSFX Then Command = Command & " -sfx" Command = Command & " " & Chr(34) & targetFile & Chr(34) & fileList If password <> "" Then Command = Command & " -p" & password If partSize <> SplitNone Then Command = Command & " -v" & GetSplitSizeString(partSize) If commentFile <> "" And fso.FileExists(commentFile) Then Command = Command & " -z" & Chr(34) & commentFile & Chr(34) ElseIf Method = SevenZip Then Command = Chr(34) & archiveProgramPath & Chr(34) & " a -mx=" & GetSevenZipCompressionLevel(compressionLevel) If isSFX Then Command = Command & " -sfx7z.sfx" Command = Command & " " & Chr(34) & targetFile & Chr(34) & fileList If password <> "" Then Command = Command & " -p" & password & " -mhe=on" If partSize <> SplitNone Then Command = Command & " -v" & GetSplitSizeString(partSize) End If BuildCompressCommand = Command Set fso = Nothing End Function ' دالة لإنشاء ملف تعليق مؤقت وإرجاع مساره لاستخدامه مع أرشيفات WinRAR ' المعاملات: ' - commentLines: سلسلة نصية أو مصفوفة تحتوي على أسطر التعليق ' - deleteAfterUse: إذا كان True (افتراضي)، يتم حذف الملف بعد الاستخدام؛ إذا كان False، يبقى الملف ' المخرجات: ' - المسار الكامل لملف التعليق المؤقت Function CreateCommentFile(commentLines As Variant, Optional deleteAfterUse As Boolean = True) As String Dim fso As Object ' كائن FileSystemObject للتعامل مع الملفات Dim tempFile As String ' مسار الملف المؤقت Dim file As Object ' كائن الملف النصي Dim line As Variant ' متغير لحلقة الكتابة Set fso = CreateObject("Scripting.FileSystemObject") ' إنشاء اسم ملف مؤقت فريد باستخدام الطابع الزمني tempFile = CurrentProject.Path & "\temp_comment_" & Format(Now, "yyyymmddhhnnss") & ".txt" ' إنشاء الملف بترميز Unicode لدعم النصوص العربية Set file = fso.CreateTextFile(tempFile, True, True) ' True الأولى للكتابة فوق الملف، True الثانية لـ Unicode If IsArray(commentLines) Then ' كتابة أسطر متعددة إذا كان المدخل مصفوفة For Each line In commentLines file.WriteLine CStr(line) Next line Else ' كتابة سلسلة واحدة إذا لم يكن مصفوفة file.WriteLine CStr(commentLines) End If file.Close ' إرجاع مسار الملف المؤقت CreateCommentFile = tempFile ' حذف الملف إذا طُلب ذلك مع تجاهل الأخطاء المحتملة (مثل الملف قيد الاستخدام) If deleteAfterUse Then On Error Resume Next fso.DeleteFile tempFile On Error GoTo 0 End If Set file = Nothing Set fso = Nothing End Function ' دالة لضغط ملفات أو مجلدات باستخدام WinRAR أو 7-Zip مع خيارات متعددة ' المعاملات: ' - itemsArray: الملفات أو المجلدات المراد ضغطها (سلسلة أو مصفوفة، اختياري) ' - password: كلمة المرور لتشفير الأرشيف (اختياري، افتراضي "") ' - Method: الأداة المستخدمة (WinRAR أو SevenZip، افتراضي SevenZip) ' - archiveType: نوع الأرشيف (RAR، ZIP، 7z، افتراضي Archive7z) ' - compressionLevel: مستوى الضغط (افتراضي CompressionNormal) ' - partSize: حجم تقسيم الأرشيف (افتراضي SplitNone) ' - targetPath: مسار حفظ الأرشيف (اختياري، افتراضي CurrentProject.Path) ' - archiveName: اسم الأرشيف (اختياري، افتراضي اسم الملف الأول) ' - isSFX: تحديد ما إذا كان الأرشيف ذاتي الاستخراج (افتراضي False) ' - commentFile: مسار ملف التعليق (اختياري، مدعوم في WinRAR فقط) Sub CompressItems( _ Optional ByVal itemsArray As Variant, _ Optional ByVal password As String = "", _ Optional ByVal Method As EnumArchiveMethod = SevenZip, _ Optional ByVal archiveType As EnumArchiveType = Archive7z, _ Optional ByVal compressionLevel As EnumCompressionLevel = CompressionNormal, _ Optional ByVal partSize As EnumSplitSizeOption = SplitNone, _ Optional ByVal targetPath As String = "", _ Optional ByVal archiveName As String = "", _ Optional ByVal isSFX As Boolean = False, _ Optional ByVal commentFile As String = "") On Error GoTo ErrorHandler Dim Command As String ' أمر الضغط الناتج من BuildCompressCommand Dim fso As Object ' كائن FileSystemObject للتحقق من الملفات Dim file As Variant ' متغير لحلقة التحقق من الملفات Dim archiveFullPath As String ' المسار الكامل للأرشيف الناتج Dim isInputArray As Boolean ' للتحقق مما إذا كان المدخل مصفوفة Set fso = CreateObject("Scripting.FileSystemObject") ' التحقق من وجود مدخل If VarType(itemsArray) = vbEmpty Then MsgBox "لم يتم تحديد ملفات أو مجلدات للضغط.", vbExclamation, "خطأ" GoTo Cleanup End If ' التحقق من نوع المدخل الأصلي isInputArray = IsArray(itemsArray) If isInputArray Then If UBound(itemsArray) < LBound(itemsArray) Then MsgBox "المصفوفة فارغة. لم يتم تحديد ملفات أو مجلدات للضغط.", vbExclamation, "خطأ" GoTo Cleanup End If End If ' تحويل المدخل إلى مصفوفة وفحص وجود الملفات If Not isInputArray Then itemsArray = Array(itemsArray) For Each file In itemsArray Dim fullPath As String If Left(file, 1) = "\" Then fullPath = CurrentProject.Path & file ' إضافة المسار الأساسي إذا بدأ بـ "\" ElseIf InStr(file, "\") = 0 Then fullPath = CurrentProject.Path & "\" & file ' إضافة المسار إذا كان اسمًا فقط Else fullPath = file ' استخدام المسار الكامل كما هو End If If Not fso.FileExists(fullPath) And Not fso.FolderExists(fullPath) Then MsgBox "الملف أو المجلد '" & fullPath & "' غير موجود!", vbCritical, "خطأ" GoTo Cleanup End If Next file ' استدعاء BuildCompressCommand لبناء الأمر Command = BuildCompressCommand( _ sourceFile:=itemsArray, _ password:=password, _ Method:=Method, _ archiveType:=archiveType, _ compressionLevel:=compressionLevel, _ partSize:=partSize, _ targetPath:=targetPath, _ archiveName:=archiveName, _ isSFX:=isSFX, _ commentFile:=commentFile _ ) If Command = "" Then MsgBox "فشل في إنشاء أمر الضغط.", vbCritical, "خطأ" GoTo Cleanup End If ' تنفيذ الأمر باستخدام ShellWait ShellWait Command, vbHide ' vbHide لإخفاء نافذة سطر الأوامر ' تحديد المسار النهائي للأرشيف لعرضه في رسالة النجاح If targetPath = "" Then archiveFullPath = CurrentProject.Path & "\" & IIf(archiveName = "", fso.GetBaseName(itemsArray(LBound(itemsArray))), archiveName) & IIf(isSFX, ".exe", IIf(archiveType = ArchiveRAR, ".rar", IIf(archiveType = ArchiveZIP, ".zip", ".7z"))) Else archiveFullPath = targetPath & "\" & IIf(archiveName = "", fso.GetBaseName(itemsArray(LBound(itemsArray))), archiveName) & IIf(isSFX, ".exe", IIf(archiveType = ArchiveRAR, ".rar", IIf(archiveType = ArchiveZIP, ".zip", ".7z"))) End If ' التحكم في عرض رسالة النجاح بناءً على السياق If isInputArray Then MsgBox "تم الضغط بنجاح إلى '" & archiveFullPath & "'!", vbInformation, "نجاح" ElseIf Not IsInLoop Then MsgBox "تم الضغط بنجاح إلى '" & archiveFullPath & "'!", vbInformation, "نجاح" Else ArchivesList = ArchivesList & archiveFullPath & vbCrLf ' إضافة إلى قائمة الحلقة End If Cleanup: ' حذف ملف التعليق إذا كان موجودًا If commentFile <> "" And fso.FileExists(commentFile) Then fso.DeleteFile commentFile Set fso = Nothing Exit Sub ErrorHandler: Dim errorMsg As String If Err.Number = 450 Then errorMsg = "خطأ في تمرير المعاملات:" & vbCrLf & _ "الترتيب المتوقع:" & vbCrLf & _ "1. itemsArray (Variant, اختياري) - الملفات أو المجلدات" & vbCrLf & _ "2. password (String, اختياري) - كلمة المرور" & vbCrLf & _ "3. Method (EnumArchiveMethod, اختياري) - WinRAR أو SevenZip" & vbCrLf & _ "4. archiveType (EnumArchiveType, اختياري) - ArchiveRAR أو ArchiveZIP أو Archive7z" & vbCrLf & _ "5. compressionLevel (EnumCompressionLevel, اختياري) - مستوى الضغط" & vbCrLf & _ "6. partSize (EnumSplitSizeOption, اختياري) - حجم التقسيم" & vbCrLf & _ "7. targetPath (String, اختياري) - مسار الهدف" & vbCrLf & _ "8. archiveName (String, اختياري) - اسم الأرشيف" & vbCrLf & _ "9. isSFX (Boolean, اختياري) - إنشاء ملف SFX" & vbCrLf & _ "10. commentFile (String, اختياري) - مسار ملف التعليق" & vbCrLf & _ "تفاصيل الخطأ: " & Err.Description Else errorMsg = "حدث خطأ أثناء الضغط: " & Err.Description End If MsgBox errorMsg, vbCritical, "خطأ" GoTo Cleanup End Sub ' دوال مساعدة للحلقات (الضغط) ' دالة مساعدة لبدء حلقة ضغط متعددة وتهيئة المتغيرات العامة Sub StartCompressionLoop() IsInLoop = True ' تفعيل وضع الحلقة ArchivesList = "" ' تهيئة قائمة الأرشيفات End Sub ' دالة مساعدة لعرض رسالة نجاح موحدة بعد انتهاء حلقة الضغط Sub ShowCompressionSuccess() If IsInLoop And ArchivesList <> "" Then MsgBox "تم الضغط بنجاح للملفات التالية:" & vbCrLf & ArchivesList, vbInformation, "نجاح" End If IsInLoop = False ' إنهاء وضع الحلقة ArchivesList = "" ' إعادة تهيئة القائمة End Sub ' دالة لفك ضغط الأرشيفات باستخدام WinRAR أو 7-Zip إلى مسار محدد ' المعاملات: ' - archivePaths: المسارات الكاملة للأرشيفات (سلسلة أو مصفوفة) ' - destinationPath: مسار الوجهة لفك الضغط ' - password: كلمة المرور إذا كان الأرشيف مشفرًا (اختياري، افتراضي "") ' - Method: الأداة المستخدمة (WinRAR أو SevenZip، افتراضي WinRAR) ' - OverwriteMode: طريقة التعامل مع الملفات الموجودة (OverwriteAll أو OverwriteNone، افتراضي OverwriteAll) Sub ExtractItems( _ archivePaths As Variant, _ destinationPath As String, _ Optional ByVal password As String = "", _ Optional ByVal Method As EnumArchiveMethod = WinRAR, _ Optional ByVal OverwriteMode As EnumOverwriteMode = OverwriteAll) On Error GoTo ErrorHandler Dim Command As String ' أمر فك الضغط Dim archiveProgramPath As String ' مسار البرنامج التنفيذي Dim fso As Object ' كائن FileSystemObject للتحقق من الملفات Dim archiveList As String ' قائمة الأرشيفات المراد فك ضغطها Dim archive As Variant ' متغير لحلقة التحقق Dim isInputArray As Boolean ' للتحقق مما إذا كان المدخل مصفوفة Set fso = CreateObject("Scripting.FileSystemObject") ' التحقق من وجود البرنامج archiveProgramPath = DetermineArchivePath(IIf(Method = WinRAR, "WinRAR", "SevenZip")) If archiveProgramPath = "" Or Not fso.FileExists(archiveProgramPath) Then MsgBox "تعذر العثور على برنامج فك الضغط المطلوب! تأكد من تثبيته.", vbCritical, "خطأ" GoTo Cleanup End If ' التحقق من وجود مدخل If VarType(archivePaths) = vbEmpty Then MsgBox "لم يتم تحديد أرشيفات لفك الضغط.", vbExclamation, "خطأ" GoTo Cleanup End If ' التحقق من نوع المدخل الأصلي isInputArray = IsArray(archivePaths) If isInputArray Then If UBound(archivePaths) < LBound(archivePaths) Then MsgBox "المصفوفة فارغة. لم يتم تحديد أرشيفات لفك الضغط.", vbExclamation, "خطأ" GoTo Cleanup End If End If ' تجهيز قائمة الأرشيفات مع إضافة علامات الاقتباس archiveList = "" If Not isInputArray Then archivePaths = Array(archivePaths) For Each archive In archivePaths If Not fso.FileExists(archive) Then MsgBox "الملف '" & archive & "' غير موجود!", vbCritical, "خطأ" GoTo Cleanup End If archiveList = archiveList & " " & Chr(34) & archive & Chr(34) Next archive ' إنشاء مجلد الوجهة إذا لم يكن موجودًا If Dir(destinationPath, vbDirectory) = "" Then MkDir destinationPath End If ' بناء أمر فك الضغط بناءً على الأداة If Method = WinRAR Then Command = Chr(34) & archiveProgramPath & Chr(34) & " x " & archiveList & " " & Chr(34) & destinationPath & Chr(34) If password <> "" Then Command = Command & " -p" & password Select Case OverwriteMode Case OverwriteAll: Command = Command & " -o+" ' الكتابة فوق الملفات Case OverwriteNone: Command = Command & " -o-" ' تجاهل الملفات الموجودة Case OverwritePrompt MsgBox "خيار 'OverwritePrompt' غير مدعوم في وضع سطر الأوامر. سيتم استخدام 'OverwriteAll' افتراضيًا.", vbInformation, "تحذير" Command = Command & " -o+" End Select ElseIf Method = SevenZip Then Command = Chr(34) & archiveProgramPath & Chr(34) & " x " & archiveList & " -o" & Chr(34) & destinationPath & Chr(34) If password <> "" Then Command = Command & " -p" & password Select Case OverwriteMode Case OverwriteAll: Command = Command & " -aoa" ' الكتابة فوق الملفات Case OverwriteNone: Command = Command & " -aos" ' تخطي الملفات الموجودة Case OverwritePrompt MsgBox "خيار 'OverwritePrompt' غير مدعوم في وضع سطر الأوامر. سيتم استخدام 'OverwriteAll' افتراضيًا.", vbInformation, "تحذير" Command = Command & " -aoa" End Select End If ' تنفيذ الأمر باستخدام ShellWait ShellWait Command, vbHide ' التحكم في عرض رسالة النجاح If isInputArray Then MsgBox "تم فك الضغط بنجاح إلى '" & destinationPath & "'!", vbInformation, "نجاح" ElseIf Not IsInLoop Then MsgBox "تم فك الضغط بنجاح إلى '" & destinationPath & "'!", vbInformation, "نجاح" Else ArchivesList = ArchivesList & archivePaths(LBound(archivePaths)) & vbCrLf ' إضافة إلى قائمة الحلقة End If Cleanup: Set fso = Nothing Exit Sub ErrorHandler: Dim errorMsg As String If Err.Number = 450 Then errorMsg = "خطأ في تمرير المعاملات:" & vbCrLf & _ "الترتيب المتوقع:" & vbCrLf & _ "1. archivePaths (Variant) - المسارات الكاملة للأرشيفات (سلسلة أو مصفوفة)" & vbCrLf & _ "2. destinationPath (String) - المسار الوجهة لفك الضغط" & vbCrLf & _ "3. password (String, اختياري) - كلمة المرور" & vbCrLf & _ "4. Method (EnumArchiveMethod, اختياري) - WinRAR أو SevenZip" & vbCrLf & _ "5. OverwriteMode (EnumOverwriteMode, اختياري) - OverwriteAll أو OverwriteNone" & vbCrLf & _ "تفاصيل الخطأ: " & Err.Description Else errorMsg = "حدث خطأ أثناء فك الضغط: " & Err.Description End If MsgBox errorMsg, vbCritical, "خطأ" GoTo Cleanup End Sub ' دوال مساعدة للحلقات (فك الضغط) ' دالة مساعدة لبدء حلقة فك ضغط متعددة وتهيئة المتغيرات العامة Sub StartExtractionLoop() IsInLoop = True ' تفعيل وضع الحلقة ArchivesList = "" ' تهيئة قائمة الأرشيفات End Sub ' دالة مساعدة لعرض رسالة نجاح موحدة بعد انتهاء حلقة فك الضغط Sub ShowExtractionSuccess() If IsInLoop And ArchivesList <> "" Then MsgBox "تم فك الضغط بنجاح للملفات التالية:" & vbCrLf & ArchivesList, vbInformation, "نجاح" End If IsInLoop = False ' إنهاء وضع الحلقة ArchivesList = "" ' إعادة تهيئة القائمة End Sub ' دالة تستخدم لاختبار ' DetermineArchivePath ' التي تحدد مسار ملفي ' ("WinRAR : WinRAR.exe " أو "SevenZip : 7z.exe") ' تلقائيا أو يدوًا ' يمكن حذفها هى فقط كانت لتجربة الكود والتأكد من جلب مسارات التطبيقات Sub TestDetermineArchivePath() ' الغرض: اختبار دالة DetermineArchivePath لتحديد مسارات WinRAR و7-Zip ' المخرجات: ' - طباعة المسارات في نافذة Immediate إذا تم العثور عليها ' - عرض رسالة إذا لم يتم العثور على الأداة On Error GoTo ErrorHandler Dim tools As Variant Dim tool As Variant ' يجب أن يكون Variant لاستخدامه في For Each Dim archivePath As String ' قائمة الأدوات للاختبار tools = Array("WinRAR", "SevenZip") ' اختبار كل أداة For Each tool In tools archivePath = DetermineArchivePath(CStr(tool)) ' تحويل Variant إلى String صراحة If archivePath <> "" Then Debug.Print "تم العثور على " & tool & " في: " & archivePath Else MsgBox "لم يتم العثور على " & tool & ".", vbInformation, "نتيجة الاختبار" End If Next tool Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء اختبار DetermineArchivePath: " & Err.Description, vbCritical, "خطأ" Exit Sub End Sub الكود مرتبط بـ : ShellWait الغرض: تشغيل برنامج والانتظار حتى ينتهي مع السماح بمعالجة الأحداث الأخرى الكود داخل وحده نمطيه عامة باسم : basShellWait ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit '======================================================================================================================= '----------------------------------------------- الثوابت ----------------------------------------------- '======================================================================================================================= ' ثوابت عامة للتحكم في الانتظار والعمليات Public Const INFINITE As Long = &HFFFFFFFF ' مهلة لا نهائية، تُستخدم مع ShellW للانتظار حتى تنتهي العملية Public Const STATUS_PENDING As Long = &H103& ' 259 - حالة العملية مستمرة Public Const STILL_ACTIVE As Long = STATUS_PENDING ' تعني أن العملية لا تزال نشطة Public Const USER_TIMER_MINIMUM As Long = &HA& ' الحد الأدنى للمهلة (10 مللي ثانية) Public Const USER_TIMER_MAXIMUM As Long = &H7FFFFFFF ' الحد الأقصى للمهلة Public Const PROCESS_HAS_TERMINATED As Long = vbObjectError Or &HDEAD& ' رمز الخطأ عند انتهاء العملية '======================================================================================================================= '-------------------------------------------- التعدادات -------------------------------------------- '======================================================================================================================= ' تعداد للقيم المنطقية (TRUE/FALSE) Private Enum BOOL FALSE_ ' 0 - خطأ TRUE_ ' 1 - صحيح End Enum #If False Then Dim FALSE_, TRUE_ #End If ' تعداد لإعدادات ShellExecuteEx (الأقنعة) Private Enum SEE_Mask SEE_MASK_DEFAULT = &H0 ' استخدام القيم الافتراضية SEE_MASK_NOCLOSEPROCESS = &H40 ' الاحتفاظ بمقبض العملية لمعرفة متى تنتهي SEE_MASK_DOENVSUBST = &H200 ' توسيع متغيرات البيئة في المسارات SEE_MASK_FLAG_NO_UI = &H400 ' عدم عرض رسائل الخطأ من النظام ' ... (يمكن إضافة تعليقات لكل قناع إذا لزم الأمر) End Enum #If False Then Dim SEE_MASK_DEFAULT, SEE_MASK_NOCLOSEPROCESS, SEE_MASK_DOENVSUBST, SEE_MASK_FLAG_NO_UI #End If ' تعداد لأنماط عرض النافذة Private Enum E_ShowCmd SW_HIDE = 0 ' إخفاء النافذة وتنشيط نافذة أخرى SW_SHOWNORMAL = 1 ' عرض النافذة بحجمها الطبيعي وتنشيطها SW_SHOWMINIMIZED = 2 ' تصغير النافذة وتنشيطها SW_SHOWMAXIMIZED = 3 ' تكبير النافذة وتنشيطها ' ... (يمكن إكمال التعليقات لكل نمط إذا لزم الأمر) End Enum #If False Then Dim SW_HIDE, SW_SHOWNORMAL, SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED #End If ' تعداد عام لأنماط النافذة لـ ShellW Public Enum AppWinStyle vbHide = SW_HIDE vbShowNormal = SW_SHOWNORMAL vbShowMinimized = SW_SHOWMINIMIZED vbShowMaximized = SW_SHOWMAXIMIZED ' ... (يمكن إكمال التعليقات إذا لزم الأمر) End Enum #If False Then Dim vbHide, vbShowNormal, vbShowMinimized, vbShowMaximized #End If '======================================================================================================================= '--------------------------------------- تعريف الأنواع --------------------------------------- '======================================================================================================================= ' نوع بيانات لتخزين معلومات ShellExecuteEx Private Type SHELLEXECUTEINFO cbSize As Long ' حجم الهيكل بالبايت fMask As SEE_Mask ' الأقنعة لتحديد السلوك (مثل الاحتفاظ بمقبض العملية) HWnd As Long ' مقبض النافذة الأم (اختياري) lpVerb As String ' الأمر (مثل "open" أو "print") lpFile As String ' مسار الملف أو الأمر المراد تنفيذه lpParameters As String ' المعاملات (اختياري) lpDirectory As String ' دليل العمل (اختياري) nShow As E_ShowCmd ' نمط عرض النافذة hInstApp As Long ' نتيجة التنفيذ (أكبر من 32 عند النجاح) lpIDList As Long ' معرف القائمة (غير مستخدم هنا) lpClass As String ' نوع الملف (غير مستخدم هنا) hkeyClass As Long ' مفتاح السجل (غير مستخدم هنا) dwHotKey As Long ' اختصار لوحة المفاتيح (غير مستخدم هنا) #If True Then hIcon As Long ' مقبض الأيقونة (غير مستخدم في الإصدارات الحديثة) #Else hMonitor As Long ' مقبض الشاشة (غير مستخدم هنا) #End If hProcess As Long ' مقبض العملية الناتجة End Type '======================================================================================================================= '---------------------------------------- تعريفات API ---------------------------------------- '======================================================================================================================= ' تعريفات API لنظام 64 بت #If VBA7 And Win64 Then 'Used only by ShellWait Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As BOOL, ByVal dwProcessId As Long) As Long 'Used by both ShellWait and ShellW Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As BOOL Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As Long) As Long Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As BOOL Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "User32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As BOOL, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long 'Used by ShellW Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As BOOL, Optional ByVal lpTimerName As Long) As Long Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As BOOL Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As BOOL) As BOOL Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As BOOL Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) Dim hProcess As LongPtr #Else ' تعريفات API لنظام 32 بت 'Used only by ShellWait Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As BOOL, ByVal dwProcessId As Long) As Long 'Used by both ShellWait and ShellW Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As BOOL Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As BOOL Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "User32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As BOOL, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long 'Used by ShellW Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As BOOL, Optional ByVal lpTimerName As Long) As Long Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As BOOL Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As BOOL) As BOOL Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As BOOL Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) Dim hProcess As Long #End If '======================================================================================================================= '---------------------------------------- المتغيرات العامة ---------------------------------------- '======================================================================================================================= Public g_ExitDoLoops As Boolean ' متغير عام للتحكم في إنهاء الحلقات (يُضبط إلى True عند إنهاء البرنامج) '======================================================================================================================= '--------------------------------------- المتغيرات الخاصة --------------------------------------- '======================================================================================================================= Private m_Busy1 As Boolean ' علامة مشغول لـ ShellWait Private m_Busy2 As Boolean ' علامة مشغول لـ ShellW '======================================================================================================================= '------------------------------------------ الدوال العامة ------------------------------------------ '======================================================================================================================= ' دالة لتشغيل برنامج والانتظار حتى ينتهي مع السماح بمعالجة الأحداث الأخرى Public Function ShellWait(ByRef PathName As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus) As Long Const PROCESS_QUERY_INFORMATION = &H400&, QS_ALLINPUT = &H4FF&, SYNCHRONIZE = &H100000 Dim sPath As String ' متغير لتخزين المسار بعد توسيع متغيرات البيئة ' التحقق من عدم وجود استدعاء آخر نشط للدالة If Not m_Busy1 Then m_Busy1 = True Else Exit Function ' توسيع متغيرات البيئة إذا وجدت في المسار If InStr(PathName, "%") = 0& Then sPath = PathName Else SysReAllocStringLen VarPtr(sPath), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1& ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(sPath), Len(sPath) + 1& End If ' تشغيل البرنامج والحصول على مقبض العملية On Error GoTo 1 hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, FALSE_, Shell(sPath, WindowStyle)) On Error GoTo 0 If hProcess Then sPath = vbNullString g_ExitDoLoops = False ' الانتظار حتى تنتهي العملية مع السماح بمعالجة الأحداث Do While MsgWaitForMultipleObjects(1&, hProcess, FALSE_, INFINITE, QS_ALLINPUT) DoEvents If g_ExitDoLoops Then Exit Do Loop ' استرجاع رمز الخروج وإغلاق المقبض WindowStyle = GetExitCodeProcess(hProcess, ShellWait): Debug.Assert WindowStyle hProcess = CloseHandle(hProcess): Debug.Assert hProcess End If m_Busy1 = False Exit Function 1 m_Busy1 = False ' إعادة تعيين علامة المشغول في حالة الخطأ End Function ' دالة لتشغيل ملف أو أمر مع خيار الانتظار لمدة محددة Public Function ShellW(ByRef PathName As String, Optional ByVal WindowStyle As AppWinStyle = vbShowNormal, _ Optional ByVal Wait As Long) As Long Const MAX_PATH = 260&, QS_ALLINPUT = &H4FF&, WAIT_OBJECT_0 = &H0& Dim TimedOut As Boolean, nCount As Long, pHandles As LongPtr, RV As Long, SEI As SHELLEXECUTEINFO ' تهيئة الدالة والتحقق من المدخلات Err.Clear If m_Busy2 Then Exit Function If LenB(PathName) Then m_Busy2 = True Else Exit Function With SEI .cbSize = LenB(SEI) .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_DOENVSUBST Or SEE_MASK_FLAG_NO_UI ' إعدادات للاحتفاظ بالمقبض وتوسيع المتغيرات .nShow = WindowStyle ' توسيع متغيرات البيئة إذا وجدت If InStr(PathName, "%") Then SysReAllocStringLen VarPtr(.lpFile), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1& ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(.lpFile), Len(.lpFile) + 1& Else .lpFile = PathName End If ' تبسيط المسار إذا احتوى على "." أو ".." If InStr(.lpFile, "\.") <> 0& Or InStr(.lpFile, ".\") <> 0& Then If Len(.lpFile) < MAX_PATH Then SysReAllocStringLen VarPtr(.lpVerb), , MAX_PATH - 1& If PathCanonicalizeW(StrPtr(.lpVerb), StrPtr(.lpFile)) Then SysReAllocString VarPtr(.lpFile), StrPtr(.lpVerb) End If .lpVerb = vbNullString End If End If ' فصل المعاملات عن المسار SysReAllocString VarPtr(.lpParameters), PathGetArgsW(StrPtr(.lpFile)) If LenB(.lpParameters) Then PathRemoveArgsW StrPtr(.lpFile) If InStr(.lpParameters, """") Then .lpParameters = Replace(.lpParameters, """", """""""") End If ' تنفيذ الأمر If ShellExecuteExW(VarPtr(SEI)) Then ShellW = GetProcessId(.hProcess) If Wait Then .lpFile = vbNullString .lpParameters = vbNullString g_ExitDoLoops = False If .hProcess Then nCount = 1& pHandles = VarPtr(.hProcess) End If ' إعداد مؤقت إذا كانت المهلة محددة If Wait > INFINITE Then .hIcon = CreateWaitableTimerW If .hIcon Then nCount = nCount + 1& pHandles = VarPtr(.hIcon) Wait = SetWaitableTimer(.hIcon, CCur(-Wait)): Debug.Assert Wait End If End If ' الانتظار مع معالجة الأحداث Do RV = MsgWaitForMultipleObjects(nCount, ByVal pHandles, FALSE_, INFINITE, QS_ALLINPUT) If RV < nCount Then If .hIcon Then TimedOut = RV = 0& RV = CloseHandle(.hIcon): Debug.Assert RV End If Err.Clear Exit Do End If DoEvents Loop Until g_ExitDoLoops ' استرجاع رمز الخروج إذا انتهت العملية If Not (TimedOut Or g_ExitDoLoops) Then RV = GetExitCodeProcess(.hProcess, ShellW): Debug.Assert RV Err = PROCESS_HAS_TERMINATED Err.Description = "Exit Code" End If End If If .hProcess Then RV = CloseHandle(.hProcess): Debug.Assert RV End If End With m_Busy2 = False End Function ' دالة بسيطة لتشغيل أمر باستخدام WScript.Shell Public Function ShellWScript(ByRef Command As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus, _ Optional ByVal WaitOnReturn As Boolean) As Long Dim ws As Object Set ws = CreateObject("Wscript.Shell") ShellWScript = ws.Run(Command, WindowStyle, WaitOnReturn) End Function اوامر الاستدعاء المختلفة : سوف نقوم بعمل وحده نمطيه عامه لتجربة : WinRAR اسم الوحده النمطيه : basArchiveExamplesWinRAR Option Compare Database Option Explicit ' وحدة نمطية تحتوي على أمثلة شاملة لضغط وفك ضغط باستخدام WinRAR مع كل الخيارات ' =========================================================================== ' 1. ضغط ملف واحد ' =========================================================================== ' بدون كلمة مرور، مستوى ضغط عادي Sub CompressSingleFileNoPasswordWinRAR() CompressItems "file1.txt", , WinRAR, ArchiveRAR, CompressionNormal ' الناتج: file1.rar في CurrentProject.Path End Sub ' مع كلمة مرور، مستوى ضغط أقصى Sub CompressSingleFileWithPasswordMaxCompressionWinRAR() Dim password As String ' تعيين كلمة المرور password = "officena" CompressItems "file1.txt", password, WinRAR, ArchiveRAR, CompressionMaximum ' الناتج: file1.rar (مشفر، مضغوط بأقصى مستوى) في CurrentProject.Path End Sub ' مع تقسيم الأرشيف (Split500MB) Sub CompressSingleFileWithSplitWinRAR() Dim password As String ' تعيين كلمة المرور password = "officena" CompressItems "file1.txt", password, WinRAR, ArchiveRAR, CompressionNormal, Split500MB ' الناتج: file1.rar مقسم إلى أجزاء بحجم 500 ميجابايت End Sub ' ذاتي الاستخراج (SFX) مع تعليق ' ضغط مجلد واحد مع تعليق باستخدام متغير لكلمة المرور Sub CompressSingleFileSFXWithCommentWinRAR() Dim commentLines As Variant Dim commentFile As String Dim password As String ' تعيين كلمة المرور password = "officena" ' إعداد التعليق باستخدام المتغير commentLines = Array( _ "منتديات أوفيسنا", _ "www.officena.net", _ "وقت وتاريخ إنشاء الأرشيف:", _ Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _ "كلمة المرور لفك الضغط: " & password, _ "مع أطيب الأماني: أبو جودى") commentFile = CreateCommentFile(commentLines, False) ' استخدام كلمة المرور في الضغط CompressItems CurrentProject.Path & "\Folder1", password, WinRAR, ArchiveRAR, CompressionNormal, , , , , commentFile ' الناتج: Folder1.rar (مشفر بكلمة المرور "MS-Access(officena)"، مع تعليق) في CurrentProject.Path End Sub ' =========================================================================== ' 2. فك ضغط ملف واحد ' =========================================================================== ' بدون كلمة مرور، الكتابة فوق الملفات Sub ExtractSingleFileNoPasswordOverwriteWinRAR() ExtractItems CurrentProject.Path & "\file1.rar", CurrentProject.Path & "\Extracted", , WinRAR, OverwriteAll ' الناتج: محتويات file1.rar مفكوكة في CurrentProject.Path\Extracted مع الكتابة فوق الملفات End Sub ' مع كلمة مرور، تجاهل الملفات الموجودة Sub ExtractSingleFileWithPasswordNoOverwriteWinRAR() Dim password As String ' تعيين كلمة المرور password = "officena" ExtractItems CurrentProject.Path & "\file1.rar", CurrentProject.Path & "\Extracted", password, WinRAR, OverwriteNone ' الناتج: محتويات file1.rar مفكوكة في CurrentProject.Path\Extracted مع تجاهل الملفات الموجودة End Sub ' =========================================================================== ' 3. ضغط عدة ملفات (كل ملف على حدة) ' =========================================================================== ' بدون كلمة مرور، نوع ZIP Sub CompressMultipleFilesSeparateNoPasswordZipWinRAR() Dim filesArray As Variant filesArray = Array(CurrentProject.Path & "\file1.txt", CurrentProject.Path & "\file2.docx", CurrentProject.Path & "\file3.pdf") StartCompressionLoop Dim filePath As Variant For Each filePath In filesArray CompressItems CStr(filePath), , WinRAR, ArchiveZIP, CompressionNormal Next filePath ShowCompressionSuccess ' الناتج: file1.zip, file2.zip, file3.zip في CurrentProject.Path End Sub ' مع كلمة مرور وتعليق Sub CompressMultipleFilesSeparateWithCommentWinRAR() Dim commentLines As Variant Dim commentFile As String Dim password As String ' تعيين كلمة المرور password = "officena" ' إعداد التعليق باستخدام المتغير commentLines = Array( _ "منتديات أوفيسنا", _ "www.officena.net", _ "وقت وتاريخ إنشاء الأرشيف:", _ Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _ "كلمة المرور لفك الضغط: " & password, _ "مع أطيب الأماني: أبو جودى") commentFile = CreateCommentFile(commentLines, False) Dim filesArray As Variant filesArray = Array(CurrentProject.Path & "\file1.txt", CurrentProject.Path & "\file2.docx", CurrentProject.Path & "\file3.pdf") StartCompressionLoop Dim filePath As Variant For Each filePath In filesArray CompressItems CStr(filePath), password, WinRAR, ArchiveRAR, CompressionNormal, , , , , commentFile Next filePath ShowCompressionSuccess ' الناتج: file1.rar, file2.rar, file3.rar (مشفرة، مع تعليق) في CurrentProject.Path End Sub ' =========================================================================== ' 4. فك ضغط عدة ملفات (كل ملف على حدة) ' =========================================================================== ' بدون كلمة مرور Sub ExtractMultipleFilesSeparateNoPasswordWinRAR() Dim filesArray As Variant filesArray = Array(CurrentProject.Path & "\file1.rar", CurrentProject.Path & "\file2.rar", CurrentProject.Path & "\file3.rar") StartExtractionLoop Dim filePath As Variant For Each filePath In filesArray ExtractItems CStr(filePath), CurrentProject.Path, , WinRAR, OverwriteAll Next filePath ShowExtractionSuccess ' الناتج: محتويات كل ملف مفكوكة في CurrentProject.Path End Sub ' مع كلمة مرور Sub ExtractMultipleFilesSeparateWithPasswordWinRAR() Dim password As String ' تعيين كلمة المرور password = "officena" Dim filesArray As Variant filesArray = Array(CurrentProject.Path & "\file1.rar", CurrentProject.Path & "\file2.rar", CurrentProject.Path & "\file3.rar") StartExtractionLoop Dim filePath As Variant For Each filePath In filesArray ExtractItems CStr(filePath), CurrentProject.Path, password, WinRAR, OverwriteNone Next filePath ShowExtractionSuccess ' الناتج: محتويات كل ملف مفكوكة في CurrentProject.Path مع تجاهل الموجود End Sub ' =========================================================================== ' 5. ضغط عدة ملفات في أرشيف واحد ' =========================================================================== ' بدون كلمة مرور، تقسيم 100MB Sub CompressMultipleFilesOneArchiveWithSplitWinRAR() Dim files As Variant files = Array("file1.txt", "file2.docx", "file3.pdf") CompressItems files, , WinRAR, ArchiveRAR, CompressionNormal, Split100MB, , "CompressedFiles" ' الناتج: CompressedFiles.rar مقسم إلى أجزاء بحجم 100 ميجابايت End Sub ' مع كلمة مرور وتعليق Sub CompressMultipleFilesOneArchiveWithCommentWinRAR() Dim commentLines As Variant Dim commentFile As String Dim password As String ' تعيين كلمة المرور password = "officena" ' إعداد التعليق باستخدام المتغير commentLines = Array( _ "منتديات أوفيسنا", _ "www.officena.net", _ "وقت وتاريخ إنشاء الأرشيف:", _ Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _ "كلمة المرور لفك الضغط: " & password, _ "مع أطيب الأماني: أبو جودى") commentFile = CreateCommentFile(commentLines, False) Dim files As Variant files = Array("file1.txt", "file2.docx", "file3.pdf") CompressItems files, password, WinRAR, ArchiveRAR, CompressionMaximum, , , "CompressedFiles", , commentFile ' الناتج: CompressedFiles.rar (مشفر، مع تعليق) في CurrentProject.Path End Sub ' =========================================================================== ' 6. فك ضغط أرشيف واحد يحتوي على عدة ملفات ' =========================================================================== ' بدون كلمة مرور Sub ExtractMultipleFilesOneArchiveNoPasswordWinRAR() Dim archives As Variant archives = Array(CurrentProject.Path & "\CompressedFiles.rar") ExtractItems archives, CurrentProject.Path, , WinRAR, OverwriteAll ' الناتج: محتويات CompressedFiles.rar مفكوكة في CurrentProject.Path End Sub ' مع كلمة مرور Sub ExtractMultipleFilesOneArchiveWithPasswordWinRAR() Dim password As String ' تعيين كلمة المرور password = "officena" Dim archives As Variant archives = Array(CurrentProject.Path & "\CompressedFiles.rar") ExtractItems archives, CurrentProject.Path, password, WinRAR, OverwriteNone ' الناتج: محتويات CompressedFiles.rar مفكوكة في CurrentProject.Path مع تجاهل الموجود End Sub ' =========================================================================== ' 7. ضغط مجلد واحد ' =========================================================================== ' مع تعليق Sub CompressSingleFolderWithCommentWinRAR() Dim commentLines As Variant Dim password As String ' تعيين كلمة المرور password = "officena" ' إعداد التعليق باستخدام المتغير commentLines = Array( _ "منتديات أوفيسنا", _ "www.officena.net", _ "وقت وتاريخ إنشاء الأرشيف:", _ Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _ "كلمة المرور لفك الضغط: " & password, _ "مع أطيب الأماني: أبو جودى") Dim commentFile As String commentFile = CreateCommentFile(commentLines, False) CompressItems CurrentProject.Path & "\Folder1", password, WinRAR, ArchiveRAR, CompressionNormal, , , , , commentFile ' الناتج: Folder1.rar (مشفر، مع تعليق) في CurrentProject.Path End Sub ' مع تقسيم وSFX Sub CompressSingleFolderWithSplitSFXWinRAR() Dim password As String ' تعيين كلمة المرور password = "officena" CompressItems CurrentProject.Path & "\Folder1", password, WinRAR, ArchiveRAR, CompressionNormal, Split1GB, , "Folder1SFX", True ' الناتج: Folder1SFX.exe مقسم إلى أجزاء بحجم 1 جيجابايت End Sub ' =========================================================================== ' 8. ضغط عدة مجلدات (كل مجلد على حدة) ' =========================================================================== ' بدون كلمة مرور Sub CompressMultipleFoldersNoPasswordWinRAR() Dim foldersArray As Variant foldersArray = Array(CurrentProject.Path & "\Folder1", CurrentProject.Path & "\Folder2") StartCompressionLoop Dim folderPath As Variant For Each folderPath In foldersArray CompressItems CStr(folderPath), , WinRAR, ArchiveRAR, CompressionNormal Next folderPath ShowCompressionSuccess ' الناتج: Folder1.rar, Folder2.rar في CurrentProject.Path End Sub ' مع كلمة مرور وتعليق Sub CompressMultipleFoldersWithCommentWinRAR() Dim commentLines As Variant Dim password As String ' تعيين كلمة المرور password = "officena" ' إعداد التعليق باستخدام المتغير commentLines = Array( _ "منتديات أوفيسنا", _ "www.officena.net", _ "وقت وتاريخ إنشاء الأرشيف:", _ Format(Now, "dd-mm-yyyy hh:nn AM/PM"), _ "كلمة المرور لفك الضغط: " & password, _ "مع أطيب الأماني: أبو جودى") Dim commentFile As String commentFile = CreateCommentFile(commentLines, False) Dim foldersArray As Variant foldersArray = Array(CurrentProject.Path & "\Folder1", CurrentProject.Path & "\Folder2") StartCompressionLoop Dim folderPath As Variant For Each folderPath In foldersArray CompressItems CStr(folderPath), password, WinRAR, ArchiveRAR, CompressionNormal, , , , , commentFile Next folderPath ShowCompressionSuccess ' الناتج: Folder1.rar, Folder2.rar (مشفرة، مع تعليق) في CurrentProject.Path End Sub ' =========================================================================== ' 9. فك ضغط مجلد واحد ' =========================================================================== ' بدون كلمة مرور Sub ExtractSingleFolderNoPasswordWinRAR() ExtractItems CurrentProject.Path & "\Folder1.rar", CurrentProject.Path & "\Extracted", , WinRAR, OverwriteAll ' الناتج: محتويات Folder1.rar مفكوكة في CurrentProject.Path\Extracted End Sub ' مع كلمة مرور Sub ExtractSingleFolderWithPasswordWinRAR() Dim password As String ' تعيين كلمة المرور password = "officena" ExtractItems CurrentProject.Path & "\Folder1.rar", CurrentProject.Path & "\Extracted", password, WinRAR, OverwriteNone ' الناتج: محتويات Folder1.rar مفكوكة في CurrentProject.Path\Extracted مع تجاهل الموجود End Sub سوف نقوم بعمل وحده نمطيه عامه لتجربة : 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(CurrentProject.Path & "\file1.txt", CurrentProject.Path & "\file2.docx", CurrentProject.Path & "\file3.pdf") StartCompressionLoop Dim filePath As Variant For Each filePath In filesArray CompressItems CStr(filePath), , SevenZip, Archive7z, CompressionNormal Next filePath ShowCompressionSuccess ' الناتج: file1.7z, file2.7z, file3.7z في CurrentProject.Path End Sub ' مع كلمة مرور وتقسيم Sub CompressMultipleFilesSeparateWithSplitSevenZip() Dim password As String ' تعيين كلمة المرور password = "officena" Dim filesArray As Variant filesArray = Array(CurrentProject.Path & "\file1.txt", CurrentProject.Path & "\file2.docx", CurrentProject.Path & "\file3.pdf") StartCompressionLoop Dim filePath As Variant For Each filePath In filesArray CompressItems CStr(filePath), password, SevenZip, Archive7z, CompressionNormal, Split100MB Next filePath ShowCompressionSuccess ' الناتج: file1.7z, file2.7z, file3.7z مقسمة إلى أجزاء بحجم 100 ميجابايت End Sub ' =========================================================================== ' 4. فك ضغط عدة ملفات (كل ملف على حدة) ' =========================================================================== ' بدون كلمة مرور Sub ExtractMultipleFilesSeparateNoPasswordSevenZip() Dim filesArray As Variant filesArray = Array(CurrentProject.Path & "\file1.7z", CurrentProject.Path & "\file2.7z", CurrentProject.Path & "\file3.7z") StartExtractionLoop Dim filePath As Variant For Each filePath In filesArray ExtractItems CStr(filePath), CurrentProject.Path, , SevenZip, OverwriteAll Next filePath ShowExtractionSuccess ' الناتج: محتويات كل ملف مفكوكة في CurrentProject.Path End Sub ' مع كلمة مرور Sub ExtractMultipleFilesSeparateWithPasswordSevenZip() Dim password As String ' تعيين كلمة المرور password = "officena" Dim filesArray As Variant filesArray = Array(CurrentProject.Path & "\file1.7z", CurrentProject.Path & "\file2.7z", CurrentProject.Path & "\file3.7z") StartExtractionLoop Dim filePath As Variant For Each filePath In filesArray ExtractItems CStr(filePath), CurrentProject.Path, password, SevenZip, OverwriteNone Next filePath ShowExtractionSuccess ' الناتج: محتويات كل ملف مفكوكة في CurrentProject.Path مع تجاهل الموجود End Sub ' =========================================================================== ' 5. ضغط عدة ملفات في أرشيف واحد ' =========================================================================== ' بدون كلمة مرور، تقسيم 100MB Sub CompressMultipleFilesOneArchiveWithSplitSevenZip() Dim files As Variant files = Array("file1.txt", "file2.docx", "file3.pdf") CompressItems files, , SevenZip, Archive7z, CompressionNormal, Split100MB, , "CompressedFiles" ' الناتج: CompressedFiles.7z مقسم إلى أجزاء بحجم 100 ميجابايت End Sub ' مع كلمة مرور وSFX Sub CompressMultipleFilesOneArchiveSFXSevenZip() Dim password As String ' تعيين كلمة المرور password = "officena" Dim files As Variant files = Array("file1.txt", "file2.docx", "file3.pdf") CompressItems files, password, SevenZip, Archive7z, CompressionMaximum, , , "CompressedFilesSFX", True ' الناتج: CompressedFilesSFX.exe (مشفر) في CurrentProject.Path End Sub ' =========================================================================== ' 6. فك ضغط أرشيف واحد يحتوي على عدة ملفات ' =========================================================================== ' بدون كلمة مرور Sub ExtractMultipleFilesOneArchiveNoPasswordSevenZip() Dim archives As Variant archives = Array(CurrentProject.Path & "\CompressedFiles.7z") ExtractItems archives, CurrentProject.Path, , SevenZip, OverwriteAll ' الناتج: محتويات CompressedFiles.7z مفكوكة في CurrentProject.Path End Sub ' مع كلمة مرور Sub ExtractMultipleFilesOneArchiveWithPasswordSevenZip() Dim password As String ' تعيين كلمة المرور password = "officena" Dim archives As Variant archives = Array(CurrentProject.Path & "\CompressedFiles.7z") ExtractItems archives, CurrentProject.Path, password, SevenZip, OverwriteNone ' الناتج: محتويات CompressedFiles.7z مفكوكة في CurrentProject.Path مع تجاهل الموجود End Sub ' =========================================================================== ' 7. ضغط مجلد واحد ' =========================================================================== ' مع تقسيم وSFX Sub CompressSingleFolderWithSplitSFXSevenZip() Dim password As String ' تعيين كلمة المرور password = "officena" CompressItems CurrentProject.Path & "\Folder1", password, SevenZip, Archive7z, CompressionNormal, Split1GB, , "Folder1SFX", True ' الناتج: Folder1SFX.exe مقسم إلى أجزاء بحجم 1 جيجابايت End Sub ' =========================================================================== ' 8. ضغط عدة مجلدات (كل مجلد على حدة) ' =========================================================================== ' بدون كلمة مرور Sub CompressMultipleFoldersNoPasswordSevenZip() Dim foldersArray As Variant foldersArray = Array(CurrentProject.Path & "\Folder1", CurrentProject.Path & "\Folder2") StartCompressionLoop Dim folderPath As Variant For Each folderPath In foldersArray CompressItems CStr(folderPath), , SevenZip, Archive7z, CompressionNormal Next folderPath ShowCompressionSuccess ' الناتج: Folder1.7z, Folder2.7z في CurrentProject.Path End Sub ' مع كلمة مرور وتقسيم Sub CompressMultipleFoldersWithSplitSevenZip() Dim password As String ' تعيين كلمة المرور password = "officena" Dim foldersArray As Variant foldersArray = Array(CurrentProject.Path & "\Folder1", CurrentProject.Path & "\Folder2") StartCompressionLoop Dim folderPath As Variant For Each folderPath In foldersArray CompressItems CStr(folderPath), password, SevenZip, Archive7z, CompressionNormal, Split500MB Next folderPath ShowCompressionSuccess ' الناتج: Folder1.7z, Folder2.7z مقسمة إلى أجزاء بحجم 500 ميجابايت End Sub ' =========================================================================== ' 9. فك ضغط مجلد واحد ' =========================================================================== ' بدون كلمة مرور Sub ExtractSingleFolderNoPasswordSevenZip() ExtractItems CurrentProject.Path & "\Folder1.7z", CurrentProject.Path & "\Extracted", , SevenZip, OverwriteAll ' الناتج: محتويات Folder1.7z مفكوكة في CurrentProject.Path\Extracted End Sub ' مع كلمة مرور Sub ExtractSingleFolderWithPasswordSevenZip() Dim password As String ' تعيين كلمة المرور password = "officena" ExtractItems CurrentProject.Path & "\Folder1.7z", CurrentProject.Path & "\Extracted", password, SevenZip, OverwriteNone ' الناتج: محتويات Folder1.7z مفكوكة في CurrentProject.Path\Extracted مع تجاهل الموجود End Sub فى انتظار آرائكم بشغف انا كتبت اكواد التجربة على اعتبار وجود المجلدات والملفات فى مسار قاعدة البيانات على ان يكون اسماء المجلدات كالتالى : Folder1 Folder2 واسماء الملفات كالتالى : file1.txt file2.docx file3.pdf طبعا يمكنكم تغيير اسماء وأماكن المجلدات والمسارات فى اكواد التجربه كما يحلو لكم لم أقم فقط بتجربـــــة التقسيم عند الضغط وطبعا محاولة فك الناتج من الملفات المضغوطه والمقسمه مستوى الضفط أما ما دون ذلك تمت تجربته ولكن قد أكون أخطأت فى أى شئ بسبب كبر الكود وتشعبه لذلك فى انتظار مراجعتكم وآرائكم ان شاء الله اتمنى لكم تجربة ممتعة OfficenaZip.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

شاهد الشرح ولو محتاج نسخه تجريبية كلمني واتساب https://wa.me/+201068694941?text=محتاج_نسخه_تجريبية او تليجرام https://t.me/Programming472

السلام عليكم ورحمة والله تعالى وبركاته طيب ببساطه انظر للسلسلة النصية الاتية "Moh8202281012343434" ونريد التعديل عليها لتظهر بهذا الشكل "Moh-820-228-101-234-343-4" او بهذا الشكل "Moh,820,228,101,234,343,4" او بهذا الشكل Moh820/228101/234343/4 يتم عمل ذلك من خلال الكود الاتى Function ReFormat(ByVal strText As String, Optional strSymbol As String = "-", Optional intCountDigits As Integer = 3) Dim i As Long ReFormat = "" For i = 0 To Len(strText) - 1 Step intCountDigits If i = 0 Then ReFormat = Mid(strText, i + 1, intCountDigits) Else ReFormat = ReFormat & strSymbol & Mid(strText, i + 1, intCountDigits) End If Next i End Function syntax code ReFormat(string ,Symbol, Count Digits) Result By default syntax used ReFormat(string) Symbol >-->> - Count Digits >-->> 3 اذا من خلال استدعاء الكود عن طريق البنية المفضلة الاتية: ReFormat(string) تحصل على اضافة العلامة - بعد كل 3 مواضع فى السلسلة النصية اما اذا اردت التعديل فى شكل الرمز وعدد المواضع يمكنك استخدام الكود الاتى : ReFormat(string ,Symbol, Count Digits) مثلا لو اردت استخدام الرمز $ بدلا من الرمز - وتريد وضع الرمز فى السلسلة النصية بعد كل خمس مواضع يكون الكود كالأتى: ReFormat(string ,"$", 5)

انشاء مجلد واحد او العديد من المجلدات دفعة واحدة CreateMultiFolders.mdb

فكرة جديدة لاحتساب تاريخ نهاية الصلاحية بدون بدون حتى كتابة تاريخ الصلاحية داخل الجدول ExpirationDate.mdb

التلميح داخل مربع النص مع علامة مائية فى حالة كان مربع النص فارغ ويختفيان بمجرد التركيز داخل مربه النص او الكتابة ... ToolTip.mdb

شفافيــــــــــــTransparent Formsــــــــــــة النماذج Transparent Forms.mdb

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله تعالى وبركاته بحكم الاوقات التي يعيشها الان الكثير من ابناء الامة العربية الدين هم مقبلين على الامتحانات قررت ان اشارك موضوعي المتواضع هدا معكم وان شاء الله تستفيدوا منه اليوم ان شاء الله سنتعرف على بعض النقاط التي يجب ان تلتزم بها لكي تحضر للامتحانات بطريقة سليمة اولا-مشكل تشتت الداكرة هدا المشكل سببه الاول والرئيسي هو التعب.وهدا شيء طبيعي لاننا نرى العديد من التلاميد والطلبة يسهرون الى غاية اوقات متاخرة من الليل. ولحل هدا المشكل اقترح عليكم اعزائي شيء جيد.بل افضل حل.وهو قراءة ما تيسر من القران على الاقل عشرة دقائق او تسبيح الله عز وجل ولوبضعة دقائق او التوضؤ والصلاة ركعتين لله تعالى كل هدا كاف لاسترجاع الهدوء والتركيز والراحة النفسية ثانيا-مشكل الدراسة والمراجعة فقط في الليل اخي او اختي هدا امر خاطئ ادا كنت تفعله لانه يشكل لك خطر التركيز يوم الامتحان فالنوم ليلا لايعوض بالنوم نهارا لدلك نم في وقت مبكر وحاول ان تستيقظ في الصباح الباكر وابدء العمل على بركة الله ودلك يتجلى في قول الله سبحانه وتعالى "وجعلنا الليل سباتا" ثم قوله تعالى " ان ناشئة الليل هي أشد وطأ أقوم قيلا " ثالثا-الطريقة السليمة للمراجعة للامتحانات اثناء المراجعة يجب على الشخص ان ياخد النقاط المهمة في الدرس ثم حفظها ادا كانت تستلزم دلك رابعا-طريقة الحفظ السليمة بعد تلخيصك الدرس تاتي مرحلة حفظ التلخيص.واسهل طريقة للحفظ بالنسبة لي هي الطريقة التي يستعملها حملة كتاب الله عز وجل وهي تكرار مثلا الجملة عشر مرات لكي تبقى عالقة في الداكرة ثم مسالة المحيط الخاص بالحفظ يجب ان يكوم مضاء ومهوى وان تحفظ بصوت مرتفع ولا توجد ضوضاء في المكان اي يجب ان تكون منعزل. ثم بعد الحفظ يمكنك ان تغلق الثغرات بشرحك الدرس لشخص اخر كيفما كان نوعه بحيث تعتبر نفسك انت الاستاد وهو التلميد. خامسا-مراجعة متكررة بين فترات متقاربة لكي لا تكون عرضة للنسيان. سادسا-القلق قبل الامتحان وكيفية التغلب عليها. تنتج حالات القلق عن خوف التلميد من رسوب او عدم تحقيق النتيجة التي يطمح اليها وهدا القلق ادا طال حتى اوقات الدخول في وسط الامتحان يكون امر خطير جدا يؤدي الى حدوث امراض نفسية اما في الامتحان او بعده. وللتخلص من هدا القلق والخوف يجب عليك اخي او اختي ان تثق في الله سبحانه ثم ان تثق في نفسك مادمت قد راجعت دروسك ثم تدكر قول الله سبحانه وتعالى " أَلَا بِذِكْرِ اللهِ تَطْمَئِنُّ الْقُلُوْب" حاول ان لا تزيل التسبيح والتكبير من فمك. سابعا-حل التمارين والامتحانات السابقة حتى تتعود على الامتحان وتدخل اليه كانه فرض في القسم وشيء عادي. ثامنا-لا تراجع او تحفظ دروسك وانت تعيش مشكلة اجتماعية او نفسية .يجب عليك حل المشاكل ثم ابدء بالعمل على بركة الله. تاسعا-يجب ان تخطط لما تريد ان تراجع الى غاية الامتحان ثم الالتزام بتطبيق ما خططت له. عاشرا-لا تؤخر عمل اليوم الى الغد. وفي الاخير لدي هدية لكم وهي عبارة عن دعاء للامتحان ربي ادخلني مدخل صدق واخرجني مخرج صدق واجعل لي من لدنك سلطانا ونصيرا وقل جاء الحق وزهق الباطل ان الباطل كان زهوقا .. قل لو كان البحر مداد لكلمات ربي لنفذ البحر قبل ان تنفذ كلمات ربي ولو جئنا بمثله مددا.. يامعلم ابراهيم علمني ويامفهم سليمان فهمني .. وقت توزيع الاسئلة قراءة اية الكرسي والمعوذات والدعاء.. اللهم لا سهلا الا ما جعلته سهلا وانت إذا شئت جعلت الحزن سهلا اذا مسك الطالب ورقة الامتحان .. ربي اشرح لي صدري ويسر لي امري واحلل عقدة من لساني يفقهو قولي .. اذا نسي امرا .. عسى ان يهديني ربي لأقرب من هذا رشدا .. اذا اصيب الطالب بهم او كرب .. اللهم اني عبدك ابن عبدك ابن امتك ناصيتي بيدك ماضي في حكمك عدل في قضاؤك اسألك بكل اسم هو لك سميت به نفسك أو استأثرت به في على الغيب عندك ان تجعل القران ربيع قلبي ونور صدري وجلاء حزني وذهاب همي وصدق الله العظيم حين قال: (( إِنا لاَ نُضِيعُ أَجْرَ مَنْ أَحْسَنَ عَمَلاً)) والحمد لله رب العالمين الى هنا اكون قد وصلت الى نهاية الموضوع ارجوا من الله ان تكونوا قد استفدتم من الموضوع وشكرا بالتوفيق والنجاح ان شاء الله كان معكم الاخ المايسترو القائد

اليكم شيت قوائم الفصول وكشوف اعمال السنة على اخر التعديلات للقرار377 وكشوف الانشطة مفتوح بدون حماية وسهل التعديل فيه بالحذف والاضافة للطلبة ارجو ان يكون مفيدا للجميع https://up.top4top.net/downloadf-669x4t571-rar.html