Visual Basic Registry Routines
GetSecurityInfo: Obtaining Registry Key Owner Information
     
Posted:   Thursday July 03, 2008
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6
Developed with:   VB6, Windows Vista
OS restrictions:   NT4, Windows 2000, Windows XP, Windows Vista, Windows Server 2003
Author:   VBnet - Randy Birch
     
     
 Prerequisites
None.

Demo showing how to retrieve the Owner of a specific registry key.
 BAS Module Code
None.

 Form Code
Add a command button (Command1), text box (Text1) and label (Label1) along with the following code:

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright 1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const HKEY_USERS As Long = &H80000003
Private Const HKEY_CURRENT_CONFIG As Long = &H80000005

Private Const OWNER_SECaURITY_INFORMATION As Long = &H1
Private Const SE_REGISTRY_KEY As Long = 4

Private Const ERROR_SUCCESS As Long = 0
Private Const ERROR_INSUFFICIENT_BUFFER = 122&

Private Const STANDARD_RIGHTS_READ As Long = &H20000
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const SYNCHRONIZE As Long = &H100000
Private Const KEY_READ As Long = ((STANDARD_RIGHTS_READ Or _
                                   KEY_QUERY_VALUE Or _
                                   KEY_ENUMERATE_SUB_KEYS Or _
                                   KEY_NOTIFY) And _
                                   (Not SYNCHRONIZE))
                                   
Private 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

Private Declare Function GetSecurityInfo Lib "advapi32.dll" _
  (ByVal hkey As Long, _
   ByVal ObjectType As Long, _
   ByVal SecurityInfo As Long, _
   ppsidOwner As Long, _
   ppsidGroup As Long, _
   ppDacl As Long, _
   ppSacl As Long, _
   ppSecurityDescriptor As Any) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" _
  (ByVal hkey As Long) As Long
  
Private Declare Function LookupAccountSid Lib "advapi32.dll" _
   Alias "LookupAccountSidA" _
  (ByVal lpSystemName As String, _
   ByVal Sid As Long, _
   ByVal name As String, _
   cbName As Long, _
   ByVal ReferencedDomainName As String, _
   cbReferencedDomainName As Long, _
   peUse As Long) As Long
   
Private Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long

Private Declare Function LocalFree Lib "kernel32" _
   (ByVal hMem As Long) As Long


Private Sub Form_Load()

  Label1.Caption = ""
  Command1.Caption = "Get RegKey Owner"
   
End Sub


Private Sub Command1_Click()

   Dim hkey As Long
   Dim regPath As String
   Dim ppsidOwner As Long
   Dim sRegKeyOwner As String  'the result!


  'A few sample reg key paths
  'regPath = "SYSTEM\ControlSet001\Services\lanmanworkstation\NetworkProvider"
  'hkey = OpenRegKey(HKEY_LOCAL_MACHINE, regPath)
   
  'regPath = "Printers\Settings\Wizard" 
  'hkey = OpenRegKey(HKEY_CURRENT_USER, regPath)
   
  'regPath = "Software\Fonts"  
  'hkey = OpenRegKey(HKEY_CURRENT_CONFIG, regPath)

   regPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"  'HKEY_LOCAL_MACHINE
   hkey = OpenRegKey(HKEY_LOCAL_MACHINE, regPath)
   
   If hkey <> 0 Then
   
     'get the SID of the owner of the
     'specified registry key
      sRegKeyOwner = GetRegKeyOwner(hkey)
      Call RegCloseKey(hkey)
      
  End If

  Label1.Caption = regPath
  Text1.Text = sRegKeyOwner

End Sub


Private Function GetRegKeyOwner(hkey As Long) As String

   Dim ppsidOwner As Long
   Dim ppsidGroup As Long
   Dim ppsidDacl As Long
   Dim ppsidSacl As Long
   Dim ppSecDescriptor As Long
   
   If hkey <> 0 Then
   
      If GetSecurityInfo(hkey, _
                         SE_REGISTRY_KEY, _
                         OWNER_SECURITY_INFORMATION, _
                         ppsidOwner, ppsidGroup, _
                         ppsidDacl, ppsidSacl, _
                         ppSecDescriptor) = ERROR_SUCCESS Then
                                        
      
         If ppsidOwner <> 0 Then
         
           'convert the SID to the owner. LookupAccountSid
           'needs a server passed; if always called on the
           'local machine the first parameter can be deleted,
           'and the code in GetRegKeyOwnerBySid modified to always
           'pass vbNullString as the server variable.
            GetRegKeyOwner = GetRegKeyOwnerBySid("", ppsidOwner)
         
         End If  'ppsidOwner
      
      
        'we're done with the security descriptor,
        'so release its memory
         LocalFree ppSecDescriptor
      
      End If  'GetSecurityInfo

   End If  'hkey

End Function


Private Function GetRegKeyOwnerBySid(ByVal sServer As String, ByVal ppsidOwner As Long) As String

   Dim bSuccess As Long
   Dim sName As String
   Dim cbName As Long
   Dim sReferencedDomain As String
   Dim cbReferencedDomain As Long
   Dim dwUse As Long

   If Len(sServer) > 0 Then
      sServer = QualifyServer(sServer)
   Else
      sServer = vbNullString
   End If

   If (ppsidOwner <> 0) Then
   
     'call LookupAccountSid twice to
     'get the name of the account and the
     'first domain on which this SID is found;
     'the first call gets the correct buffer size,
     'the second gets the data
      bSuccess = LookupAccountSid(sServer, _
                                  ppsidOwner, _
                                  sName, _
                                  cbName, _
                                  sReferencedDomain, _
                                  cbReferencedDomain, _
                                  dwUse)
                                     
      If (bSuccess = 0) And _
         (Err.LastDllError = ERROR_INSUFFICIENT_BUFFER) Then
           
        'fill buffers and call again
         sName = Space$(cbName)
         sReferencedDomain = Space$(cbReferencedDomain)

         If LookupAccountSid(sServer, _
                             ppsidOwner, _
                             sName, _
                             cbName, _
                             sReferencedDomain, _
                             cbReferencedDomain, _
                             dwUse) = 1 Then
 
            GetRegKeyOwnerBySid = TrimNull(sName)
                  
         End If  'LookupAccountSid
      End If  'bSuccess
   End If  'ppsidOwner

End Function


Private Function OpenRegKey(ByVal hkey As Long, _
                            ByVal lpSubKey As String) As Long

  Dim hSubKey As Long

  If RegOpenKeyEx(hkey, _
                  lpSubKey, _
                  0, _
                  KEY_READ, _
                  hSubKey) = ERROR_SUCCESS Then

      OpenRegKey = hSubKey

  End If

End Function


Private Function QualifyServer(ByVal sServer As String) As String

  'if nullstring was passed, the
  'API does not expect slashes in
  'the server name
   If Len(sServer) > 0 Then
  
     'are already two slashes
     'preceding the server name?
      If Left$(sServer, 2) = "\\" Then
   
        'return the passed string
         QualifyServer = sServer
   
      Else
   
        'there aren't two, but is there one?
         If Left$(sServer, 1) = "\" Then
      
           'yes, so add one more
            QualifyServer = "\" & sServer
      
         Else
      
           'the string needs both
            QualifyServer = "\\" & sServer
      
         End If  'Left$(sServer, 1) <> "\"
      End If  'Left$(sServer, 2) = "\\"
   
   Else
   
     'empty string passed, so return it
      QualifyServer = sServer
      
   End If  'Len(sServer)
   
End Function


Private Function TrimNull(startstr As String) As String

   TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
   
End Function
 Comments

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter