[VBA] úprava registrů

[Kooca]

Zdravím,

může mi někdo poradit jak pomocí kódu ve VBA upravovat registry?

[Kon]

Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Global Const KEY_ALL_ACCESS = &H3F
Global Const KEY_READ = &H19

Global Const REG_OPTION_NON_VOLATILE = 0

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey 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
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
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNull Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long


Private Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long

  Dim lValue As Long
  Dim sValue As String
  
  Select Case lType
      Case REG_SZ
          sValue = vValue & Chr$(0)
          SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
      Case REG_DWORD
          lValue = vValue
          SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
  End Select
        
End Function

Sub SetKeyValue(lMainKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)

  Dim lRetVal As Long         'result of the SetValueEx function
  Dim hKey As Long            'handle of open key

  'open the specified key
  lRetVal = RegOpenKeyEx(lMainKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
  lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
  RegCloseKey (hKey)
       
End Sub

Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long

Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String

On Error GoTo QueryValueExError

' Determine the size and type of data to be read
lrc = RegQueryValueExNull(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then
  Err.Raise Number&#58;=5, Description&#58;=&#40;Error&#40;5&#41;&#41;
End If

Select Case lType
  ' For strings
  Case REG_SZ&#58;
    sValue = String&#40;cch, 0&#41;
    lrc = RegQueryValueExString&#40;lhKey, szValueName, 0&, lType, sValue, cch&#41;
    If lrc = ERROR_NONE Then
      vValue = Left$&#40;sValue, cch - 1&#41;
    Else
      vValue = Empty
    End If
    
  ' For DWORDS
  Case REG_DWORD&#58;
    lrc = RegQueryValueExLong&#40;lhKey, szValueName, 0&, lType, lValue, cch&#41;
    If lrc = ERROR_NONE Then vValue = lValue
    
  'all other data types not supported
  Case Else
    lrc = -1
    
End Select

QueryValueExExit&#58;
  QueryValueEx = lrc
  Exit Function

QueryValueExError&#58;
  Resume QueryValueExExit

End Function

Function QueryValue&#40;lMainKey As Long, sKeyName As String, sValueName As String&#41;

  Dim lRetVal As Long      'result of the API functions
  Dim hKey As Long         'handle of opened key
  Dim vValue As Variant    'setting of queried value
  
  lRetVal = RegOpenKeyEx&#40;lMainKey, sKeyName, 0, KEY_READ, hKey&#41;
  lRetVal = QueryValueEx&#40;hKey, sValueName, vValue&#41;
  If lRetVal <> 0 Then vValue = Empty
  RegCloseKey &#40;hKey&#41;
  QueryValue = vValue
  
End Function

Public Function CreateKey&#40;ByVal hKey As Long, ByVal Key As String&#41;

  Dim lRetVal As Long
  
  lRetVal = RegCreateKeyEx&#40;hKey, Key, 0, ByVal 0, 0, 0, 0, 0, 0&#41;

End Function

[Jochynator]

VBA neumí zapisovat a číst do/z libovolného registru, potřebujes k tomu API.
V případe, že bys chtěl jen načítat/ukládat nastavení tvých Excelovských aplikací můžeš použít funkce VBA GetSettings a SaveSettings ( http://j-walk.com/ss/excel/tips/tip60.htm ), ale s těma se dostaneš jen na jeden klič:

HKEY_CURRENT_USER\Software\VB and VBA Program Settings

Tady jsou ty API fce:

' 32-bit declarations 
Private Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" _ 
    (ByVal hKey As Long, ByVal sSubKey As String, _ 
    ByRef hkeyResult As Long) As Long 

Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" _ 
    (ByVal hKey As Long) As Long 

Private Declare Function RegSetValueExA Lib "ADVAPI32.DLL" _ 
    (ByVal hKey As Long, ByVal sValueName As String, _ 
    ByVal dwReserved As Long, ByVal dwType As Long, _ 
    ByVal sValue As String, ByVal dwSize As Long) As Long 

Private Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" _ 
    (ByVal hKey As Long, ByVal sSubKey As String, _ 
    ByRef hkeyResult As Long) As Long 

Private Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" _ 
    (ByVal hKey As Long, ByVal sValueName As String, _ 
    ByVal dwReserved As Long, ByRef lValueType As Long, _ 
    ByVal sValue As String, ByRef lResultLen As Long) As Long

A pro ně vytvořené obálkové fce:
ČTENÍ:

Private Function GetRegistry(Key, Path, ByVal ValueName As String) 
'  Reads a value from the Windows Registry 

    Dim hKey As Long 
    Dim lValueType As Long 
    Dim sResult As String 
    Dim lResultLen As Long 
    Dim ResultLen As Long 
    Dim x, TheKey As Long 

    TheKey = -99 
    Select Case UCase(Key) 
        Case "HKEY_CLASSES_ROOT": TheKey = &H80000000 
        Case "HKEY_CURRENT_USER": TheKey = &H80000001 
        Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002 
        Case "HKEY_USERS": TheKey = &H80000003 
        Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004 
        Case "HKEY_DYN_DATA": TheKey = &H80000005 
    End Select 
    
'   Exit if key is not found 
    If TheKey = -99 Then 
        GetRegistry = "Not Found" 
        Exit Function 
    End If 

    If RegOpenKeyA&#40;TheKey, Path, hKey&#41; <> 0 Then _ 
        x = RegCreateKeyA&#40;TheKey, Path, hKey&#41; 
    
    sResult = Space&#40;100&#41; 
    lResultLen = 100 
    
    x = RegQueryValueExA&#40;hKey, ValueName, 0, lValueType, _ 
    sResult, lResultLen&#41; 
        
    Select Case x 
        Case 0&#58; GetRegistry = Left&#40;sResult, lResultLen - 1&#41; 
        Case Else&#58; GetRegistry = "Not Found" 
    End Select 
    
    RegCloseKey hKey 
End Function

ZÁPIS:

Private Function WriteRegistry(ByVal Key As String, _ 
    ByVal Path As String, ByVal entry As String, _ 
    ByVal value As String) 
    
    Dim hKey As Long 
    Dim lValueType As Long 
    Dim sResult As String 
    Dim lResultLen As Long 
    Dim TheKey As Long 
    Dim x 
    
    
    TheKey = -99 
    Select Case UCase(Key) 
        Case "HKEY_CLASSES_ROOT": TheKey = &H80000000 
        Case "HKEY_CURRENT_USER": TheKey = &H80000001 
        Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002 
        Case "HKEY_USERS": TheKey = &H80000003 
        Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004 
        Case "HKEY_DYN_DATA": TheKey = &H80000005 
    End Select 
    
'   Exit if key is not found 
    If TheKey = -99 Then 
        WriteRegistry = False 
        Exit Function 
    End If 

'   Make sure  key exists 
    If RegOpenKeyA&#40;TheKey, Path, hKey&#41; <> 0 Then 
        x = RegCreateKeyA&#40;TheKey, Path, hKey&#41; 
    End If 

    x = RegSetValueExA&#40;hKey, entry, 0, 1, value, Len&#40;value&#41; + 1&#41; 
    If x = 0 Then WriteRegistry = True Else WriteRegistry = False 
End Function