Code From Module PAWWMIRegistry, Database: WMISample.mdb

Return to Home Page

Procedures:
Module PAWWMIRegistry


Module PAWWMIRegistry

Option Compare Database
Option Explicit

Const HKLM = &H80000002  ' Registry const
Const HKEY_CLASSES_ROOT = &H80000000 
Const HKEY_CURRENT_USER = &H80000001 
Const HKEY_LOCAL_MACHINE = &H80000002 
Const HKEY_USERS = &H80000003 
Const HKEY_CURRENT_CONFIG = &H80000005 

Const REG_SZ = 1 
Const REG_EXPAND_SZ = 2 
Const REG_BINARY = 3 
Const REG_DWORD = 4 
Const REG_MULTI_SZ = 7 


'---------------------------------------------------------------------------------------
' Procedure : CreateRegKeyHKLM
' Author    : Patrick Wood http://gainingaccess.net/
' Date      : 3/22/2010
' Purpose   : Create a HKEY_LOCAL_MACHINE Registry subkey.
' Example   : Call CreateRegKeyHKLM("SOFTWARE\ATestKey")
'---------------------------------------------------------------------------------------
'
Sub CreateRegKeyHKLM(strKeyPath As String) 
On Error Resume Next 
   
    Dim objReg As Object 
    Dim lngReturn As Long 
    Dim strComputer As String 
   
    strComputer = "."
   
    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
   
    lngReturn = objReg.CreateKey(HKEY_LOCAL_MACHINE, strKeyPath) 
   
    ' If the lngReturn value is 0 the subkey was saved successfully.
    If lngReturn > 0 Then 
        Debug.Print  "Create Registry Key failed. Wbem Error Number " & lngReturn
    End If 
   
    If Err.Number > 0 Then 
        Debug.Print  "Error " & Err.Number & vbCrLf & Err.Description _
             & vbCrLf & "In procedure CreateStringValueHKCU"
    End If 
   
    Set objReg = Nothing 
   
End Sub

Back to Top of Code

 
'---------------------------------------------------------------------------------------
' Procedure : CreateRegKeyHKCU
' Author    : Patrick Wood http://gainingaccess.net/
' Date      : 3/22/2010
' Purpose   : Create a HKEY_CURRENT_USER Registry subkey.
' Example   : Call CreateRegKeyHKCU("SOFTWARE\ATestKey")
'---------------------------------------------------------------------------------------
'
Sub CreateRegKeyHKCU(strKeyPath As String) 
On Error Resume Next 
   
    Dim objReg As Object 
    Dim lngReturn As Long 
    Dim strComputer As String 
   
    strComputer = "."
   
    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
   
     lngReturn = objReg.CreateKey(HKEY_CURRENT_USER, strKeyPath) 
   
    ' If the lngReturn value is 0 the subkey was saved successfully.
    If lngReturn > 0 Then 
        Debug.Print  "Create Registry Key failed. Wbem Error Number " & lngReturn
    End If 
   
    If Err.Number > 0 Then 
        Debug.Print  "Error " & Err.Number & vbCrLf & Err.Description _
             & vbCrLf & "In procedure CreateStringValueHKCU"
    End If 
   
    Set objReg = Nothing 
   
End Sub

Back to Top of Code


'---------------------------------------------------------------------------------------
' Procedure : RegWriteStringValue
' Author    : Patrick Wood http://gainingaccess.net/
' Date      : 3/22/2010
' Purpose   : Write a new subkey, StringValueName, and StringValue to the Registry
'---------------------------------------------------------------------------------------
'
Sub RegWriteStringValue() 
   
    Dim WshShell As Object 
   
    Set WshShell = CreateObject( "WScript.Shell")
   
    WshShell.RegWrite  "HKCU\Software\ANewTestKey\MyStringValue", "My New Value", "REG_SZ"
   
    Set WshShell = Nothing 
   
End Sub

Back to Top of Code


'---------------------------------------------------------------------------------------
' Procedure : RegWriteDWORDValue
' Author    : Patrick Wood http://gainingaccess.net/
' Date      : 3/22/2010
' Purpose   : Write a new subkey, DWORDValueName, and DWORDValue to the Registry
'---------------------------------------------------------------------------------------
'
Sub RegWriteDWORDValue() 
   
    Dim WshShell As Object 
   
    Set WshShell = CreateObject( "WScript.Shell")
   
    WshShell.RegWrite  "HKCU\Software\ANewTesKey\MyDWORDValue", 651545474, "REG_DWORD"
   
    Set WshShell = Nothing 
   
End Sub

Back to Top of Code


'--------------------------------------------------------------------------------------------------------
' Hey, Scripting Guy! How can I retrieve the path to the Program Files folder on a computer?
' -- CC
' http://blogs.technet.com/heyscriptingguy/archive/2005/12/22/how-can-i-retrieve-the-path-to-the-program-files-folder-on-a-computer.aspx
'---------------------------------------------------------------------------------------
' Procedure : GetProgFilesDirPath
' Date      : 1/7/2010
'           : Code adapted from VBScript by Patrick Wood
' Purpose   : Get the computer's Program Files Path
'---------------------------------------------------------------------------------------
'
Function GetProgFilesPath() As String 

    Dim objReg As Object 
    Dim strComputer As String 
    Dim strKeyPath As String 
    Dim ValueName As String 
    Dim strValue 
   
    strComputer = "."
       
    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
          
    strKeyPath = "SOFTWARE\Microsoft\Windows\CurrentVersion"
     ValueName = "ProgramFilesDir"
      
    objReg.GetStringValue HKEY_LOCAL_MACHINE, strKeyPath, ValueName, strValue 
      
     GetProgFilesPath = strValue 
      
    Debug.Print GetProgFilesPath 
      
End Function

Back to Top of Code


'---------------------------------------------------------------------------------------
' Procedure : CopyFile
' Date      : 1/8/2010
' Author    : Patrick Wood http://gainingaccess.net/
' Purpose   : Copy a file to the Program Files Directory and then close this database.
'---------------------------------------------------------------------------------------
'
Sub CopyFile() 

    Dim strFilePath As String 
    Dim strProgFilesPath As String 

    ' The path and name of the database to copy
    strFilePath = "C:\MainDB.mdb"
      
    ' Get the Program Files Directory Path
    strProgFilesPath = GetProgFilesPath 

    ' Copy the Database to the Program Files Directory
    FileCopy strFilePath, strProgFilesPath & "\MainDB.mdb"

    ' We are finished with this DB so close it
'    Application.Quit
      
End Sub

Back to Top of Code


'---------------------------------------------------------------------------------------
' Read multiple type values from a Registry SubKey
'---------------------------------------------------------------------------------------
' Procedure : GetHKLMRegValues
' Purpose   : Use an Array to get security data from the Registry
' Example   : Call GetHKLMRegValues("SYSTEM\CurrentControlSet\Control\Lsa")
'---------------------------------------------------------------------------------------
'
Sub GetHKLMRegValues(strKeyPath As String) 
     
    Dim objReg As Object 
    Dim strComputer As String 
    Dim estrValue As String 
    Dim i As Long 
    Dim arrEntryNames 
    Dim arrValueTypes 
    Dim arrValues 
    Dim arrValue 
    Dim byteValue 
    Dim dwValue 
    Dim strValue 
    Dim lngCount As Long 
   
    strComputer = "."
   
    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
   
    ' Use an array to access the data
    objReg.EnumValues HKEY_LOCAL_MACHINE, _ 
        strKeyPath, arrEntryNames, arrValueTypes 
   
        Debug.Print  "HKEY_LOCAL_MACHINE\" & strKeyPath
        Debug.Print  "========================================"
   
    ' Loop through the array
    For i = 0 To UBound(arrEntryNames) 
         lngCount = lngCount + 1 
        Debug.Print  " "
        Debug.Print  "------------------" & lngCount & "-------------------"
        Debug.Print  "Entry Name: " & arrEntryNames(i)
   
        ' Get the different types of array items values
        Select Case arrValueTypes(i) 
            Case REG_SZ 
                Debug.Print  "Data Type: String"
                objReg.GetStringValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), strValue 
                Debug.Print  "Value: " & strValue
            Case REG_EXPAND_SZ 
                Debug.Print  "Data Type: Expanded String"
                objReg.GetExpandedStringValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), estrValue 
                Debug.Print  "Value: " & estrValue
            Case REG_BINARY 
                Debug.Print  "Data Type: Binary"
                objReg.GetBinaryValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), arrValue 
                For Each byteValue In arrValue 
                    Debug.Print  "Value: " & byteValue & " "
                Next 
                Debug.Print vbCrLf 
            Case REG_DWORD 
                Debug.Print  "Data Type: DWORD"
                objReg.GetDWORDValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), dwValue 
                Debug.Print  "Value: " & dwValue
            Case REG_MULTI_SZ 
                Debug.Print  "Data Type: Multi String"
                objReg.GetMultiStringValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), arrValues 
                For Each strValue In arrValues 
                    Debug.Print strValue 
                Next 
        End Select 
    Next i 

    Set objReg = Nothing 

End Sub

Back to Top of Code


'---------------------------------------------------------------------------------------
' Save multiple type values from a User Registry SubKey to a text file.
'---------------------------------------------------------------------------------------
' Procedure : SaveUserRegValues
' Date      : 6/6/2009
' Author    : Patrick Wood http://gainingaccess.net/
' Purpose   : Use an Array to get security data from the Registry
' Example   : Call SaveUserRegValues("Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "C:\UserFileLocations.txt")
'---------------------------------------------------------------------------------------
'
Sub SaveUserRegValues(strKeyPath As String, strTextFilePath As String) 
      
    Dim objReg As Object 
    Dim fso As Object 
    Dim fsoFile As Object 
    Dim strComputer As String 
    Dim estrValue As String 
    Dim i As Long 
    Dim arrEntryNames 
    Dim arrValueTypes 
    Dim arrValues 
    Dim arrValue 
    Dim byteValue 
    Dim dwValue 
    Dim strValue 

    Set fso = CreateObject( "Scripting.FileSystemObject")
    Set fsoFile = fso.CreateTextFile(strTextFilePath) 
      
    strComputer = "."
      
    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
             
    ' Use an array to access the data
    objReg.EnumValues HKEY_CURRENT_USER, _ 
        strKeyPath, arrEntryNames, arrValueTypes 

        ' Begin writing to the text file
        fsoFile.WriteLine  "HKEY_CURRENT_USER\" & strKeyPath
        fsoFile.WriteLine  "========================================"
      
    ' Loop through the array
    For i = 1 To UBound(arrEntryNames) 
        fsoFile.WriteLine  " "
        fsoFile.WriteLine  "-------------------------------------"
        fsoFile.WriteLine  "Entry Name: " & arrEntryNames(i)
          
        ' Write the different types of array items values
        Select Case arrValueTypes(i) 
            Case REG_SZ 
                fsoFile.WriteLine  "Data Type: String"
                objReg.GetStringValue HKEY_CURRENT_USER, _ 
                    strKeyPath, arrEntryNames(i), strValue 
                fsoFile.WriteLine  "Value: " & strValue
            Case REG_EXPAND_SZ 
                fsoFile.WriteLine  "Data Type: Expanded String"
                objReg.GetExpandedStringValue HKEY_CURRENT_USER, _ 
                    strKeyPath, arrEntryNames(i), estrValue 
                fsoFile.WriteLine  "Value: " & estrValue
            Case REG_BINARY 
                fsoFile.WriteLine  "Data Type: Binary"
                objReg.GetBinaryValue HKEY_CURRENT_USER, _ 
                    strKeyPath, arrEntryNames(i), arrValue 
                For Each byteValue In arrValue 
                    fsoFile.WriteLine  "Value: " & byteValue & " "
                Next 
                fsoFile.WriteLine vbCrLf 
            Case REG_DWORD 
                fsoFile.WriteLine  "Data Type: DWORD"
                objReg.GetDWORDValue HKEY_CURRENT_USER, _ 
                    strKeyPath, arrEntryNames(i), dwValue 
                fsoFile.WriteLine  "Value: " & dwValue
            Case REG_MULTI_SZ 
                fsoFile.WriteLine  "Data Type: Multi String"
                objReg.GetMultiStringValue HKEY_CURRENT_USER, _ 
                    strKeyPath, arrEntryNames(i), arrValues 
                For Each strValue In arrValues 
                    fsoFile.WriteLine strValue 
                Next 
        End Select 
    Next i 

    fsoFile.Close 
       
    Set fsoFile = Nothing 
    Set fso = Nothing 
    Set objReg = Nothing 

      
End Sub

Back to Top of Code


'---------------------------------------------------------------------------------------
' Save multiple type values from a Registry SubKey to a text file.
'---------------------------------------------------------------------------------------
' Procedure : SaveRegValues
' Date      : 6/6/2009
' Author    : Patrick Wood http://gainingaccess.net/
' Purpose   : Use an Array to get security data from the Registry
' Example   : Call SaveRegValues("SYSTEM\CurrentControlSet\Control\Lsa", "C:\RegistryValues.txt")
'---------------------------------------------------------------------------------------
'
Sub SaveRegValues(strKeyPath As String, strTextFilePath As String) 
On Error GoTo ErrHandle 
      
    Dim objReg As Object 
    Dim fso As Object 
    Dim fsoFile As Object 
    Dim strComputer As String 
    Dim estrValue As String 
    Dim i As Long 
    Dim arrEntryNames 
    Dim arrValueTypes 
    Dim arrValues 
    Dim arrValue 
    Dim byteValue 
    Dim dwValue 
    Dim strValue 

    Set fso = CreateObject( "Scripting.FileSystemObject")
    Set fsoFile = fso.CreateTextFile(strTextFilePath) 
      
    strComputer = "."
      
    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
             
    ' Use an array to access the data
    objReg.EnumValues HKEY_LOCAL_MACHINE, _ 
        strKeyPath, arrEntryNames, arrValueTypes 

        ' Begin writing to the text file
        fsoFile.WriteLine  "HKEY_LOCAL_MACHINE\" & strKeyPath
        fsoFile.WriteLine  "========================================"
      
    ' Loop through the array
    For i = 1 To UBound(arrEntryNames) 
        fsoFile.WriteLine  " "
        fsoFile.WriteLine  "-------------------------------------"
        fsoFile.WriteLine  "Entry Name: " & arrEntryNames(i)
          
        ' Write the different types of array items values
        Select Case arrValueTypes(i) 
            Case REG_SZ 
                fsoFile.WriteLine  "Data Type: String"
                objReg.GetStringValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), strValue 
                fsoFile.WriteLine  "Value: " & strValue
            Case REG_EXPAND_SZ 
                fsoFile.WriteLine  "Data Type: Expanded String"
                objReg.GetExpandedStringValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), estrValue 
                fsoFile.WriteLine  "Value: " & estrValue
            Case REG_BINARY 
                fsoFile.WriteLine  "Data Type: Binary"
                objReg.GetBinaryValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), arrValue 
                For Each byteValue In arrValue 
                    fsoFile.WriteLine  "Value: " & byteValue & " "
                Next 
                fsoFile.WriteLine vbCrLf 
            Case REG_DWORD 
                fsoFile.WriteLine  "Data Type: DWORD"
                objReg.GetDWORDValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), dwValue 
                fsoFile.WriteLine  "Value: " & dwValue
            Case REG_MULTI_SZ 
                fsoFile.WriteLine  "Data Type: Multi String"
                objReg.GetMultiStringValue HKEY_LOCAL_MACHINE, _ 
                    strKeyPath, arrEntryNames(i), arrValues 
                For Each strValue In arrValues 
                    fsoFile.WriteLine strValue 
                Next 
        End Select 
    Next i 

    fsoFile.Close 
       
    Set fsoFile = Nothing 
    Set fso = Nothing 
    Set objReg = Nothing 

 ExitHere: 
    Exit Sub 

 ErrHandle: 
     MsgBox  "Error " & Err.Number & vbCrLf & Err.Description _
     & vbCrLf & "In procedure SaveRegValues"
    Resume ExitHere 
      
End Sub

Back to Top of Code


'---------------------------------------------------------------------------------------
' Procedure : GetRegCountryCodes
' Author    : Patrick Wood http://gainingaccess.net/
' Purpose   : Get Country Names matched to Numbers from the Registry
' Example   : Call GetRegCountryCodes("tblCountries")
'---------------------------------------------------------------------------------------
'
Sub GetRegCountryCodes(strTable As String) 
On Error Resume Next 
   
    Dim db As DAO.Database 
    Dim rst As DAO.Recordset 
    Dim objReg As Object 
    Dim strComputer As String 
    Dim strKeyPath As String 
    Dim strValue As String  ' The Entry Value
    Dim strValueName As String 
    Dim arrSubKeys 
    Dim SubKey 
   
    strComputer = "."
   
    Set db = CurrentDb 
   
    'Set up the file.
    Set rst = db.OpenRecordset(strTable, dbOpenDynaset) 
   
    ' The NamesSpace is not "\root\cimv2" but "\root\default:StdRegProv"
    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
   
    ' The Registry Path we need to access
    strKeyPath = _ 
          "SOFTWARE\Microsoft\Windows\CurrentVersion\Telephony\Country List"
   
    strValueName = "Name" ' The name of the Entry from which to get the value
   
    ' Create an Array of the Subkeys
    objReg.EnumKey HKEY_LOCAL_MACHINE, strKeyPath, arrSubKeys 
   
    ' Loop through the Array Add the records to the Table
    For Each SubKey In arrSubKeys 
        ' Get the Country name from the Subkey Entry "Name" using the strValue variable
         objReg.GetStringValue HKLM, strKeyPath & "\" & SubKey, strValueName, strValue
        ' Append the information to the Table
         rst.AddNew 
         rst!CountryID = SubKey 
         rst!CountryName = strValue 
         rst.Update 
    Next 
   
     rst.Close 
   
    Set objReg = Nothing 
    Set rst = Nothing 
    Set db = Nothing 
   
End Sub

Back to Top of Code


'---------------------------------------------------------------------------------------
' Procedure : SaveSelectCaseCountries
' Author    : Patrick Wood http://gainingaccess.net/
' Purpose   : Save Procedure Select Case Country Names from the Registry as a text file
' Example   : Call SaveSelectCaseCountries("C:\CountriesSelectCase.txt") or
'           : Call SaveSelectCaseCountries("C:\CountriesSelectCase.bas")
'---------------------------------------------------------------------------------------
'
Sub SaveSelectCaseCountries(strTxtFilePath As String) 
    Dim objReg As Object 
    Dim strComputer As String 
    Dim strKeyPath As String 
    Dim strValue As String 
    Dim strValueName As String 
    Dim fso As Object 
    Dim fsoFile As Object 
    Dim arrSubKeys 
    Dim SubKey 
   
    strComputer = "."
   
    Set fso = CreateObject( "Scripting.FileSystemObject")
    Set fsoFile = fso.CreateTextFile(strTxtFilePath) 
   
    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
   
    strKeyPath = _ 
          "SOFTWARE\Microsoft\Windows\CurrentVersion\Telephony\Country List"
   
    strValueName = "Name"
   
    objReg.EnumKey HKEY_LOCAL_MACHINE, strKeyPath, arrSubKeys 
   
    fsoFile.WriteLine  "Option Compare Database"
    fsoFile.WriteLine  "Option Explicit"
    fsoFile.WriteBlankLines (1) 
    fsoFile.WriteLine  "Function GetCountryName(strNumber As String) As String"
    fsoFile.WriteBlankLines (1) 
    fsoFile.WriteLine  "    Select Case strNumber"
   
    For Each SubKey In arrSubKeys 
         objReg.GetStringValue HKLM, strKeyPath & "\" & SubKey, strValueName, strValue
        ' Write the value as a String
        fsoFile.WriteLine  "        Case """ & SubKey & """"
        fsoFile.WriteLine  "            GetCountryName = """ & strValue & """"
    Next 
   
    fsoFile.WriteLine  "        Case Else"
    fsoFile.WriteLine  "            GetCountryName = ""Unknown"""
    fsoFile.WriteLine  "    End Select"
    fsoFile.WriteBlankLines (1) 
    fsoFile.WriteLine  "End Function"
   
    fsoFile.Close 
   
    Set fsoFile = Nothing 
    Set fso = Nothing 
    Set objReg = Nothing 
   
End Sub

Back to Top of Code


'---------------------------------------------------------------------------------------
' Procedure : SaveSelectCaseCountryNo
' Date      : 6/06/2009
' Author    : Patrick Wood http://gainingaccess.net/
' Purpose   : Save Country Names and the codes as Strings from the Registry as a Procedure using
'           : Select Case in a text file
' Example   : Call SaveSelectCaseCountryNo("C:\CountriesSelectCaseNo.txt") or
'           : Call SaveSelectCaseCountryNo("C:\CountriesSelectCaseNo.bas")
'---------------------------------------------------------------------------------------
'
Sub SaveSelectCaseCountryNo(strTxtFilePath As String) 
    Dim objReg As Object 
    Dim fso As Object 
    Dim fsoFile As Object 
    Dim strComputer As String 
    Dim strKeyPath As String 
    Dim strValue As String 
    Dim strValueName As String 
    Dim arrSubKeys 
    Dim SubKey 

    strComputer = "."

    Set fso = CreateObject( "Scripting.FileSystemObject")
    Set fsoFile = fso.CreateTextFile(strTxtFilePath) 

    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
          
    strKeyPath = _ 
          "SOFTWARE\Microsoft\Windows\CurrentVersion\Telephony\Country List"
      
    strValueName = "Name"

    objReg.EnumKey HKEY_LOCAL_MACHINE, strKeyPath, arrSubKeys 

    fsoFile.WriteLine  "Option Compare Database"
    fsoFile.WriteLine  "Option Explicit"
    fsoFile.WriteBlankLines (1) 
    fsoFile.WriteLine  "Function GetCountryNameNo(lngNumber As Long) As String"
    fsoFile.WriteBlankLines (1) 
    fsoFile.WriteLine  "    Select Case lngNumber"
      
    For Each SubKey In arrSubKeys 
         objReg.GetStringValue HKLM, strKeyPath & "\" & SubKey, strValueName, strValue
        ' Write the value as an Integer
        fsoFile.WriteLine  "        Case Is = " & SubKey
        fsoFile.WriteLine  "            GetCountryNameNo = """ & strValue & """"
    Next 

    fsoFile.WriteLine  "        Case Else"
    fsoFile.WriteLine  "            GetCountryNameNo = ""Unknown"""
    fsoFile.WriteLine  "    End Select"
    fsoFile.WriteBlankLines (1) 
    fsoFile.WriteLine  "End Function"
      
    fsoFile.Close 

    Set fsoFile = Nothing 
    Set fso = Nothing 
    Set objReg = Nothing 

End Sub

Back to Top of Code


'--------------------------------------------------------------------
' Save data to the Access VBA Default Registry location:
' HKEY_CURRENT_USER\Software\VB and VBA Program Settings
' You must first enter an Application Title ("AppTitle") in the
' Menu Bar Tools > Startup "Application Title" textbox.
'--------------------------------------------------------------------
'
Sub SaveVBARegValue() 

    SaveSetting CurrentDb.Properties("AppTitle"), "StoredData", "MyKey", "My data."

End Sub

Back to Top of Code


'--------------------------------------------------------------------
' Read the data previously saved to the Access VBA Default Registry location
' To have different Settings for Different Databases give each database
' a unique AppTitle using the Menu or VBA.
' Author: Patrick Wood http://gainingaccess.net/
'--------------------------------------------------------------------
'
Sub ReadVBARegValue() 

    Debug.Print GetSetting(CurrentDb.Properties("AppTitle"), _
          "StoredData", "MyKey", "myDefault")

End Sub

Back to Top of Code


' Several ways to read the same data from the Registry
Sub ReadRegKeyValue() 

    Dim strValue As String 
      
    Debug.Print GetSetting(CurrentDb.Properties("AppTitle"), _
          "StoredData", "MyKey", "myDefault")
   
    strValue = GetSetting(CurrentDb.Properties("AppTitle"), _
          "StoredData", "MyKey", "Default")
   
    Debug.Print strValue 
      
    Debug.Print GetSetting(CurrentDb.Properties("AppTitle"), _
          "StoredData", "MyKey")

End Sub

Back to Top of Code


' Author: Patrick Wood http://gainingaccess.net/
' Read all of the Keys and their Values of a specified section
  Sub GetAllKeyValues() 

    Dim varData As Variant 
    Dim i As Integer 
      
     varData = GetAllSettings(CurrentDb.Properties("AppTitle"), "StoredData")
      
    For i = LBound(varData, 1) To UBound(varData, 1) 
        Debug.Print varData(i, 0) & " - " & varData(i, 1)
    Next i 

End Sub

Back to Top of Code


Sub DeleteRegKey() 
   
     DeleteSetting CurrentDb.Properties("AppTitle"), "StoredData", "MyKey"
      
End Sub

Back to Top of Code


Sub DeleteRegSection() 

     DeleteSetting CurrentDb.Properties("AppTitle"), "StoredData"
      
End Sub

Back to Top of Code


'--------------------------------------------------------------------
' Read a DWord registry value.       Const REG_DWORD = 4
' Author: Patrick Wood http://gainingaccess.net/
'--------------------------------------------------------------------
'
Sub GetRegDWord() 
    Dim objReg As Object 
    Dim strComputer As String 
    Dim strKeyPath As String 
    Dim strValueName As String 
    Dim strDWordValue As String 
    Dim dwValue 

    strComputer = "."
      
      Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
              
    strKeyPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\WindowsUpdate\Auto Update"
    strValueName = "AUOptions"
      
    objReg.GetDWORDValue HKEY_LOCAL_MACHINE, strKeyPath, strValueName, dwValue 
      
    strDWordValue = Nz(dwValue,  "Null")
      
    Select Case strDWordValue 
        Case  "2"
             strDWordValue = strDWordValue & " - Notify for download and notify for install."
        Case  "3"
             strDWordValue = strDWordValue & " - Auto download and notify for install."
        Case  "4"
             strDWordValue = strDWordValue & " - Auto download and schedule the install."
        Case  "Null"
             strDWordValue = "Automatic Updates status is Unknown - No value was returned."
        Case Else 
             strDWordValue = strDWordValue & " - Automatic Updates are not enabled."
    End Select 
      
    Debug.Print strDWordValue 
      
    Set objReg = Nothing 

End Sub

Back to Top of Code


'--------------------------------------------------------------------
' Read a string registry value  Const REG_SZ = 1
' Author: Patrick Wood http://gainingaccess.net/
'--------------------------------------------------------------------
'
Sub GetRegString() 
    Dim objReg As Object 
    Dim strComputer As String 
    Dim strKeyPath As String 
    Dim strValueName As String 
    Dim strValue 

    strComputer = "."
      
      Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
              
    strKeyPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\MSACCESS.EXE"
    strValueName = "Path"
      
    objReg.GetStringValue HKEY_LOCAL_MACHINE, strKeyPath, strValueName, strValue 
    Debug.Print  "Microsoft Access Location: " & strValue
      
    Set objReg = Nothing 

End Sub

Back to Top of Code


'--------------------------------------------------------------------
' Purpose : Read a multi-string registry value   Const REG_MULTI_SZ = 7
' Author  : Patrick Wood http://gainingaccess.net/
' Example : Call SaveRegSystemEventLog("C:\MyTextFile.txt")
'--------------------------------------------------------------------
'
Sub SaveRegSystemEventLog(strTextFilePath As String) 
    Dim objReg As Object 
    Dim fso As Object 
    Dim fsoFile As Object 
    Dim strComputer As String 
    Dim strValueName As String 
    Dim strKeyPath As String 
    Dim arrValues 
    Dim arrValue 

    Set fso = CreateObject( "Scripting.FileSystemObject")
    Set fsoFile = fso.CreateTextFile(strTextFilePath) 
          
    strComputer = "."
      
      Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
       
    strKeyPath = "SYSTEM\CurrentControlSet\Services\Eventlog\System"
    strValueName = "Sources"

    objReg.GetMultiStringValue HKEY_LOCAL_MACHINE, strKeyPath, _ 
        strValueName, arrValues 
          
    For Each arrValue In arrValues 
        fsoFile.WriteLine arrValue 
'        Debug.Print arrValue
    Next 

    fsoFile.Close 
       
    Set fsoFile = Nothing 
    Set fso = Nothing 
    Set objReg = Nothing 
      
End Sub

Back to Top of Code


'--------------------------------------------------------------------
' Read an expanded string registry value.     Const REG_EXPAND_SZ = 2
' Author: Patrick Wood http://gainingaccess.net/
'--------------------------------------------------------------------
'
Sub ReadExpandedRegString() 

    Dim objReg As Object 
    Dim strComputer As String 
    Dim strValueName As String 
    Dim strKeyPath As String 
    Dim strValue 

    strComputer = "."
       
    Set objReg = GetObject( "winmgmts:{impersonationLevel=impersonate}!\\" & _
        strComputer & "\root\default:StdRegProv")
       
    strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\WinLogon"
    strValueName = "UIHost"
      
    objReg.GetExpandedStringValue HKEY_LOCAL_MACHINE, strKeyPath, _ 
        strValueName, strValue 
       
    Debug.Print  "The Windows logon UI host is: " & strValue

    Set objReg = Nothing 

End Sub

Back to Top of Code


'---------------------------------------------------------------------------------------
' Read a binary registry value.     Const REG_BINARY = 3
' Author: Patrick Wood http://gainingaccess.net/
'---------------------------------------------------------------------------------------
'
Sub ReadBinaryRegValue(strTextFilePath As String) 

    Dim objReg As Object 
    Dim fso As Object 
    Dim fsoFile As Object 
    Dim strComputer As String 
    Dim strKeyPath As String 
    Dim strValueName As String 
    Dim i As Long 
    Dim varValue 

    Const HKEY_LOCAL_MACHINE = &H80000002 
      
    Set fso = CreateObject( "Scripting.FileSystemObject")
    Set fsoFile = fso.CreateTextFile(strTextFilePath) 
          
    strComputer = "."
      
    Set objReg = GetObject( "winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\default:StdRegProv")
       
    strKeyPath = "Software\Microsoft\Office\11.0\Access"
    strValueName = "AccessName"
      
    objReg.GetBinaryValue HKEY_CURRENT_USER, strKeyPath, _ 
        strValueName, varValue 
       
    For i = LBound(varValue) To UBound(varValue) 
        fsoFile.WriteLine varValue(i) 
    Next 
      
    fsoFile.Close 
       
    Set fsoFile = Nothing 
    Set fso = Nothing 
    Set objReg = Nothing 

End Sub 

Back to Top of Code

This page was last updated Monday, May 29, 2014. For questions or comments about this page, please email WebMaster