Tek-Tips is the largest IT community on the Internet today!
Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!
-
Congratulations SkipVought on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!
Creating folders are setting security 1
- Thread starter DavidJA
- Start date
You are actually manipulating the ACLs of the folder, and there is a Microsoft Q article: Q240176, which tells how to set the security of NTFS folders programatically. I don't have any code to show how it's done, but I know there are examples out there.
-
1
- #3
mortgagedeveloper
Programmer
After much banging of the head, and hacking apart other's code, I just finished this for myself...enjoy.
Note: this will only set the advanced security settings ofr the folder, still working on the regular security settings,if anyone know how to get to these settings, please help me out.
Public Function AddUserToFolder(sSharePath As String, sUserId As String, rError As String) As Integer
On Error GoTo ErrorHandler
AddUserToFolder = RESULT_OK
'use FSO for better errors if the folder can't be accessed
Dim fs As folder
Set fs = fso.GetFolder(sSharePath)
'get File System Security Descriptor from FSO
Set sd = ads.GetSecurityDescriptor("FILE://" & fs)
'get the discretionary ACL from the file's Security Descriptor
Set dacl = sd.DiscretionaryAcl
'delete `everyone` ace's from the folder rights
AddUserToFolder = DeleteAces(dacl, rError)
strSid = LocalConvertBINToSDDL("GMDADEVTEST", sUserId)
Select Case strSid
Case "S-0-0", ""
AddUserToFolder = RESULT_ERROR
rError = "AddUserToFolder: Could not get " & sUserId & "'s SID: - '" & strSid & "'"
Call CleanUpAds
GoTo Done
End Select
'create new ACE to add to the DACL
With aceUser
.AccessMask = ADS_RIGHT_DELETE Or _
ADS_RIGHT_READ_CONTROL Or _
ADS_RIGHT_WRITE_DAC Or _
ADS_RIGHT_WRITE_OWNER Or _
ADS_RIGHT_SYNCHRONIZE Or _
ADS_RIGHT_ACCESS_SYSTEM_SECURITY Or _
ADS_RIGHT_GENERIC_READ Or _
ADS_RIGHT_GENERIC_WRITE Or _
ADS_RIGHT_GENERIC_EXECUTE Or _
ADS_RIGHT_GENERIC_ALL Or _
ADS_RIGHT_DS_CREATE_CHILD Or _
ADS_RIGHT_DS_DELETE_CHILD Or _
ADS_RIGHT_ACTRL_DS_LIST Or _
ADS_RIGHT_DS_SELF Or _
ADS_RIGHT_DS_READ_PROP Or _
ADS_RIGHT_DS_WRITE_PROP Or _
ADS_RIGHT_DS_DELETE_TREE Or _
ADS_RIGHT_DS_LIST_OBJECT Or _
ADS_RIGHT_DS_CONTROL_ACCESS
.AceType = ADS_ACETYPE_ACCESS_ALLOWED
.Trustee = strSid
End With
'add the ACE to the DACL
dacl.AddAce aceUser
'reorder and set revision on the new DACL
Set dacl = ReOrderDacl(dacl)
'set the Security Descriptor's DACL to the modified DACL
sd.DiscretionaryAcl = dacl
'set the file's Security Descriptor to the modified SD
ads.SetSecurityDescriptor sd, "FILE://" & fs
AddUserToFolder = RESULT_OK
Done:
rError = "User: " & sUserId & " successfully added to " & sSharePath
Exit Function
ErrorHandler:
AddUserToFolder = RESULT_ERROR
rError = "AddUserToFolder: " & adsErr.GetErrorMessage(Err.Number)
'clean up
Call CleanUpAds
Err.Clear
End Function
Private Function DeleteAces(oDacl As AccessControlList, rError As String) As Integer
On Error GoTo ErrorHandler
For Each ace In oDacl
Select Case UCase(ace.Trustee)
Case "Everyone", "GMDCUSTOMERS", "GMD-UPLOAD"
oDacl.RemoveAce ace
End Select
Next
DeleteAces = RESULT_OK
ErrorHandler:
DeleteAces = RESULT_ERROR
rError = "Deleting ACES: Error: " & Err.Number & " Description: " & Err.Description
Err.Clear
End Function
Private Function ReOrderDacl(dacl As AccessControlList) As AccessControlList
' Initialize all of the new ACLs
Dim newDacl As New AccessControlList
Dim ImpDenyDacl As New AccessControlList
Dim InheritedDacl As New AccessControlList
Dim ImpAllowDacl As New AccessControlList
Dim InhAllowDacl As New AccessControlList
Dim ImpDenyObjectDacl As New AccessControlList
Dim impAllowObjectDacl As New AccessControlList
For Each ace In dacl
' Sort the original ACEs into their appropriate ACLs
If ((ace.AceFlags And ADS_ACEFLAG_INHERITED_ACE) = ADS_ACEFLAG_INHERITED_ACE) Then
' Don't really care about the order of inherited aces. Since we are
' adding them to the top of a new list, when they are added back
' to the Dacl for the object, they will be in the same order as
' they were originally. Just a positive side affect of adding items
' of a LIFO ( Last In First Out) type list.
InheritedDacl.AddAce ace
Else
' We have an Implicit ACE, lets put it the proper pool
Select Case ace.AceType
Case ADS_ACETYPE_ACCESS_ALLOWED
' We have an implicit allow ace
ImpAllowDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_DENIED
' We have a implicit Deny ACE
ImpDenyDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_ALLOWED_OBJECT
' We have an object allowed ace
' Does it apply to a property? or an Object?
impAllowObjectDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_DENIED_OBJECT
' We have a object Deny ace
ImpDenyObjectDacl.AddAce ace
End Select
End If
Next
For Each ace In ImpDenyDacl
newDacl.AddAce ace
Next
' Implicit Deny Object
For Each ace In ImpDenyObjectDacl
newDacl.AddAce ace
Next
' Implicit Allow
For Each ace In ImpAllowDacl
newDacl.AddAce ace
Next
' Implicit Allow Object
For Each ace In impAllowObjectDacl
newDacl.AddAce ace
Next
' Inherited Aces
For Each ace In InheritedDacl
newDacl.AddAce ace
Next
' Clean up
Set ImpDenyDacl = Nothing
Set InheritedDacl = Nothing
Set ImpAllowDacl = Nothing
Set InhAllowDacl = Nothing
Set ImpDenyObjectDacl = Nothing
Set impAllowObjectDacl = Nothing
' Set the appropriate revision level for the DACL
newDacl.AclRevision = dacl.AclRevision
' Replace the Security Descriptor
Set ReOrderDacl = newDacl
End Function
' LocalConvertBINToSDDL takes two arguments: strNTDomain-> Netbios name for the NT machine to
' Request account information from
' strNTAccount-> The NT SAM account name for the user
' The function returns the SDDL form of the user's SID
Private Function LocalConvertBINToSDDL(strNTDomain As String, strNTAccount As String) As String ' pSid As pSid, pszSidText)
Dim SDDL_SID As String
Dim pSia As Long
Dim pSiaByte(5) As Byte
Dim pSid() As Byte
Dim pSubAuthorityCount As Long
Dim bSubAuthorityCount As Byte
Dim pAuthority As Long
Dim lAuthority As Long
Dim dAuthority As Double
Dim pDomain As Long
Dim lReturn As Long
Dim AuthCount As Integer
Dim i As Integer
Dim uniUser As String
Dim strDomain As String
' Get the SID for the user's account, targetting a local PDC
lReturn = GetUserSID(strNTAccount, "", strNTDomain, pSid)
If lReturn = 0 Then Exit Function
' Convert the raw sid into its SDDL form ( S-?-?-???-?????? )
' The first item in the S- format is the revision level. If we look closely at the
' SID structure in the WinNT.H C Header, we find that the revision value for the SID is
' stored in the 0th byte to the raw sid.
'
' Another interesting fact is that the last byte of the Identifying authority structure contains
' the second component of the SDDL form, so lets retrieve both of those and
' place them into the string.
pSia = GetSidIdentifierAuthority(pSid(0))
'
' The GetSidIdentifierAuthority returns a pointer to the Identifying Authority structure
' The pointer must be copied into some memory that VB knows how to manage, so....
CopyByValMemory pSiaByte(0), pSia, 6
SDDL_SID = "S-" + LTrim(Str(pSid(0))) + "-" + LTrim(Str(pSiaByte(5)))
'
' The rest of the SDDL form contains a list of sub authorities separated by
' "-"s. The total number of these authorities can be obtained by
' calling the GetSidSubAuthorityCount. The value returned is a pointer into the
' SID memory that contains the Sub Authority value, once again, this memory
' must be copied into something that VB knows how to manage.
'
' Notice that only 1 byte is copied. This is because the sub authority count
' is stored in a single byte ( see the SID srtructure definition above )
pSubAuthorityCount = GetSidSubAuthorityCount(pSid(0))
CopyByValMemory bSubAuthorityCount, pSubAuthorityCount, 1
'
' We can loop throught the sub authorities and convert
' their DWORD values to VB longs, then convert them to a
' string.
' The count is 0 based, so we start a 0 and goto the
' number of sub authorities - 1
For AuthCount = 0 To bSubAuthorityCount - 1
pAuthority = GetSidSubAuthority(pSid(0), AuthCount)
CopyByValMemory lAuthority, pAuthority, LenB(lAuthority)
'
' VB does not have an unsigned type, the sub authority value
' could have the most significant bit set. If it is set,
' the Str function will return a negative number. Therefore
' we must account for this case by converting the value to
' a double then to its string form
'
' Step 1: Test the bit if set, Do step 2 and 3 else put
' the value in the output string.
' Step 2: 1 is true, so, AND off all the bits save the most
' significant bit, place in a temp double variable
' Step 3: Add the most significant bit to the double variable ( 2^31)
' Output the string
'
' Step 1:
'
dAuthority = lAuthority
If ((lAuthority And &H80000000) <> 0) Then
'
' Bit is set, Step 2:
dAuthority = lAuthority & &H7FFFFFFF
'
' Step 3:
dAuthority = dAuthority + 2 ^ 31
End If
SDDL_SID = SDDL_SID + "-" + LTrim(Str(dAuthority))
Next AuthCount
'
' We are done, the SDDL_SID variable contains the SID in
' SDDL form,
' Return it...
LocalConvertBINToSDDL = SDDL_SID
End Function
Private Function GetUserSID(ByRef sAccountName As String, _
ByRef sDomainName As String, _
ByVal sSystemName As String, _
ByRef bSID() As Byte) As Boolean
Dim SUCCESS As Long
Dim cbSid As Long
Dim cbDomainName As Long
Dim peUse As Long
sDomainName = vbNullString
cbDomainName = 0
If Len(sSystemName) = 0 Then
'If the system name (machine name)
'not specified, pass a null string
'to have the account lookup on
'the local machine
sSystemName = vbNullString
End If
'First call passes null as the SID.
'The call returns a success of 0 and
'the required buffer size in cbSid.
'In addition, because sDomainName is
'passed as null, cbDomainName returns
'the required buffer size for the lookup
'domain.
SUCCESS = LookupAccountName(sSystemName, _
sAccountName, _
0&, _
cbSid, _
sDomainName, _
cbDomainName, _
peUse)
'prevent errors
If (SUCCESS = 0) And (cbSid > 0) Then
'Prepare a buffer into which
'the domain where the account
'name is found will be returned
sDomainName = Space$(cbDomainName)
'create a buffer for the SID and
'call again.
ReDim bSID(0 To cbSid - 1)
'The function attempts to find a SID
'for the specified name by first
'checking a list of well-known SIDs.
'If the name does not correspond to a
'well-known SID, the function checks
'built-in and administratively-defined
'local accounts. Next, the function
'checks the primary domain. If the name
'is not found there, trusted domains
'are checked.
'On Windows 2000/XP, in addition to
'lookup local accounts, local domain
'accounts, and explicitly trusted
'domain accounts, LookupAccountName
'can look up the name for any account
'in any domain in the Windows 2000 forest.
'
'The further 'out' the search has to go,
'the longer it will take to return.
'
'peUse returns a pointer to a SID_NAME_USE
'enumerated type indicating the type of
'the account when the function returns.
SUCCESS = LookupAccountName(sSystemName, _
sAccountName, _
bSID(0), _
cbSid, _
sDomainName, _
cbDomainName, _
peUse)
If SUCCESS > 0 Then
'obtain the domain name
'returned
If cbDomainName > 0 Then
sDomainName = Left$(sDomainName, cbDomainName)
End If
End If
End If
'the call succeeded if success is greater than 0
GetUserSID = SUCCESS
End Function
Note: this will only set the advanced security settings ofr the folder, still working on the regular security settings,if anyone know how to get to these settings, please help me out.
Public Function AddUserToFolder(sSharePath As String, sUserId As String, rError As String) As Integer
On Error GoTo ErrorHandler
AddUserToFolder = RESULT_OK
'use FSO for better errors if the folder can't be accessed
Dim fs As folder
Set fs = fso.GetFolder(sSharePath)
'get File System Security Descriptor from FSO
Set sd = ads.GetSecurityDescriptor("FILE://" & fs)
'get the discretionary ACL from the file's Security Descriptor
Set dacl = sd.DiscretionaryAcl
'delete `everyone` ace's from the folder rights
AddUserToFolder = DeleteAces(dacl, rError)
strSid = LocalConvertBINToSDDL("GMDADEVTEST", sUserId)
Select Case strSid
Case "S-0-0", ""
AddUserToFolder = RESULT_ERROR
rError = "AddUserToFolder: Could not get " & sUserId & "'s SID: - '" & strSid & "'"
Call CleanUpAds
GoTo Done
End Select
'create new ACE to add to the DACL
With aceUser
.AccessMask = ADS_RIGHT_DELETE Or _
ADS_RIGHT_READ_CONTROL Or _
ADS_RIGHT_WRITE_DAC Or _
ADS_RIGHT_WRITE_OWNER Or _
ADS_RIGHT_SYNCHRONIZE Or _
ADS_RIGHT_ACCESS_SYSTEM_SECURITY Or _
ADS_RIGHT_GENERIC_READ Or _
ADS_RIGHT_GENERIC_WRITE Or _
ADS_RIGHT_GENERIC_EXECUTE Or _
ADS_RIGHT_GENERIC_ALL Or _
ADS_RIGHT_DS_CREATE_CHILD Or _
ADS_RIGHT_DS_DELETE_CHILD Or _
ADS_RIGHT_ACTRL_DS_LIST Or _
ADS_RIGHT_DS_SELF Or _
ADS_RIGHT_DS_READ_PROP Or _
ADS_RIGHT_DS_WRITE_PROP Or _
ADS_RIGHT_DS_DELETE_TREE Or _
ADS_RIGHT_DS_LIST_OBJECT Or _
ADS_RIGHT_DS_CONTROL_ACCESS
.AceType = ADS_ACETYPE_ACCESS_ALLOWED
.Trustee = strSid
End With
'add the ACE to the DACL
dacl.AddAce aceUser
'reorder and set revision on the new DACL
Set dacl = ReOrderDacl(dacl)
'set the Security Descriptor's DACL to the modified DACL
sd.DiscretionaryAcl = dacl
'set the file's Security Descriptor to the modified SD
ads.SetSecurityDescriptor sd, "FILE://" & fs
AddUserToFolder = RESULT_OK
Done:
rError = "User: " & sUserId & " successfully added to " & sSharePath
Exit Function
ErrorHandler:
AddUserToFolder = RESULT_ERROR
rError = "AddUserToFolder: " & adsErr.GetErrorMessage(Err.Number)
'clean up
Call CleanUpAds
Err.Clear
End Function
Private Function DeleteAces(oDacl As AccessControlList, rError As String) As Integer
On Error GoTo ErrorHandler
For Each ace In oDacl
Select Case UCase(ace.Trustee)
Case "Everyone", "GMDCUSTOMERS", "GMD-UPLOAD"
oDacl.RemoveAce ace
End Select
Next
DeleteAces = RESULT_OK
ErrorHandler:
DeleteAces = RESULT_ERROR
rError = "Deleting ACES: Error: " & Err.Number & " Description: " & Err.Description
Err.Clear
End Function
Private Function ReOrderDacl(dacl As AccessControlList) As AccessControlList
' Initialize all of the new ACLs
Dim newDacl As New AccessControlList
Dim ImpDenyDacl As New AccessControlList
Dim InheritedDacl As New AccessControlList
Dim ImpAllowDacl As New AccessControlList
Dim InhAllowDacl As New AccessControlList
Dim ImpDenyObjectDacl As New AccessControlList
Dim impAllowObjectDacl As New AccessControlList
For Each ace In dacl
' Sort the original ACEs into their appropriate ACLs
If ((ace.AceFlags And ADS_ACEFLAG_INHERITED_ACE) = ADS_ACEFLAG_INHERITED_ACE) Then
' Don't really care about the order of inherited aces. Since we are
' adding them to the top of a new list, when they are added back
' to the Dacl for the object, they will be in the same order as
' they were originally. Just a positive side affect of adding items
' of a LIFO ( Last In First Out) type list.
InheritedDacl.AddAce ace
Else
' We have an Implicit ACE, lets put it the proper pool
Select Case ace.AceType
Case ADS_ACETYPE_ACCESS_ALLOWED
' We have an implicit allow ace
ImpAllowDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_DENIED
' We have a implicit Deny ACE
ImpDenyDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_ALLOWED_OBJECT
' We have an object allowed ace
' Does it apply to a property? or an Object?
impAllowObjectDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_DENIED_OBJECT
' We have a object Deny ace
ImpDenyObjectDacl.AddAce ace
End Select
End If
Next
For Each ace In ImpDenyDacl
newDacl.AddAce ace
Next
' Implicit Deny Object
For Each ace In ImpDenyObjectDacl
newDacl.AddAce ace
Next
' Implicit Allow
For Each ace In ImpAllowDacl
newDacl.AddAce ace
Next
' Implicit Allow Object
For Each ace In impAllowObjectDacl
newDacl.AddAce ace
Next
' Inherited Aces
For Each ace In InheritedDacl
newDacl.AddAce ace
Next
' Clean up
Set ImpDenyDacl = Nothing
Set InheritedDacl = Nothing
Set ImpAllowDacl = Nothing
Set InhAllowDacl = Nothing
Set ImpDenyObjectDacl = Nothing
Set impAllowObjectDacl = Nothing
' Set the appropriate revision level for the DACL
newDacl.AclRevision = dacl.AclRevision
' Replace the Security Descriptor
Set ReOrderDacl = newDacl
End Function
' LocalConvertBINToSDDL takes two arguments: strNTDomain-> Netbios name for the NT machine to
' Request account information from
' strNTAccount-> The NT SAM account name for the user
' The function returns the SDDL form of the user's SID
Private Function LocalConvertBINToSDDL(strNTDomain As String, strNTAccount As String) As String ' pSid As pSid, pszSidText)
Dim SDDL_SID As String
Dim pSia As Long
Dim pSiaByte(5) As Byte
Dim pSid() As Byte
Dim pSubAuthorityCount As Long
Dim bSubAuthorityCount As Byte
Dim pAuthority As Long
Dim lAuthority As Long
Dim dAuthority As Double
Dim pDomain As Long
Dim lReturn As Long
Dim AuthCount As Integer
Dim i As Integer
Dim uniUser As String
Dim strDomain As String
' Get the SID for the user's account, targetting a local PDC
lReturn = GetUserSID(strNTAccount, "", strNTDomain, pSid)
If lReturn = 0 Then Exit Function
' Convert the raw sid into its SDDL form ( S-?-?-???-?????? )
' The first item in the S- format is the revision level. If we look closely at the
' SID structure in the WinNT.H C Header, we find that the revision value for the SID is
' stored in the 0th byte to the raw sid.
'
' Another interesting fact is that the last byte of the Identifying authority structure contains
' the second component of the SDDL form, so lets retrieve both of those and
' place them into the string.
pSia = GetSidIdentifierAuthority(pSid(0))
'
' The GetSidIdentifierAuthority returns a pointer to the Identifying Authority structure
' The pointer must be copied into some memory that VB knows how to manage, so....
CopyByValMemory pSiaByte(0), pSia, 6
SDDL_SID = "S-" + LTrim(Str(pSid(0))) + "-" + LTrim(Str(pSiaByte(5)))
'
' The rest of the SDDL form contains a list of sub authorities separated by
' "-"s. The total number of these authorities can be obtained by
' calling the GetSidSubAuthorityCount. The value returned is a pointer into the
' SID memory that contains the Sub Authority value, once again, this memory
' must be copied into something that VB knows how to manage.
'
' Notice that only 1 byte is copied. This is because the sub authority count
' is stored in a single byte ( see the SID srtructure definition above )
pSubAuthorityCount = GetSidSubAuthorityCount(pSid(0))
CopyByValMemory bSubAuthorityCount, pSubAuthorityCount, 1
'
' We can loop throught the sub authorities and convert
' their DWORD values to VB longs, then convert them to a
' string.
' The count is 0 based, so we start a 0 and goto the
' number of sub authorities - 1
For AuthCount = 0 To bSubAuthorityCount - 1
pAuthority = GetSidSubAuthority(pSid(0), AuthCount)
CopyByValMemory lAuthority, pAuthority, LenB(lAuthority)
'
' VB does not have an unsigned type, the sub authority value
' could have the most significant bit set. If it is set,
' the Str function will return a negative number. Therefore
' we must account for this case by converting the value to
' a double then to its string form
'
' Step 1: Test the bit if set, Do step 2 and 3 else put
' the value in the output string.
' Step 2: 1 is true, so, AND off all the bits save the most
' significant bit, place in a temp double variable
' Step 3: Add the most significant bit to the double variable ( 2^31)
' Output the string
'
' Step 1:
'
dAuthority = lAuthority
If ((lAuthority And &H80000000) <> 0) Then
'
' Bit is set, Step 2:
dAuthority = lAuthority & &H7FFFFFFF
'
' Step 3:
dAuthority = dAuthority + 2 ^ 31
End If
SDDL_SID = SDDL_SID + "-" + LTrim(Str(dAuthority))
Next AuthCount
'
' We are done, the SDDL_SID variable contains the SID in
' SDDL form,
' Return it...
LocalConvertBINToSDDL = SDDL_SID
End Function
Private Function GetUserSID(ByRef sAccountName As String, _
ByRef sDomainName As String, _
ByVal sSystemName As String, _
ByRef bSID() As Byte) As Boolean
Dim SUCCESS As Long
Dim cbSid As Long
Dim cbDomainName As Long
Dim peUse As Long
sDomainName = vbNullString
cbDomainName = 0
If Len(sSystemName) = 0 Then
'If the system name (machine name)
'not specified, pass a null string
'to have the account lookup on
'the local machine
sSystemName = vbNullString
End If
'First call passes null as the SID.
'The call returns a success of 0 and
'the required buffer size in cbSid.
'In addition, because sDomainName is
'passed as null, cbDomainName returns
'the required buffer size for the lookup
'domain.
SUCCESS = LookupAccountName(sSystemName, _
sAccountName, _
0&, _
cbSid, _
sDomainName, _
cbDomainName, _
peUse)
'prevent errors
If (SUCCESS = 0) And (cbSid > 0) Then
'Prepare a buffer into which
'the domain where the account
'name is found will be returned
sDomainName = Space$(cbDomainName)
'create a buffer for the SID and
'call again.
ReDim bSID(0 To cbSid - 1)
'The function attempts to find a SID
'for the specified name by first
'checking a list of well-known SIDs.
'If the name does not correspond to a
'well-known SID, the function checks
'built-in and administratively-defined
'local accounts. Next, the function
'checks the primary domain. If the name
'is not found there, trusted domains
'are checked.
'On Windows 2000/XP, in addition to
'lookup local accounts, local domain
'accounts, and explicitly trusted
'domain accounts, LookupAccountName
'can look up the name for any account
'in any domain in the Windows 2000 forest.
'
'The further 'out' the search has to go,
'the longer it will take to return.
'
'peUse returns a pointer to a SID_NAME_USE
'enumerated type indicating the type of
'the account when the function returns.
SUCCESS = LookupAccountName(sSystemName, _
sAccountName, _
bSID(0), _
cbSid, _
sDomainName, _
cbDomainName, _
peUse)
If SUCCESS > 0 Then
'obtain the domain name
'returned
If cbDomainName > 0 Then
sDomainName = Left$(sDomainName, cbDomainName)
End If
End If
End If
'the call succeeded if success is greater than 0
GetUserSID = SUCCESS
End Function
suoirotciv
Programmer
unable to run your code . . . looking for AccessControlList . . what do i need to do Please pardon the grammar.
Not good in english.
Not good in english.
suoirotciv
Programmer
so i got that one . .but where is the CleanUpAds Please pardon the grammar.
Not good in english.
Not good in english.
suoirotciv
Programmer
where is the following:
GetSidIdentifierAuthority
GetSidSubAuthorityCount
CopyByValMemory
GetSidSubAuthority
LookupAccountName
Please pardon the grammar.
Not good in english.
GetSidIdentifierAuthority
GetSidSubAuthorityCount
CopyByValMemory
GetSidSubAuthority
LookupAccountName
Please pardon the grammar.
Not good in english.
mortgagedeveloper
Programmer
Sorry about the missing pieces, they are from the API, CleanupAds is just a routine to cleanup variables, here is the rest of the code...
blnDoFatalError is an internal error handler, just replace it with your own...
when you look at the security on the folder, it won't be human readable, it will be a SID, and the you have to go into the Properties->Security->Advanced section of the folder to see the rights that were given.
' reference - Microsoft Scripting Runtime
' reference - Mabry NT User Management COM objects
' reference - ADsSecurity 2.5 Type Library
' reference - Active DS Type Library
' reference - ADsError 1.0 type Library
' uses basUtility.bas
Option Explicit
'**********************************************************************************
' User and Group Share APIs
Private Declare Function NetShareAdd Lib "netapi32" (ByVal pServername As Long, ByVal dwLevel As Long, pBuffer As SHARE_INFO_2, parmerr As Long) As Long
Private Declare Function NetShareDel Lib "netapi32" (ByVal pServername As Long, ByVal pNetName As Long, ByVal dwReserved As Long) As Long
Private Declare Function NetShareGetInfo Lib "netapi32" (ByVal pServername As Any, ByVal pNetName As Any, ByVal dwLevel As Long, ByVal pShareInfo2 As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32" (ByVal pBuffer As Long) As Long
Private Declare Function NetUserGetInfo Lib "netapi32" (ByVal pServername As Long, ByVal pUsername As Long, ByVal dwLevel As Long, pBuffer As USER_INFO_2) As Long
Private Declare Function NetGroupGetInfo Lib "netapi32" (ByVal pServername As Long, ByVal pGroupname As Long, ByVal dwLevel As Long, ByVal pBuffer As Long) As Long
Private Declare Function NetUserAdd Lib "netapi32" (ByVal pServername As Long, ByVal dwLevel As Long, ByVal pBuffer As USER_INFO_2, ByVal parm_err As Long) As Long
'**********************************************************************************
' NTFS Security APIs
Private Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function SetFileSecurity Lib "advapi32" Alias "SetFileSecurityA" (ByVal lpFileName As String, ByVal SecurityInformation As Long, pSecurityDescriptor As SECURITY_DESCRIPTOR) As Long
Private Declare Function InitializeSecurityDescriptor Lib "advapi32" (pSecurityDescriptor As SECURITY_DESCRIPTOR, ByVal dwRevision As Long) As Long
Private Declare Function LookupAccountName Lib "advapi32" Alias "LookupAccountNameA" (ByVal lpSystemName As String, ByVal lpAccountName As String, Sid As Byte, cbSid As Long, ByVal DomainName As String, cbDomainName As Long, peUse As Long) As Long
Private Declare Function GetFileSecurity Lib "advapi32" Alias "GetFileSecurityA" (ByVal lpFileName As String, ByVal RequestedInformation As Long, pSecurityDescriptor As Byte, ByVal nLength As Long, pnLengthNeeded As Long) As Long
Private Declare Function SetSecurityDescriptorDacl Lib "advapi32" (pSecurityDescriptor As SECURITY_DESCRIPTOR, ByVal bDaclPresent As Long, pDacl As Byte, ByVal bDaclDefaulted As Long) As Long
Private Declare Function GetSecurityDescriptorDacl Lib "advapi32" (pSD As Any, lDaclPresent As Long, pDacl As Long, lpbDaclDefaulted As Long) As Long
Private Declare Function GetAclInformation Lib "advapi32" (ByVal pAcl As Long, pAclInformation As Any, ByVal nAclInformationLength As Long, ByVal dwAclInformationClass As Long) As Long
Private Declare Function GetLengthSid Lib "advapi32" (pSid As Any) As Long
Private Declare Function InitializeAcl Lib "advapi32" (pAcl As Byte, ByVal nAclLength As Long, ByVal dwAclRevision As Long) As Long
Private Declare Function GetAce Lib "advapi32" (ByVal pAcl As Long, ByVal dwAceIndex As Long, pace As Any) As Long
Private Declare Function AddAce Lib "advapi32" (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 AddAccessAllowedAce Lib "advapi32" (pAcl As Byte, ByVal dwAceRevision As Long, ByVal AccessMask As Long, pSid As Any) As Long
Private Declare Function EqualSid Lib "advapi32" (pSID1 As Any, ByVal pSID2 As Long) As Long
Private Declare Function InitializeSid Lib "advapi32" (ByVal Sid As Long, pIndentifierAuthority As Any, ByVal nSubAuthorityCount As Byte) As Long
Private Declare Function GetSidSubAuthority Lib "advapi32" (pSid As Any, ByVal nSubAuthority As Long) As Long
Private Declare Function GetSidLengthRequired Lib "advapi32" (ByVal nSubAuthorityCount As Byte) As Long
Private Declare Function LookupAccountSid Lib "advapi32" Alias "LookupAccountSidA" (ByVal lpSystemName As String, Sid As Any, ByVal name As String, cbName As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Integer) As Long
Private Declare Function GetSidSubAuthorityCount Lib "advapi32" (pSid As Any) As Long
Private Declare Function GetSidIdentifierAuthority Lib "advapi32" (pSid As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Sub CopyByValMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
Private Declare Sub CopyByRefMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, Source As Any, ByVal Length As Long)
Private Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function NetGetDCName Lib "NETAPI32.DLL" (ServerName As Byte, DomainName As Byte, DCNPtr As Long) As Long
Private Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyW" (RetVal As Byte, ByVal Ptr As Long) As Long
Private Declare Sub lstrcpyW Lib "kernel32" (dest As Any, ByVal src As Any)
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpszString As Any) As Long
'**********************************************************************************
' Ace Mask definitions
'The right to delete the object.
Private Const ADS_RIGHT_DELETE = &H10000
'The right to read data from the security descriptor of the object, not including the data in the SACL.
Private Const ADS_RIGHT_READ_CONTROL = &H20000
'The right to modify the discretionary access-control list (DACL) in the object security descriptor.
Private Const ADS_RIGHT_WRITE_DAC = &H40000
'The right to assume ownership of the object. The user must be an object trustee. The user cannot transfer the ownership to other users.
Private Const ADS_RIGHT_WRITE_OWNER = &H80000
'The right to use the object for synchronization. This enables a thread to wait until the object is in the signaled state.
Private Const ADS_RIGHT_SYNCHRONIZE = &H100000
'The right to get or set the SACL in the object security descriptor.
Private Const ADS_RIGHT_ACCESS_SYSTEM_SECURITY = &H1000000
'The right to read permissions on this object, read all the properties on this object, list this object name when the parent container is listed, and list the contents of this object if it is a container.
Private Const ADS_RIGHT_GENERIC_READ = &H80000000
'The right to read permissions on this object, write all the properties on this object, and perform all validated writes to this object.
Private Const ADS_RIGHT_GENERIC_WRITE = &H40000000
'The right to read permissions on, and list the contents of, a container object.
Private Const ADS_RIGHT_GENERIC_EXECUTE = &H20000000
'The right to create or delete children, delete a subtree, read and write properties, examine children and the object itself, add and remove the object from the directory, and read or write with an extended right.
Private Const ADS_RIGHT_GENERIC_ALL = &H10000000
'The right to create children of the object. The ObjectType member of an ACE can contain a GUID that identifies the type of child object whose creation is controlled. If ObjectType does not contain a GUID, the ACE controls the creation of all child object types.
Private Const ADS_RIGHT_DS_CREATE_CHILD = &H1
'The right to delete children of the object. The ObjectType member of an ACE can contain a GUID that identifies a type of child object whose deletion is controlled. If ObjectType does not contain a GUID, the ACE controls the deletion of all child object types.
Private Const ADS_RIGHT_DS_DELETE_CHILD = &H2
'The right to list children of this object.
Private Const ADS_RIGHT_ACTRL_DS_LIST = &H4
'The right to perform an operation controlled by a validated write access right. The ObjectType member of an ACE can contain a GUID that identifies the validated write. If ObjectType does not contain a GUID, the ACE controls the rights to perform all valided write operations associated with the object.
Private Const ADS_RIGHT_DS_SELF = &H8
'The right to read properties of the object. The ObjectType member of an ACE can contain a GUID that identifies a property set or property. If ObjectType does not contain a GUID, the ACE controls the right to read all of the object properties.
Private Const ADS_RIGHT_DS_READ_PROP = &H10
'The right to write properties of the object. The ObjectType member of an ACE can contain a GUID that identifies a property set or property. If ObjectType does not contain a GUID, the ACE controls the right to write all of the object properties.
Private Const ADS_RIGHT_DS_WRITE_PROP = &H20
'The right to delete all children of this object, regardless of the permissions of the children.
Private Const ADS_RIGHT_DS_DELETE_TREE = &H40
'The right to list a particular object. If the user is not granted such a right, and the user does not have ADS_RIGHT_ACTRL_DS_LIST set on the object parent, the object is hidden from the user.
Private Const ADS_RIGHT_DS_LIST_OBJECT = &H80
'The right to perform an operation controlled by an extended access right. The ObjectType member of an ACE can contain a GUID that identifies the extended right. If ObjectType does not contain a GUID, the ACE controls the right to perform all extended right operations associated with the object.
Private Const ADS_RIGHT_DS_CONTROL_ACCESS = &H100
'**********************************************************************************
' Ace Type definitions
Private Const ADS_ACETYPE_ACCESS_ALLOWED = &H0
Private Const ADS_ACETYPE_ACCESS_DENIED = &H1
Private Const ADS_ACETYPE_SYSTEM_AUDIT = &H2
Private Const ADS_ACETYPE_ACCESS_ALLOWED_OBJECT = &H5
Private Const ADS_ACETYPE_ACCESS_DENIED_OBJECT = &H6
Private Const ADS_ACETYPE_SYSTEM_AUDIT_OBJECT = &H7
'**********************************************************************************
' Ace Flag Constants
Private Const ADS_ACEFLAG_UNKNOWN = &H1
Private Const ADS_ACEFLAG_INHERIT_ACE = &H2
Private Const ADS_ACEFLAG_NO_PROPAGATE_INHERIT_ACE = &H4
Private Const ADS_ACEFLAG_INHERIT_ONLY_ACE = &H8
Private Const ADS_ACEFLAG_INHERITED_ACE = &H10
Private Const ADS_ACEFLAG_VALID_INHERIT_FLAGS = &H1F
Private Const ADS_ACEFLAG_llResultFUL_ACCESS = &H40
Private Const ADS_ACEFLAG_FAILED_ACCESS = &H80
'**********************************************************************************
'
Private Const ADS_SID_RAW = &H0
Private Const ADS_SID_HEXSTRING = &H1
Private Const ADS_SID_SAM = &H2
Private Const ADS_SID_UPN = &H3
Private Const ADS_SID_SDDL = &H4
Private Const ADS_SID_WINNT_PATH = &H5
Private Const ADS_SID_ACTIVE_DIRECTORY_PATH = &H6
Private Const ADS_SID_SID_BINDING = &H7
'Private const fldname = "C:\test2" '<----Change this to the top folder name
'Private const usrname = "Domain\User" '<---Change this to the user you want to add permissions for
'**********************************************************************************
' Net constants
Private Const umfNormalAccount = 512 'This is a default type that represents a typical user.
Private Const umfTmpDuplicateAccount = 256 'This is for users whose primary account is in another domain. This account provides access to the domain, but not to any domain that trusts this domain. The NT User Manager refers to this account type as a local user account.
Private Const umfWrkTrustAccount = 4096 'This is a computer account for a Windows NT Workstation or Windows NT Server that is a member of this domain.
Private Const umfSvrTrustAccount = 8192 'This is a computer account for a Windows NT Backup Domain Controller that is a member of this domain.
Private Const umfInterTrustAccount = 2048 'This is a permit to trust account for a Windows NT domain that trusts other domains.
'**********************************************************************************
' Structure for Getversion
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 'Maintenance string for PSS usage
End Type
'**********************************************************************************
' Net share types
Private Const STYPE_DISKTREE As Long = &H0
Private Const STYPE_PRINTQ As Long = &H1
Private Const STYPE_DEVICE As Long = &H2
Private Const STYPE_IPC As Long = &H3
Private Const STYPE_SPECIAL As Long = &H80000000
'**********************************************************************************
' Net permissions
Private Const ACCESS_READ As Long = &H1
Private Const ACCESS_WRITE As Long = &H2
Private Const ACCESS_CREATE As Long = &H4
Private Const ACCESS_EXEC As Long = &H8
Private Const ACCESS_DELETE As Long = &H10
Private Const ACCESS_ATRIB As Long = &H20
Private Const ACCESS_PERM As Long = &H40
Private Const ACCESS_CHANGE As Long = ACCESS_READ Or ACCESS_WRITE Or ACCESS_CREATE Or ACCESS_EXEC Or ACCESS_ATRIB Or ACCESS_PERM
'**********************************************************************************
' Net Return Codes
Private Const ERROR_llResult As Long = 0&
Private Const NERR_Success As Long = 0&
Private Const ERROR_ACCESS_DENIED As Long = 5&
Private Const ERROR_INVALID_LEVEL As Long = 124&
Private Const ERROR_INVALID_PARAMETER As Long = 87&
Private Const ERROR_MORE_DATA As Long = 234&
Private Const ERROR_NOT_ENOUGH_MEMORY As Long = 8&
Private Const ERROR_INVALID_NAME As Long = 123&
'**********************************************************************************
' Share Info Structure
Private Type SHARE_INFO_2
shi2_netname As Long
shi2_type As Long
shi2_remark As Long
shi2_permissions As Long
shi2_max_uses As Long
shi2_current_uses As Long
shi2_path As Long
shi2_passwd As Long
End Type
'**********************************************************************************
' Group Info Structure
Private Type GROUP_INFO_2
grpi2_name As Long
grpi2_comment As Long
grpi2_group_id As Long
grpi2_attributes As Long
End Type
'**********************************************************************************
' User Info struct
Private Type USER_INFO_0
lpstrUsri0_name As Long
End Type
Private Type USER_INFO_2
usri2_name As Long
usri2_password As Long
usri2_password_age As Long
usri2_priv As Long
usri2_home_dir As Long
usri2_comment As Long
usri2_flags As Long
usri2_script_path As Long
usri2_auth_flags As Long
usri2_full_name As Long
usri2_usr_comment As Long
usri2_parms As Long
usri2_workstations As Long
usri2_last_logon As Long
usri2_last_logoff As Long
usri2_acct_expires As Long
usri2_max_storage As Long
usri2_units_per_week As Long
usri2_logon_hours As Byte
usri2_bad_pw_count As Long
usri2_num_logons As Long
usri2_logon_server As Long
usri2_country_code As Long
usri2_code_page As Long
End Type
'**********************************************************************************
' Share Info Constants
Private Const SHGFI_ATTRIBUTES As Long = &H800
Private Const SFGAO_SHARE As Long = &H20000
Private Const MAX_PATH As Long = 260
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
'**********************************************************************************
' Net Flags
Private Const umfScript = 1 'Execute logon script. This value is set by default for Windows NT.
Private Const umfAccountDisable = 2 'The user's account is disabled.
Private Const umfPasswdNotReq = 32 'No password is required for user logon.
Private Const umfPasswdCantChange = 64 'The user cannot change the password.
Private Const umfLockout = 16 'The account is currently locked out.
Private Const umfDontExpirePasswd = 65536 'The password will never expire on this account.
'**********************************************************************************
' Return codes from my functions
Private Const USER_FOUND = &H0
Private Const GROUP_FOUND = &H0
Private Const GROUP_NOT_FOUND = &H8AC
Private Const USER_NOT_FOUND = &H8AD
'**********************************************************************************
' Memory constants used through various memory API calls.
Private Const GMEM_MOVEABLE = &H2
Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED + LMEM_ZEROINIT)
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_ALL = &H10000000
Private Const GENERIC_EXECUTE = &H20000000
Private Const GENERIC_WRITE = &H40000000
'**********************************************************************************
' The file/security API call constants
Private Const DACL_SECURITY_INFORMATION = &H4
Private Const SECURITY_DESCRIPTOR_REVISION = 1
Private Const SECURITY_DESCRIPTOR_MIN_LENGTH = 20
Private Const SD_SIZE = (65536 + SECURITY_DESCRIPTOR_MIN_LENGTH)
Private Const ACL_REVISION2 = 2
Private Const ACL_REVISION = 2
Private Const MAXDWORD = &HFFFFFFFF
Private Const SidTypeUser = 1
Private Const AclSizeInformation = 2
'**********************************************************************************
' The following are the inherit flags that go into the AceFlags field
' of an Ace header.
Private Const OBJECT_INHERIT_ACE = &H1
Private Const CONTAINER_INHERIT_ACE = &H2
Private Const NO_PROPAGATE_INHERIT_ACE = &H4
Private Const INHERIT_ONLY_ACE = &H8
Private Const INHERITED_ACE = &H10
Private Const VALID_INHERIT_FLAGS = &H1F
Private Const DELETE = &H10000
'**********************************************************************************
' Structures used by our API calls.
Private Type ACE_HEADER
AceType As Byte
AceFlags As Byte
AceSize As Integer
End Type
Private Type ACCESS_DENIED_ACE
Header As ACE_HEADER
Mask As Long
SidStart As Long
End Type
Private Type ACCESS_ALLOWED_ACE
Header As ACE_HEADER
Mask As Long
SidStart As Long
End Type
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 SECURITY_DESCRIPTOR
Revision As Byte
Sbz1 As Byte
Control As Long
Owner As Long
Group As Long
Sacl As ACL
dacl As ACL
End Type
Private Type FILE_INFO_3
fi3_id As Long
fi3_permissions As Long
fi3_num_locks As Long
fi3_pathname As String
fi3_username As String
End Type
'**********************************************************************************
'return codes
Private Const RESULT_OK = 1
Private Const RESULT_WARNING = 2
Private Const RESULT_ERROR = 4
'**********************************************************************************
' share members
'**********************************************************************************
Private dwServer As Long
Private dwNetname As Long
Private dwPath As Long
Private dwRemark As Long
Private dwPw As Long
Private parmerr As Long
Private dwShareInfo2 As Long
Private dwGroupInfo2 As Long
Private dwUserInfo0 As Long
Private si2 As SHARE_INFO_2
Private gi2 As GROUP_INFO_2
Private ui0 As USER_INFO_0
Private ui2 As USER_INFO_2
Private resultStatus As Long
Private um As New NTUserX.UserManager
Private lgm As NTUserX.LocalGroupMgr
Private lgo As NTUserX.LocalGroupObj
Private uo As NTUserX.UserObj
'**********************************************************************************
' security members
'**********************************************************************************
Private sd As New SecurityDescriptor
Private newSd As New SecurityDescriptor
Private dacl As New AccessControlList
Private newDacl As New AccessControlList
Private aceUser As New AccessControlEntry
Private ace As AccessControlEntry
Private ads As New ADsSecurity
Private adsErr As New ADsError
Private fso As New FileSystemObject
Private strDebug As String
Private sDisplayText As String
Private lResult As Long
Private sSid As String
Private sAdminSid As String
Private sAgentSid As String
Private fnError As String
Private i As Integer
'**********************************************************************************
' Public Methods
'**********************************************************************************
Public Function AddUser(ByVal sServer As String, _
ByVal sSharePath As String, _
ByVal sShareName As String, _
ByVal userId As String, _
ByRef fnError As String) As Long
'userid in just a string
'server is in the format \\server
'sSharePath is in the format C:\folders\userId
'sShareName is in the format \folder1\folder2'see return codes above for return values
On Error GoTo ErrorHandler
'create customer folder
lResult = CreateFolder(sServer, sShareName, userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'add the shared folder
lResult = ShareAdd(sServer, sSharePath, userId, vbNullString, "gmd-" & userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'create the user
lResult = CreateLocalUser(sServer, sShareName, userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'add user to Users group
lResult = AddUserToGroup(sServer, "Users", userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'add user to GMDCustomers group
lResult = AddUserToGroup(sServer, "GMDCustomers", userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'add the user to the folder and delete an extraneous users
lResult = AddUserToFolder(sServer, sShareName, userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
fnError = "User added successfully!"
lResult = RESULT_OK
Done:
On Error Resume Next
AddUser = lResult
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: AddUser", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
'**********************************************************************************
' Private Methods
'**********************************************************************************
'**********************************************************************************
' Security Methods
'**********************************************************************************
Private Function AddUserToFolder(ByVal sServer As String, ByVal sRootPath As String, ByVal sUserId As String, ByRef fnError As String) As Integer
'sServer is in the format of \\server
'sRootPath is in the format \folder\folder'sUserId is the ANSII string of the user name
'fnError is the error string that is filled in and 'returned'
On Error GoTo ErrorHandler
AddUserToFolder = RESULT_OK
'use FSO for better errors if the folder can't be accessed
Dim fs As Folder
Set fs = fso.GetFolder(sServer & sRootPath & sUserId)
'get File System Security Descriptor from FSO
Set sd = ads.GetSecurityDescriptor("FILE://" & fs.Path)
'get the discretionary ACL from the file's Security Descriptor
Set dacl = sd.DiscretionaryAcl
sSid = LocalConvertBINToSDDL(sServer, sUserId)
sAdminSid = LocalConvertBINToSDDL(sServer, "Administrator"
'delete unwanted ace's from the folder rights
If DeleteAces(dacl, sSid, fnError) <> RESULT_OK Then GoTo Done
Select Case sSid
Case "S-0-0", ""
AddUserToFolder = RESULT_ERROR
fnError = "AddUserToFolder: Could not get " & sUserId & "'s SID: - '" & sSid & "'"
Call CleanUpAds
GoTo Done
End Select
'create new ACE to add to the DACL
With aceUser
.AccessMask = ADS_RIGHT_GENERIC_READ Or _
ADS_RIGHT_GENERIC_WRITE Or _
ADS_RIGHT_SYNCHRONIZE Or _
ADS_RIGHT_GENERIC_EXECUTE Or _
ADS_RIGHT_DS_CREATE_CHILD Or _
ADS_RIGHT_ACTRL_DS_LIST Or _
ADS_RIGHT_DS_READ_PROP Or _
ADS_RIGHT_DS_WRITE_PROP Or _
ADS_RIGHT_DS_LIST_OBJECT Or _
ADS_RIGHT_DS_CONTROL_ACCESS Or _
ADS_RIGHT_DS_SELF Or _
ADS_RIGHT_DELETE
.AceType = ADS_ACETYPE_ACCESS_ALLOWED
.AceFlags = ADS_ACEFLAG_INHERIT_ACE
.Trustee = sSid
End With
'check to see if user already exists in the security settings for the folder
For Each ace In dacl
If ace.Trustee = sSid Then
fnError = "AddUserToFolder: " & sUserId & " already exists in " & sServer & sRootPath & "!"
AddUserToFolder = RESULT_WARNING
GoTo Done
End If
Next
'add the ACE to the DACL
dacl.AddAce aceUser
'reorder and set revision on the new DACL
Set dacl = ReOrderDacl(dacl)
'Call DisplayAllAceInfo(dacl)
'set the Security Descriptor's DACL to the modified DACL
sd.DiscretionaryAcl = dacl
'set the file's Security Descriptor to the modified SD
ads.SetSecurityDescriptor sd, "FILE://" & fs.Path
'if we got this far with no errors, success
AddUserToFolder = RESULT_OK
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
fnError = "AddUserToFolder: " & Err.Number & ": " & Err.Description
AddUserToFolder = RESULT_ERROR
If blnDoFatalError(Err.Number, _
"clsUserManager: AddUserToFolder", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
Private Function DeleteAces(ByVal oDacl As AccessControlList, ByVal sSid As String, ByRef fnError As String) As Integer
'oDacl is the discretionary access control list of a Security Descriptor
'sSid must be in SDDL format
'fnError is the error string that is filled in and 'returned'
On Error GoTo ErrorHandler
For Each ace In oDacl
Select Case ace.Trustee
Case sSid, sAdminSid ', sAgentSid
Case Else
oDacl.RemoveAce ace
End Select
Next
DeleteAces = RESULT_OK
Done:
On Error Resume Next
Exit Function
ErrorHandler:
DeleteAces = RESULT_ERROR
fnError = "DeleteAces: " & Err.Number & ": " & Err.Description
If blnDoFatalError(Err.Number, _
"clsUserManager: DeleteAces", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
Private Function ReOrderDacl(ByVal oDacl As AccessControlList) As AccessControlList
On Error GoTo ErrorHandler
' Initialize all of the new ACLs
Dim newDacl As New AccessControlList
Dim ImpDenyDacl As New AccessControlList
Dim InheritedDacl As New AccessControlList
Dim ImpAllowDacl As New AccessControlList
Dim InhAllowDacl As New AccessControlList
Dim ImpDenyObjectDacl As New AccessControlList
Dim impAllowObjectDacl As New AccessControlList
For Each ace In oDacl
' Sort the original ACEs into their appropriate ACLs
If ((ace.AceFlags And ADS_ACEFLAG_INHERITED_ACE) = ADS_ACEFLAG_INHERITED_ACE) Then
' Don't really care about the order of inherited aces. Since we are
' adding them to the top of a new list, when they are added back
' to the Dacl for the object, they will be in the same order as
' they were originally. Just a positive side affect of adding items
' of a LIFO ( Last In First Out) type list.
InheritedDacl.AddAce ace
Else
' We have an Implicit ACE, lets put it the proper pool
Select Case ace.AceType
Case ADS_ACETYPE_ACCESS_ALLOWED
' We have an implicit allow ace
ImpAllowDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_DENIED
' We have a implicit Deny ACE
ImpDenyDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_ALLOWED_OBJECT
' We have an object allowed ace
' Does it apply to a property? or an Object?
impAllowObjectDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_DENIED_OBJECT
' We have a object Deny ace
ImpDenyObjectDacl.AddAce ace
End Select
End If
Next
For Each ace In ImpDenyDacl
newDacl.AddAce ace
Next
' Implicit Deny Object
For Each ace In ImpDenyObjectDacl
newDacl.AddAce ace
Next
' Implicit Allow
For Each ace In ImpAllowDacl
newDacl.AddAce ace
Next
' Implicit Allow Object
For Each ace In impAllowObjectDacl
newDacl.AddAce ace
Next
' Inherited Aces
For Each ace In InheritedDacl
newDacl.AddAce ace
Next
' Set the appropriate revision level for the DACL
newDacl.AclRevision = dacl.AclRevision
' Replace the Security Descriptor
Set ReOrderDacl = newDacl
Done:
On Error Resume Next
' Clean up
Set ImpDenyDacl = Nothing
Set InheritedDacl = Nothing
Set ImpAllowDacl = Nothing
Set InhAllowDacl = Nothing
Set ImpDenyObjectDacl = Nothing
Set impAllowObjectDacl = Nothing
Set oDacl = Nothing
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: ReOrderDacl", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
' LocalConvertBINToSDDL takes two arguments: strNTDomain-> Netbios name for the NT machine to
' Request account information from
' strNTAccount-> The NT SAM account name for the user
' The function returns the SDDL form of the user's SID
Private Function LocalConvertBINToSDDL(ByVal strNTDomain As String, ByVal strNTAccount As String) As String
On Error GoTo ErrorHandler
Dim SDDL_SID As String
Dim pSia As Long
Dim pSiaByte(5) As Byte
Dim pSid() As Byte
Dim pSubAuthorityCount As Long
Dim bSubAuthorityCount As Byte
Dim pAuthority As Long
Dim lAuthority As Long
Dim dAuthority As Double
Dim pDomain As Long
Dim lReturn As Long
Dim AuthCount As Integer
Dim i As Integer
Dim uniUser As String
Dim strDomain As String
' Get the SID for the user's account, targetting a local PDC
lReturn = GetUserSID(strNTAccount, "", strNTDomain, pSid)
If lReturn = 0 Then GoTo Done
' Convert the raw sid into its SDDL form ( S-?-?-???-?????? )
' The first item in the S- format is the revision level. If we look closely at the
' SID structure in the WinNT.H C Header, we find that the revision value for the SID is
' stored in the 0th byte to the raw sid.
'
' Another interesting fact is that the last byte of the Identifying authority structure contains
' the second component of the SDDL form, so lets retrieve both of those and
' place them into the string.
pSia = GetSidIdentifierAuthority(pSid(0))
'
' The GetSidIdentifierAuthority returns a pointer to the Identifying Authority structure
' The pointer must be copied into some memory that VB knows how to manage, so....
CopyByValMemory pSiaByte(0), pSia, 6
SDDL_SID = "S-" + LTrim(Str(pSid(0))) + "-" + LTrim(Str(pSiaByte(5)))
'
' The rest of the SDDL form contains a list of sub authorities separated by
' "-"s. The total number of these authorities can be obtained by
' calling the GetSidSubAuthorityCount. The value returned is a pointer into the
' SID memory that contains the Sub Authority value, once again, this memory
' must be copied into something that VB knows how to manage.
'
' Notice that only 1 byte is copied. This is because the sub authority count
' is stored in a single byte ( see the SID srtructure definition above )
pSubAuthorityCount = GetSidSubAuthorityCount(pSid(0))
CopyByValMemory bSubAuthorityCount, pSubAuthorityCount, 1
'
' We can loop throught the sub authorities and convert
' their DWORD values to VB longs, then convert them to a
' string.
' The count is 0 based, so we start a 0 and goto the
' number of sub authorities - 1
For AuthCount = 0 To bSubAuthorityCount - 1
pAuthority = GetSidSubAuthority(pSid(0), AuthCount)
CopyByValMemory lAuthority, pAuthority, LenB(lAuthority)
'
' VB does not have an unsigned type, the sub authority value
' could have the most significant bit set. If it is set,
' the Str function will return a negative number. Therefore
' we must account for this case by converting the value to
' a double then to its string form
'
' Step 1: Test the bit if set, Do step 2 and 3 else put
' the value in the output string.
' Step 2: 1 is true, so, AND off all the bits save the most
' significant bit, place in a temp double variable
' Step 3: Add the most significant bit to the double variable ( 2^31)
' Output the string
'
' Step 1:
'
dAuthority = lAuthority
If ((lAuthority And &H80000000) <> 0) Then
'
' Bit is set, Step 2:
dAuthority = lAuthority & &H7FFFFFFF
'
' Step 3:
dAuthority = dAuthority + 2 ^ 31
End If
SDDL_SID = SDDL_SID + "-" + LTrim(Str(dAuthority))
Next AuthCount
'
' We are done, the SDDL_SID variable contains the SID in
' SDDL form,
' Return it...
LocalConvertBINToSDDL = SDDL_SID
Done:
On Error Resume Next
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: LocalConvertBINToSDDL", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Function
Private Function GetUserSID(ByRef sAccountName As String, _
ByRef sDomainName As String, _
ByVal sSystemName As String, _
ByRef bSID() As Byte) As Boolean
On Error GoTo ErrorHandler
Dim llResult As Long
Dim cbSid As Long
Dim cbDomainName As Long
Dim peUse As Long
sDomainName = vbNullString
cbDomainName = 0
If Len(sSystemName) = 0 Then
'If the system name (machine name)
'not specified, pass a null string
'to have the account lookup on
'the local machine
sSystemName = vbNullString
End If
'First call passes null as the SID.
'The call returns a success of 0 and
'the required buffer size in cbSid.
'In addition, because sDomainName is
'passed as null, cbDomainName returns
'the required buffer size for the lookup
'domain.
llResult = LookupAccountName(sSystemName, _
sAccountName, _
0&, _
cbSid, _
sDomainName, _
cbDomainName, _
peUse)
'prevent errors
If (llResult = 0) And (cbSid > 0) Then
'Prepare a buffer into which
'the domain where the account
'name is found will be returned
sDomainName = Space$(cbDomainName)
'create a buffer for the SID and
'call again.
ReDim bSID(0 To cbSid - 1)
'The function attempts to find a SID
'for the specified name by first
'checking a list of well-known SIDs.
'If the name does not correspond to a
'well-known SID, the function checks
'built-in and administratively-defined
'local accounts. Next, the function
'checks the primary domain. If the name
'is not found there, trusted domains
'are checked.
'On Windows 2000/XP, in addition to
'lookup local accounts, local domain
'accounts, and explicitly trusted
'domain accounts, LookupAccountName
'can look up the name for any account
'in any domain in the Windows 2000 forest.
'
'The further 'out' the search has to go,
'the longer it will take to return.
'
'peUse returns a pointer to a SID_NAME_USE
'enumerated type indicating the type of
'the account when the function returns.
llResult = LookupAccountName(sSystemName, _
sAccountName, _
bSID(0), _
cbSid, _
sDomainName, _
cbDomainName, _
peUse)
If llResult <> 0 Then
'obtain the domain name
'returned
If cbDomainName > 0 Then
sDomainName = Left$(sDomainName, cbDomainName)
End If
End If
End If
'the call succeeded if llResult is not 0
GetUserSID = llResult
Done:
On Error Resume Next
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: GetUserSID", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Function
Private Sub DisplayAllAceInfo(ByVal dacl As AccessControlList)
On Error GoTo ErrorHandler
Dim sAce As String
sAce = ""
'display all info for all aces in a dacl
For Each ace In dacl
sAce = sAce & "Trustee: " & ace.Trustee & vbCrLf
sAce = sAce & "Mask: " & ace.AccessMask & vbCrLf
sAce = sAce & "AceFlags: " & ace.AceFlags & vbCrLf
sAce = sAce & "Type: " & ace.AceType & vbCrLf
sAce = sAce & "Flags: " & ace.Flags & vbCrLf
sAce = sAce & "Inherited Object Type: " & ace.InheritedObjectType & vbCrLf
sAce = sAce & "Object Type: " & ace.ObjectType & vbCrLf
sAce = sAce & "====================================================" & vbCrLf
Next
MsgBox sAce
Done:
On Error Resume Next
Exit Sub
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: DisplayAllAceInfo", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Sub
Private Sub DisplayDaclForFolder(ByVal sServer As String, ByVal sFolder As String)
On Error GoTo ErrorHandler
Dim um As New UserManager
Dim lgm As LocalGroupMgr
Dim uo As UserObj
Dim fs As Folder
um.Server = "GMDADEVTEST"
Set lgm = um.GetLocalGroupManager
sDisplayText = "Local Users" & vbCrLf & vbCrLf
For Each uo In um
sDisplayText = sDisplayText & "Name: " & uo.name & vbCrLf
Next
sDisplayText = sDisplayText & "--------------------------" & vbCrLf
'**********************************************************************************
'use FSO for better errors if the folder can't be accessed
Set fs = fso.GetFolder(sFolder)
'get File System Security Descriptor from FSO
Set sd = ads.GetSecurityDescriptor("FILE://" & fs)
'get the discretionary ACL from the file's Security Descriptor
Set dacl = sd.DiscretionaryAcl
sDisplayText = sDisplayText & "Aces for " & sFolder & ":" & vbCrLf & vbCrLf
For Each ace In dacl
sDisplayText = sDisplayText & "Trustee: " & ace.Trustee & " - "
sDisplayText = sDisplayText & "Ace Type: "
Select Case ace.AceType
Case ADS_ACETYPE_ACCESS_ALLOWED
' We have an implicit allow ace
sDisplayText = sDisplayText & "ACCESS_ALLOWED" & vbCrLf
Case ADS_ACETYPE_ACCESS_DENIED
' We have a implicit Deny ACE
sDisplayText = sDisplayText & "ACCESS_DENIED" & vbCrLf
Case ADS_ACETYPE_ACCESS_ALLOWED_OBJECT
' We have an object allowed ace
' Does it apply to a property? or an Object?
sDisplayText = sDisplayText & "ACCESS_ALLOWED_OBJECT" & vbCrLf
Case ADS_ACETYPE_ACCESS_DENIED_OBJECT
' We have a object Deny ace
sDisplayText = sDisplayText & "ACCESS_DENIED_OBJECT" & vbCrLf
Case Default
' This has to be some kind of mistake
sDisplayText = sDisplayText & "ACCESS_UNKOWN!" & vbCrLf
End Select
Next
MsgBox sDisplayText
Done:
On Error Resume Next
Set fs = Nothing
Set sd = Nothing
Set um = Nothing
Set lgm = Nothing
Set uo = Nothing
Call CleanUpAll
Exit Sub
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: DisplayDaclForFolder", _
True, _
999, _
False, _
"No information to display - " & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Sub
'**********************************************************************************
' Share Methods
'**********************************************************************************
Private Function ShareDelete(ByVal sServerName As String, ByVal sNetName As String)
On Error GoTo ErrorHandler
um.Server = sServerName
Set lgm = um.GetLocalGroupManager
Set lgo = lgm(sNetName)
lgm.Remove (lgo.name)
ShareDelete = GROUP_FOUND
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: ShareDelete", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Function
Private Function ShareAdd(ByVal sServer As String, _
ByVal sSharePath As String, _
ByVal sShareName As String, _
ByVal sShareRemark As String, _
ByVal sSharePw As String, _
fnError As String) As Long
On Error GoTo ErrorHandler
'obtain pointers to the server, share and path
dwServer = StrPtr(sServer)
dwNetname = StrPtr(sShareName)
dwPath = StrPtr(sSharePath)
'if the remark or password specified, obtain pointer to those as well
If Len(sShareRemark) > 0 Then dwRemark = StrPtr(sShareRemark)
If Len(sSharePw) > 0 Then dwPw = StrPtr(sSharePw)
'prepare the SHARE_INFO_2 structure
With si2
.shi2_netname = dwNetname
.shi2_path = dwPath
.shi2_remark = dwRemark
.shi2_type = STYPE_DISKTREE
.shi2_permissions = ACCESS_CHANGE
.shi2_max_uses = -1
.shi2_passwd = dwPw
End With
'add the share
lResult = NetShareAdd(dwServer, 2, si2, parmerr)
'check share results and output
If lResult = NERR_Success Then
ShareAdd = RESULT_OK
Else
fnError = "Share Folder: " & fnError & NetReturnError(lResult)
ShareAdd = RESULT_ERROR
End If
Done:
On Error Resume Next
Exit Function
ErrorHandler:
ShareAdd = RESULT_ERROR
If blnDoFatalError(Err.Number, _
"clsUserManager: ShareAdd", _
True, _
999, _
False, _
"" & fnError) _
= True Then Resume
Resume Done
End Function
'**********************************************************************************
' Folder Methods
'**********************************************************************************
Private Function CreateFolder(ByVal sServer As String, _
ByVal sRootFolder As String, _
ByVal userId As String, _
ByRef fnError As String) As Long
On Error GoTo ErrorHandler
Dim fsoUserFolder As New FileSystemObject
If fsoUserFolder.FolderExists(sServer & sRootFolder & userId) Then
CreateFolder = RESULT_WARNING
Else
fsoUserFolder.CreateFolder (sServer & sRootFolder & userId)
CreateFolder = RESULT_OK
End If
Done:
On Error Resume Next
Set fsoUserFolder = Nothing
Exit Function
ErrorHandler:
fnError = "CreateFolder: " & Err.Number & ": " & Err.Description
If blnDoFatalError(Err.Number, _
"clsUserManager: CreateFolder", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
fnError = "CreateFolder:" & Err.Number & ": " & Err.Description
Resume Done
End Function
'**********************************************************************************
' User/Group Methods
'**********************************************************************************
Private Function CreateLocalUser(ByVal sServer As String, _
ByVal sRootFolder As String, _
ByVal userId As String, _
ByRef fnError As String) As Long
On Error GoTo ErrorHandler
Dim strPwd As String
Dim strDescription As String
Dim strScriptPath As String
Dim lFlags As Long
Dim groupNum As Integer
'build the password
strPwd = "gmd-" & userId
'build the account description
strDescription = "Local account for " & userId
'build the user's script path
strScriptPath = ""
'build the flags for this account
lFlags = umfDontExpirePasswd
lResult = CheckForUser(sServer, userId)
Select Case lResult
Case USER_NOT_FOUND
'set the server
um.Server = sServer
'create new user to add to the local group
Set uo = um.AddUser(userId, _
strDescription, _
strPwd, _
sRootFolder, _
strScriptPath, _
lFlags)
CreateLocalUser = RESULT_OK
Case USER_FOUND
um.Server = sServer
'get a reference to the user
'Set uoAccount = um(userId)
For i = 1 To um.Count
Set uo = um(i)
If uo.name = userId Then
Set uo = um(i)
Exit For
End If
Next
fnError = "CreateLocalUser: " & userId & " already exists!"
CreateLocalUser = RESULT_WARNING
Case GROUP_NOT_FOUND
fnError = "CreateLocalUser: Group not found!"
CreateLocalUser = RESULT_ERROR
Case Else
fnError = "CreateLocalUser: Unknown error!"
CreateLocalUser = RESULT_ERROR
End Select
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
Select Case Err.Number
Case -2147221400
fnError = "CreateLocalUser: Could not get a reference to the current user who already exists!"
Case Else
fnError = "CreateLocalUser: " & Err.Number & ": " & Err.Description
End Select
If blnDoFatalError(Err.Number, _
"clsUserManager: CreateLocalUser", _
True, _
999, _
False, _
fnError) _
= True Then Resume
Resume Done
End Function
Private Function AddUserToGroup(sServer As String, _
sGroupId As String, _
sUserId As String, _
fnError As String) As Long
On Error GoTo ErrorHandler
um.Server = sServer
'get a local group mngr
Set lgm = um.GetLocalGroupManager
'set the local group object to the group in question
Set lgo = lgm(sGroupId)
'add the user to the group
lgo.Add um(sUserId)
AddUserToGroup = RESULT_OK
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
Select Case Err.Number
Case -2147023518
fnError = "AddUserToGroup: " & sUserId & " already belongs to the " & sGroupId & " group!"
AddUserToGroup = RESULT_WARNING
Resume Done
Case -2147221400
fnError = "AddUserToGroup: " & sGroupId & " group does not exist!"
AddUserToGroup = RESULT_ERROR
Case Else
fnError = "AddUserToGroup: Add " & sUserId & " to " & sGroupId & ": Error: " & Err.Number & " Description: " & Err.Description
AddUserToGroup = RESULT_ERROR
End Select
If blnDoFatalError(Err.Number, _
"clsUserManager: CreateLocalUser", _
True, _
999, _
False, _
fnError) _
= True Then Resume
Resume Done
End Function
Private Function CheckForUser(ByVal sServerName As String, ByVal sUserName As String) As Long
On Error GoTo ErrorHandler
'obtain pointers to the server and share
dwServer = StrPtr(sServerName)
dwNetname = StrPtr(sUserName)
CheckForUser = NetUserGetInfo(dwServer, dwNetname, 0, ui2)
Call NetApiBufferFree(dwUserInfo0)
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: CheckForUser", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
Private Function CheckForGroup(ByVal sServerName As String, ByVal sNetName As String) As Long
On Error GoTo ErrorHandler
um.Server = sServerName
Set lgm = um.GetLocalGroupManager
'default to not found
CheckForGroup = GROUP_NOT_FOUND
For Each lgo In lgm
If lgo.name = sNetName Then CheckForGroup = GROUP_FOUND
Next
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: CheckForGroup", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
Public Function CheckForUserInGroup(ByVal strServer As String, ByVal strGroup As String, ByVal strUser As String) As Integer
On Error GoTo ErrorHandler
Dim i As Integer
um.Server = strServer
Set lgm = um.GetLocalGroupManager
'default to not found
CheckForUserInGroup = USER_NOT_FOUND Or GROUP_NOT_FOUND
'search the local user group mngr for the specific group
For Each lgo In lgm
'if the group is found, search for the specific user
If lgo.name = strGroup Then
For i = 0 To lgo.Count
If lgo.Count = 0 Then
CheckForUserInGroup = USER_NOT_FOUND
Exit For
End If
Set uo = lgo(i)
If uo.name = strUser Then
CheckForUserInGroup = USER_FOUND
Exit For
End If
Next
Else
CheckForUserInGroup = GROUP_NOT_FOUND
End If
If CheckForUserInGroup = USER_FOUND Then Exit For
Next
Done:
On Error Resume Next
Call CleanUpAll
Set um = Nothing
Set lgm = Nothing
Set lgo = Nothing
Set uo = Nothing
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: CheckForUserInGroup", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
'**********************************************************************************
' Utility Methods
'**********************************************************************************
Private Function QualifyServer(ByVal sServer As String) As String
'see if there are already two slashes preceding the server name
If Left(sServer, 2) = "\\" Then
'there are, so the server is already qualified; 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
End If
End Function
Private Function NetReturnError(ByVal Reply As Long) As String
'THIS FUNCTION IS A GENERIC FUNCTION TO RETURN WIN 32 NET API ERROR CODES FOR MOST THINGS
Dim e As String
If Reply = 0 Then
NetReturnError = ""
Exit Function
End If
NetReturnError = True
Select Case Reply
Case 5, 65
e = "you had insufficient privileges to perform this action."
Case 50
e = "a network request was not supported."
Case 53
e = "a network path was not found."
Case 86
e = "an insufficient old password was used." + Chr(13) + _
"More than 2 more failed attempts to change password will cause an" + Chr(13) + _
"account lockout for 5 minutes."
Case 87
e = "an invalid parameter was specified."
Case 123
e = "a filename, directory name, or volume label syntax is incorrect."
Case 124
e = "an invalid parameter was attempted to be passed and failed."
Case 234, 2123
e = "too little memory was allocated to perform the action and failed."
Case 2102
e = "a device driver was not installed to conduct the action."
Case 2106
e = "an action was attempted that can take place only from an NT Server."
Case 2118
e = "the name has already been shared."
Case 2138
e = "NT Workstation services have not been started."
Case 2141
e = "either the NT Server is not configured for this transaction or IPC is not shared."
Case 2202
e = "an invalid NT user name was specified."
Case 2220
e = "the NT group name does not exist."
Case 2221
e = "the NT user name was not found."
Case 2223
e = "the NT group name already exists."
Case 2224
e = "the NT user name already exists."
Case 2226
e = "the specified NT Server is not the Primary Domain Controller."
Case 2227
e = "the NT Server is not running in user-level security."
Case 2228
e = "the accounts database became full."
Case 2229
e = "an unknown error (code 2229) occurred in accessing the NT accounts database."
Case 2245
e = "the password is too short."
Case 2247
e = "the NT accounts database file is corrupted."
Case 2351
e = "an invalid NT computer name was specified."
Case 2456
e = "the NT user accounts database cannot be enlarged because the NT Server's hard disk is full."
Case 2310
e = "the shared resource does not exist."
Case Else
e = "an error code of " + Str(Reply) + " was generated."
End Select
NetReturnError = e
End Function
Private Sub CleanUpAll()
On Error Resume Next
Set um = Nothing
Set lgm = Nothing
Set lgo = Nothing
Set uo = Nothing
Set sd = Nothing
Set newSd = Nothing
Set dacl = Nothing
Set newDacl = Nothing
Set aceUser = Nothing
Set ace = Nothing
Set ads = Nothing
Set adsErr = Nothing
Set fso = Nothing
End Sub
Private Sub CleanUpAds()
On Error Resume Next
Set ads = Nothing
Set sd = Nothing
Set dacl = Nothing
Set aceUser = Nothing
Set fso = Nothing
Set newDacl = Nothing
Set newSd = Nothing
Set adsErr = Nothing
End Sub
Private Sub Class_Terminate()
Call CleanUpAll
End Sub
Private Function UtoA(pUNIstring As Long) As String
On Error GoTo ErrorHandler
Dim wrkByte() As Byte
Dim wrkStr As String
' Get space for string each character is two bytes
' and a null terminator.
'
ReDim wrkByte(lstrlenW(pUNIstring) * 2 + 2)
' Copy the string to a byte array
Call lstrcpyW(wrkByte(0), pUNIstring)
' Covert the string from a UNI string to a ASCII string.
' this happens automatically when a byte array is copied
' to a string.
wrkStr = wrkByte
' return everything upto the the null terminator.
'
UtoA = Left(wrkStr, InStr(wrkStr, Chr(0)) - 1)
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: UtoA", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
blnDoFatalError is an internal error handler, just replace it with your own...
when you look at the security on the folder, it won't be human readable, it will be a SID, and the you have to go into the Properties->Security->Advanced section of the folder to see the rights that were given.
' reference - Microsoft Scripting Runtime
' reference - Mabry NT User Management COM objects
' reference - ADsSecurity 2.5 Type Library
' reference - Active DS Type Library
' reference - ADsError 1.0 type Library
' uses basUtility.bas
Option Explicit
'**********************************************************************************
' User and Group Share APIs
Private Declare Function NetShareAdd Lib "netapi32" (ByVal pServername As Long, ByVal dwLevel As Long, pBuffer As SHARE_INFO_2, parmerr As Long) As Long
Private Declare Function NetShareDel Lib "netapi32" (ByVal pServername As Long, ByVal pNetName As Long, ByVal dwReserved As Long) As Long
Private Declare Function NetShareGetInfo Lib "netapi32" (ByVal pServername As Any, ByVal pNetName As Any, ByVal dwLevel As Long, ByVal pShareInfo2 As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32" (ByVal pBuffer As Long) As Long
Private Declare Function NetUserGetInfo Lib "netapi32" (ByVal pServername As Long, ByVal pUsername As Long, ByVal dwLevel As Long, pBuffer As USER_INFO_2) As Long
Private Declare Function NetGroupGetInfo Lib "netapi32" (ByVal pServername As Long, ByVal pGroupname As Long, ByVal dwLevel As Long, ByVal pBuffer As Long) As Long
Private Declare Function NetUserAdd Lib "netapi32" (ByVal pServername As Long, ByVal dwLevel As Long, ByVal pBuffer As USER_INFO_2, ByVal parm_err As Long) As Long
'**********************************************************************************
' NTFS Security APIs
Private Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function SetFileSecurity Lib "advapi32" Alias "SetFileSecurityA" (ByVal lpFileName As String, ByVal SecurityInformation As Long, pSecurityDescriptor As SECURITY_DESCRIPTOR) As Long
Private Declare Function InitializeSecurityDescriptor Lib "advapi32" (pSecurityDescriptor As SECURITY_DESCRIPTOR, ByVal dwRevision As Long) As Long
Private Declare Function LookupAccountName Lib "advapi32" Alias "LookupAccountNameA" (ByVal lpSystemName As String, ByVal lpAccountName As String, Sid As Byte, cbSid As Long, ByVal DomainName As String, cbDomainName As Long, peUse As Long) As Long
Private Declare Function GetFileSecurity Lib "advapi32" Alias "GetFileSecurityA" (ByVal lpFileName As String, ByVal RequestedInformation As Long, pSecurityDescriptor As Byte, ByVal nLength As Long, pnLengthNeeded As Long) As Long
Private Declare Function SetSecurityDescriptorDacl Lib "advapi32" (pSecurityDescriptor As SECURITY_DESCRIPTOR, ByVal bDaclPresent As Long, pDacl As Byte, ByVal bDaclDefaulted As Long) As Long
Private Declare Function GetSecurityDescriptorDacl Lib "advapi32" (pSD As Any, lDaclPresent As Long, pDacl As Long, lpbDaclDefaulted As Long) As Long
Private Declare Function GetAclInformation Lib "advapi32" (ByVal pAcl As Long, pAclInformation As Any, ByVal nAclInformationLength As Long, ByVal dwAclInformationClass As Long) As Long
Private Declare Function GetLengthSid Lib "advapi32" (pSid As Any) As Long
Private Declare Function InitializeAcl Lib "advapi32" (pAcl As Byte, ByVal nAclLength As Long, ByVal dwAclRevision As Long) As Long
Private Declare Function GetAce Lib "advapi32" (ByVal pAcl As Long, ByVal dwAceIndex As Long, pace As Any) As Long
Private Declare Function AddAce Lib "advapi32" (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 AddAccessAllowedAce Lib "advapi32" (pAcl As Byte, ByVal dwAceRevision As Long, ByVal AccessMask As Long, pSid As Any) As Long
Private Declare Function EqualSid Lib "advapi32" (pSID1 As Any, ByVal pSID2 As Long) As Long
Private Declare Function InitializeSid Lib "advapi32" (ByVal Sid As Long, pIndentifierAuthority As Any, ByVal nSubAuthorityCount As Byte) As Long
Private Declare Function GetSidSubAuthority Lib "advapi32" (pSid As Any, ByVal nSubAuthority As Long) As Long
Private Declare Function GetSidLengthRequired Lib "advapi32" (ByVal nSubAuthorityCount As Byte) As Long
Private Declare Function LookupAccountSid Lib "advapi32" Alias "LookupAccountSidA" (ByVal lpSystemName As String, Sid As Any, ByVal name As String, cbName As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Integer) As Long
Private Declare Function GetSidSubAuthorityCount Lib "advapi32" (pSid As Any) As Long
Private Declare Function GetSidIdentifierAuthority Lib "advapi32" (pSid As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Sub CopyByValMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
Private Declare Sub CopyByRefMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, Source As Any, ByVal Length As Long)
Private Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function NetGetDCName Lib "NETAPI32.DLL" (ServerName As Byte, DomainName As Byte, DCNPtr As Long) As Long
Private Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyW" (RetVal As Byte, ByVal Ptr As Long) As Long
Private Declare Sub lstrcpyW Lib "kernel32" (dest As Any, ByVal src As Any)
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpszString As Any) As Long
'**********************************************************************************
' Ace Mask definitions
'The right to delete the object.
Private Const ADS_RIGHT_DELETE = &H10000
'The right to read data from the security descriptor of the object, not including the data in the SACL.
Private Const ADS_RIGHT_READ_CONTROL = &H20000
'The right to modify the discretionary access-control list (DACL) in the object security descriptor.
Private Const ADS_RIGHT_WRITE_DAC = &H40000
'The right to assume ownership of the object. The user must be an object trustee. The user cannot transfer the ownership to other users.
Private Const ADS_RIGHT_WRITE_OWNER = &H80000
'The right to use the object for synchronization. This enables a thread to wait until the object is in the signaled state.
Private Const ADS_RIGHT_SYNCHRONIZE = &H100000
'The right to get or set the SACL in the object security descriptor.
Private Const ADS_RIGHT_ACCESS_SYSTEM_SECURITY = &H1000000
'The right to read permissions on this object, read all the properties on this object, list this object name when the parent container is listed, and list the contents of this object if it is a container.
Private Const ADS_RIGHT_GENERIC_READ = &H80000000
'The right to read permissions on this object, write all the properties on this object, and perform all validated writes to this object.
Private Const ADS_RIGHT_GENERIC_WRITE = &H40000000
'The right to read permissions on, and list the contents of, a container object.
Private Const ADS_RIGHT_GENERIC_EXECUTE = &H20000000
'The right to create or delete children, delete a subtree, read and write properties, examine children and the object itself, add and remove the object from the directory, and read or write with an extended right.
Private Const ADS_RIGHT_GENERIC_ALL = &H10000000
'The right to create children of the object. The ObjectType member of an ACE can contain a GUID that identifies the type of child object whose creation is controlled. If ObjectType does not contain a GUID, the ACE controls the creation of all child object types.
Private Const ADS_RIGHT_DS_CREATE_CHILD = &H1
'The right to delete children of the object. The ObjectType member of an ACE can contain a GUID that identifies a type of child object whose deletion is controlled. If ObjectType does not contain a GUID, the ACE controls the deletion of all child object types.
Private Const ADS_RIGHT_DS_DELETE_CHILD = &H2
'The right to list children of this object.
Private Const ADS_RIGHT_ACTRL_DS_LIST = &H4
'The right to perform an operation controlled by a validated write access right. The ObjectType member of an ACE can contain a GUID that identifies the validated write. If ObjectType does not contain a GUID, the ACE controls the rights to perform all valided write operations associated with the object.
Private Const ADS_RIGHT_DS_SELF = &H8
'The right to read properties of the object. The ObjectType member of an ACE can contain a GUID that identifies a property set or property. If ObjectType does not contain a GUID, the ACE controls the right to read all of the object properties.
Private Const ADS_RIGHT_DS_READ_PROP = &H10
'The right to write properties of the object. The ObjectType member of an ACE can contain a GUID that identifies a property set or property. If ObjectType does not contain a GUID, the ACE controls the right to write all of the object properties.
Private Const ADS_RIGHT_DS_WRITE_PROP = &H20
'The right to delete all children of this object, regardless of the permissions of the children.
Private Const ADS_RIGHT_DS_DELETE_TREE = &H40
'The right to list a particular object. If the user is not granted such a right, and the user does not have ADS_RIGHT_ACTRL_DS_LIST set on the object parent, the object is hidden from the user.
Private Const ADS_RIGHT_DS_LIST_OBJECT = &H80
'The right to perform an operation controlled by an extended access right. The ObjectType member of an ACE can contain a GUID that identifies the extended right. If ObjectType does not contain a GUID, the ACE controls the right to perform all extended right operations associated with the object.
Private Const ADS_RIGHT_DS_CONTROL_ACCESS = &H100
'**********************************************************************************
' Ace Type definitions
Private Const ADS_ACETYPE_ACCESS_ALLOWED = &H0
Private Const ADS_ACETYPE_ACCESS_DENIED = &H1
Private Const ADS_ACETYPE_SYSTEM_AUDIT = &H2
Private Const ADS_ACETYPE_ACCESS_ALLOWED_OBJECT = &H5
Private Const ADS_ACETYPE_ACCESS_DENIED_OBJECT = &H6
Private Const ADS_ACETYPE_SYSTEM_AUDIT_OBJECT = &H7
'**********************************************************************************
' Ace Flag Constants
Private Const ADS_ACEFLAG_UNKNOWN = &H1
Private Const ADS_ACEFLAG_INHERIT_ACE = &H2
Private Const ADS_ACEFLAG_NO_PROPAGATE_INHERIT_ACE = &H4
Private Const ADS_ACEFLAG_INHERIT_ONLY_ACE = &H8
Private Const ADS_ACEFLAG_INHERITED_ACE = &H10
Private Const ADS_ACEFLAG_VALID_INHERIT_FLAGS = &H1F
Private Const ADS_ACEFLAG_llResultFUL_ACCESS = &H40
Private Const ADS_ACEFLAG_FAILED_ACCESS = &H80
'**********************************************************************************
'
Private Const ADS_SID_RAW = &H0
Private Const ADS_SID_HEXSTRING = &H1
Private Const ADS_SID_SAM = &H2
Private Const ADS_SID_UPN = &H3
Private Const ADS_SID_SDDL = &H4
Private Const ADS_SID_WINNT_PATH = &H5
Private Const ADS_SID_ACTIVE_DIRECTORY_PATH = &H6
Private Const ADS_SID_SID_BINDING = &H7
'Private const fldname = "C:\test2" '<----Change this to the top folder name
'Private const usrname = "Domain\User" '<---Change this to the user you want to add permissions for
'**********************************************************************************
' Net constants
Private Const umfNormalAccount = 512 'This is a default type that represents a typical user.
Private Const umfTmpDuplicateAccount = 256 'This is for users whose primary account is in another domain. This account provides access to the domain, but not to any domain that trusts this domain. The NT User Manager refers to this account type as a local user account.
Private Const umfWrkTrustAccount = 4096 'This is a computer account for a Windows NT Workstation or Windows NT Server that is a member of this domain.
Private Const umfSvrTrustAccount = 8192 'This is a computer account for a Windows NT Backup Domain Controller that is a member of this domain.
Private Const umfInterTrustAccount = 2048 'This is a permit to trust account for a Windows NT domain that trusts other domains.
'**********************************************************************************
' Structure for Getversion
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 'Maintenance string for PSS usage
End Type
'**********************************************************************************
' Net share types
Private Const STYPE_DISKTREE As Long = &H0
Private Const STYPE_PRINTQ As Long = &H1
Private Const STYPE_DEVICE As Long = &H2
Private Const STYPE_IPC As Long = &H3
Private Const STYPE_SPECIAL As Long = &H80000000
'**********************************************************************************
' Net permissions
Private Const ACCESS_READ As Long = &H1
Private Const ACCESS_WRITE As Long = &H2
Private Const ACCESS_CREATE As Long = &H4
Private Const ACCESS_EXEC As Long = &H8
Private Const ACCESS_DELETE As Long = &H10
Private Const ACCESS_ATRIB As Long = &H20
Private Const ACCESS_PERM As Long = &H40
Private Const ACCESS_CHANGE As Long = ACCESS_READ Or ACCESS_WRITE Or ACCESS_CREATE Or ACCESS_EXEC Or ACCESS_ATRIB Or ACCESS_PERM
'**********************************************************************************
' Net Return Codes
Private Const ERROR_llResult As Long = 0&
Private Const NERR_Success As Long = 0&
Private Const ERROR_ACCESS_DENIED As Long = 5&
Private Const ERROR_INVALID_LEVEL As Long = 124&
Private Const ERROR_INVALID_PARAMETER As Long = 87&
Private Const ERROR_MORE_DATA As Long = 234&
Private Const ERROR_NOT_ENOUGH_MEMORY As Long = 8&
Private Const ERROR_INVALID_NAME As Long = 123&
'**********************************************************************************
' Share Info Structure
Private Type SHARE_INFO_2
shi2_netname As Long
shi2_type As Long
shi2_remark As Long
shi2_permissions As Long
shi2_max_uses As Long
shi2_current_uses As Long
shi2_path As Long
shi2_passwd As Long
End Type
'**********************************************************************************
' Group Info Structure
Private Type GROUP_INFO_2
grpi2_name As Long
grpi2_comment As Long
grpi2_group_id As Long
grpi2_attributes As Long
End Type
'**********************************************************************************
' User Info struct
Private Type USER_INFO_0
lpstrUsri0_name As Long
End Type
Private Type USER_INFO_2
usri2_name As Long
usri2_password As Long
usri2_password_age As Long
usri2_priv As Long
usri2_home_dir As Long
usri2_comment As Long
usri2_flags As Long
usri2_script_path As Long
usri2_auth_flags As Long
usri2_full_name As Long
usri2_usr_comment As Long
usri2_parms As Long
usri2_workstations As Long
usri2_last_logon As Long
usri2_last_logoff As Long
usri2_acct_expires As Long
usri2_max_storage As Long
usri2_units_per_week As Long
usri2_logon_hours As Byte
usri2_bad_pw_count As Long
usri2_num_logons As Long
usri2_logon_server As Long
usri2_country_code As Long
usri2_code_page As Long
End Type
'**********************************************************************************
' Share Info Constants
Private Const SHGFI_ATTRIBUTES As Long = &H800
Private Const SFGAO_SHARE As Long = &H20000
Private Const MAX_PATH As Long = 260
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
'**********************************************************************************
' Net Flags
Private Const umfScript = 1 'Execute logon script. This value is set by default for Windows NT.
Private Const umfAccountDisable = 2 'The user's account is disabled.
Private Const umfPasswdNotReq = 32 'No password is required for user logon.
Private Const umfPasswdCantChange = 64 'The user cannot change the password.
Private Const umfLockout = 16 'The account is currently locked out.
Private Const umfDontExpirePasswd = 65536 'The password will never expire on this account.
'**********************************************************************************
' Return codes from my functions
Private Const USER_FOUND = &H0
Private Const GROUP_FOUND = &H0
Private Const GROUP_NOT_FOUND = &H8AC
Private Const USER_NOT_FOUND = &H8AD
'**********************************************************************************
' Memory constants used through various memory API calls.
Private Const GMEM_MOVEABLE = &H2
Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED + LMEM_ZEROINIT)
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_ALL = &H10000000
Private Const GENERIC_EXECUTE = &H20000000
Private Const GENERIC_WRITE = &H40000000
'**********************************************************************************
' The file/security API call constants
Private Const DACL_SECURITY_INFORMATION = &H4
Private Const SECURITY_DESCRIPTOR_REVISION = 1
Private Const SECURITY_DESCRIPTOR_MIN_LENGTH = 20
Private Const SD_SIZE = (65536 + SECURITY_DESCRIPTOR_MIN_LENGTH)
Private Const ACL_REVISION2 = 2
Private Const ACL_REVISION = 2
Private Const MAXDWORD = &HFFFFFFFF
Private Const SidTypeUser = 1
Private Const AclSizeInformation = 2
'**********************************************************************************
' The following are the inherit flags that go into the AceFlags field
' of an Ace header.
Private Const OBJECT_INHERIT_ACE = &H1
Private Const CONTAINER_INHERIT_ACE = &H2
Private Const NO_PROPAGATE_INHERIT_ACE = &H4
Private Const INHERIT_ONLY_ACE = &H8
Private Const INHERITED_ACE = &H10
Private Const VALID_INHERIT_FLAGS = &H1F
Private Const DELETE = &H10000
'**********************************************************************************
' Structures used by our API calls.
Private Type ACE_HEADER
AceType As Byte
AceFlags As Byte
AceSize As Integer
End Type
Private Type ACCESS_DENIED_ACE
Header As ACE_HEADER
Mask As Long
SidStart As Long
End Type
Private Type ACCESS_ALLOWED_ACE
Header As ACE_HEADER
Mask As Long
SidStart As Long
End Type
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 SECURITY_DESCRIPTOR
Revision As Byte
Sbz1 As Byte
Control As Long
Owner As Long
Group As Long
Sacl As ACL
dacl As ACL
End Type
Private Type FILE_INFO_3
fi3_id As Long
fi3_permissions As Long
fi3_num_locks As Long
fi3_pathname As String
fi3_username As String
End Type
'**********************************************************************************
'return codes
Private Const RESULT_OK = 1
Private Const RESULT_WARNING = 2
Private Const RESULT_ERROR = 4
'**********************************************************************************
' share members
'**********************************************************************************
Private dwServer As Long
Private dwNetname As Long
Private dwPath As Long
Private dwRemark As Long
Private dwPw As Long
Private parmerr As Long
Private dwShareInfo2 As Long
Private dwGroupInfo2 As Long
Private dwUserInfo0 As Long
Private si2 As SHARE_INFO_2
Private gi2 As GROUP_INFO_2
Private ui0 As USER_INFO_0
Private ui2 As USER_INFO_2
Private resultStatus As Long
Private um As New NTUserX.UserManager
Private lgm As NTUserX.LocalGroupMgr
Private lgo As NTUserX.LocalGroupObj
Private uo As NTUserX.UserObj
'**********************************************************************************
' security members
'**********************************************************************************
Private sd As New SecurityDescriptor
Private newSd As New SecurityDescriptor
Private dacl As New AccessControlList
Private newDacl As New AccessControlList
Private aceUser As New AccessControlEntry
Private ace As AccessControlEntry
Private ads As New ADsSecurity
Private adsErr As New ADsError
Private fso As New FileSystemObject
Private strDebug As String
Private sDisplayText As String
Private lResult As Long
Private sSid As String
Private sAdminSid As String
Private sAgentSid As String
Private fnError As String
Private i As Integer
'**********************************************************************************
' Public Methods
'**********************************************************************************
Public Function AddUser(ByVal sServer As String, _
ByVal sSharePath As String, _
ByVal sShareName As String, _
ByVal userId As String, _
ByRef fnError As String) As Long
'userid in just a string
'server is in the format \\server
'sSharePath is in the format C:\folders\userId
'sShareName is in the format \folder1\folder2'see return codes above for return values
On Error GoTo ErrorHandler
'create customer folder
lResult = CreateFolder(sServer, sShareName, userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'add the shared folder
lResult = ShareAdd(sServer, sSharePath, userId, vbNullString, "gmd-" & userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'create the user
lResult = CreateLocalUser(sServer, sShareName, userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'add user to Users group
lResult = AddUserToGroup(sServer, "Users", userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'add user to GMDCustomers group
lResult = AddUserToGroup(sServer, "GMDCustomers", userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
'add the user to the folder and delete an extraneous users
lResult = AddUserToFolder(sServer, sShareName, userId, fnError)
If lResult = RESULT_ERROR Then GoTo Done
fnError = "User added successfully!"
lResult = RESULT_OK
Done:
On Error Resume Next
AddUser = lResult
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: AddUser", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
'**********************************************************************************
' Private Methods
'**********************************************************************************
'**********************************************************************************
' Security Methods
'**********************************************************************************
Private Function AddUserToFolder(ByVal sServer As String, ByVal sRootPath As String, ByVal sUserId As String, ByRef fnError As String) As Integer
'sServer is in the format of \\server
'sRootPath is in the format \folder\folder'sUserId is the ANSII string of the user name
'fnError is the error string that is filled in and 'returned'
On Error GoTo ErrorHandler
AddUserToFolder = RESULT_OK
'use FSO for better errors if the folder can't be accessed
Dim fs As Folder
Set fs = fso.GetFolder(sServer & sRootPath & sUserId)
'get File System Security Descriptor from FSO
Set sd = ads.GetSecurityDescriptor("FILE://" & fs.Path)
'get the discretionary ACL from the file's Security Descriptor
Set dacl = sd.DiscretionaryAcl
sSid = LocalConvertBINToSDDL(sServer, sUserId)
sAdminSid = LocalConvertBINToSDDL(sServer, "Administrator"
'delete unwanted ace's from the folder rights
If DeleteAces(dacl, sSid, fnError) <> RESULT_OK Then GoTo Done
Select Case sSid
Case "S-0-0", ""
AddUserToFolder = RESULT_ERROR
fnError = "AddUserToFolder: Could not get " & sUserId & "'s SID: - '" & sSid & "'"
Call CleanUpAds
GoTo Done
End Select
'create new ACE to add to the DACL
With aceUser
.AccessMask = ADS_RIGHT_GENERIC_READ Or _
ADS_RIGHT_GENERIC_WRITE Or _
ADS_RIGHT_SYNCHRONIZE Or _
ADS_RIGHT_GENERIC_EXECUTE Or _
ADS_RIGHT_DS_CREATE_CHILD Or _
ADS_RIGHT_ACTRL_DS_LIST Or _
ADS_RIGHT_DS_READ_PROP Or _
ADS_RIGHT_DS_WRITE_PROP Or _
ADS_RIGHT_DS_LIST_OBJECT Or _
ADS_RIGHT_DS_CONTROL_ACCESS Or _
ADS_RIGHT_DS_SELF Or _
ADS_RIGHT_DELETE
.AceType = ADS_ACETYPE_ACCESS_ALLOWED
.AceFlags = ADS_ACEFLAG_INHERIT_ACE
.Trustee = sSid
End With
'check to see if user already exists in the security settings for the folder
For Each ace In dacl
If ace.Trustee = sSid Then
fnError = "AddUserToFolder: " & sUserId & " already exists in " & sServer & sRootPath & "!"
AddUserToFolder = RESULT_WARNING
GoTo Done
End If
Next
'add the ACE to the DACL
dacl.AddAce aceUser
'reorder and set revision on the new DACL
Set dacl = ReOrderDacl(dacl)
'Call DisplayAllAceInfo(dacl)
'set the Security Descriptor's DACL to the modified DACL
sd.DiscretionaryAcl = dacl
'set the file's Security Descriptor to the modified SD
ads.SetSecurityDescriptor sd, "FILE://" & fs.Path
'if we got this far with no errors, success
AddUserToFolder = RESULT_OK
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
fnError = "AddUserToFolder: " & Err.Number & ": " & Err.Description
AddUserToFolder = RESULT_ERROR
If blnDoFatalError(Err.Number, _
"clsUserManager: AddUserToFolder", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
Private Function DeleteAces(ByVal oDacl As AccessControlList, ByVal sSid As String, ByRef fnError As String) As Integer
'oDacl is the discretionary access control list of a Security Descriptor
'sSid must be in SDDL format
'fnError is the error string that is filled in and 'returned'
On Error GoTo ErrorHandler
For Each ace In oDacl
Select Case ace.Trustee
Case sSid, sAdminSid ', sAgentSid
Case Else
oDacl.RemoveAce ace
End Select
Next
DeleteAces = RESULT_OK
Done:
On Error Resume Next
Exit Function
ErrorHandler:
DeleteAces = RESULT_ERROR
fnError = "DeleteAces: " & Err.Number & ": " & Err.Description
If blnDoFatalError(Err.Number, _
"clsUserManager: DeleteAces", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
Private Function ReOrderDacl(ByVal oDacl As AccessControlList) As AccessControlList
On Error GoTo ErrorHandler
' Initialize all of the new ACLs
Dim newDacl As New AccessControlList
Dim ImpDenyDacl As New AccessControlList
Dim InheritedDacl As New AccessControlList
Dim ImpAllowDacl As New AccessControlList
Dim InhAllowDacl As New AccessControlList
Dim ImpDenyObjectDacl As New AccessControlList
Dim impAllowObjectDacl As New AccessControlList
For Each ace In oDacl
' Sort the original ACEs into their appropriate ACLs
If ((ace.AceFlags And ADS_ACEFLAG_INHERITED_ACE) = ADS_ACEFLAG_INHERITED_ACE) Then
' Don't really care about the order of inherited aces. Since we are
' adding them to the top of a new list, when they are added back
' to the Dacl for the object, they will be in the same order as
' they were originally. Just a positive side affect of adding items
' of a LIFO ( Last In First Out) type list.
InheritedDacl.AddAce ace
Else
' We have an Implicit ACE, lets put it the proper pool
Select Case ace.AceType
Case ADS_ACETYPE_ACCESS_ALLOWED
' We have an implicit allow ace
ImpAllowDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_DENIED
' We have a implicit Deny ACE
ImpDenyDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_ALLOWED_OBJECT
' We have an object allowed ace
' Does it apply to a property? or an Object?
impAllowObjectDacl.AddAce ace
Case ADS_ACETYPE_ACCESS_DENIED_OBJECT
' We have a object Deny ace
ImpDenyObjectDacl.AddAce ace
End Select
End If
Next
For Each ace In ImpDenyDacl
newDacl.AddAce ace
Next
' Implicit Deny Object
For Each ace In ImpDenyObjectDacl
newDacl.AddAce ace
Next
' Implicit Allow
For Each ace In ImpAllowDacl
newDacl.AddAce ace
Next
' Implicit Allow Object
For Each ace In impAllowObjectDacl
newDacl.AddAce ace
Next
' Inherited Aces
For Each ace In InheritedDacl
newDacl.AddAce ace
Next
' Set the appropriate revision level for the DACL
newDacl.AclRevision = dacl.AclRevision
' Replace the Security Descriptor
Set ReOrderDacl = newDacl
Done:
On Error Resume Next
' Clean up
Set ImpDenyDacl = Nothing
Set InheritedDacl = Nothing
Set ImpAllowDacl = Nothing
Set InhAllowDacl = Nothing
Set ImpDenyObjectDacl = Nothing
Set impAllowObjectDacl = Nothing
Set oDacl = Nothing
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: ReOrderDacl", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
' LocalConvertBINToSDDL takes two arguments: strNTDomain-> Netbios name for the NT machine to
' Request account information from
' strNTAccount-> The NT SAM account name for the user
' The function returns the SDDL form of the user's SID
Private Function LocalConvertBINToSDDL(ByVal strNTDomain As String, ByVal strNTAccount As String) As String
On Error GoTo ErrorHandler
Dim SDDL_SID As String
Dim pSia As Long
Dim pSiaByte(5) As Byte
Dim pSid() As Byte
Dim pSubAuthorityCount As Long
Dim bSubAuthorityCount As Byte
Dim pAuthority As Long
Dim lAuthority As Long
Dim dAuthority As Double
Dim pDomain As Long
Dim lReturn As Long
Dim AuthCount As Integer
Dim i As Integer
Dim uniUser As String
Dim strDomain As String
' Get the SID for the user's account, targetting a local PDC
lReturn = GetUserSID(strNTAccount, "", strNTDomain, pSid)
If lReturn = 0 Then GoTo Done
' Convert the raw sid into its SDDL form ( S-?-?-???-?????? )
' The first item in the S- format is the revision level. If we look closely at the
' SID structure in the WinNT.H C Header, we find that the revision value for the SID is
' stored in the 0th byte to the raw sid.
'
' Another interesting fact is that the last byte of the Identifying authority structure contains
' the second component of the SDDL form, so lets retrieve both of those and
' place them into the string.
pSia = GetSidIdentifierAuthority(pSid(0))
'
' The GetSidIdentifierAuthority returns a pointer to the Identifying Authority structure
' The pointer must be copied into some memory that VB knows how to manage, so....
CopyByValMemory pSiaByte(0), pSia, 6
SDDL_SID = "S-" + LTrim(Str(pSid(0))) + "-" + LTrim(Str(pSiaByte(5)))
'
' The rest of the SDDL form contains a list of sub authorities separated by
' "-"s. The total number of these authorities can be obtained by
' calling the GetSidSubAuthorityCount. The value returned is a pointer into the
' SID memory that contains the Sub Authority value, once again, this memory
' must be copied into something that VB knows how to manage.
'
' Notice that only 1 byte is copied. This is because the sub authority count
' is stored in a single byte ( see the SID srtructure definition above )
pSubAuthorityCount = GetSidSubAuthorityCount(pSid(0))
CopyByValMemory bSubAuthorityCount, pSubAuthorityCount, 1
'
' We can loop throught the sub authorities and convert
' their DWORD values to VB longs, then convert them to a
' string.
' The count is 0 based, so we start a 0 and goto the
' number of sub authorities - 1
For AuthCount = 0 To bSubAuthorityCount - 1
pAuthority = GetSidSubAuthority(pSid(0), AuthCount)
CopyByValMemory lAuthority, pAuthority, LenB(lAuthority)
'
' VB does not have an unsigned type, the sub authority value
' could have the most significant bit set. If it is set,
' the Str function will return a negative number. Therefore
' we must account for this case by converting the value to
' a double then to its string form
'
' Step 1: Test the bit if set, Do step 2 and 3 else put
' the value in the output string.
' Step 2: 1 is true, so, AND off all the bits save the most
' significant bit, place in a temp double variable
' Step 3: Add the most significant bit to the double variable ( 2^31)
' Output the string
'
' Step 1:
'
dAuthority = lAuthority
If ((lAuthority And &H80000000) <> 0) Then
'
' Bit is set, Step 2:
dAuthority = lAuthority & &H7FFFFFFF
'
' Step 3:
dAuthority = dAuthority + 2 ^ 31
End If
SDDL_SID = SDDL_SID + "-" + LTrim(Str(dAuthority))
Next AuthCount
'
' We are done, the SDDL_SID variable contains the SID in
' SDDL form,
' Return it...
LocalConvertBINToSDDL = SDDL_SID
Done:
On Error Resume Next
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: LocalConvertBINToSDDL", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Function
Private Function GetUserSID(ByRef sAccountName As String, _
ByRef sDomainName As String, _
ByVal sSystemName As String, _
ByRef bSID() As Byte) As Boolean
On Error GoTo ErrorHandler
Dim llResult As Long
Dim cbSid As Long
Dim cbDomainName As Long
Dim peUse As Long
sDomainName = vbNullString
cbDomainName = 0
If Len(sSystemName) = 0 Then
'If the system name (machine name)
'not specified, pass a null string
'to have the account lookup on
'the local machine
sSystemName = vbNullString
End If
'First call passes null as the SID.
'The call returns a success of 0 and
'the required buffer size in cbSid.
'In addition, because sDomainName is
'passed as null, cbDomainName returns
'the required buffer size for the lookup
'domain.
llResult = LookupAccountName(sSystemName, _
sAccountName, _
0&, _
cbSid, _
sDomainName, _
cbDomainName, _
peUse)
'prevent errors
If (llResult = 0) And (cbSid > 0) Then
'Prepare a buffer into which
'the domain where the account
'name is found will be returned
sDomainName = Space$(cbDomainName)
'create a buffer for the SID and
'call again.
ReDim bSID(0 To cbSid - 1)
'The function attempts to find a SID
'for the specified name by first
'checking a list of well-known SIDs.
'If the name does not correspond to a
'well-known SID, the function checks
'built-in and administratively-defined
'local accounts. Next, the function
'checks the primary domain. If the name
'is not found there, trusted domains
'are checked.
'On Windows 2000/XP, in addition to
'lookup local accounts, local domain
'accounts, and explicitly trusted
'domain accounts, LookupAccountName
'can look up the name for any account
'in any domain in the Windows 2000 forest.
'
'The further 'out' the search has to go,
'the longer it will take to return.
'
'peUse returns a pointer to a SID_NAME_USE
'enumerated type indicating the type of
'the account when the function returns.
llResult = LookupAccountName(sSystemName, _
sAccountName, _
bSID(0), _
cbSid, _
sDomainName, _
cbDomainName, _
peUse)
If llResult <> 0 Then
'obtain the domain name
'returned
If cbDomainName > 0 Then
sDomainName = Left$(sDomainName, cbDomainName)
End If
End If
End If
'the call succeeded if llResult is not 0
GetUserSID = llResult
Done:
On Error Resume Next
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: GetUserSID", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Function
Private Sub DisplayAllAceInfo(ByVal dacl As AccessControlList)
On Error GoTo ErrorHandler
Dim sAce As String
sAce = ""
'display all info for all aces in a dacl
For Each ace In dacl
sAce = sAce & "Trustee: " & ace.Trustee & vbCrLf
sAce = sAce & "Mask: " & ace.AccessMask & vbCrLf
sAce = sAce & "AceFlags: " & ace.AceFlags & vbCrLf
sAce = sAce & "Type: " & ace.AceType & vbCrLf
sAce = sAce & "Flags: " & ace.Flags & vbCrLf
sAce = sAce & "Inherited Object Type: " & ace.InheritedObjectType & vbCrLf
sAce = sAce & "Object Type: " & ace.ObjectType & vbCrLf
sAce = sAce & "====================================================" & vbCrLf
Next
MsgBox sAce
Done:
On Error Resume Next
Exit Sub
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: DisplayAllAceInfo", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Sub
Private Sub DisplayDaclForFolder(ByVal sServer As String, ByVal sFolder As String)
On Error GoTo ErrorHandler
Dim um As New UserManager
Dim lgm As LocalGroupMgr
Dim uo As UserObj
Dim fs As Folder
um.Server = "GMDADEVTEST"
Set lgm = um.GetLocalGroupManager
sDisplayText = "Local Users" & vbCrLf & vbCrLf
For Each uo In um
sDisplayText = sDisplayText & "Name: " & uo.name & vbCrLf
Next
sDisplayText = sDisplayText & "--------------------------" & vbCrLf
'**********************************************************************************
'use FSO for better errors if the folder can't be accessed
Set fs = fso.GetFolder(sFolder)
'get File System Security Descriptor from FSO
Set sd = ads.GetSecurityDescriptor("FILE://" & fs)
'get the discretionary ACL from the file's Security Descriptor
Set dacl = sd.DiscretionaryAcl
sDisplayText = sDisplayText & "Aces for " & sFolder & ":" & vbCrLf & vbCrLf
For Each ace In dacl
sDisplayText = sDisplayText & "Trustee: " & ace.Trustee & " - "
sDisplayText = sDisplayText & "Ace Type: "
Select Case ace.AceType
Case ADS_ACETYPE_ACCESS_ALLOWED
' We have an implicit allow ace
sDisplayText = sDisplayText & "ACCESS_ALLOWED" & vbCrLf
Case ADS_ACETYPE_ACCESS_DENIED
' We have a implicit Deny ACE
sDisplayText = sDisplayText & "ACCESS_DENIED" & vbCrLf
Case ADS_ACETYPE_ACCESS_ALLOWED_OBJECT
' We have an object allowed ace
' Does it apply to a property? or an Object?
sDisplayText = sDisplayText & "ACCESS_ALLOWED_OBJECT" & vbCrLf
Case ADS_ACETYPE_ACCESS_DENIED_OBJECT
' We have a object Deny ace
sDisplayText = sDisplayText & "ACCESS_DENIED_OBJECT" & vbCrLf
Case Default
' This has to be some kind of mistake
sDisplayText = sDisplayText & "ACCESS_UNKOWN!" & vbCrLf
End Select
Next
MsgBox sDisplayText
Done:
On Error Resume Next
Set fs = Nothing
Set sd = Nothing
Set um = Nothing
Set lgm = Nothing
Set uo = Nothing
Call CleanUpAll
Exit Sub
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: DisplayDaclForFolder", _
True, _
999, _
False, _
"No information to display - " & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Sub
'**********************************************************************************
' Share Methods
'**********************************************************************************
Private Function ShareDelete(ByVal sServerName As String, ByVal sNetName As String)
On Error GoTo ErrorHandler
um.Server = sServerName
Set lgm = um.GetLocalGroupManager
Set lgo = lgm(sNetName)
lgm.Remove (lgo.name)
ShareDelete = GROUP_FOUND
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: ShareDelete", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Call CleanUpAds
Resume Done
End Function
Private Function ShareAdd(ByVal sServer As String, _
ByVal sSharePath As String, _
ByVal sShareName As String, _
ByVal sShareRemark As String, _
ByVal sSharePw As String, _
fnError As String) As Long
On Error GoTo ErrorHandler
'obtain pointers to the server, share and path
dwServer = StrPtr(sServer)
dwNetname = StrPtr(sShareName)
dwPath = StrPtr(sSharePath)
'if the remark or password specified, obtain pointer to those as well
If Len(sShareRemark) > 0 Then dwRemark = StrPtr(sShareRemark)
If Len(sSharePw) > 0 Then dwPw = StrPtr(sSharePw)
'prepare the SHARE_INFO_2 structure
With si2
.shi2_netname = dwNetname
.shi2_path = dwPath
.shi2_remark = dwRemark
.shi2_type = STYPE_DISKTREE
.shi2_permissions = ACCESS_CHANGE
.shi2_max_uses = -1
.shi2_passwd = dwPw
End With
'add the share
lResult = NetShareAdd(dwServer, 2, si2, parmerr)
'check share results and output
If lResult = NERR_Success Then
ShareAdd = RESULT_OK
Else
fnError = "Share Folder: " & fnError & NetReturnError(lResult)
ShareAdd = RESULT_ERROR
End If
Done:
On Error Resume Next
Exit Function
ErrorHandler:
ShareAdd = RESULT_ERROR
If blnDoFatalError(Err.Number, _
"clsUserManager: ShareAdd", _
True, _
999, _
False, _
"" & fnError) _
= True Then Resume
Resume Done
End Function
'**********************************************************************************
' Folder Methods
'**********************************************************************************
Private Function CreateFolder(ByVal sServer As String, _
ByVal sRootFolder As String, _
ByVal userId As String, _
ByRef fnError As String) As Long
On Error GoTo ErrorHandler
Dim fsoUserFolder As New FileSystemObject
If fsoUserFolder.FolderExists(sServer & sRootFolder & userId) Then
CreateFolder = RESULT_WARNING
Else
fsoUserFolder.CreateFolder (sServer & sRootFolder & userId)
CreateFolder = RESULT_OK
End If
Done:
On Error Resume Next
Set fsoUserFolder = Nothing
Exit Function
ErrorHandler:
fnError = "CreateFolder: " & Err.Number & ": " & Err.Description
If blnDoFatalError(Err.Number, _
"clsUserManager: CreateFolder", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
fnError = "CreateFolder:" & Err.Number & ": " & Err.Description
Resume Done
End Function
'**********************************************************************************
' User/Group Methods
'**********************************************************************************
Private Function CreateLocalUser(ByVal sServer As String, _
ByVal sRootFolder As String, _
ByVal userId As String, _
ByRef fnError As String) As Long
On Error GoTo ErrorHandler
Dim strPwd As String
Dim strDescription As String
Dim strScriptPath As String
Dim lFlags As Long
Dim groupNum As Integer
'build the password
strPwd = "gmd-" & userId
'build the account description
strDescription = "Local account for " & userId
'build the user's script path
strScriptPath = ""
'build the flags for this account
lFlags = umfDontExpirePasswd
lResult = CheckForUser(sServer, userId)
Select Case lResult
Case USER_NOT_FOUND
'set the server
um.Server = sServer
'create new user to add to the local group
Set uo = um.AddUser(userId, _
strDescription, _
strPwd, _
sRootFolder, _
strScriptPath, _
lFlags)
CreateLocalUser = RESULT_OK
Case USER_FOUND
um.Server = sServer
'get a reference to the user
'Set uoAccount = um(userId)
For i = 1 To um.Count
Set uo = um(i)
If uo.name = userId Then
Set uo = um(i)
Exit For
End If
Next
fnError = "CreateLocalUser: " & userId & " already exists!"
CreateLocalUser = RESULT_WARNING
Case GROUP_NOT_FOUND
fnError = "CreateLocalUser: Group not found!"
CreateLocalUser = RESULT_ERROR
Case Else
fnError = "CreateLocalUser: Unknown error!"
CreateLocalUser = RESULT_ERROR
End Select
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
Select Case Err.Number
Case -2147221400
fnError = "CreateLocalUser: Could not get a reference to the current user who already exists!"
Case Else
fnError = "CreateLocalUser: " & Err.Number & ": " & Err.Description
End Select
If blnDoFatalError(Err.Number, _
"clsUserManager: CreateLocalUser", _
True, _
999, _
False, _
fnError) _
= True Then Resume
Resume Done
End Function
Private Function AddUserToGroup(sServer As String, _
sGroupId As String, _
sUserId As String, _
fnError As String) As Long
On Error GoTo ErrorHandler
um.Server = sServer
'get a local group mngr
Set lgm = um.GetLocalGroupManager
'set the local group object to the group in question
Set lgo = lgm(sGroupId)
'add the user to the group
lgo.Add um(sUserId)
AddUserToGroup = RESULT_OK
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
Select Case Err.Number
Case -2147023518
fnError = "AddUserToGroup: " & sUserId & " already belongs to the " & sGroupId & " group!"
AddUserToGroup = RESULT_WARNING
Resume Done
Case -2147221400
fnError = "AddUserToGroup: " & sGroupId & " group does not exist!"
AddUserToGroup = RESULT_ERROR
Case Else
fnError = "AddUserToGroup: Add " & sUserId & " to " & sGroupId & ": Error: " & Err.Number & " Description: " & Err.Description
AddUserToGroup = RESULT_ERROR
End Select
If blnDoFatalError(Err.Number, _
"clsUserManager: CreateLocalUser", _
True, _
999, _
False, _
fnError) _
= True Then Resume
Resume Done
End Function
Private Function CheckForUser(ByVal sServerName As String, ByVal sUserName As String) As Long
On Error GoTo ErrorHandler
'obtain pointers to the server and share
dwServer = StrPtr(sServerName)
dwNetname = StrPtr(sUserName)
CheckForUser = NetUserGetInfo(dwServer, dwNetname, 0, ui2)
Call NetApiBufferFree(dwUserInfo0)
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: CheckForUser", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
Private Function CheckForGroup(ByVal sServerName As String, ByVal sNetName As String) As Long
On Error GoTo ErrorHandler
um.Server = sServerName
Set lgm = um.GetLocalGroupManager
'default to not found
CheckForGroup = GROUP_NOT_FOUND
For Each lgo In lgm
If lgo.name = sNetName Then CheckForGroup = GROUP_FOUND
Next
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: CheckForGroup", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
Public Function CheckForUserInGroup(ByVal strServer As String, ByVal strGroup As String, ByVal strUser As String) As Integer
On Error GoTo ErrorHandler
Dim i As Integer
um.Server = strServer
Set lgm = um.GetLocalGroupManager
'default to not found
CheckForUserInGroup = USER_NOT_FOUND Or GROUP_NOT_FOUND
'search the local user group mngr for the specific group
For Each lgo In lgm
'if the group is found, search for the specific user
If lgo.name = strGroup Then
For i = 0 To lgo.Count
If lgo.Count = 0 Then
CheckForUserInGroup = USER_NOT_FOUND
Exit For
End If
Set uo = lgo(i)
If uo.name = strUser Then
CheckForUserInGroup = USER_FOUND
Exit For
End If
Next
Else
CheckForUserInGroup = GROUP_NOT_FOUND
End If
If CheckForUserInGroup = USER_FOUND Then Exit For
Next
Done:
On Error Resume Next
Call CleanUpAll
Set um = Nothing
Set lgm = Nothing
Set lgo = Nothing
Set uo = Nothing
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: CheckForUserInGroup", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
'**********************************************************************************
' Utility Methods
'**********************************************************************************
Private Function QualifyServer(ByVal sServer As String) As String
'see if there are already two slashes preceding the server name
If Left(sServer, 2) = "\\" Then
'there are, so the server is already qualified; 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
End If
End Function
Private Function NetReturnError(ByVal Reply As Long) As String
'THIS FUNCTION IS A GENERIC FUNCTION TO RETURN WIN 32 NET API ERROR CODES FOR MOST THINGS
Dim e As String
If Reply = 0 Then
NetReturnError = ""
Exit Function
End If
NetReturnError = True
Select Case Reply
Case 5, 65
e = "you had insufficient privileges to perform this action."
Case 50
e = "a network request was not supported."
Case 53
e = "a network path was not found."
Case 86
e = "an insufficient old password was used." + Chr(13) + _
"More than 2 more failed attempts to change password will cause an" + Chr(13) + _
"account lockout for 5 minutes."
Case 87
e = "an invalid parameter was specified."
Case 123
e = "a filename, directory name, or volume label syntax is incorrect."
Case 124
e = "an invalid parameter was attempted to be passed and failed."
Case 234, 2123
e = "too little memory was allocated to perform the action and failed."
Case 2102
e = "a device driver was not installed to conduct the action."
Case 2106
e = "an action was attempted that can take place only from an NT Server."
Case 2118
e = "the name has already been shared."
Case 2138
e = "NT Workstation services have not been started."
Case 2141
e = "either the NT Server is not configured for this transaction or IPC is not shared."
Case 2202
e = "an invalid NT user name was specified."
Case 2220
e = "the NT group name does not exist."
Case 2221
e = "the NT user name was not found."
Case 2223
e = "the NT group name already exists."
Case 2224
e = "the NT user name already exists."
Case 2226
e = "the specified NT Server is not the Primary Domain Controller."
Case 2227
e = "the NT Server is not running in user-level security."
Case 2228
e = "the accounts database became full."
Case 2229
e = "an unknown error (code 2229) occurred in accessing the NT accounts database."
Case 2245
e = "the password is too short."
Case 2247
e = "the NT accounts database file is corrupted."
Case 2351
e = "an invalid NT computer name was specified."
Case 2456
e = "the NT user accounts database cannot be enlarged because the NT Server's hard disk is full."
Case 2310
e = "the shared resource does not exist."
Case Else
e = "an error code of " + Str(Reply) + " was generated."
End Select
NetReturnError = e
End Function
Private Sub CleanUpAll()
On Error Resume Next
Set um = Nothing
Set lgm = Nothing
Set lgo = Nothing
Set uo = Nothing
Set sd = Nothing
Set newSd = Nothing
Set dacl = Nothing
Set newDacl = Nothing
Set aceUser = Nothing
Set ace = Nothing
Set ads = Nothing
Set adsErr = Nothing
Set fso = Nothing
End Sub
Private Sub CleanUpAds()
On Error Resume Next
Set ads = Nothing
Set sd = Nothing
Set dacl = Nothing
Set aceUser = Nothing
Set fso = Nothing
Set newDacl = Nothing
Set newSd = Nothing
Set adsErr = Nothing
End Sub
Private Sub Class_Terminate()
Call CleanUpAll
End Sub
Private Function UtoA(pUNIstring As Long) As String
On Error GoTo ErrorHandler
Dim wrkByte() As Byte
Dim wrkStr As String
' Get space for string each character is two bytes
' and a null terminator.
'
ReDim wrkByte(lstrlenW(pUNIstring) * 2 + 2)
' Copy the string to a byte array
Call lstrcpyW(wrkByte(0), pUNIstring)
' Covert the string from a UNI string to a ASCII string.
' this happens automatically when a byte array is copied
' to a string.
wrkStr = wrkByte
' return everything upto the the null terminator.
'
UtoA = Left(wrkStr, InStr(wrkStr, Chr(0)) - 1)
Done:
On Error Resume Next
Call CleanUpAll
Exit Function
ErrorHandler:
If blnDoFatalError(Err.Number, _
"clsUserManager: UtoA", _
True, _
999, _
False, _
"" & Err.Description) _
= True Then Resume
Resume Done
End Function
- Status
Similar threads
