شخابيط وأفكار و حلول : إدارة بيانات الاعتماد - الحل الأمثل لإدارة الاتصال بالشبكة المحلية

[ابو جودي]

في بيئات العمل الحديثة التي تعتمد على الشبكات المحلية، يُعد الاتصال المستقر بقاعدة البيانات الخلفية أمرًا أساسيًا لاستمرارية العمليات اليومية.
ومع ذلك، تظهر أحيانًا مشكلات تقنية تتعلق بفقدان بيانات الاعتماد (اسم المستخدم وكلمة المرور) الخاصة بالوصول إلى مجلدات شبكية تحتوي على قاعدة البيانات ويتم الاتصال بالشبكات أو الأجهزة عبر البروتوكولات مثل RDP أو SMB.

تخيل هذا السيناريو:

·         جهاز جديد ينضم إلى الشبكة.

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

الحل: أداة متقدمة لإدارة بيانات الاعتماد

تم تطوير كود ذكي لمعالجة هذه المشكلة بفعالية وكفاءة، من خلال :
تخزين بيانات الاتصال (العنوان - اسم المستخدم - كلمة المرور) داخل نظام Windows Credential Manager المدمج في نظام التشغيل.

أبرز المميزات:

·         سهولة الاستخدام:
          وظائف جاهزة لإضافة، وحذف بيانات الاعتماد بضغطة واحدة، دون الحاجة لأي معرفة برمجية.

·         ثبات الاتصال:
         يتم حفظ بيانات الاعتماد بشكل دائم حتى بعد إعادة تشغيل الجهاز، مما يضمن استمرارية الاتصال بقواعد البيانات دون الحاجة لإعادة الإدخال يدويًا.

·         توافق واسع:
          متوافق مع أنظمة Windows وOffice بنواتيها 32-بت و64-بت، ما يضمن عمله في مختلف بيئات العمل بدون مشاكل توافق.

فوائد الكود:

·         توفير الوقت بإلغاء الحاجة إلى إدخال بيانات الاعتماد بشكل متكرر.

·         ضمان اتصال دائم وموثوق مع الشبكة وقواعد البيانات.

·         إمكانية التخصيص ليتناسب مع احتياجات كل مستخدم أو مؤسسة.

·         مناسب لجميع المستخدمين سواء المبتدئين أو المحترفين.

الخاتمة:

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

صور توضح مكان حفظ أو جلب بيانات الاعتماد من النظام:
للتأكيد هنا نتعامل مع Windows Credentials
وذلك لادارة بيانات اعتماد خاصة بتسجيل الدخول في نطاق (Domain) خاص بـ Windows
مثل كلمات المرور المستخدمة لتسجيل الدخول إلى الشبكات أو الأجهزة عبر البروتوكولات مثل RDP أو SMB

الكود الخاص بإدارة البيانات ( إضافة / حذف )
سوف نضع وحده نمطية باسم : 

•  

basCredentialsmanager 

Option Compare Database
Option Explicit

'===========================
' إضافة بيانات Credential
'===========================
Public Function AddWindowsCredential(ByVal strTarget As String, ByVal strUserName As String, ByVal strPassword As String) As Boolean
    Dim strCommand As String
    Dim lngExitCode As Long
    
    strCommand = "cmd.exe /c cmdkey /add:" & strTarget & " /user:""" & strUserName & """ /pass:""" & strPassword & """ && exit 0 || exit 1"

    lngExitCode = ExecuteAndWait(strCommand, WindowHidden, True)
    AddWindowsCredential = (lngExitCode = 0)
End Function

'===========================
' حذف بيانات Credential
'===========================
Public Function DeleteWindowsCredential(ByVal strTarget As String) As Boolean
    Dim strCommand As String
    Dim lngExitCode As Long
        
    strCommand = "cmd.exe /c cmdkey /delete:""" & strTarget & """ && exit 0 || exit 1"
     
     lngExitCode = ExecuteAndWait(strCommand, WindowHidden, True)
     DeleteWindowsCredential = (lngExitCode = 0)
End Function

' وظيفة للتحقق من أن السلسلة غير فارغة وخالية من محرف Null
Public Function ValidateString(strInput As String) As Boolean
    ' أولاً، تحقق من أن السلسلة ليست فارغة بعد إزالة المسافات الزائدة
    ValidateString = Len(Trim(strInput)) > 0

    ' إذا كانت السلسلة ليست فارغة، تحقق من عدم وجود محرف Null (vbNullChar)
    If ValidateString Then
        ValidateString = InStr(strInput, vbNullChar) = 0
    End If
End Function


' ====================================================
' أمثلة لدوال اختبار الكود
' ====================================================

' ====================================================
'  إضافة بيانات اعتماد (اسم مستخدم وكلمة مرور)
' ====================================================
Public Sub TestAddWindowsCredential()
    Dim strNetworkAddress   As String
    Dim strNetworkUserName  As String
    Dim strNetworkPassword  As String
    Dim blnSuccess          As Boolean

    ' بيانات اعتماد تجريبية
    strNetworkAddress = "TestTarget0123"
    strNetworkUserName = "TestUser0123"
    strNetworkPassword = "TestPass0123"

    ' استدعاء دالة الإضافة
    blnSuccess = AddWindowsCredential(strNetworkAddress, strNetworkUserName, strNetworkPassword)

    ' عرض النتيجة
    If blnSuccess Then
        MsgBox "تمت إضافة بيانات الاعتماد بنجاح.", vbInformation, "نجاح"
    Else
        MsgBox "تعذر إضافة بيانات الاعتماد.", vbInformation, "تنبيــه"
    End If
End Sub

' ====================================================
' حذف بيانات الاعتماد المخزنة
' ====================================================
Public Sub TestDeleteWindowsCredential()
    Dim strNetworkAddress   As String
    Dim blnSuccess          As Boolean

    ' العنوان الذي نريد حذف بياناته
    strNetworkAddress = "TestTarget0123"

    ' استدعاء دالة الحذف
    blnSuccess = DeleteWindowsCredential(strNetworkAddress)

    ' عرض النتيجة
    If blnSuccess Then
        MsgBox "تم حذف بيانات الاعتماد بنجاح.", vbInformation, "نجاح"
    Else
        MsgBox "تعذر حذف بيانات الاعتماد. تأكد من تسجيل الجهاز مسبقًا.", vbInformation, "تنبيــه"
    End If
End Sub

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

إضافة وحدة نمطية عامة باسم : 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) 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

وأخيرا المرفق

ملاحظة:
تم تعديل المرفق والموضوع بتاريخ : 02/06/2025

 

Credential Manager.accdb

تم تعديل يونيو 2 بواسطه ابو جودي
تعديل الموضوع والمرفق

[Foksh]

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

يا هلا بالأفكار النيرة ، والإبداعات المثيرة  .

تحفة فنية جمية منسوجة بإحكاااااام و براعة 

عند قراءة الفكرة وبتمعن ، خطر لي سؤال  :-

ماذا يحدث عند نقل قاعدة البيانات إلى جهاز جديد ؟؟؟؟؟ 

( هل سيتم نقل بيانات الاعتماد تلقائياً ؟ )

 

لكن جوهر الفكرة جميل جداً بأفكار صاحب الأفكار الجميلة ,,,

 

 

[ابو جودي]

 

في 1‏/6‏/2025 at 00:52, Foksh said:

عند قراءة الفكرة وبتمعن ، خطر لي سؤال  :-

سؤال لولبى 
 

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

 

طيب اجابة السؤال كالتالى  : 

الكود لا يعتمد فى هذا الشكل على اى بيانات ولا هيكله ولا فى النموذج

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

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

 

طيب الفكرة الصحيحة او الطبخة المعتبرة : 

عمل جدول اعدادات الاتصال بالسيرفر يحتوى على بيانات اعتماد الاتصال ( اسم الجهاز او الـ IP  +  اسم المستخدم و كلمة المرور لهذا المستخدم )

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

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

 

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

 

 

 

[عمر ضاحى]

يا هلا يا هلا يا هلا 

ما شاء الله على الابداع والتنظيم 

تختفي ولما تظهر تظهر بابداع جديد 

سلمت يداك استاذي ابوجودي

 

[Moosak]

فنان وبيعمل حاجات بتوع فنانين 

ربنا يديك العافية على الحركات الجميلة والأفكار الإبداعية ..

قد أكون مش ملم بالموضوع دا فنيا وتقنيا لأني ماليش في الشبكات كثير !! .. 😅

بس هل زي مانا فهمت أنه يتم تخزين بيانات الاعتماد من خلال النموذج التالي ؟ .. يعني مش بيقراها الكود تلقائيا من إعدادات الويندوز ؟ أوعك تتريق عليه 👊

 

[ابو جودي]

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

في 1‏/6‏/2025 at 09:20, Moosak said:

بس هل زي مانا فهمت أنه يتم تخزين بيانات الاعتماد من خلال النموذج التالي ؟ .. يعني مش بيقراها الكود تلقائيا من إعدادات الويندوز ؟

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

يتم اضافة وتخزين البيانات التى يتم تمريرها من خلال الأكواد الى : Windows Credentials 

الكود لا يقرئها من أعدادت الويندوز 

لأن أساس الفكرة وهذا الموضوع هى

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

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

يتم اضافة وتخزين البيانات عند فتح القاعدة الامامية من اول نموذج قبل محاولة الاتصال بجداول القاعدة الخلفية او ربط/إعادة ربط الجداول