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

[ابو جودي]

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

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

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

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

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

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

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

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

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

·         نظام تسجيل احترافي:
          يسجل جميع العمليات والأخطاء في ملف خارجي، مما يسهّل تتبع المشكلات وحلها بسرعة وكفاءة.

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

فوائد الكود:

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

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

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

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

الخاتمة:

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

الكود
 

Option Compare Database
Option Explicit

' تعريفات Windows API للتعامل مع Credential Manager
#If VBA7 Then
    Private Declare PtrSafe Function CredWrite Lib "Advapi32.dll" Alias "CredWriteW" (ByRef udtCREDENTIAL As udtCREDENTIAL, ByVal lngFlags As Long) As Long
    Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByVal lngDest As LongPtr, ByVal lngSrc As LongPtr, ByVal lngLen As LongPtr)
    Private Declare PtrSafe Function CredRead Lib "Advapi32.dll" Alias "CredReadW" (ByVal ptrTargetName As LongPtr, ByVal lngCredType As Long, ByVal lngFlags As Long, ByRef ptrCredential As LongPtr) As Long
    Private Declare PtrSafe Sub CredFree Lib "Advapi32.dll" (ByVal ptrBuffer As LongPtr)
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef bytDestination As Any, ByVal ptrSource As LongPtr, ByVal lngBytesCount As Long)
    Private Declare PtrSafe Function lstrcpyW Lib "kernel32" (ByVal ptrDest As LongPtr, ByVal ptrSrc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CredDelete Lib "Advapi32.dll" Alias "CredDeleteW" (ByVal ptrTargetName As LongPtr, ByVal lngType As Long, ByVal lngFlags As Long) As Long
    Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
    Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cbMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long
#Else
    Private Declare Function CredWrite Lib "advapi32.dll" Alias "CredWriteW" (ByRef udtCredential As udtCREDENTIAL, ByVal lngFlags As Long) As Long
    Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal lngDest As Long, ByVal lngSrc As Long, ByVal lngLen As Long)
    Private Declare Function CredRead Lib "Advapi32.dll" Alias "CredReadW" (ByVal ptrTargetName As Long, ByVal lngCredType As Long, ByVal lngFlags As Long, ByRef ptrCredential As Long) As Long
    Private Declare Sub CredFree Lib "Advapi32.dll" (ByVal ptrBuffer As Long)
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef bytDestination As Any, ByVal ptrSource As Long, ByVal lngBytesCount As Long)
    Private Declare Function lstrcpyW Lib "kernel32" (ByVal ptrDest As Long, ByVal ptrSrc As Long) As Long
    Private Declare Function CredDelete Lib "Advapi32.dll" Alias "CredDeleteW" (ByVal ptrTargetName As Long, ByVal lngType As Long, ByVal lngFlags As Long) As Long
    Private Declare Function GetLastError Lib "kernel32" () As Long
    Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cbMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
#End If

' تعريف هيكل بيانات الاعتماد
#If VBA7 Then
    Private Type udtCREDENTIAL
        lngFlags                As Long         ' العلامات التي تحدد سلوك بيانات الاعتماد
        lngType                 As Long         ' نوع بيانات الاعتماد (عام أو خاص بنطاق)
        ptrTargetName           As LongPtr      ' مؤشر إلى اسم الهدف (اسم بيانات الاعتماد)
        ptrComment              As LongPtr      ' مؤشر إلى تعليق يصف بيانات الاعتماد
        curLastWritten          As Currency     ' وقت آخر تعديل لبيانات الاعتماد
        lngCredentialBlobSize   As Long         ' حجم بيانات الاعتماد (مثل كلمة المرور)
        lngptrCredentialBlob    As LongPtr      ' مؤشر إلى بيانات الاعتماد (مثل كلمة المرور)
        lngPersist              As Long         ' نوع التخزين (محلي، جلسة، أو مؤسسة)
        lngAttributeCount       As Long         ' عدد السمات الإضافية
        ptrAttributes           As LongPtr      ' مؤشر إلى السمات الإضافية
        ptrTargetAlias          As LongPtr      ' مؤشر إلى الاسم المستعار للهدف
        ptrUserName             As LongPtr      ' مؤشر إلى اسم المستخدم
    End Type
#Else
    Private Type udtCREDENTIAL
        lngFlags                As Long         ' العلامات التي تحدد سلوك بيانات الاعتماد
        lngType                 As Long         ' نوع بيانات الاعتماد (عام أو خاص بنطاق)
        ptrTargetName           As Long         ' مؤشر إلى اسم الهدف (اسم بيانات الاعتماد)
        ptrComment              As Long         ' مؤشر إلى تعليق يصف بيانات الاعتماد
        curLastWritten          As Currency     ' وقت آخر تعديل لبيانات الاعتماد
        lngCredentialBlobSize   As Long         ' حجم بيانات الاعتماد (مثل كلمة المرور)
        lngptrCredentialBlob    As Long         ' مؤشر إلى بيانات الاعتماد (مثل كلمة المرور)
        lngPersist              As Long         ' نوع التخزين (محلي، جلسة، أو مؤسسة)
        lngAttributeCount       As Long         ' عدد السمات الإضافية
        ptrAttributes           As Long         ' مؤشر إلى السمات الإضافية
        ptrTargetAlias          As Long         ' مؤشر إلى الاسم المستعار للهدف
        ptrUserName             As Long         ' مؤشر إلى اسم المستخدم
    End Type
#End If

' الثوابت المستخدمة
Private Const CRED_TYPE_GENERIC As Long = 1              ' نوع بيانات اعتماد عام
Private Const CRED_PERSIST_LOCAL_MACHINE As Long = 2     ' تخزين بيانات الاعتماد محليًا
Private Const CP_ACP As Long = 0                         ' رمز الصفحة لتحويل النصوص
Private Const ERROR_NOT_FOUND As Long = 1168             ' رمز الخطأ عند عدم العثور على بيانات الاعتماد
Private Const MAX_LOG_SIZE As Long = 1048576             ' الحد الأقصى لحجم ملف السجل (1 ميجابايت)

Public DebugMode As Boolean   ' متغير عام للتحكم في طباعة التتبع في النافذة الفورية

' وظيفة لتسجيل الأخطاء
Private Sub LogError(strFunction As String, strError As String, lngErrorCode As Long)
    ' الغرض: تسجيل الأخطاء في ملف Log مع اسم الوظيفة ورمز الخطأ
    If DebugMode Then
        Debug.Print "Error in " & strFunction & ": " & strError & " (Code: " & lngErrorCode & ")"
    End If
    WriteToLog LogPath, "خطأ في : " & strFunction & ": " & strError & " (Code: " & lngErrorCode & ")"
End Sub

' وظيفة لتحويل رمز الخطأ إلى رسالة واضحة
Private Function GetErrorMessage(lngErrorCode As Long, Optional strLang As String = "ar") As String
    If strLang = "ar" Then
        Select Case lngErrorCode
            Case ERROR_NOT_FOUND
                GetErrorMessage = "بيانات الاعتماد غير موجودة"
            Case 1312
                GetErrorMessage = "اسم الهدف غير صالح أو غير موجود"
            Case 1008
                GetErrorMessage = "لا يمكن تخصيص الذاكرة"
            Case Else
                GetErrorMessage = "خطأ غير معروف: " & lngErrorCode
        End Select
    Else
        Select Case lngErrorCode
            Case ERROR_NOT_FOUND
                GetErrorMessage = "Credential not found"
            Case 1312
                GetErrorMessage = "Invalid or non-existent target name"
            Case 1008
                GetErrorMessage = "Unable to allocate memory"
            Case Else
                GetErrorMessage = "Unknown error: " & lngErrorCode
        End Select
    End If
End Function

' وظيفة لتحويل مؤشر سلسلة إلى نص
Private Function strPtrToString(ByVal lngPtrString As LongPtr) As String
    ' الغرض: تحويل مؤشر سلسلة يونيكود إلى نص VBA
    ' المدخلات: lngPtrString - مؤشر إلى سلسلة يونيكود
    ' المخرجات: السلسلة النصية المستخرجة أو سلسلة فارغة إذا فشل التحويل
    On Error GoTo ErrHandler
    
    Dim strTemp As String

    ' التحقق من صحة المؤشر
    If lngPtrString = 0 Then
        strPtrToString = ""
        Exit Function
    End If

    ' تخصيص سلسلة مؤقتة بحجم كافٍ (255 حرفًا) ونسخ البيانات من المؤشر
    strTemp = String$(255, vbNullChar)
    lstrcpyW StrPtr(strTemp), lngPtrString
    ' استخراج النص حتى أول حرف null
    strPtrToString = Left$(strTemp, InStr(strTemp, vbNullChar) - 1)
    Exit Function

ErrHandler:
    LogError "strPtrToString", Err.Description, Err.Number
    strPtrToString = ""
End Function

' وظيفة لتحويل النص إلى يونيكود
Private Function ConvertToUnicode(ByVal sInput As String) As String
    ' الغرض: تحويل سلسلة نصية إلى تنسيق يونيكود للاستخدام مع Windows API
    ' المدخلات: sInput - السلسلة النصية الأصلية
    ' المخرجات: السلسلة المحولة إلى يونيكود أو السلسلة الأصلية إذا فشل التحويل
    On Error GoTo ErrHandler
    
    Dim nChars  As Long
    Dim sOutput As String

    ' التحقق من أن السلسلة غير فارغة
    If Len(sInput) = 0 Then
        ConvertToUnicode = ""
        Exit Function
    End If

    ' حساب عدد الأحرف المطلوبة لتحويل النص إلى يونيكود
    nChars = MultiByteToWideChar(CP_ACP, 0, sInput, Len(sInput), 0, 0)
    If nChars <= 0 Then
        LogError "ConvertToUnicode", "فشل تحويل النص إلى يونيكود", GetLastError
        ConvertToUnicode = sInput
        Exit Function
    End If

    ' تخصيص سلسلة الإخراج وإجراء التحويل
    sOutput = String$(nChars, vbNullChar)
    MultiByteToWideChar CP_ACP, 0, sInput, Len(sInput), StrPtr(sOutput), nChars
    ConvertToUnicode = sOutput
    Exit Function

ErrHandler:
    LogError "ConvertToUnicode", Err.Description, Err.Number
    ConvertToUnicode = sInput
End Function

' وظيفة لتحويل مصفوفة بايت إلى سلسلة يونيكود
Private Function arrBytesToUnicodeString(arrBytes() As Byte) As String
    ' الغرض: تحويل مصفوفة بايت (تحتوي على بيانات يونيكود) إلى سلسلة نصية
    ' المدخلات: arrBytes - مصفوفة البايت التي تحتوي على بيانات يونيكود
    ' المخرجات: السلسلة النصية المستخرجة أو سلسلة فارغة إذا فشل التحويل
    On Error GoTo ErrHandler
    
    Dim strResult   As String
    Dim lngChars    As Long

    ' التحقق من أن المصفوفة ليست فارغة
    If UBound(arrBytes) < 0 Then
        arrBytesToUnicodeString = ""
        Exit Function
    End If

    ' حساب عدد الأحرف بناءً على حجم المصفوفة (يونيكود = 2 بايت لكل حرف)
    lngChars = UBound(arrBytes) \ 2 + 1
    strResult = String$(lngChars, vbNullChar)
    ' نسخ البيانات من المصفوفة إلى السلسلة
    CopyMemory ByVal StrPtr(strResult), arrBytes(0), UBound(arrBytes) + 1
    arrBytesToUnicodeString = strResult
    Exit Function

ErrHandler:
    LogError "arrBytesToUnicodeString", Err.Description, Err.Number
    arrBytesToUnicodeString = ""
End Function

' وظيفة لتحويل مؤشر بيانات إلى سلسلة
Private Function ByteArrayToString(ByVal lpData As LongPtr, ByVal lngSize As Long) As String
    ' الغرض: تحويل بيانات من مؤشر (مثل كلمة المرور) إلى سلسلة نصية
    ' المدخلات: lpData - مؤشر إلى البيانات، lngSize - حجم البيانات بالبايت
    ' المخرجات: السلسلة النصية المستخرجة أو سلسلة فارغة إذا فشل التحويل
    On Error GoTo ErrHandler
    
    Dim arrBytes() As Byte

    ' التحقق من صحة المؤشر وحجم البيانات
    If lngSize <= 0 Or lpData = 0 Then
        ByteArrayToString = ""
        Exit Function
    End If

    ' تخصيص مصفوفة بايت ونسخ البيانات من المؤشر
    ReDim arrBytes(0 To lngSize - 1)
    CopyMemory arrBytes(0), ByVal lpData, lngSize
    ByteArrayToString = arrBytesToUnicodeString(arrBytes)
    Exit Function

ErrHandler:
    LogError "ByteArrayToString", Err.Description, Err.Number
    ByteArrayToString = ""
End Function

' وظيفة للتحقق من صحة المدخلات
Public Function IsValidInput(strInput As String) As Boolean
    ' الغرض: التحقق من أن السلسلة صالحة (غير فارغة ولا تحتوي على أحرف غير مسموح بها)
    ' المدخلات: strInput - السلسلة المراد فحصها
    ' المخرجات: True إذا كانت السلسلة صالحة، False إذا لم تكن كذلك
    Dim strInvalidChars As String
    
    strInvalidChars = "<>|/\\:*?""" ' الأحرف غير المسموح بها
    
    ' التحقق من أن السلسلة غير فارغة بعد إزالة المسافات
    If Len(Trim(strInput)) = 0 Then
        IsValidInput = False
        Exit Function
    End If
    
    ' التحقق من وجود أحرف غير مسموح بها
    Dim i As Long
    For i = 1 To Len(strInvalidChars)
        If InStr(strInput, Mid(strInvalidChars, i, 1)) > 0 Then
            IsValidInput = False
            Exit Function
        End If
    Next i
    
    ' التحقق من الطول (مثلًا، الحد الأقصى 255 حرفًا)
    If Len(strInput) > 255 Then
        IsValidInput = False
        Exit Function
    End If
    
    IsValidInput = True
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


' وظيفة لإضافة بيانات اعتماد إلى Windows Credential Manager
Public Function AddWindowsCredential(strNetworkAddress As String, strNetworkUserName As String, strNetworkPassword As String) As Boolean
    On Error GoTo ErrHandler
    
    Dim udtCred                 As udtCREDENTIAL
    Dim lngResult               As Long
    Dim strPasswordWithNull     As String

    ' التحقق من صحة المدخلات
    If Not IsValidInput(strNetworkAddress) Or Not IsValidInput(strNetworkUserName) Then
        MsgBox "عنوان الشبكة أو اسم المستخدم غير صالح. يجب ألا يحتوي على أحرف غير مسموح بها أو يكون فارغًا.", vbCritical
        LogError "AddWindowsCredential", "مدخلات غير صالحة", 0
        AddWindowsCredential = False
        Exit Function
    End If
    
    ' التحقق من طول كلمة المرور (اختياري، يمكن أن تكون فارغة)
    If Len(strNetworkPassword) > 255 Then
        MsgBox "كلمة المرور طويلة جدًا (الحد الأقصى 255 حرفًا).", vbCritical
        LogError "AddWindowsCredential", "كلمة المرور طويلة جدًا", 0
        AddWindowsCredential = False
        Exit Function
    End If

    ' إضافة vbNullChar إلى كلمة المرور إذا لزم الأمر
    If Right$(strNetworkPassword, 1) <> vbNullChar Then
        strPasswordWithNull = strNetworkPassword & vbNullChar
    Else
        strPasswordWithNull = strNetworkPassword
    End If

    ' تهيئة هيكل بيانات الاعتماد
    With udtCred
        .lngFlags = 0
        .lngType = CRED_TYPE_GENERIC
        .lngPersist = CRED_PERSIST_LOCAL_MACHINE
        .lngCredentialBlobSize = LenB(strPasswordWithNull)
        .ptrTargetName = StrPtr(strNetworkAddress)
        .ptrUserName = StrPtr(strNetworkUserName)
        .lngptrCredentialBlob = StrPtr(ConvertToUnicode(strPasswordWithNull))
        .ptrComment = 0
        .lngAttributeCount = 0
        .ptrAttributes = 0
        .ptrTargetAlias = 0
        .curLastWritten = 0
    End With

    lngResult = CredWrite(udtCred, 0)
    If lngResult = 0 Then
        Dim lngError As Long
        lngError = GetLastError()
        MsgBox "فشل في إضافة بيانات الاعتماد. الخطأ: " & GetErrorMessage(lngError), vbCritical
        LogError "AddWindowsCredential", GetErrorMessage(lngError), lngError
        AddWindowsCredential = False
        Exit Function
    End If

    AddWindowsCredential = True
    Exit Function

ErrHandler:
    LogError "AddWindowsCredential", Err.Description, Err.Number
    MsgBox "حدث خطأ غير متوقع: " & Err.Description, vbCritical
    AddWindowsCredential = False
End Function

' وظيفة لقراءة بيانات الاعتماد من Windows Credential Manager
Public Function ReadWindowsCredential(ByVal strNetworkAddress As String, ByRef strOutNetworkUserName As String, ByRef strOutNetworkPassword As String) As Boolean
    On Error GoTo ErrHandler
    
    Dim ptrCredential   As LongPtr
    Dim typCred         As udtCREDENTIAL
    Dim lngResult       As Long
    Dim strTemp         As String

    ' التحقق من صحة المدخلات
    If Not IsValidInput(strNetworkAddress) Then
        MsgBox "عنوان الشبكة غير صالح. يجب ألا يحتوي على أحرف غير مسموح بها أو يكون فارغًا.", vbCritical
        LogError "ReadWindowsCredential", "عنوان الشبكة غير صالح", 0
        ReadWindowsCredential = False
        Exit Function
    End If

    lngResult = CredRead(StrPtr(strNetworkAddress), CRED_TYPE_GENERIC, 0, ptrCredential)
    If lngResult = 0 Then
        Dim lngError As Long
        lngError = GetLastError()
        MsgBox "فشل في قراءة بيانات الاعتماد. الخطأ: " & GetErrorMessage(lngError), vbCritical
        LogError "ReadWindowsCredential", GetErrorMessage(lngError), lngError
        ReadWindowsCredential = False
        Exit Function
    End If

    ' التحقق من صحة المؤشر
    If ptrCredential = 0 Then
        MsgBox "فشل في تخصيص الذاكرة لبيانات الاعتماد", vbCritical
        LogError "ReadWindowsCredential", "مؤشر بيانات الاعتماد غير صالح", 0
        ReadWindowsCredential = False
        Exit Function
    End If

    ' نسخ البيانات إلى الهيكل
    CopyMemory typCred, ByVal ptrCredential, LenB(typCred)
    strOutNetworkUserName = strPtrToString(typCred.ptrUserName)

    If typCred.lngCredentialBlobSize > 0 Then
        strTemp = strPtrToString(typCred.lngptrCredentialBlob)
        If LenB(strTemp) = 0 Then
            strOutNetworkPassword = ByteArrayToString(typCred.lngptrCredentialBlob, typCred.lngCredentialBlobSize)
        Else
            strOutNetworkPassword = Left$(strTemp, typCred.lngCredentialBlobSize \ 2)
        End If
    Else
        strOutNetworkPassword = ""
    End If

    ' تحرير الذاكرة
    CredFree ptrCredential
    ReadWindowsCredential = True
    Exit Function

ErrHandler:
    If ptrCredential <> 0 Then CredFree ptrCredential
    LogError "ReadWindowsCredential", Err.Description, Err.Number
    ReadWindowsCredential = False
End Function

' وظيفة لقراءة بيانات الاعتماد وإرجاعها ككائن Dictionary
Public Function ReadWindowsCredentialByNetworkAddress(strNetworkAddress As String) As Object
    On Error GoTo ErrHandler
    
    Dim objResult               As Object
    Dim strNetworkUserName      As String
    Dim strNetworkPassword      As String

    ' التحقق من صحة المدخلات
    If Not IsValidInput(strNetworkAddress) Then
        LogError "ReadWindowsCredentialByNetworkAddress", "عنوان الشبكة غير صالح", 0
        Set ReadWindowsCredentialByNetworkAddress = Nothing
        Exit Function
    End If

    If ReadWindowsCredential(strNetworkAddress, strNetworkUserName, strNetworkPassword) Then
        Set objResult = CreateObject("Scripting.Dictionary")
        If objResult Is Nothing Then
            LogError "ReadWindowsCredentialByNetworkAddress", "فشل في إنشاء كائن Dictionary", 0
            Set ReadWindowsCredentialByNetworkAddress = Nothing
            Exit Function
        End If
        objResult("NetworkUserName") = strNetworkUserName
        objResult("NetworkPassword") = strNetworkPassword
        Set ReadWindowsCredentialByNetworkAddress = objResult
    Else
        Set ReadWindowsCredentialByNetworkAddress = Nothing
    End If
    Exit Function

ErrHandler:
    LogError "ReadWindowsCredentialByNetworkAddress", Err.Description, Err.Number
    Set ReadWindowsCredentialByNetworkAddress = Nothing
End Function

' وظيفة لحذف بيانات الاعتماد من Windows Credential Manager
Public Function DeleteWindowsCredential(strNetworkAddress As String) As Boolean
    On Error GoTo ErrHandler
    
    Dim lngResult       As Long
    Dim lngLastError    As Long

    ' التحقق من صحة المدخلات
    If Not IsValidInput(strNetworkAddress) Then
        MsgBox "عنوان الشبكة غير صالح. يجب ألا يحتوي على أحرف غير مسموح بها أو يكون فارغًا.", vbCritical
        LogError "DeleteWindowsCredential", "عنوان الشبكة غير صالح", 0
        DeleteWindowsCredential = False
        Exit Function
    End If

    lngResult = CredDelete(StrPtr(strNetworkAddress), CRED_TYPE_GENERIC, 0)
    If lngResult <> 0 Then
        DeleteWindowsCredential = True
    Else
        lngLastError = GetLastError()
        MsgBox "فشل في حذف بيانات الاعتماد. الخطأ: " & GetErrorMessage(lngLastError), vbCritical
        LogError "DeleteWindowsCredential", GetErrorMessage(lngLastError), lngLastError
        DeleteWindowsCredential = False
    End If
    Exit Function

ErrHandler:
    LogError "DeleteWindowsCredential", Err.Description, Err.Number
    DeleteWindowsCredential = False
End Function

Public Function GetCredentialsByNetworkAddress(strNetworkAddress As String, _
                                               ByRef strUserName As String, _
                                               ByRef strPassword As String) As Boolean
    ' هنا يمكنك استدعاء دالة قراءة البيانات حسب عنوان الشبكة
    Dim objDict As Object

    ' استدعاء دالة قراءة بيانات الاعتماد باستخدام العنوان
    Set objDict = ReadWindowsCredentialByNetworkAddress(strNetworkAddress)

    If Not objDict Is Nothing Then
        ' إذا كانت البيانات موجودة في القاموس، نقوم بإرجاعها في المتغيرات
        strUserName = objDict("NetworkUserName")
        strPassword = objDict("NetworkPassword")
        GetCredentialsByNetworkAddress = True
    Else
        ' في حال لم تجد البيانات
        GetCredentialsByNetworkAddress = False
    End If
End Function

' (IP Address / عنوان الشبكة / اسم الجهاز) استخراج
Function GetNetworkAddressOrIP(Path As String) As String
    Dim parts() As String

    ' التحقق إذا كان المسار يبدأ بـ \\
    If Left(Path, 2) = "\\" Then
        ' إزالة \\ من البداية
        Path = Mid(Path, 3)

        ' تقسيم المسار إلى أجزاء باستخدام العلامة \
        parts = Split(Path, "\")

        ' إرجاع الجزء الأول (اسم الجهاز أو عنوان IP)
        If UBound(parts) >= 0 Then
            GetNetworkAddressOrIP = parts(0)
        Else
            GetNetworkAddressOrIP = ""
        End If
    Else
        ' إذا لم يبدأ بـ \\، يرجع قيمة فارغة
        GetNetworkAddressOrIP = ""
    End If
End Function

' وظيفة للحصول على مسار ملف السجل
Function LogPath() As String
    ' الغرض: إرجاع مسار ملف السجل الأساسي
    LogPath = CurrentProject.Path & "\Logs\NetworkConnectionLog.txt"
End Function

' وظيفة للحصول على مسار ملف السجل مع دعم التدوير
Private Function GetRotatedLogPath(ByVal BaseLogPath As String) As String
    ' الغرض: إرجاع مسار ملف السجل، مع إنشاء ملف جديد إذا تجاوز الحجم الحد الأقصى
    ' المدخلات: BaseLogPath - المسار الأساسي لملف السجل
    ' المخرجات: المسار الفعلي لملف السجل (قد يكون ملفًا جديدًا إذا لزم الأمر)
    Dim FileSystem      As Object
    Dim FileSize        As Long
    Dim Counter         As Integer
    Dim NewLogPath      As String
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    
    ' إذا لم يكن الملف موجودًا، استخدم المسار الأساسي
    If Not FileSystem.FileExists(BaseLogPath) Then
        GetRotatedLogPath = BaseLogPath
        Exit Function
    End If
    
    ' التحقق من حجم الملف
    FileSize = FileSystem.GetFile(BaseLogPath).Size
    If FileSize < MAX_LOG_SIZE Then
        GetRotatedLogPath = BaseLogPath
        Exit Function
    End If
    
    ' إنشاء ملف جديد بإضافة رقم تسلسلي
    Counter = 1
    Do
        NewLogPath = FileSystem.GetParentFolderName(BaseLogPath) & "\" & FileSystem.GetBaseName(BaseLogPath) & "_" & Format(Counter, "000") & "." & FileSystem.GetExtensionName(BaseLogPath)
        If Not FileSystem.FileExists(NewLogPath) Then
            GetRotatedLogPath = NewLogPath
            Exit Function
        End If
        Counter = Counter + 1
    Loop Until Counter > 999 ' الحد الأقصى لعدد الملفات المدورة
    
    ' إذا لم يتم العثور على مسار متاح، استخدم المسار الأساسي
    GetRotatedLogPath = BaseLogPath
End Function

' وظيفة لإرجاع رمز الخطأ الأخير
Public Function GetLastErrorCode() As Long
    GetLastErrorCode = GetLastError()
End Function

' تسجيل الأحداث والأخطاء في ملف
Public Sub WriteToLog(ByVal LogPath As String, ByVal Message As String)
    ' الغرض: تسجيل الأحداث والأخطاء في ملف Log مع دعم تدوير السجلات
    ' المدخلات: LogPath - المسار الأساسي لملف Log، Message - الرسالة المراد تسجيلها
    On Error GoTo LogError
    
    Dim FileSystem      As Object
    Dim LogFile         As Object
    Dim ActualLogPath   As String
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    
    ' إنشاء مجلد Logs إذا لم يكن موجودًا
    If Not FileSystem.FolderExists(FileSystem.GetParentFolderName(LogPath)) Then
        FileSystem.CreateFolder FileSystem.GetParentFolderName(LogPath)
    End If
    
    ' التحقق من أذونات الكتابة
    If Not IsFolderWritable(FileSystem.GetParentFolderName(LogPath)) Then
        If DebugMode Then
            Debug.Print "لا توجد أذونات كتابة لمسار Log: " & LogPath
        End If
        GoTo LogCleanUp
    End If
    
    ' الحصول على مسار السجل مع دعم التدوير
    ActualLogPath = GetRotatedLogPath(LogPath)
    
    ' فتح ملف Log وكتابة الرسالة
    Set LogFile = FileSystem.OpenTextFile(ActualLogPath, 8, True) ' 8 = للإلحاق
    LogFile.WriteLine Now & " - " & Message
    LogFile.Close
    
LogCleanUp:
    Set LogFile = Nothing
    Set FileSystem = Nothing
    Exit Sub
    
LogError:
    If DebugMode Then
        Debug.Print "خطأ في كتابة ملف Log: " & Err.Description
    End If
    Resume LogCleanUp
End Sub

Public Function IsFolderWritable(ByVal FolderPath As String) As Boolean
    ' الغرض: التحقق من إمكانية الكتابة في المجلد
    ' المدخلات: مسار المجلد
    ' المخرجات: True إذا كان المجلد قابلًا للكتابة، False إذا لم يكن كذلك
    On Error Resume Next
    
    Dim FileSystem      As Object
    Dim TestFile        As String
    Dim TestStream      As Object
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    TestFile = FolderPath & "\test_write_" & Format(Now, "yyyymmddhhnnss") & ".tmp"
    
    Set TestStream = FileSystem.CreateTextFile(TestFile, True)
    If Not TestStream Is Nothing Then
        TestStream.Close
        FileSystem.DeleteFile TestFile
        IsFolderWritable = True
    Else
        IsFolderWritable = False
    End If
    
    Set TestStream = Nothing
    Set FileSystem = Nothing
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)

    ' عرض النتيجة
    MsgBox "AddWindowsCredential Result: " & blnSuccess, vbInformation
End Sub

' ====================================================
'  قراءة بيانات اعتماد كاملة
' ====================================================
Public Sub TestReadWindowsCredential()
    Dim strNetworkAddress   As String
    Dim strNetworkUserName  As String
    Dim strNetworkPassword  As String
    Dim blnSuccess          As Boolean
    
    ' عنوان الشبكة المطابق لبيانات الاعتماد المخزنة
    strNetworkAddress = "TestTarget0123"
    
    ' استدعاء دالة القراءة
    blnSuccess = ReadWindowsCredential(strNetworkAddress, strNetworkUserName, strNetworkPassword)

    ' عرض النتيجة
    If blnSuccess Then
        MsgBox "UserName: " & strNetworkUserName & vbCrLf & "Password: " & strNetworkPassword, vbInformation, "ReadWindowsCredential"
    Else
        MsgBox "Failed to read credential.", vbExclamation
    End If
End Sub

' ====================================================
'  قراءة بيانات الاعتماد
' ====================================================
Public Sub TestReadWindowsCredentialSimple()
    Dim strNetworkAddress   As String
    Dim objDict             As Object

    ' العنوان المرتبط ببيانات الاعتماد
    strNetworkAddress = "moh3sam"

    Set objDict = ReadWindowsCredentialByNetworkAddress(strNetworkAddress)

    If Not objDict Is Nothing Then
        MsgBox "UserName: " & objDict("NetworkUserName") & vbCrLf & "Password: " & objDict("NetworkPassword"), vbInformation, "ReadWindowsCredentialSimple"
    Else
        MsgBox "Failed to read credential " & strNetworkAddress & ".", vbExclamation
    End If

    If DebugMode Then
        Debug.Print "" & objDict("NetworkUserName")
        Debug.Print "" & objDict("NetworkPassword")
    End If
End Sub

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

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

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

    ' عرض النتيجة
    MsgBox "DeleteWindowsCredential Result: " & blnSuccess, vbInformation
End Sub

صور توضح مكان حفظ أو جلب بيانات الاعتماد من النظام

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

إدارة بيانات الاعتماد.zip

[Foksh]

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

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

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

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

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

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

 

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

 

 

[ابو جودي]

 

3 دقائق مضت, Foksh said:

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

سؤال لولبى 
 

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

 

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

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

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

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

 

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

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

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

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

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

 

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

 

 

 

[عمر ضاحى]

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

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

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

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

 

[Moosak]

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

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

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

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