Advapi32.dll
Private Declare PtrSafe Function RegOpenKeyA Lib "advapi32.dll" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As LongPtr
Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As LongPtr
Private Declare PtrSafe 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 LongPtr
Private Declare PtrSafe Function RegCreateKeyA Lib "advapi32.dll" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As LongPtr
Private Declare PtrSafe 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 LongPtr
Private Declare PtrSafe 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 LongPtr
'Private Declare PtrSafe Function RegQueryValueExLong Lib "advapi32.dll" _ '(ByVal hKey As Long, ByVal lpValueName As String, _ 'ByVal lpReserved As Long, lpType As Long, _ 'lpData As Long, lpcbData As Long) As LongPtr
Private Const REG_SZ As Long = 1
Private Const REG_EXPAND_SZ As Long = 2
Private Const REG_BINARY As Long = 3
Private Const REG_DWORD As Long = 4
Public Sub GetRegistry_Value()
Dim RootKey As String
Dim Path As String
Dim RegEntry As String
Dim lasttime As String
RootKey = "HKEY_CURRENT_USER"
'Path = "software\microsoft\office\16.0\Excel"
'RegEntry = "ExcelName"
Path = "software\microsoft\office\16.0\excel\options"
RegEntry = "Open1"
'Path = "software\microsoft\office\excel\addins\COMExcelModelCover.MyConnect"
'RegEntry = "FriendlyName"
Call GetRegistry(RootKey, Path, RegEntry)
End Sub
Private Function GetRegistry( _
ByVal Key As String, _
ByVal Path As String, _
ByVal ValueName As String) 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 As LongPtr
Dim 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(TheKey, Path, hKey) <> 0 Then
MsgBox "cannot find/open key"
Exit Function
End If
lValueType = REG_SZ
sResult = Space(150)
lResultLen = 150
x = RegQueryValueExString(hKey, ValueName, 0&, lValueType, sResult, lResultLen)
Call RegCloseKey(hKey)
If (x = 2) Then
Call MsgBox("Cannot find the file specified")
Exit Function
End If
Call MsgBox("'" & VBA.Left(VBA.Trim(sResult), lResultLen - 1) & "'")
End Function
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
Sub UpdateRegistryWithTime()
RootKey = "hkey_current_user"
Path = "software\microsoft\office\9.0\excel\LastStarted"
RegEntry = "DateTime"
RegVal = Now()
LastTime = GetRegistry(RootKey, Path, RegEntry)
Select Case LastTime
Case "Not Found"
Msg = "This routine has not been executed before."
Case Else
Msg = "This routine was lasted executed: " & LastTime
End Select
Msg = Msg & Chr(13) & Chr(13)
Select Case WriteRegistry(RootKey, Path, RegEntry, RegVal)
Case True
Msg = Msg & "The registry has been updated with the current date and time."
Case False
Msg = Msg & "An error occured writing to the registry..."
End Select
MsgBox Msg, vbInformation, "Registry Demo"
End Sub
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(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
' Exit if key is not found
If TheKey = -99 Then
WriteRegistry = False
Exit Function
End If
' Make sure key exists
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 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
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext