set permission for each user

[chris1990]

If you follow this link you will find the code i have to change the permissions of a registry key.
http://www.vbforums.com/showthread.php?t=452607

I would like to know how to put it through a loop for every user. I have a code to get a list of usernames in to a list box. I just need to know how to loop it.

Thanks in advance Chris1990

[Al42]

Dim i As Integer
  For i = 0 To List1.ListCount - 1
    'run your code here
    'the username is List1.List(i) each time through the loop
  Next i

[chris1990]

Dim i As Integer
  For i = 0 To List1.ListCount - 1
    'run your code here
    'the username is List1.List(i) each time through the loop
  Next i

I have this code


run your code here
'the username is List1.List(i) each time through the loop
the code i need is the code to replace this

[schoolbusdriver]

What ? Haven't you finished this yet ? . You need to pass the HKEY, subkey and users names to "UpdatePermissionsOfHKLM".

This following is an adaptation from the "SetPerm.bas" module. I've removed the unnecessary stuff to make it clearer, and changed the name of the procedure from "UpdatePermissionsOfHKLM" to "ChangeSubKeyPermissions", and added the necessary parameters so it can be called in a loop.

It's a lot of code, so spans the next few posts. You simply call "ChangeSubKeyPermissions", passing the parameters as required. "strUser" is, obviously, the user name.

EDIT: I've ripped this from an app I made, so one or more declarations (such as "RegCloseKey") or constants may be missing from the code - you will have to add them yourself. Make sure "Break On Unhandled Errors" is selected.

Option Explicit

'Extract from SetPerm.exe, available from:-
'http://support.microsoft.com/kb/316440/
'"How to use low-level access control APIs from Visual Basic"

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
   (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

Private Declare Sub FreeSid Lib "advapi32.dll" _
   (ByVal pSid As Long)

Private Declare Function AddAce Lib "advapi32.dll" _
   (ByVal pAcl As Long, ByVal dwAceRevision As Long, ByVal dwStartingAceIndex As Long, _
   ByVal pAceList As Long, ByVal nAceListLength As Long) As Long

Private Declare Function AllocateAndInitializeSid Lib "advapi32.dll" _
   (pIdentifierAuthority As SID_IDENTIFIER_AUTHORITY, ByVal nSubAuthorityCount As Byte, _
   ByVal nSubAuthority0 As Long, ByVal nSubAuthority1 As Long, ByVal nSubAuthority2 As Long, _
   ByVal nSubAuthority3 As Long, ByVal nSubAuthority4 As Long, ByVal nSubAuthority5 As Long, _
   ByVal nSubAuthority6 As Long, ByVal nSubAuthority7 As Long, lpPSid As Long) As Long

Private Declare Function EqualSid Lib "advapi32.dll" _
   (ByVal pSid1 As Long, ByVal pSid2 As Long) As Long

Private Declare Function GetAce Lib "advapi32.dll" _
   (ByVal pAcl As Long, ByVal dwAceIndex As Long, pACE As Long) As Long

Private Declare Function GetAclInformation Lib "advapi32.dll" _
   (ByVal pAcl As Long, pAclInformation As Any, ByVal nAclInformationLength As Long, _
   ByVal dwAclInformationClass As Long) As Long

Private Declare Function GetLengthSid Lib "advapi32.dll" _
   (ByVal pSid As Long) As Long

Private Declare Function GetSecurityDescriptorControl Lib "advapi32.dll" _
   (ByVal pSecurityDescriptor As Long, pControl As Long, lpdwRevision As Long) As Long

Private Declare Function GetSecurityDescriptorDacl Lib "advapi32.dll" _
   (ByVal pSecurityDescriptor As Long, lpbDaclPresent As Long, pDacl As Long, lpbDaclDefaulted As Long) As Long

Private Declare Function InitializeAcl Lib "advapi32.dll" _
   (ByVal pAcl As Long, ByVal nAclLength As Long, ByVal dwAclRevision As Long) As Long

Private Declare Function InitializeSecurityDescriptor Lib "advapi32.dll" _
   (ByVal pSecurityDescriptor As Long, ByVal dwRevision As Long) As Long

Private Declare Function LocalAlloc Lib "kernel32.dll" _
   (ByVal wFlags As Long, ByVal wBytes As Long) As Long

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

Private Declare Function LookupAccountName Lib "advapi32.dll" Alias "LookupAccountNameA" _
   (ByVal lpSystemName As Long, ByVal lpAccountName As String, ByVal Sid As Long, cbSid As Long, _
   ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long

Private Declare Function SetSecurityDescriptorControl Lib "advapi32.dll" _
   (ByVal pSecurityDescriptor As Long, ByVal controlBitsOfInterest As Long, _
   ByVal controlBitsToSet As Long) As Long

Private Declare Function SetSecurityDescriptorDacl Lib "advapi32.dll" _
   (ByVal pSecurityDescriptor As Long, ByVal bDaclPresent As Long, ByVal pDacl As Long, _
   ByVal bDaclDefaulted As Long) As Long

'APIs for modifying DACL of a registry key
Private Declare Function RegGetKeySecurity Lib "advapi32.dll" _
   (ByVal hKey As Long, ByVal SecurityInformation As Long, ByVal pSecurityDescriptor As Long, _
   lpcbSecurityDescriptor As Long) As Long

Private Declare Function RegSetKeySecurity Lib "advapi32.dll" _
   (ByVal hKey As Long, ByVal SecurityInformation As Long, ByVal pSecurityDescriptor As Long) As Long

'Version Checking APIs
Private Declare Function GetVersionExA Lib "kernel32.dll" _
   (lpVersionInformation As OSVERSIONINFO) As Integer

' Memory constants used by various memory API calls.
Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED + LMEM_ZEROINIT)

'Generic Access Rights
Public Const GENERIC_ALL = &H10000000
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_EXECUTE = &H20000000
Public Const GENERIC_WRITE = &H40000000

'Standard Access Rights
Public Const DELETE = &H10000
Public Const READ_CONTROL = &H20000
Public Const WRITE_DAC = &H40000
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const STANDARD_RIGHTS_READ = READ_CONTROL
Public Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Public Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Public Const STANDARD_RIGHTS_ALL = &H1F0000

'Constants to be used in API calls. Refer to the MSDN for more information on how/what these constants are used for.
Private Const DACL_SECURITY_INFORMATION = &H4
Private Const SECURITY_DESCRIPTOR_REVISION = 1
Private Const SECURITY_DESCRIPTOR_MIN_LENGTH = 20
Private Const ACL_REVISION = 2
Private Const MAXDWORD = &HFFFFFFFF

'The following are the inherit flags that go into the AceFlags field of an Ace header.
Private Const CONTAINER_INHERIT_ACE = &H2
Private Const INHERIT_ONLY_ACE = &H8
Private Const INHERITED_ACE = &H10

'The following are the security descriptor flags.
Private Const SE_DACL_AUTO_INHERIT_REQ = &H100
Private Const SE_DACL_AUTO_INHERITED = &H400
Private Const SE_DACL_PROTECTED = &H1000

'Type of ACE being added.
Private Const ACCESS_ALLOWED_ACE_TYPE = 0
Private Const ACCESS_DENIED_ACE_TYPE = 1

'Constants from WINNT.H for the various well-known SIDs, users and groups
Private Const SECURITY_WORLD_SID_AUTHORITY = &H1
Private Const SECURITY_WORLD_RID = &H0
Private Const DOMAIN_USER_RID_GUEST = &H1F5

'Version Information constant
Private Const VER_PLATFORM_WIN32_NT = &H2

'Types needed for ACL manipulation. Refer to MSDN for more info
Private Type ACL
   AclRevision As Byte
   Sbz1 As Byte
   AclSize As Integer
   AceCount As Integer
   Sbz2 As Integer
End Type

Private Type ACL_SIZE_INFORMATION
   AceCount As Long
   AclBytesInUse As Long
   AclBytesFree As Long
End Type

Private Type ACE_HEADER
   AceType As Byte
   AceFlags As Byte
   AceSize As Integer
End Type

Private Type ACE
   Header As ACE_HEADER
   Mask As Long
   SidStart As Long
End Type

Private Type SID_IDENTIFIER_AUTHORITY
   Value(6) As Byte
End Type

Private Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion As String * 128
End Type

' Application Types
Private Type AccountPerm
    AccountName As String
    AccessMask As Long
    AceFlags As Byte
    AceType As Byte
    pSid As Long
    SidPassedByCaller As Boolean
End Type
   
Private Type SDMemInfo
    pSD As Long
    pAcl As Long
End Type

Public Sub ChangeSubKeyPermissions(lngHKey As Long, strSubKey As String, strUser As String)
   Dim hKey As Long
   Dim KeyName As String
   Dim Accounts(0 To 2) As AccountPerm
   Dim fResult As Long, n As Long
   Dim dwNumOfAccounts As Long
   Dim siaNtAuthority As SID_IDENTIFIER_AUTHORITY
      
   KeyName = strSubKey
   dwNumOfAccounts = UBound(Accounts)
'Set up the account permissions that need to be created as an array
   Accounts(0).AccountName = ""
   Accounts(0).AccessMask = GENERIC_READ
   Accounts(0).AceFlags = CONTAINER_INHERIT_ACE
   Accounts(0).AceType = ACCESS_ALLOWED_ACE_TYPE
'Construct SID for Everyone "Universal well-known SID"
   siaNtAuthority.Value(5) = SECURITY_WORLD_SID_AUTHORITY
   If AllocateAndInitializeSid(siaNtAuthority, 1, SECURITY_WORLD_RID, 0, 0, 0, 0, 0, 0, 0, Accounts(0).pSid) = 0 Then
      MsgBox "AllocateAndInitializeSid failed with error code : " & Err.LastDllError
      Exit Sub
   End If
'If the caller initializes SID, set SidPassedByCaller member to True
   Accounts(0).SidPassedByCaller = True
'The following entry will allow permissions on the specified key
   Accounts(1).AccountName = strUser
   Accounts(1).AccessMask = GENERIC_READ Or GENERIC_WRITE Or GENERIC_EXECUTE Or DELETE
   Accounts(1).AceFlags = 0
   Accounts(1).AceType = ACCESS_ALLOWED_ACE_TYPE
   Accounts(1).pSid = 0
   Accounts(1).SidPassedByCaller = False
'The following entry will deny all permissions on future subkeys
   Accounts(2).AccountName = strUser
   Accounts(2).AccessMask = GENERIC_ALL
   Accounts(2).AceFlags = CONTAINER_INHERIT_ACE Or INHERIT_ONLY_ACE
   Accounts(2).AceType = ACCESS_DENIED_ACE_TYPE
   Accounts(2).pSid = 0
   Accounts(2).SidPassedByCaller = False
   
   fResult = RegOpenKeyEx(lngHKey, KeyName, 0, READ_CONTROL Or WRITE_DAC, hKey)
   If fResult <> ERROR_SUCCESS Then
      MsgBox "RegOpenKeyEx failed with error code : " & fResult
   Else
      UpdatePermissionsOfRegistryKey hKey, Accounts
      RegCloseKey hKey
   End If
'Make sure we clean up
   For n = 0 To dwNumOfAccounts
      If Accounts(n).pSid <> 0 And Accounts(n).SidPassedByCaller Then
         FreeSid (Accounts(n).pSid)
         Accounts(n).pSid = 0
      End If
   Next
End Sub

[schoolbusdriver]

Private Function UpdatePermissionsOfRegistryKey(ByVal hKey As Long, Accounts() As AccountPerm) As Boolean
   Dim fResult As Long
   Dim sdInfo As SDMemInfo
   Dim oldSD As Long
   Dim nLengthNeeded As Long
   Dim bStatus As Boolean

   bStatus = False
   On Error GoTo Cleanup
   sdInfo.pAcl = 0
   sdInfo.pSD = 0
   nLengthNeeded = 0
   fResult = RegGetKeySecurity(hKey, DACL_SECURITY_INFORMATION, 0, nLengthNeeded)
'This call will fail. On Return nLengthNeeded will be updated.
'Check for that below
   If nLengthNeeded = 0 Then
      MsgBox "RegGetKeySecurity failed with error code : " & fResult
      Err.Raise 0
   End If
   oldSD = LocalAlloc(LPTR, nLengthNeeded)
   If oldSD = 0 Then
      MsgBox "LocalAlloc failed with error code : " & Err.LastDllError
      Err.Raise 0
   End If
   fResult = RegGetKeySecurity(hKey, DACL_SECURITY_INFORMATION, oldSD, nLengthNeeded)
   If fResult <> ERROR_SUCCESS Then
      MsgBox "RegGetKeySecurity failed with error code : " & fResult
      Err.Raise 0
   End If
   fResult = AddSecurityDescriptor(oldSD, Accounts(), sdInfo)
   If fResult = 0 Then
      MsgBox "Unable to create Security Descriptor"
      Err.Raise 0
   End If
   fResult = RegSetKeySecurity(hKey, DACL_SECURITY_INFORMATION, sdInfo.pSD)
   If fResult <> ERROR_SUCCESS Then
      MsgBox "RegSetKeySecurity failed with error code : " & fResult
      Err.Raise 0
   End If
   bStatus = True
Cleanup:
'Free the memory allocated
   If (oldSD <> 0) Then LocalFree oldSD
   oldSD = 0
   If (sdInfo.pSD <> 0) Then LocalFree sdInfo.pSD
   sdInfo.pSD = 0
   If (sdInfo.pAcl <> 0) Then LocalFree sdInfo.pAcl
   sdInfo.pAcl = 0
   UpdatePermissionsOfRegistryKey = bStatus
End Function

Private Function AddSecurityDescriptor(ByVal pOldSD As Long, Accounts() As AccountPerm, sdInfo As SDMemInfo) As Long
   Dim pNewACL As Long
   Dim dwNewACLSize As Long
   Dim dwTotalDACLSize As Long
   Dim szDomainName As String
   Dim cbDomainName As Long
   Dim nSidSize As Long
   Dim I As Long, n As Long
   Dim eUse As Long
   Dim fReturn As Long
   Dim fResult As Long
   Dim tempACL As ACL
   Dim tempAce As ACE
   Dim Ptr As Long
   Dim dwNumOfAccounts As Long
   Dim pSD As Long
   Dim AceIndex As Long
   Dim lDaclPresent As Long
   Dim lDaclDefaulted As Long
   Dim sACLInfo As ACL_SIZE_INFORMATION
   Dim pAcl As Long
   Dim osinfo As OSVERSIONINFO
   Dim w2kOrAbove As Boolean

   On Error GoTo ExitLabel
'Determine if system is Windows 2000 or above
   osinfo.dwOSVersionInfoSize = Len(osinfo)
   osinfo.szCSDVersion = Space$(128)
   GetVersionExA osinfo
   w2kOrAbove = (osinfo.dwPlatformId = VER_PLATFORM_WIN32_NT And osinfo.dwMajorVersion >= 5)
'Intialize some of the variables
   fReturn = 0
   sdInfo.pAcl = 0
   sdInfo.pSD = 0
   dwNumOfAccounts = UBound(Accounts)
'Allocate memory for a new Security Descriptor
   pSD = LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH)
   If pSD = 0 Then Err.Raise 0
   sdInfo.pSD = pSD
'Initialize the new Security Descriptor
   fResult = InitializeSecurityDescriptor(pSD, SECURITY_DESCRIPTOR_REVISION)
   If fResult = 0 Then Err.Raise 0
'Get the existing ACL size
   lDaclPresent = 0
   pAcl = 0
   If (pOldSD) Then
      fResult = GetSecurityDescriptorDacl(pOldSD, lDaclPresent, pAcl, lDaclDefaulted)
      If fResult = 0 Then Err.Raise 0
      If (lDaclPresent <> 0 And pAcl <> 0) Then
         fResult = GetAclInformation(pAcl, sACLInfo, Len(sACLInfo), 2&)
         If fResult = 0 Then Err.Raise 0
         dwTotalDACLSize = sACLInfo.AclBytesInUse
      Else
         dwTotalDACLSize = Len(tempACL)
      End If
   Else
       dwTotalDACLSize = Len(tempACL)
   End If
'Find the SIDs for each userName supplied in Accounts() array and compute the new ACL size needed.
'Call LookupAccountName only for the entries where the SID is not supplied by the caller.
   szDomainName = Space(256)
   For n = 0 To dwNumOfAccounts
       If (Accounts(n).pSid = 0) Then
          nSidSize = 0
          cbDomainName = 256
'Lookup the SID for this user
'First call is to find the buffer size required for SID
         fResult = LookupAccountName(0, Accounts(n).AccountName, 0, nSidSize, szDomainName, cbDomainName, eUse)
         Accounts(n).pSid = LocalAlloc(LPTR, nSidSize)
         If Accounts(n).pSid = 0 Then Err.Raise 0
'Get the Actual SID value in this second call
         fResult = LookupAccountName(0, Accounts(n).AccountName, Accounts(n).pSid, nSidSize, szDomainName, cbDomainName, eUse)
         If fResult = 0 Then Err.Raise 0
      End If
'sizeof(DWORD) = 4
      dwNewACLSize = Len(tempAce) + GetLengthSid(Accounts(n).pSid) - 4
      dwTotalDACLSize = dwTotalDACLSize + dwNewACLSize
   Next
'Allocate memory for the new ACL
   pNewACL = LocalAlloc(LPTR, dwTotalDACLSize)
   If pNewACL = 0 Then Err.Raise 0
   sdInfo.pAcl = pNewACL
'Initialize the new ACL
   fResult = InitializeAcl(pNewACL, dwTotalDACLSize, ACL_REVISION)
   If fResult = 0 Then Err.Raise 0
   AceIndex = 0
'Add the new ACCESS DENIED ACEs first to the DACL
   For n = 0 To dwNumOfAccounts
      If (Accounts(n).AceType = ACCESS_DENIED_ACE_TYPE) Then
         fResult = ConstructAndAddAce(pNewACL, Accounts(n).AceType, Accounts(n).AceFlags, Accounts(n).AccessMask, Accounts(n).pSid)
         If fResult = 0 Then Err.Raise 0
         AceIndex = AceIndex + 1
      End If
   Next
'Copy all non-inherited ACEs from the existing DACL
   If (lDaclPresent <> 0 And pAcl <> 0 And sACLInfo.AceCount > 0) Then
'Get each ACE from the old DACL and add them into the new DACL.
      For I = 0 To (sACLInfo.AceCount - 1)
'Attempt to get the next ACE.
         fResult = GetAce(pAcl, I, Ptr)
         If (fResult = 0) Then Err.Raise 0
         CopyMemory tempAce, Ptr, LenB(tempAce)
'Exit this for loop, once the first INHERITED_ACE is found
         If ((tempAce.Header.AceFlags And INHERITED_ACE) = INHERITED_ACE) Then
            Exit For
         End If
'Add the ACE to the new DACL if the SID is not in Accounts()
         If Not (IsEqual(Accounts(), Ptr + 8)) Then
'Now that you have the ACE, add it to the new ACL.
            fResult = AddAce(pNewACL, ACL_REVISION, MAXDWORD, Ptr, tempAce.Header.AceSize)
            If fResult = 0 Then Err.Raise 0
            AceIndex = AceIndex + 1
         End If
      Next I
   End If
'Add the new ACCESS ALLOWED ACEs next to the DACL
   For n = 0 To dwNumOfAccounts
      If (Accounts(n).AceType = ACCESS_ALLOWED_ACE_TYPE) Then
         fResult = ConstructAndAddAce(pNewACL, Accounts(n).AceType, Accounts(n).AceFlags, Accounts(n).AccessMask, Accounts(n).pSid)
         If fResult = 0 Then Err.Raise 0
         AceIndex = AceIndex + 1
      End If
   Next
'Copy now all inherited ACEs from the existing DACL, so that the new DACL will be in the Windows 2000 preferred order
   If (lDaclPresent <> 0 And pAcl <> 0 And sACLInfo.AceCount > 0) Then
'Get each INHERITED_ACE from the old ACL and add them into the new ACL.
      For I = I To (sACLInfo.AceCount - 1)
'Attempt to get the next ACE.
         fResult = GetAce(pAcl, I, Ptr)
         If (fResult = 0) Then Err.Raise 0
         CopyMemory tempAce, Ptr, LenB(tempAce)
'Add it to the new ACL.
         fResult = AddAce(pNewACL, ACL_REVISION, MAXDWORD, Ptr, tempAce.Header.AceSize)
         If fResult = 0 Then Err.Raise 0
         AceIndex = AceIndex + 1
      Next I
   End If
   
   If w2kOrAbove And pOldSD <> 0 Then
      Dim controlFlag As Long
      Dim dwRevision As Long
      Dim controlBitsOfInterest As Long
      Dim controlBitsToSet As Long
      fResult = GetSecurityDescriptorControl(pOldSD, controlFlag, dwRevision)
      If (fResult <> 0) Then
         controlBitsOfInterest = 0
         controlBitsToSet = 0
         If ((controlFlag And SE_DACL_AUTO_INHERITED) = SE_DACL_AUTO_INHERITED) Then
            controlBitsOfInterest = SE_DACL_AUTO_INHERIT_REQ Or SE_DACL_AUTO_INHERITED
            controlBitsToSet = controlBitsOfInterest
         ElseIf ((controlFlag And SE_DACL_PROTECTED) = SE_DACL_PROTECTED) Then
            controlBitsOfInterest = SE_DACL_PROTECTED
            controlBitsToSet = controlBitsOfInterest
         End If
         If controlBitsToSet <> 0 Then
            fResult = SetSecurityDescriptorControl(pSD, controlBitsOfInterest, controlBitsToSet)
            If fResult = 0 Then Err.Raise 0
         End If
      End If
   End If
'Add the new DACL to the new Security Descriptor
   fResult = SetSecurityDescriptorDacl(pSD, 1, pNewACL, 0)
   If fResult = 0 Then Err.Raise 0
   fReturn = 1
ExitLabel:
'Make sure we clean up
   For n = 0 To dwNumOfAccounts
'Free only the SIDs that has been allocated in this function
      If Accounts(n).pSid <> 0 And Not (Accounts(n).SidPassedByCaller) Then
         LocalFree (Accounts(n).pSid)
         Accounts(n).pSid = 0
      End If
   Next
'If any of the functions failed, free new SD, and new ACL
   If fReturn = 0 Then
      If (sdInfo.pSD <> 0) Then LocalFree sdInfo.pSD
      sdInfo.pSD = 0
      If (sdInfo.pAcl <> 0) Then LocalFree sdInfo.pAcl
      sdInfo.pAcl = 0
   End If
   AddSecurityDescriptor = fReturn
End Function

[schoolbusdriver]

Private Function ConstructAndAddAce(ByVal pNewACL As Long, ByVal AceType As Byte, ByVal AceFlags As Byte, ByVal AccessMask As Long, ByVal pSid As Long) As Long
   Dim fResult As Long
   Dim dwNewACESize As Long
   Dim dwSidLen As Long
   Dim tempAce As ACE
   Dim pACE As Long

   fResult = 0
   On Error GoTo Label1
'Find the length of SID and size of new ACE to be added
   dwSidLen = GetLengthSid(pSid)
   dwNewACESize = Len(tempAce) + dwSidLen - 4
'Allocate memory for the new ACE
   pACE = LocalAlloc(LPTR, dwNewACESize)
   If pACE = 0 Then Err.Raise 0
'Set up the ACE structure in VB variable
   tempAce.Header.AceType = AceType
   tempAce.Header.AceFlags = AceFlags
   tempAce.Header.AceSize = dwNewACESize
   tempAce.Mask = AccessMask
'Copy the VB variable contents and the SID to the the ACE allocated
   CopyMemory ByVal pACE, VarPtr(tempAce), LenB(tempAce)
   CopyMemory ByVal pACE + 8, pSid, dwSidLen
'Add the new ACE to the new ACL
   fResult = AddAce(pNewACL, ACL_REVISION, MAXDWORD, pACE, dwNewACESize)
   LocalFree pACE
Label1:
   ConstructAndAddAce = fResult
End Function

Private Function IsEqual(Accounts() As AccountPerm, pSid As Long) As Boolean
   Dim nEntries As Long
   Dim nIndex As Long

'Check if the supplied SID pSid matches with one of the new SIDs specified in Accounts()
   nEntries = UBound(Accounts)
   For nIndex = 0 To nEntries
      If (EqualSid(Accounts(nIndex).pSid, pSid)) Then
         IsEqual = True
         Exit Function
      End If
   Next
   IsEqual = False
End Function

[schoolbusdriver]

One last thing you may want to consider: It's handy to flash up a message if someone NOT logged in as admin tries to create a shared key. This code checks for the users status.

Option Explicit
 
'http://www.devx.com/vb2themax/Tip/18672
'---------------------------------------

'"Check whether the current user is an administrator"

'Important assumption for this code.
Option Base 0

'Fixed at this size for comfort. Could be bigger or made dynamic.
Private Const ANYSIZE_ARRAY As Long = 100

'Security APIs
Private Const TokenUser = 1
Private Const TokenGroups = 2
Private Const TokenPrivileges = 3
Private Const TokenOwner = 4
Private Const TokenPrimaryGroup = 5
Private Const TokenDefaultDacl = 6
Private Const TokenSource = 7
Private Const TokenType = 8
Private Const TokenImpersonationLevel = 9
Private Const TokenStatistics = 10

'Token Specific Access Rights
Private Const TOKEN_ASSIGN_PRIMARY = &H1
Private Const TOKEN_DUPLICATE = &H2
Private Const TOKEN_IMPERSONATE = &H4
Private Const TOKEN_QUERY = &H8
Private Const TOKEN_QUERY_SOURCE = &H10
Private Const TOKEN_ADJUST_PRIVILEGES = &H20
Private Const TOKEN_ADJUST_GROUPS = &H40
Private Const TOKEN_ADJUST_DEFAULT = &H80

'NT well-known SIDs
Private Const SECURITY_DIALUP_RID = &H1
Private Const SECURITY_NETWORK_RID = &H2
Private Const SECURITY_BATCH_RID = &H3
Private Const SECURITY_INTERACTIVE_RID = &H4
Private Const SECURITY_SERVICE_RID = &H6
Private Const SECURITY_ANONYMOUS_LOGON_RID = &H7
Private Const SECURITY_LOGON_IDS_RID = &H5
Private Const SECURITY_LOCAL_SYSTEM_RID = &H12
Private Const SECURITY_NT_NON_UNIQUE = &H15
Private Const SECURITY_BUILTIN_DOMAIN_RID = &H20

'Well-known domain relative sub-authority values (RIDs)
Private Const DOMAIN_ALIAS_RID_ADMINS = &H220
Private Const DOMAIN_ALIAS_RID_USERS = &H221
Private Const DOMAIN_ALIAS_RID_GUESTS = &H222
Private Const DOMAIN_ALIAS_RID_POWER_USERS = &H223
Private Const DOMAIN_ALIAS_RID_ACCOUNT_OPS = &H224
Private Const DOMAIN_ALIAS_RID_SYSTEM_OPS = &H225
Private Const DOMAIN_ALIAS_RID_PRINT_OPS = &H226
Private Const DOMAIN_ALIAS_RID_BACKUP_OPS = &H227
Private Const DOMAIN_ALIAS_RID_REPLICATOR = &H228

Private Const SECURITY_NT_AUTHORITY = &H5

Private Type SID_AND_ATTRIBUTES
   Sid As Long
   Attributes As Long
End Type

Private Type TOKEN_GROUPS
   GroupCount As Long
   Groups(ANYSIZE_ARRAY) As SID_AND_ATTRIBUTES
End Type

Private Type SID_IDENTIFIER_AUTHORITY
   Value(0 To 5) As Byte
End Type

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

Private Declare Function GetCurrentThread Lib "kernel32" () As Long

Private Declare Function OpenProcessToken Lib "Advapi32" (ByVal ProcessHandle _
   As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long

Private Declare Function OpenThreadToken Lib "Advapi32" (ByVal ThreadHandle As _
   Long, ByVal DesiredAccess As Long, ByVal OpenAsSelf As Long, _
   TokenHandle As Long) As Long

Private Declare Function GetTokenInformation Lib "Advapi32" (ByVal TokenHandle _
   As Long, TokenInformationClass As Integer, TokenInformation As Any, _
   ByVal TokenInformationLength As Long, ReturnLength As Long) As Long

Private Declare Function AllocateAndInitializeSid Lib "Advapi32" _
   (pIdentifierAuthority As SID_IDENTIFIER_AUTHORITY, ByVal nSubAuthorityCount As Byte, _
   ByVal nSubAuthority0 As Long, ByVal nSubAuthority1 As Long, ByVal nSubAuthority2 As Long, _
   ByVal nSubAuthority3 As Long, ByVal nSubAuthority4 As Long, ByVal nSubAuthority5 As Long, _
   ByVal nSubAuthority6 As Long, ByVal nSubAuthority7 As Long, lpPSid As Long) As Long

Private Declare Function RtlMoveMemory Lib "kernel32" (Dest As Any, _
   Source As Any, ByVal lSize As Long) As Long

Private Declare Function IsValidSid Lib "Advapi32" (ByVal pSid As Long) As Long

Private Declare Function EqualSid Lib "Advapi32" (pSid1 As Any, pSid2 As Any) As Long

Private Declare Sub FreeSid Lib "Advapi32" (pSid As Any)

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Function IsAdmin() As Boolean
'Returns True if the thread is running in the user context of the local Administrator account.
'Example: MsgBox "Current user is the Administrator: " & IsAdmin
   Dim hProcessToken       As Long
   Dim BufferSize          As Long
   Dim psidAdmin           As Long
   Dim lResult             As Long
   Dim X                   As Integer
   Dim tpTokens            As TOKEN_GROUPS
   Dim tpSidAuth           As SID_IDENTIFIER_AUTHORITY
   Dim llRetVal            As Long
   Dim InfoBuffer()        As Long
   Dim sids()              As SID_AND_ATTRIBUTES
   Dim llCount             As Long
   Dim llIdx               As Long
   Dim llMax               As Long
   
   IsAdmin = False
   tpSidAuth.Value(5) = SECURITY_NT_AUTHORITY

'Obtain current process token
   If Not OpenThreadToken(GetCurrentThread(), TOKEN_QUERY, True, hProcessToken) Then
      Call OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, hProcessToken)
   End If
   If hProcessToken Then
'Deternine the buffer size required
      llRetVal = GetTokenInformation(hProcessToken, ByVal TokenGroups, 0, 0, BufferSize)
      If BufferSize Then
         ReDim InfoBuffer((BufferSize \ 4) - 1) As Long
         ReDim sids(0 To tpTokens.GroupCount) As SID_AND_ATTRIBUTES
'Retrieve your token information
         lResult = GetTokenInformation(hProcessToken, ByVal TokenGroups, InfoBuffer(0), BufferSize, BufferSize)
         If lResult <> 1 Then Exit Function
'Move it from memory into the token structure
         Call RtlMoveMemory(tpTokens, InfoBuffer(0), LenB(tpTokens))
'Retreive the admins sid pointer
         lResult = AllocateAndInitializeSid(tpSidAuth, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdmin)
         If lResult <> 1 Then Exit Function
         If IsValidSid(psidAdmin) Then
            For X = 0 To tpTokens.GroupCount
'Run through your token sid pointers
               If IsValidSid(tpTokens.Groups(X).Sid) Then
'Test for a match between the admin sid equalling your Sid 's
                  If EqualSid(ByVal tpTokens.Groups(X).Sid, ByVal psidAdmin) Then
                     IsAdmin = True
                     Exit For
                  End If
               End If
            Next
         End If
         If psidAdmin Then Call FreeSid(psidAdmin)
      End If
      Call CloseHandle(hProcessToken)
   End If
End Function

[Al42]

I have this code


run your code here
'the username is List1.List(i) each time through the loop
the code i need is the code to replace this

You said

I would like to know how to put it through a loop for every user. I have a code to get a list of usernames in to a list box. I just need to know how to loop it.

That's the code I gave you - to loop through the list of usernames.

[schoolbusdriver]

Just to re-iterate what Al42 said, and clarify my own posts WRT the above code: (the call to "ChangeSubKeyPermissions" is in post #4)

Dim i As Integer
   
For i = 0 To List1.ListCount - 1
   ChangeSubKeyPermissions HKEY_LOCAL_MACHINE, "Software\MY APPS\" & App.EXEName, List1.List(i)
Next i

[chris1990]

schoolbusdriver

Please could you edit your posts and use the code tags not the vbcode tags. As when copying and pasting the code i have to go through all the code and press enter in places.

By the way i did use it last time, i just need it automated now though. Thanks

[schoolbusdriver]

Please could you edit your posts and use the code tags not the vbcode tags. As when copying and pasting the code i have to go through all the code and press enter in places.

Done! (Except for post #9 )

[chris1990]

thanks this works great , although there is a problem instead of setting permissions it removes the ticks from the allow and deny checkboxes. Will i still be able to read and write to the key.

[schoolbusdriver]

Take a look at http://msdn2.microsoft.com/en-us/lib...7t(VS.80).aspx

In particular:

Checked ListBox
In Visual Basic 6.0, the Style property of a ListBox control determines whether a check box is displayed next to each text item. Multiple items in the ListBox can be selected by selecting the check box beside them even if the MultiSelect property is set to False. There is no way to programmatically determine the checked state of an item; if you required this capability, you have to use a ListView control instead.

May I suggest you change to a ListView control instead ? . The page has some VB6 ListView examples you may find useful such as:-

Code Changes for Determining Checked Items in a CheckedListBox Control

Despite the wording, the VB6 example refers to a ListView.