VBA/Excel/Access/Word/Windows API/Registry
Содержание
Reads a value from the Windows Registry
<source lang="vb">
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 Function GetRegistry(Key, Path, ByVal ValueName As String)
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 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 If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then _ x = RegCreateKeyA(TheKey, Path, hKey) sResult = Space(100) lResultLen = 100 x = RegQueryValueExA(hKey, ValueName, 0, lValueType, _ sResult, lResultLen) Select Case x Case 0: GetRegistry = Left(sResult, lResultLen - 1) Case Else: GetRegistry = "Not Found" End Select RegCloseKey hKey
End Function Sub TestIt()
RootKey = "hkey_current_user" Path = "software\microsoft\office\9.0\common\autocorrect" RegEntry = "path" MsgBox GetRegistry(RootKey, Path, RegEntry), vbInformation, _ Path & "\RegEntry"
End Sub
</source>
Using RegQueryValueEx to Read Registry Information
<source lang="vb">
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 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 Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Sub cmdRead()
Dim strValue As String * 256 Dim lngRetval As Long Dim lngLength As Long Dim lngKey As Long If RegOpenKeyEx(HKEY_CURRENT_USER, "Your_Key_Name", 0, KEY_QUERY_VALUE, lngKey) Then End If lngLength = 256 "Retrieve the value of the key lngRetval = RegQueryValueEx( _ lngKey, "YourValueName", 0, 0, ByVal strValue, lngLength) MsgBox Left(strValue, lngLength) "Close the key RegCloseKey (lngKey)
End Sub
</source>
Using RegSetValueEx to Write Information to the Registry
<source lang="vb">
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 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 Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Sub cmdWrite_Click()
Dim strValue As String Dim strKeyName As String Dim lngRetval As Long Dim lngLength As Long Dim lngKey As Long strKeyName = "KeyName" & vbNullString If RegOpenKeyEx(HKEY_CURRENT_USER, strKeyName, 0, KEY_WRITE, lngKey) Then End If strValue = "YourValue" & vbNullString lngLength = Len("YourValue") + 1 lngRetval = RegSetValueEx( lngKey, "YourValue", 0, REG_SZ, ByVal strValue, lngLength) "Close the key RegCloseKey (lngKey)
End Sub
</source>
Working with the Registry Using the VBA Registry Functions
<source lang="vb">
Sub ExperimentWithRegistry()
Dim vaKeys As Variant " create new registry entries SaveSetting "XLTest", "General", "App_Name", "XLTest" SaveSetting "XLTest", "General", "App_Version", "1.0.0" SaveSetting "XLTest", "General", "App_Date", "10/11/2003" PrintRegistrySettings SaveSetting "XLTest", "General", "App_Version", "1.0.1" PrintRegistrySettings vaKeys = GetAllSettings("XLTest", "General") PrintAllSettings vaKeys DeleteSetting "XLTest", "General", "App_Name" DeleteSetting "XLTest", "General", "App_Version" DeleteSetting "XLTest", "General", "App_Date" PrintRegistrySettings
End Sub Sub PrintRegistrySettings()
On Error Resume Next Debug.Print "Application Name: " & GetSetting("XLTest", "General", "App_Name") Debug.Print "Application Version: " & GetSetting("XLTest", "General", "App_Version") Debug.Print "Application Date: " & GetSetting("XLTest", "General", "App_Date")
End Sub Sub PrintAllSettings(vaSettings As Variant)
Dim nItem As Integer If IsArray(vaSettings) Then For nItem = 0 To UBound(vaSettings) Debug.Print vaSettings(nItem, 0) & ": " & _ vaSettings(nItem, 1) Next End If
End Sub
</source>
Write a value from the Windows Registry
<source lang="vb">
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 Function GetRegistry(Key, Path, ByVal ValueName As String)
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 If TheKey = -99 Then GetRegistry = "Not Found" Exit Function End If If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then _ x = RegCreateKeyA(TheKey, Path, hKey) sResult = Space(100) lResultLen = 100 x = RegQueryValueExA(hKey, ValueName, 0, lValueType, _ sResult, lResultLen) Select Case x Case 0: GetRegistry = Left(sResult, lResultLen - 1) Case Else: GetRegistry = "Not Found" End Select RegCloseKey hKey
End Function 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 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 If TheKey = -99 Then WriteRegistry = False Exit Function End If If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then x = RegCreateKeyA(TheKey, Path, hKey) End If x = RegSetValueExA(hKey, entry, 0, 1, value, Len(value) + 1) If x = 0 Then WriteRegistry = True Else WriteRegistry = False
End Function
Sub UpdateRegistryWithTime()
RootKey = "hkey_current_user" Path = "software\microsoft\office\9.0\excel\LastStarted" RegEntry = "DateTime" RegVal = Now() LastTime = GetRegistry(RootKey, Path, RegEntry) Debug.Print LastTime Call WriteRegistry(RootKey, Path, RegEntry, RegVal)
End Sub
</source>