REGISTRE WINDOWS

Public Enum enREG_KEYS
  HKEY_CLASSES_ROOT = &H80000000
  HKEY_CURRENT_USER = &H80000001
  HKEY_LOCAL_MACHINE = &H80000002
  HKEY_USERS = &H80000003
  HKEY_PERFORMANCE_DATA = &H80000004
  HKEY_CURRENT_CONFIG = &H80000005
  HKEY_DYN_DATA = &H80000006
End Enum

Enum enREG_TYPES
  REG_NONE = 0 ' No value type
  REG_SZ = 1 ' Unicode nul terminated string
  REG_EXPAND_SZ = 2 ' Unicode nul terminated string
  REG_BINARY = 3 ' Free form binary
  REG_BINARY_HEX = 8 ' Free form binary hex
  REG_BINARY_LONG = 9 ' Free form binary lng
  REG_DWORD = 4 ' 32-bit number
  REG_DWORD_BIG_ENDIAN = REG_DWORD
  REG_LINK = 6 ' Symbolic Link (unicode)
  REG_MULTI_SZ = 7 ' Multiple Unicode strings
End Enum

Private Type tyRegister
  hKey As Long 'Handle clé registre depuis constante
  hSKey As Long 'Handle de retour apres ouverture registre
  SubKey As String 'Chaine de la sous clé
  TypeKey As Long 'Type de donnée écrire ou lue
  HaveError As Boolean 'Erreur dans la fonction executé
  HaveErrorDescription As String 'Description de l'erreur
End Type
Public MyRegister As tyRegister

Const KEY_READ = &H20019

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)

Public Function DIRECT_QueryValueEx(ByRef myKey As enREG_KEYS, ByRef mySubKey As String, ByRef myValueKey As String) As Variant
  Dim lResult As Long, lRtData As Long
  Dim lRtType As enREG_TYPES
  
  Call OpenRegister(myKey, mySubKey)
  
    lResult = RegQueryValueEx(MyRegister.phKey, myValueKey, 0, lRtType, ByVal 0, lRtData)
    TypeKey = lRtType
    
    '0 = Success de lecture de la valeur
    If lResult = 0 Then
      DIRECT_QueryValueEx = True
    Else
      DIRECT_QueryValueEx = False
    End If
    DIRECT_QueryValueEx = GetStringRegisterError("ERROR", "DIRECT_QueryValueEx", 0, lRt)
  
  Call CloseRegister
End Function

Public Function GetValue(ByVal sKeyValue As String) As Variant
    Dim lResult As Long, sDataBuf() As Byte, lDataBufSize As Long
    Dim lRtType As enREG_TYPES
    Dim rtString As String
    Dim rtLong As Long
    
      lResult = RegQueryValueEx(MyRegister.hSKey, sKeyValue, 0, lRtType, ByVal 0, lDataBufSize)
      TypeKey = lRtType
      
    If lResult = 0 Then
    
      ReDim sDataBuf(0 To lDataBufSize) As Byte
      lResult = RegQueryValueEx(MyRegister.hSKey, sKeyValue, 0, 0, sDataBuf(0), lDataBufSize)
      
        Select Case lRtType
         
          Case REG_SZ, REG_EXPAND_SZ
              rtString = Space$(lDataBufSize - 1)
              CopyMemory ByVal rtString, sDataBuf(0), lDataBufSize - 1
              GetValue = Trim(rtString)
              
          Case REG_MULTI_SZ
              rtString = Space$(lDataBufSize - 1)
              CopyMemory ByVal rtString, sDataBuf(0), lDataBufSize - 1
              GetValue = Replace(rtString, Chr(0), vbNewLine)
              
          Case REG_DWORD
              CopyMemory rtLong, sDataBuf(0), 4
              GetValue = rtLong
              
          Case REG_BINARY
              If lDataBufSize <> UBound(sDataBuf) + 1 Then
                ReDim Preserve sDataBuf(0 To lDataBufSize - 1) As Byte
              End If
              GetValue = sDataBuf()
        
          End Select
    End If

      Call GetStringRegisterError("ERROR", "GETVALUE", 0, lResult)

End Function

Private Function GetStringToBytesNumber(sAny As String) As Long
  Static i As Long
  Dim j As Long
  
    j = 0
      For i = 1 To Len(sAny) Step 2
        j = j + 1
      Next i
    GetStringToBytesNumber = j
End Function

Public Sub SetValue(ByVal lRtType As enREG_TYPES, sKeyValue As String, strData As Variant)
  Dim lResult As Long
  Dim lenTmp As Long
  Dim sDataBuf() As Byte
  Dim rtString As String
  Dim rtLong As Long
    
    Select Case lRtType
      Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
        rtString = CStr(strData)
        lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, lRtType, ByVal rtString, Len(rtString))
      Case REG_BINARY
        If IsNumeric(strData) = True Then
          rtLong = CLng(strData)
        Else
          rtLong = CLng("&h" & strData)
        End If
        lenTmp = GetStringToBytesNumber(CStr(rtLong))
        ReDim sDataBuf(lenTmp - 1) As Byte
        CopyMemory sDataBuf(0), rtLong, lenTmp
        lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, lRtType, sDataBuf(0), lenTmp - 1)
      Case REG_BINARY_HEX
        lenTmp = GetStringToBytesNumber(CStr(strData))
        ReDim sDataBuf(lenTmp - 1) As Byte
        rtLong = "&h" & strData
        CopyMemory sDataBuf(0), rtLong, lenTmp
        lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, REG_BINARY, sDataBuf(0), lenTmp)
      Case REG_BINARY_LONG
        rtLong = strData
        lenTmp = GetStringToBytesNumber(CStr(Hex(strData)))
        lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, REG_BINARY, rtLong, lenTmp)
      Case REG_DWORD
        rtLong = CLng(strData)
        lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, lRtType, rtLong, 4)
    End Select
        
    Erase sDataBuf
    Call GetStringRegisterError("ERROR", "SETVALUE", 0, lResult)
End Sub

Public Sub CreateKey(ByVal myNewSKey As String, Optional CreateAndRoot As Boolean = False)
Dim lResult As Long, rtKey As Long

  If CheckRoot(myNewSKey) = True Then Exit Sub
    lResult = RegCreateKey(MyRegister.hKey, myNewSKey, rtKey)
      If GetStringRegisterError("ERROR", "CREATEKEY", 0, lResult) = "" Then
        If CreateAndRoot = True Then
          MyRegister.hSKey = rtKey
          MyRegister.SubKey = myNewSKey
          SetRoot myNewSKey
        End If
      End If
End Sub

Public Sub CreateSubKey(ByVal myNewSKey As String, Optional CreateAndRoot As Boolean = False)
Dim lResult As Long, rtKey As Long

  If CheckRoot(myNewSKey) = True Then Exit Sub
    lResult = RegCreateKey(MyRegister.hSKey, myNewSKey, rtKey)
      If GetStringRegisterError("ERROR", "CreateSubKey", 0, lResult) = "" Then
        If CreateAndRoot = True Then
          MyRegister.hSKey = rtKey
          MyRegister.SubKey = MyRegister.SubKey & "\" & myNewSKey
          SetSubRoot MyRegister.SubKey
        End If
      End If
End Sub

Public Function CheckRoot(ByVal mySKey As String) As Boolean
  Dim hRead As Long, hResult As Long
  
    hResult = RegOpenKeyEx(MyRegister.hKey, mySKey, 0, KEY_READ, hRead)
      If hResult = 0 Then RegCloseKey hRead
        Call GetStringRegisterError("ERROR", "CheckRoot", 0, lResult)
End Function

Public Sub OpenRegister(myKey As enREG_KEYS)
  If MyRegister.hKey > 0 Then CloseRegister
    Call ClearRegister
      MyRegister.hKey = myKey
End Sub

Public Sub SetRoot(mySKey As String)
  Dim lResult As Long
    MyRegister.SubKey = mySKey
    If MyRegister.hSKey > 0 Then RegCloseKey MyRegister.hSKey
      lResult = RegOpenKey(MyRegister.hKey, MyRegister.SubKey, MyRegister.hSKey)
        Call GetStringRegisterError("ERROR", "SetRoot", 0, lResult)
End Sub

Public Sub SetSubRoot(mySKey As String)
  Dim lResult As Long
    If Not MyRegister.SubKey = mySKey Then
      MyRegister.SubKey = MyRegister.SubKey & "\" & mySKey
    End If
    If MyRegister.hSKey > 0 Then RegCloseKey MyRegister.hSKey
      lResult = RegOpenKey(MyRegister.hKey, MyRegister.SubKey, MyRegister.hSKey)
        Call GetStringRegisterError("ERROR", "SetRoot", 0, lResult)
End Sub

Public Sub CloseRegister()
  RegCloseKey MyRegister.hSKey
    Call ClearRegister
End Sub

Private Sub ClearRegister()
  With MyRegister
    .hKey = 0
    .hSKey = 0
    .SubKey = ""
    .TypeKey = 0
    .HaveError = False
    .HaveErrorDescription = ""
  End With
End Sub

Private Function GetStringRegisterError(sLabel As String, sFunction As String, lTrueResult As Long, ByVal lResult As Long) As String
'Error ; Function Error ;
'Retour Query ; Key Handle ; SubKey Handle ; Root String
Dim rtERR As String
  If lTrueResult = lResult Then
    MyRegister.HaveError = False
    rtERR = ""
  Else
    MyRegister.HaveError = True
    rtERR = UCase(sLabel) & "[;]" & _
            UCase(sFunction) & "[;]" & _
            CStr(lResult) & "[;]" & _
            MyRegister.hKey & "[;]" & _
            MyRegister.hSKey & "[;]" & _
            MyRegister.SubKey & "[;]"
  End If
    MyRegister.HaveErrorDescription = rtERR
    GetStringRegisterError = rtERR
End Function