الكتابة لملف الريجستي والقراءة والحذف

حفظ المعلومات في الريجستي يكون باستخدام SaveSetting كالتالي :

SaveSetting "اسم التطبيق","اسم القسم","المفتاح","القيمة"

مثال :

SaveSetting "برنامجي", "نموذج الخيارات", "إظهار حقل", مربع_التدقيق_الأول

والإستعادة أو القراءة تكون باستخدام GetSetting كالتالي :

متغير= GetSetting ("اسم التطبيق","اسم القسم","المفتاح")

مثال :

مربع_التدقيق_الأول= GetSetting("إظهار حقل", "نموذج الخيارات", "برنامجي")

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

وبإمكانك وضع قيم افتراضيه حالما يتم تحميل النموذج عندما لايجد قيم مسجله في الريجستي وللتأكد من عدم وجود قيمة استخدم :

If GetSetting("اسم التطبيق", "اسم القسم", "المفتاح") = "" Then

وإذا استخدمت متغير فاجعل من نوع Variant أو String .

فائدة :

ولحذف إدخال في سجل (للمثال السابق) :

1- لكافة التطبيق :
DeleteSetting "برنامجي" 
2- لحذف قسم واحد فقط :
DeleteSetting "برنامجي","نموذج الخيارات"
3- لحذف إدخال واحد فقط :
DeleteSetting "إظهار حقل", "نموذج الخيارات", "برنامجي"

فائدة :

لفتح ملف التسجيل لمعاينة التغييرات ؛ انقر ابدأ ثم تشغيل واكتب RegEdit وانتقل إلى HKEY_CURRENT_USERSoftwareVB and VBA Program Settings وستجد اسم التطبيق انقر عليه وستجد الأقسام التي وضعتها داخل اسم التطبيق .

ملاحظة هامة جداً : كن حذراً جداً من أي تغيير في السجل لاتعرف تأثيره لأنه قد يؤدي إلى في أسوأ الأحوال إلى توقف الوندوز عن العمل وفي أقلها تعطل بعض البرامج أو الخيارات أو غيرها .

ولك تحياتي

جزاكم الله خيرا علي هذا الشرح الوافي

و جعله الله فى ميزان حسناتك

(f) (f) (f)

رفع للفائدة ولأهمية الموضوع .

وهذا الكود يمكنك من القراءة والكتابة وحذف قيمة من مفتاح مع ملاحظة أنه يمكن تخزين القيم وإنشاء مفاتيح تحت أحد الجذور الأربعة التالية لملف الريجستي :

HKeyClassesRoot

HKeyCurrentUser

HKeyLocalMachine

HKeyUsers

والان اليكم الكود :

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Private Declare Function RegCloseKey _
  Lib "advapi32.dll" _
  (ByVal lngHKey As Long) _
  As Long

Private Declare Function RegCreateKeyEx _
  Lib "advapi32.dll" _
  Alias "RegCreateKeyExA" _
  (ByVal lngHKey As Long, _
    ByVal lpSubKey As String, _
    ByVal Reserved As Long, _
    ByVal lpClass As String, _
    ByVal dwOptions As Long, _
    ByVal samDesired As Long, _
    ByVal lpSecurityAttributes As Long, _
    phkResult As Long, _
    lpdwDisposition As Long) _
  As Long

Private Declare Function RegOpenKeyEx _
  Lib "advapi32.dll" _
  Alias "RegOpenKeyExA" _
  (ByVal lngHKey As Long, _
    ByVal lpSubKey As String, _
    ByVal ulOptions As Long, _
    ByVal samDesired As Long, _
    phkResult As Long) _
  As Long

Private Declare Function RegQueryValueExString _
  Lib "advapi32.dll" _
  Alias "RegQueryValueExA" _
  (ByVal lngHKey As Long, _
    ByVal lpValueName As String, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    ByVal lpData As String, _
    lpcbData As Long) _
  As Long

Private Declare Function RegQueryValueExLong _
  Lib "advapi32.dll" _
  Alias "RegQueryValueExA" _
  (ByVal lngHKey As Long, _
    ByVal lpValueName As String, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    lpData As Long, _
    lpcbData As Long) _
  As Long

Private Declare Function RegQueryValueExBinary _
  Lib "advapi32.dll" _
  Alias "RegQueryValueExA" _
  (ByVal lngHKey As Long, _
    ByVal lpValueName As String, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    ByVal lpData As Long, _
    lpcbData As Long) _
  As Long

Private Declare Function RegQueryValueExNULL _
  Lib "advapi32.dll" _
  Alias "RegQueryValueExA" _
  (ByVal lngHKey As Long, _
    ByVal lpValueName As String, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    ByVal lpData As Long, _
    lpcbData As Long) _
  As Long

Private Declare Function RegSetValueExString _
  Lib "advapi32.dll" _
  Alias "RegSetValueExA" _
  (ByVal lngHKey As Long, _
    ByVal lpValueName As String, _
    ByVal Reserved As Long, _
    ByVal dwType As Long, _
    ByVal lpValue As String, _
    ByVal cbData As Long) _
  As Long

Private Declare Function RegSetValueExLong _
  Lib "advapi32.dll" _
  Alias "RegSetValueExA" _
  (ByVal lngHKey As Long, _
    ByVal lpValueName As String, _
    ByVal Reserved As Long, _
    ByVal dwType As Long, _
    lpValue As Long, _
    ByVal cbData As Long) _
  As Long

Private Declare Function RegSetValueExBinary _
  Lib "advapi32.dll" _
  Alias "RegSetValueExA" _
  (ByVal lngHKey As Long, _
    ByVal lpValueName As String, _
    ByVal Reserved As Long, _
    ByVal dwType As Long, _
    ByVal lpValue As Long, _
    ByVal cbData As Long) _
  As Long

Private Declare Function RegEnumKey _
  Lib "advapi32.dll" _
  Alias "RegEnumKeyA" _
  (ByVal lngHKey As Long, _
    ByVal dwIndex As Long, _
    ByVal lpName As String, _
    ByVal cbName As Long) _
  As Long

Private Declare Function RegQueryInfoKey _
  Lib "advapi32.dll" _
  Alias "RegQueryInfoKeyA" _
  (ByVal lngHKey As Long, _
    ByVal lpClass As String, _
    ByVal lpcbClass As Long, _
    ByVal lpReserved As Long, _
    lpcSubKeys As Long, _
    lpcbMaxSubKeyLen As Long, _
    ByVal lpcbMaxClassLen As Long, _
    lpcValues As Long, _
    lpcbMaxValueNameLen As Long, _
    ByVal lpcbMaxValueLen As Long, _
    ByVal lpcbSecurityDescriptor As Long, _
    lpftLastWriteTime As FILETIME) _
  As Long

Private Declare Function RegEnumValue _
  Lib "advapi32.dll" _
  Alias "RegEnumValueA" _
  (ByVal lngHKey As Long, _
    ByVal dwIndex As Long, _
    ByVal lpValueName As String, _
    lpcbValueName As Long, _
    ByVal lpReserved As Long, _
    ByVal lpType As Long, _
    ByVal lpData As Byte, _
    ByVal lpcbData As Long) _
  As Long

Private Declare Function RegDeleteKey _
  Lib "advapi32.dll" _
  Alias "RegDeleteKeyA" _
  (ByVal lngHKey As Long, _
    ByVal lpSubKey As String) _
  As Long

Private Declare Function RegDeleteValue _
  Lib "advapi32.dll" _
  Alias "RegDeleteValueA" _
  (ByVal lngHKey As Long, _
    ByVal lpValueName As String) _
  As Long

Public Enum EnumRegistryRootKeys
  HKeyClassesRoot = &H80000000
  HKeyCurrentUser = &H80000001
  HKeyLocalMachine = &H80000002
  HKeyUsers = &H80000003
End Enum

Public Enum EnumRegistryValueType
  rrkRegSZ = 1
  rrkregbinary = 3
  rrkRegDWord = 4
End Enum

Private Const mcregOptionNonVolatile = 0

Private Const mcregErrorNone = 0
Private Const mcregErrorBadDB = 1
Private Const mcregErrorBadKey = 2
Private Const mcregErrorCantOpen = 3
Private Const mcregErrorCantRead = 4
Private Const mcregErrorCantWrite = 5
Private Const mcregErrorOutOfMemory = 6
Private Const mcregErrorInvalidParameter = 7
Private Const mcregErrorAccessDenied = 8
Private Const mcregErrorInvalidParameterS = 87
Private Const mcregErrorNoMoreItems = 259

Private Const mcregKeyAllAccess = &H3F
Private Const mcregKeyQueryValue = &H1

Public Sub RegistryCreateNewKey( _
  eRootKey As EnumRegistryRootKeys, _
  strKeyName As String)
  Dim lngRetVal As Long
  Dim lngHKey As Long

  On Error GoTo PROC_ERR

  lngRetVal = RegCreateKeyEx(eRootKey, strKeyName, 0&, vbNullString, _
    mcregOptionNonVolatile, mcregKeyAllAccess, 0&, lngHKey, 0&)
  If lngRetVal = mcregErrorNone Then
    RegCloseKey (lngHKey)
  End If

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "RegistryCreateNewKey"
  Resume PROC_EXIT

End Sub

Public Sub RegistryDeleteKey( _
  eRootKey As EnumRegistryRootKeys, _
  strKeyName As String)

  Dim lngRetVal As Long

  On Error GoTo PROC_ERR

  ' Delete the key
  lngRetVal = RegDeleteKey(eRootKey, strKeyName)

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "RegistryDeleteKey"
  Resume PROC_EXIT

End Sub

Public Sub RegistryDeleteValue( _
  eRootKey As EnumRegistryRootKeys, _
  strKeyName As String, _
  strValueName As String)

  Dim lngRetVal As Long
  Dim lngHKey As Long

  On Error GoTo PROC_ERR

  ' Open the key
  lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyAllAccess, _
    lngHKey)

  ' If the key was opened successfully, then delete it
  If lngRetVal = mcregErrorNone Then
    lngRetVal = RegDeleteValue(lngHKey, strValueName)
  End If

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "RegistryDeleteValue"
  Resume PROC_EXIT

End Sub

Public Sub RegistryEnumerateSubKeys( _
  eRootKey As EnumRegistryRootKeys, _
  strKeyName As String, _
  astrKeys() As String, _
  lngKeyCount As Long)

  Dim lngRetVal As Long
  Dim lngHKey As Long
  Dim lngKeyIndex As Long
  Dim strSubKeyName As String
  Dim lngSubkeyCount As Long
  Dim lngMaxKeyLen As Long
  Dim typFT As FILETIME

  On Error GoTo PROC_ERR

  ' Open the key
  lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyAllAccess, _
    lngHKey)

  If lngRetVal = mcregErrorNone Then
    'find the number of subkeys, and redim the return string array
    lngRetVal = RegQueryInfoKey(lngHKey, vbNullString, 0, 0, lngSubkeyCount, _
      lngMaxKeyLen, 0, 0, 0, 0, 0, typFT)
    If mcregErrorNone = lngRetVal Then
      If lngSubkeyCount > 0 Then
        ReDim astrKeys(lngSubkeyCount - 1) As String

        'set up the while loop
        lngKeyIndex = 0
        ' Pad the string to the maximum length of a sub key, plus 1 for null
        ' termination
        lngMaxKeyLen = lngMaxKeyLen + 1
        strSubKeyName = Space$(lngMaxKeyLen)

        Do While RegEnumKey(lngHKey, lngKeyIndex, strSubKeyName, lngMaxKeyLen + 1) = 0

          ' Set the string array to the key name, removing null termination
          If InStr(1, strSubKeyName, vbNullChar) > 0 Then
            astrKeys(lngKeyIndex) = Left$(strSubKeyName, InStr(1, strSubKeyName, _
              vbNullChar) - 1)
          End If
          ' Increment the key index for the return string array
          lngKeyIndex = lngKeyIndex + 1

        Loop
      End If
      ' return the new dimension of the return string array
      lngKeyCount = lngSubkeyCount
    End If

    ' Close the key
    RegCloseKey (lngHKey)
  End If

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "RegistryEnumerateSubKeys"
  Resume PROC_EXIT

End Sub

Public Sub RegistryEnumerateValues( _
  eRootKey As EnumRegistryRootKeys, _
  strKeyName As String, _
  astrValues() As String, _
  lngValueCount As Long)

  Dim lngRetVal As Long
  Dim lngHKey As Long
  Dim lngKeyIndex As Long
  Dim strValueName As String
  Dim lngTempValueCount As Long
  Dim lngMaxValueLen As Long
  Dim typFT As FILETIME

  On Error GoTo PROC_ERR

  ' Open the key
  lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyAllAccess, _
    lngHKey)

  If lngRetVal = mcregErrorNone Then
    'find the number of subkeys, and redim the return string array
    lngRetVal = RegQueryInfoKey(lngHKey, vbNullString, 0, 0, 0, _
      0, 0, lngTempValueCount, lngMaxValueLen, 0, 0, typFT)
    If mcregErrorNone = lngRetVal Then
      If lngTempValueCount > 0 Then
        ReDim astrValues(lngTempValueCount - 1) As String

        'set up the while loop
        lngKeyIndex = 0
        ' Pad the string to the maximum length of a sub key, plus 1 for null
        ' termination
        lngMaxValueLen = lngMaxValueLen + 1
        strValueName = Space$(lngMaxValueLen)

        Do While RegEnumValue(lngHKey, lngKeyIndex, strValueName, _
          lngMaxValueLen + 1, 0, 0, 0, 0) = 0

          ' Set the string array to the key name, removing null termination
          If InStr(1, strValueName, vbNullChar) > 0 Then
            astrValues(lngKeyIndex) = Left$(strValueName, InStr(1, strValueName, _
              vbNullChar) - 1)
          End If
          ' Increment the key index for the return string array
          lngKeyIndex = lngKeyIndex + 1

        Loop
      End If
      ' return the new dimension of the return string array
      lngValueCount = lngTempValueCount
    End If

    ' Close the key
    RegCloseKey (lngHKey)
  End If

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "RegistryEnumerateValues"
  Resume PROC_EXIT

End Sub

Public Function RegistryGetKeyValue( _
  eRootKey As EnumRegistryRootKeys, _
  strKeyName As String, _
  strValueName As String) _
  As Variant

  Dim lngRetVal As Long
  Dim lngHKey As Long
  Dim varValue As Variant
  Dim strValueData As String
  Dim abytValueData() As Byte
  Dim lngValueData As Long
  Dim lngValueType As Long
  Dim lngDataSize As Long

  On Error GoTo PROC_ERR

  varValue = Empty

  lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0&, mcregKeyQueryValue, _
    lngHKey)

  If mcregErrorNone = lngRetVal Then

    lngRetVal = RegQueryValueExNULL(lngHKey, strValueName, 0&, lngValueType, _
      0&, lngDataSize)

    If lngRetVal = mcregErrorNone Then

      Select Case lngValueType

      ' String type

        Case rrkRegSZ:
          If lngDataSize > 0 Then
            strValueData = String(lngDataSize, 0)
            lngRetVal = RegQueryValueExString(lngHKey, strValueName, 0&, _
              lngValueType, strValueData, lngDataSize)
            If InStr(strValueData, vbNullChar) > 0 Then
              strValueData = Mid$(strValueData, 1, InStr(strValueData, _
                vbNullChar) - 1)
            End If
          End If
          If mcregErrorNone = lngRetVal Then
            varValue = Left$(strValueData, lngDataSize)
          Else
            varValue = Empty
          End If

        ' Long type
        Case rrkRegDWord:
          lngRetVal = RegQueryValueExLong(lngHKey, strValueName, 0&, _
            lngValueType, lngValueData, lngDataSize)
          If mcregErrorNone = lngRetVal Then
            varValue = lngValueData
          End If

        ' Binary type
        Case rrkregbinary
          If lngDataSize > 0 Then
            ReDim abytValueData(lngDataSize) As Byte
            lngRetVal = RegQueryValueExBinary(lngHKey, strValueName, 0&, _
              lngValueType, VarPtr(abytValueData(0)), lngDataSize)
          End If
          If mcregErrorNone = lngRetVal Then
            varValue = abytValueData
          Else
            varValue = Empty
          End If

        Case Else
          'No other data types supported
          lngRetVal = -1

      End Select

    End If

    RegCloseKey (lngHKey)
  End If

  'Return varValue
  RegistryGetKeyValue = varValue
PROC_EXIT:
  Exit Function

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "RegistryGetKeyValue"
  Resume PROC_EXIT
End Function

Public Sub RegistrySetKeyValue( _
  eRootKey As EnumRegistryRootKeys, _
  strKeyName As String, _
  strValueName As String, _
  varData As Variant, _
  eDataType As EnumRegistryValueType)

  Dim lngRetVal As Long
  Dim lngHKey As Long
  Dim strData As String
  Dim lngData As Long
  Dim abytData() As Byte

  On Error GoTo PROC_ERR

  ' Open the specified key, If it does not exist then create it
  lngRetVal = RegCreateKeyEx(eRootKey, strKeyName, 0&, vbNullString, _
    mcregOptionNonVolatile, mcregKeyAllAccess, 0&, lngHKey, 0&)

  ' Determine the data type of the key
  Select Case eDataType

  Case rrkRegSZ
    strData = varData & vbNullChar
    lngRetVal = RegSetValueExString(lngHKey, strValueName, 0&, eDataType, _
      strData, Len(strData))

  Case rrkRegDWord
    lngData = varData
    lngRetVal = RegSetValueExLong(lngHKey, strValueName, 0&, eDataType, _
      lngData, Len(lngData))

  ' Binary type
  Case rrkregbinary
    abytData = varData
    lngRetVal = RegSetValueExBinary(lngHKey, strValueName, 0&, eDataType, _
      VarPtr(abytData(0)), UBound(abytData) + 1)

  End Select

  RegCloseKey (lngHKey)

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "RegistrySetKeyValue"
  Resume PROC_EXIT

End Sub

' مثال لإنشاء مفتاح رئيس تحت الجذر
[code]RegistryCreateNewKey HKeyUsers, "New FloderSub Floder"

' مثال على إسناد قيمة لمفتاح فرعي

' إذا لم يجد المفتاح الفرعي فإنه ينشئه

RegistrySetKeyValue HKeyUsers, "New FloderSub Floder", "اسم كائن", True, rrkRegSZ

MsgBox RegistryGetKeyValue(HKeyUsers, "New FloderSub Floder", "اسم كائن")

' حذف قيمة مسندة لمفتاح فرعي

RegistryDeleteValue HKeyUsers, "New FloderSub Floder", "اسم كائن"

' مثال لحذف مفتاح رئيس تحت الجذر

RegistryDeleteKey HKeyUsers, "مجلد جديد"

علماً أنني نقلته من أحد المواقع .

وللجميع التحية