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




© 2020 Better Solutions Limited. All Rights Reserved. © 2020 Better Solutions Limited TopPrevNext