VBA/Excel/Access/Word/Windows API/Registry — различия между версиями
Admin (обсуждение | вклад) м (1 версия) |
|
(нет различий)
|
Версия 16:33, 26 мая 2010
Содержание
Reads a value from the Windows Registry
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
Using RegQueryValueEx to Read Registry Information
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
Using RegSetValueEx to Write Information to the Registry
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
Working with the Registry Using the VBA Registry Functions
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
Write a value from the Windows Registry
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