VBA/Excel/Access/Word/Windows API/Registry

Материал из VB Эксперт
Версия от 15:48, 26 мая 2010; Admin (обсуждение | вклад) (1 версия)
(разн.) ← Предыдущая | Текущая версия (разн.) | Следующая → (разн.)
Перейти к: навигация, поиск

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>