shellexecutor شخابيط و افكار : تنفيذ الأوامر والملفات في بيئة Windows مع تحكم دقيق في العمليات

[ابو جودي]

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

أشارك معكم اليوم وحدة نمطية متقدمة باسم basShellExecutor 

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

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

وتعرف او شائعه لدى المطورين باسم : ShellWait  

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

 

مميزات الكود

• المرونة: يدعم تنفيذ الأوامر بثلاث طرق (انتظار غير محدود , مهلة زمنية محددة , تنفيذ بسيط) مما يجعله متعدد الاستخدامات
• الاستجابة: يستخدم " DoEvents " لضمان استجابة واجهة المستخدم أثناء الانتظار مما يمنع تجمد التطبيق
• التحكم الدقيق: يتيح إنهاء الحلقات يدويا عبر متغير عام (g_TerminateLoops) ويمنع التداخل بين الاستدعاءات باستخدام (m_IsExecuting)
• التوافق: توافق تعريفات API مع أنظمة 32 بت و64 بت
• معالجة الأخطاء: يوفر معالجة أخطاء قوية مع رسائل واضحة لتسهيل التصحيح
• التنظيم: مقسم إلى أقسام واضحة (ثوابت , تعريفات , دوال) مع تعليقات عربية شاملة لتسهيل الصيانة والفهم

 

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

الدوال الرئيسية هي:

1. ExecuteAndWait:
   • الغرض: تنفيذ أمر أو تشغيل ملف والانتظار حتى اكتماله مع استجابة مستمرة لواجهة المستخدم 
   • الاستخدام: مثالي للعمليات التي تحتاج إلى إكمال كامل قبل المتابعة (مثل فتح برنامج وانتظار إغلاقه)
2. ExecuteWithTimeout:
   • الغرض: تنفيذ أمر أو تشغيل ملف مع مهلة زمنية مع إمكانية إنهاء العملية إذا تجاوزت الحد
   • الاستخدام: ممناسب للعمليات ذات الوقت المحدود أو التي قد تتوقف (مثل محاولة استخدام أدوات خارجية)
3. ExecuteWScript:
   • الغرض: تنفيذ أمر بسيط باستخدام  " WScript.Shell " مع خيار الانتظار
   • الاستخدام: مفيد للمهام السريعة دون تعقيد على سبيل المثال (مثل تشغيل أوامر CMD)
4. ExecuteWScriptCapture (اختياري):
   • الغرض: تنفيذ أمر والتقاط ناتجه النصي للاستخدام البرمجي
   • الاستخدام: مثالي لتحليل نتائج الأوامر (مثل قوائم الملفات من " dir " )

اسم الوحدة النمطية العامة : basShellExecutor 
الكود : 

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


'=======================================================================================================================
'------    الثوابت
Public Const PROCESS_TIMEOUT_INFINITE As Long = &HFFFFFFFF
Public Const PROCESS_STILL_ACTIVE As Long = &H103
Public Const PROCESS_TERMINATED As Long = vbObjectError Or &HDEAD
Public Const MAX_PATH_LENGTH As Long = 260
Public Const QS_ALL_INPUT As Long = &H4FF

Private Const ERR_NO_COMMAND As Long = vbObjectError Or 1001
Private Const ERR_EXECUTING As Long = vbObjectError Or 1002
Private Const ERR_EXECUTION_FAILED As Long = vbObjectError Or 1003
Private Const ERR_TERMINATION_FAILED As Long = vbObjectError Or 1004

Private Const SHELL_MASK_NOCLOSEPROCESS As Long = &H40
Private Const SHELL_MASK_DOENVSUBST As Long = &H200
Private Const SHELL_MASK_SUPPRESS_ERRORS As Long = &H400

Private Const PROCESS_QUERY_INFO As Long = &H400
Private Const PROCESS_SYNCHRONIZE As Long = &H100000
Private Const PROCESS_TERMINATE As Long = &H1
Private Const ERROR_ACCESS_DENIED As Long = 5

'=======================================================================================================================
'------     التعدادات
Public Enum ShellWindowStyle
    WindowHidden = 0
    WindowNormal = 1
    WindowMinimized = 2
    WindowMaximized = 3
    WindowNoActivate = 4
End Enum

'=======================================================================================================================
'------    الأنواع المخصصة
#If VBA7 Then
    Private Type ShellExecuteParams
        Size As Long
        Mask As Long
        ParentWindowHandle As LongPtr
        Verb As String
        filePath As String
        Arguments As String
        WorkingDirectory As String
        ShowCommand As Long
        InstanceHandle As LongPtr
        ItemListPointer As LongPtr
        ClassName As String
        ClassKeyHandle As LongPtr
        HotKey As Long
        IconHandle As LongPtr
        ProcessHandle As LongPtr
    End Type
#Else
    Private Type ShellExecuteParams
        Size As Long
        Mask As Long
        ParentWindowHandle As Long
        Verb As String
        filePath As String
        Arguments As String
        WorkingDirectory As String
        ShowCommand As Long
        InstanceHandle As Long
        ItemListPointer As Long
        ClassName As String
        ClassKeyHandle As Long
        HotKey As Long
        IconHandle As Long
        ProcessHandle As Long
    End Type
#End If

'=======================================================================================================================
'------    تعريفات API
#If VBA7 Then
    Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr ' فتح مقبض العملية
    Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long ' إغلاق مقبض العملية
    Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة
    Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية
    Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث
    Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة
    Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr ' إنشاء مؤقت قابل للانتظار
    Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long ' جلب معرف العملية
    Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long ' تبسيط المسار
    Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr ' استخراج المعاملات من المسار
    Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long ' ضبط المؤقت
    Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long ' تنفيذ أمر عبر Shell
    Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long ' إعادة تخصيص السلسلة
    Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) ' إزالة المعاملات من المسار
    Private Declare PtrSafe Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا
    Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي
#Else
    Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long ' فتح مقبض العملية
    Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long ' إغلاق مقبض العملية
    Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة
    Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية
    Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث
    Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة
    Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long ' إنشاء مؤقت قابل للانتظار
    Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long ' جلب معرف العملية
    Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long ' تبسيط المسار
    Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long ' استخراج المعاملات من المسار
    Private Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long ' ضبط المؤقت
    Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long ' تنفيذ أمر عبر Shell
    Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long ' إعادة تخصيص السلسلة
    Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) ' إزالة المعاملات من المسار
    Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا
    Private Declare Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي
#End If

'=======================================================================================================================
'------    المتغيرات العامة و الخاصة
Public g_TerminateLoops As Boolean      ' متغير للتحكم في إنهاء الحلقات يدويًا
Private m_IsExecuting As Boolean        ' علامة لمنع التداخل أثناء التنفيذ

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

' تشغيل أمر والانتظار حتى ينتهي مع استجابة الواجهة
Public Function ExecuteAndWait(ByVal CommandLine As String, _
                               Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, _
                               Optional ByVal RunAsAdmin As Boolean = False, _
                               Optional ByVal MaxWaitMs As Long = PROCESS_TIMEOUT_INFINITE) As Long
    #If VBA7 Then
        Dim ShellParams As ShellExecuteParams
        Dim ProcessHandle As LongPtr
    #Else
        Dim ShellParams As ShellExecuteParams
        Dim ProcessHandle As Long
    #End If
    
    Dim ExpandedPath As String
    Dim Executable As String
    Dim Arguments As String
    Dim startTime As Long
    Dim ExitCode As Long
    Dim Result As Long
    
    If m_IsExecuting Then
        Err.Raise ERR_EXECUTING, "ExecuteAndWait", "عملية أخرى قيد التنفيذ"
    End If
    
    m_IsExecuting = True
    On Error GoTo Cleanup
    
    ' توسيع متغيرات البيئة
    ExpandedPath = ExpandEnvVars(CommandLine)
    
    ' فصل المسار التنفيذي عن المعاملات يدويًا
    If Left(ExpandedPath, 1) = """" Then
        Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2)
        Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2))
    Else
        Dim Parts() As String
        Parts = Split(ExpandedPath, " ", 2)
        Executable = Parts(0)
        If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = ""
    End If
    
    With ShellParams
        .Size = LenB(ShellParams)
        .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS
        .ShowCommand = WindowStyle
        .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط
        .Arguments = Arguments ' المعاملات كما هي
        If RunAsAdmin Then .Verb = "runas"
        
        If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then
            Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر: " & CommandLine
        End If
        
        ProcessHandle = .ProcessHandle
    End With
    
    startTime = GetTickCount
    Do
        Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT)
        DoEvents
        
        If GetExitCodeProcess(ProcessHandle, ExitCode) Then
            If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do
        End If
        
        If MaxWaitMs <> PROCESS_TIMEOUT_INFINITE Then
            If (GetTickCount - startTime) > MaxWaitMs Then
                Debug.Print "تجاوز الحد الأقصى للانتظار: " & MaxWaitMs & " ميلي ثانية"
                Exit Do
            End If
        End If
    Loop
    
    ExecuteAndWait = ExitCode

Cleanup:
    If ProcessHandle <> 0 Then CloseHandle ProcessHandle
    m_IsExecuting = False
    If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteAndWait", Err.Description
End Function

' دالة لتنفيذ أمر مع مهلة زمنية اختيارية وخيار التشغيل كمسؤول
Public Function ExecuteWithTimeout(Command As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long, Optional ByVal RunAsAdmin As Boolean = False, Optional RetryCount As Long = 0) As Long
    #If VBA7 Then
        Dim ShellParams As ShellExecuteParams
        Dim ProcessHandle As LongPtr
    #Else
        Dim ShellParams As ShellExecuteParams
        Dim ProcessHandle As Long
    #End If
    
    Dim ExpandedPath As String
    Dim Executable As String
    Dim Arguments As String
    Dim startTime As Long
    Dim ExitCode As Long
    Dim Result As Long
    Dim RetryIndex As Long
    
    If m_IsExecuting Then
        Err.Raise ERR_EXECUTING, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ"
    End If
    
    m_IsExecuting = True
    On Error GoTo Cleanup
    
    ExpandedPath = ExpandEnvVars(Command)
    
    ' فصل المسار التنفيذي عن المعاملات يدويًا
    If Left(ExpandedPath, 1) = """" Then
        Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2)
        Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2))
    Else
        Dim Parts() As String
        Parts = Split(ExpandedPath, " ", 2)
        Executable = Parts(0)
        If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = ""
    End If
    
    For RetryIndex = 0 To RetryCount
        With ShellParams
            .Size = LenB(ShellParams)
            .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS
            .ShowCommand = WindowStyle
            .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط
            .Arguments = Arguments ' المعاملات كما هي
            If RunAsAdmin Then .Verb = "runas"
            
            If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then
                If RetryIndex = RetryCount Then
                    Err.Raise ERR_EXECUTION_FAILED, "ExecuteWithTimeout", "فشل في تنفيذ الأمر بعد " & RetryCount + 1 & " محاولات: " & Command
                End If
            Else
                ProcessHandle = .ProcessHandle
                Exit For
            End If
        End With
    Next RetryIndex
    
    startTime = GetTickCount
    Do
        Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT)
        DoEvents
        
        If GetExitCodeProcess(ProcessHandle, ExitCode) Then
            If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do
        End If
        
        If TimeoutMs > 0 Then
            If (GetTickCount - startTime) > TimeoutMs Then
                If TerminateProcess(ProcessHandle, PROCESS_TERMINATED) = 0 Then
                    Debug.Print "فشل في إنهاء العملية بعد تجاوز المهلة"
                End If
                ExitCode = PROCESS_TERMINATED
                Exit Do
            End If
        End If
        
        If g_TerminateLoops Then Exit Do
    Loop
    
    ExecuteWithTimeout = ExitCode

Cleanup:
    If ProcessHandle <> 0 Then CloseHandle ProcessHandle
    m_IsExecuting = False
    If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteWithTimeout", Err.Description
End Function

' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار
Public Function ExecuteWScript(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal WaitForCompletion As Boolean = False) As Long
    Dim WScriptShell As Object
    
    On Error GoTo ErrorHandler
    Set WScriptShell = CreateObject("WScript.Shell")
    ExecuteWScript = WScriptShell.Run(CommandLine, WindowStyle, WaitForCompletion)
    Exit Function

ErrorHandler:
    Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description
    Err.Raise Err.Number, "ExecuteWScript", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description
End Function

' دالة محسنة لتشغيل أمر باستخدام WScript.Shell والتقاط الناتج
Public Function ExecuteWScriptCapture(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal) As String
    Dim WScriptShell As Object
    Dim ShellExec As Object
    Dim Output As String
    
    On Error GoTo ErrorHandler
    Set WScriptShell = CreateObject("WScript.Shell")
    Set ShellExec = WScriptShell.Exec(CommandLine)
    
    Do While ShellExec.Status = 0
        DoEvents
    Loop
    Output = ShellExec.StdOut.ReadAll
    
    ExecuteWScriptCapture = Output
    Exit Function

ErrorHandler:
    Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description
    ExecuteWScriptCapture = ""
    Err.Raise Err.Number, "ExecuteWScriptCapture", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description
End Function

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

' دالة لتوسيع متغيرات البيئة في سلسلة (مثل %windir%)
Private Function ExpandEnvVars(ByVal Path As String) As String
    Dim Buffer As String
    Dim Length As Long
    
    If InStr(Path, "%") Then
        Length = ExpandEnvironmentStringsW(StrPtr(Path), 0, 0)
        If Length > 0 Then
            Buffer = String$(Length - 1, vbNullChar)
            If ExpandEnvironmentStringsW(StrPtr(Path), StrPtr(Buffer), Length) Then
                ExpandEnvVars = Left$(Buffer, Length - 1)
            Else
                Debug.Print "فشل توسيع متغيرات البيئة، يتم إرجاع المسار الأصلي: " & Path
                ExpandEnvVars = Path
            End If
        Else
            ExpandEnvVars = Path
        End If
    Else
        ExpandEnvVars = Path
    End If
End Function

' دالة لتبسيط المسار (مثل حل النقاط . و ..)
Private Function CanonicalizePath(ByVal Path As String) As String
    Dim TempPath As String
    If InStr(Path, "\.") Or InStr(Path, ".\") Then
        If Len(Path) < MAX_PATH_LENGTH Then
            TempPath = String$(MAX_PATH_LENGTH - 1, vbNullChar)
            If PathCanonicalizeW(StrPtr(TempPath), StrPtr(Path)) Then
                CanonicalizePath = Left$(TempPath, InStr(TempPath, vbNullChar) - 1)
            Else
                Debug.Print "فشل تبسيط المسار، يتم إرجاع المسار الأصلي: " & Path
                CanonicalizePath = Path
            End If
        Else
            CanonicalizePath = Path
        End If
    Else
        CanonicalizePath = Path
    End If
End Function

' دالة لاستخراج المعاملات من المسار
Private Function ExtractArguments(ByRef Path As String) As String
    SysReAllocString VarPtr(ExtractArguments), PathGetArgsW(StrPtr(Path))
    If LenB(ExtractArguments) Then
        PathRemoveArgsW StrPtr(Path)
        If InStr(ExtractArguments, """") Then ExtractArguments = Replace(ExtractArguments, """", """""")
    End If
End Function

' دالة مساعدة لاستخراج اسم العملية من الأمر
Private Function ExtractProcessName(ByVal CommandLine As String) As String
    Dim Parts() As String
    Dim FirstPart As String
    
    If Left(CommandLine, 1) = """" Then
        FirstPart = Mid(CommandLine, 2, InStr(2, CommandLine, """") - 2)
    Else
        Parts = Split(CommandLine, " ")
        FirstPart = Parts(0)
    End If
    ExtractProcessName = Mid(FirstPart, InStrRev(FirstPart, "\") + 1)
End Function

' دالة لإنهاء عملية باستخدام WMI بناءً على اسم العملية
Public Function KillProcess(sProcessName As String, Optional sHost As String = ".") As Boolean
    On Error GoTo Error_Handler
    Dim oWMI As Object
    Dim sWMIQuery As String
    Dim oCols As Object
    Dim oCol As Object
    
    Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2")
    sWMIQuery = "SELECT Name FROM Win32_Process"
    Set oCols = oWMI.ExecQuery(sWMIQuery)
    For Each oCol In oCols
        If LCase(sProcessName) = LCase(oCol.Name) Then
            oCol.Terminate
        End If
    Next oCol
    KillProcess = True
    
Error_Handler_Exit:
    On Error Resume Next
    Set oCol = Nothing
    Set oCols = Nothing
    Set oWMI = Nothing
    Exit Function
    
Error_Handler:
    Debug.Print "خطأ في KillProcess: " & Err.Description & " - رقم الخطأ: " & Err.Number
    KillProcess = False
    Resume Error_Handler_Exit
End Function

وأخيــــرا الامثلة :

'=======================================================================================================================
'------    أمثلة الاستدعاء

' مثال لاستدعاء ExecuteAndWait
' يفتح Notepad وينتظر إغلاقه
Sub TestExecuteAndWait()
    Dim ExitCode As Long
    On Error Resume Next
    ExitCode = ExecuteAndWait("notepad.exe C:\test.txt", WindowNormal)
    Err.Clear ' مسح أي أخطاء سابقة
    If Err.Number = 0 Then
        MsgBox "رمز الخروج: " & ExitCode
    Else
        MsgBox "حدث خطأ: " & Err.Description
    End If
    On Error GoTo 0
End Sub

' مثال لاستدعاء ExecuteWithTimeout
' يفتح الحاسبة وينتظر 5 ثوانٍ كحد أقصى
Sub TestExecuteWithTimeout()
    Dim ProcessId As Long
    On Error Resume Next
    ProcessId = ExecuteWithTimeout("paint.exe", WindowMaximized, 5000)
    Err.Clear ' مسح أي أخطاء سابقة
    If Err.Number = PROCESS_TERMINATED Then
        MsgBox "اكتملت العملية برمز الخروج: " & ProcessId
    ElseIf Err.Number = 0 Then
        MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)"
    Else
        MsgBox "حدث خطأ: " & Err.Description
    End If
    On Error GoTo 0
End Sub

' مثال لاستدعاء ExecuteWScript
' يشغل أمر dir في CMD وينتظر النتيجة
Sub TestExecuteWScript()
    Dim Result As Long
    On Error Resume Next
    Result = ExecuteWScript("cmd.exe /c dir", WindowNormal, True)
    Err.Clear ' مسح أي أخطاء سابقة
    If Err.Number = 0 Then
        MsgBox "النتيجة: " & Result
    Else
        MsgBox "حدث خطأ: " & Err.Description
    End If
    On Error GoTo 0
End Sub

' مثال لاستدعاء ExecuteWScript مع إبقاء النافذة مفتوحة
Sub TestExecuteWScript_KeepOpen()
    Dim Result As Long
    ' استخدام /k بدلاً من /c لإبقاء نافذة CMD مفتوحة بعد تنفيذ الأمر
    On Error Resume Next
    Result = ExecuteWScript("cmd.exe /k dir", WindowNormal, False)
    Err.Clear ' مسح أي أخطاء سابقة
    If Err.Number = 0 Then
        MsgBox "النتيجة: " & Result
    Else
        MsgBox "حدث خطأ: " & Err.Description
    End If
    On Error GoTo 0
End Sub

' مثال لاستدعاء ExecuteWithTimeout لتشغيل CMD
Sub TestExecuteWithTimeoutCMD()
    Dim ProcessId As Long
    ' تشغيل CMD مع أمر dir وانتظار 5 ثوانٍ كحد أقصى
    On Error Resume Next
    ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000)
    Err.Clear ' مسح أي أخطاء سابقة
    If Err.Number = PROCESS_TERMINATED Then
        MsgBox "اكتملت العملية برمز الخروج: " & ProcessId
    ElseIf Err.Number = 0 Then
        MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)"
    Else
        MsgBox "حدث خطأ: " & Err.Description
    End If
    On Error GoTo 0
End Sub

' مثال لاستدعاء ExecuteWithTimeout مع RunAsAdmin وإعادة المحاولة
Sub TestExecuteWithTimeoutAdmin()
    Dim ProcessId As Long
    ' تشغيل CMD كمسؤول وانتظار 5 ثوانٍ كحد أقصى مع محاولتين
    On Error Resume Next
    ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000, True, 2)
    Err.Clear ' مسح أي أخطاء سابقة
    If Err.Number = PROCESS_TERMINATED Then
        MsgBox "اكتملت العملية برمز الخروج: " & ProcessId
    ElseIf Err.Number = 0 Then
        MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)"
    Else
        MsgBox "حدث خطأ: " & Err.Description
    End If
    On Error GoTo 0
End Sub

' مثال لاستدعاء ExecuteWScriptCapture
Sub TestExecuteWScriptCapture()
    Dim CommandOutput As String
    ' تنفيذ أمر dir والتقاط الناتج
    On Error Resume Next
    CommandOutput = ExecuteWScriptCapture("cmd.exe /c dir")
    Err.Clear ' مسح أي أخطاء سابقة
    If Err.Number = 0 Then
        MsgBox "ناتج الأمر:" & vbCrLf & CommandOutput
    Else
        MsgBox "حدث خطأ: " & Err.Description
    End If
    On Error GoTo 0
End Sub

 

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