Option Explicit

' Speicherkonstanten für den aufruf einiger API Funktionen
Const GMEM_MOVEABLE = &H2
Const LMEM_FIXED = &H0
Const LMEM_ZEROINIT = &H40
Const LPTR = (LMEM_FIXED + LMEM_ZEROINIT)
Const GENERIC_READ = &H80000000
Const GENERIC_ALL = &H10000000
Const GENERIC_EXECUTE = &H20000000
Const GENERIC_WRITE = &H40000000

'Datei / Sicherheits - Konstanten für API Funktonen
Const DACL_SECURITY_INFORMATION = &H4
Const SECURITY_DESCRIPTOR_REVISION = 1
Const SECURITY_DESCRIPTOR_MIN_LENGTH = 20
Const SD_SIZE = (65536 + SECURITY_DESCRIPTOR_MIN_LENGTH)
Const ACL_REVISION2 = 2
Const ACL_REVISION = 2
Const MAXDWORD = &HFFFFFFFF
Const SidTypeUser = 1
Const AclSizeInformation = 2

Const OBJECT_INHERIT_ACE = &H1
Const CONTAINER_INHERIT_ACE = &H2
Const NO_PROPAGATE_INHERIT_ACE = &H4
Const INHERIT_ONLY_ACE = &H8
Const INHERITED_ACE = &H10
Const VALID_INHERIT_FLAGS = &H1F
Const DELETE = &H10000

' Stukturen die für die API Funktionen benötigt werden
Type ACE_HEADER
   AceType As Byte
   AceFlags As Byte
   AceSize As Integer
End Type

Public Type ACCESS_DENIED_ACE
  Header As ACE_HEADER
  Mask As Long
  SidStart As Long
End Type

Type ACCESS_ALLOWED_ACE
   Header As ACE_HEADER
   Mask As Long
   SidStart As Long
End Type

Type ACL
   AclRevision As Byte
   Sbz1 As Byte
   AclSize As Integer
   AceCount As Integer
   Sbz2 As Integer
End Type

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

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 Declare Function GetComputerName Lib "kernel32" Alias _
   "GetComputerNameA" (ByVal lpBuffer As String, _
   nSize As Long) As Long

Private Declare Function GetUserName Lib "advapi32.dll" Alias _
   "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

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

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

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

Private Declare Function GetFileSecurityN Lib "advapi32.dll" Alias _
   "GetFileSecurityA" (ByVal lpFileName As String, _
   ByVal RequestedInformation As Long, _
   ByVal pSecurityDescriptor As Long, ByVal nLength As Long, _
   lpnLengthNeeded As Long) As Long

Private Declare Function GetFileSecurity Lib "advapi32.dll" Alias _
   "GetFileSecurityA" (ByVal lpFileName As String, _
   ByVal RequestedInformation As Long, _
   pSecurityDescriptor As Byte, ByVal nLength As Long, _
   lpnLengthNeeded As Long) As Long

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

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

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

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

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

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

Private Declare Function AddAccessAllowedAce Lib "advapi32.dll" _
   (pAcl As Byte, ByVal dwAceRevision As Long, _
   ByVal AccessMask As Long, pSid As Byte) As Long

Private Declare Function AddAccessDeniedAce Lib "advapi32.dll" _
  (pAcl As Byte, ByVal dwAceRevision As Long, _
   ByVal AccessMask As Long, pSid As Byte) As Long

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

Private Declare Function SetFileSecurity Lib "advapi32.dll" Alias _
   "SetFileSecurityA" (ByVal lpFileName As String, _
   ByVal SecurityInformation As Long, _
   pSecurityDescriptor As SECURITY_DESCRIPTOR) As Long

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

Private mvarFErr As String

Private Sub SetAccess(sUserName As String, sFileName As String, lMask As Long)
   Dim lResult As Long             ' Resultat der verschiedenen API-Aufrufe.
   Dim I As Integer                ' Allgem. Zaehler
   Dim bUserSid(255) As Byte      ' enthält die SID.
   Dim bTempSid(255) As Byte      ' enthält die  Sid für jeden ACE in der ACL .
   Dim sSystemName As String      ' Name des Computersystems

   Dim lSystemNameLength As Long  'Länge des Strings, welcher den Computernamen enthält

   Dim lLengthUserName As Long    ' Maximale Länge des Benutzernamen
  
   Dim lUserSID As Long           ' SID des Benutzers

   Dim lTempSid As Long            'SID für jeden ACE in der ACL
   Dim lUserSIDSize As Long          ' Grösse der SID.
   Dim sDomainName As String * 255   ' DomainName
   Dim lDomainNameLength As Long     ' Länge des Domainnames

   Dim lSIDType As Long             'Typ der SID

   Dim sFileSD As SECURITY_DESCRIPTOR   ' SD der Datei

   Dim bSDBuf() As Byte          Puffer für die SD für eine Datei

   Dim lFileSDSize As Long           ' Grösse der Datei SD
   Dim lSizeNeeded As Long           ' Benötigte Grösse der Datei SD

   Dim sNewSD As SECURITY_DESCRIPTOR ' Neuer security descriptor.

   'Wird verwendet, wenn das DACL von der Datei Sd geöffnet wird.
   Dim sACL As ACL                
   Dim lDaclPresent As Long         
   Dim lDaclDefaulted As Long      

   Dim sACLInfo As ACL_SIZE_INFORMATION    'Wird verwendet, wenn das ACL von der Datei Sd geöffnet wird.

   Dim lACLSize As Long           ' Größe der ACL-Struktur

   Dim pAcl As Long               '  ACL der Datei
   Dim lNewACLSize As Long        ' Grösse der neuen ACL welche erzeugt wurde
   Dim bNewACL() As Byte          ' Puffer der neuen ACL.

   Dim sCurrentACE As ACCESS_ALLOWED_ACE    ' Aktuelle ACE.
   Dim pCurrentAce As Long              

   Dim nRecordNumber As Long

   lResult = LookupAccountName(vbNullString, sUserName, _
      bUserSid(0), 255, sDomainName, lDomainNameLength, _
      lSIDType)

     If (lResult = 0) Then
        FErr = "Error: Unable to Lookup the Current User Account: " _
           & sUserName
        Exit Sub
     End If

   If (lResult = 0) Then
       FErr = "Error: Unable to Get the File Security Descriptor"
      Exit Sub
   End If

         If (lResult = 0) Then
             FErr = "Error: Unable to Add ACL to DACL"
            Exit Sub
         End If

         If GetAttr(sFileName) And vbDirectory Then
            
      
            lResult = GetAce(VarPtr(bNewACL(0)), nRecordNumber, pCurrentAce)
           
            If (lResult = 0) Then
                FErr = "Error: Unable to Obtain ACE (" & I & ")"
               Exit Sub
            End If

            CopyMemory sCurrentACE, pCurrentAce, LenB(sCurrentACE)
            sCurrentACE.Header.AceFlags = OBJECT_INHERIT_ACE + INHERIT_ONLY_ACE
            CopyMemory ByVal pCurrentAce, VarPtr(sCurrentACE), LenB(sCurrentACE)

         If (lResult = 0) Then
             FErr = "Error: " & _
                "Unable to Set New DACL to Security Descriptor"
            Exit Sub
         End If

         lResult = SetFileSecurity(sFileName, _
            DACL_SECURITY_INFORMATION, sNewSD)

         If (lResult = 0) Then
             FErr = "Error: Unable to Set New Security Descriptor " _
               & " to File : " & sFileName
             FErr = Err.LastDllError
         Else
             FErr = "Updated Security Descriptor on File: " _
               & sFileName
         End If

      End If

   End If

End Sub

Public Sub Change(sFolderName As String, sUserName As String, sAccess As String)
    sUserName = Trim$(sUserName)
    sFolderName = Trim$(sFolderName)
    sAccess = UCase(sAccess)
   
    Select Case sAccess
        Case "R"
            SetAccess sUserName, sFolderName, GENERIC_READ
        Case "EX"
            SetAccess sUserName, sFolderName, GENERIC_EXECUTE
        Case "D"
            SetAccess sUserName, sFolderName, DELETE
        Case "W"
            SetAccess sUserName, sFolderName, GENERIC_WRITE
        Case "ALL"
            SetAccess sUserName, sFolderName, GENERIC_ALL
        Case Else
       
    End Select
End Sub

Private Property Let FErr(ByVal vData As String)
    mvarFErr = vData
End Property

Public Property Get FErr() As String
    FErr = mvarFErr
End Property