查看与更改NTFS文件夹权限

    最近写的一个可以查看并且更改NTFS文件夹访问权限的小工具。

http://www.geocities.com/james0001csdn/NTFSSecurity.zip

主要用到的 API 函数：
GetNamedSecurityInfo - 用来得到一个文件夹的权限列表。
SetNamedSecurityInfo - 用来设置一个文件夹的权限（需要有足够权限）。
AddAce    - 用来获得/修改权限列表项目信息。
DeleteAce
GetAce


frmMain.frm - 工程唯一需要的主窗口文件（没来得及注释）

---

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "NTFS文件夹权限"
   ClientHeight    =   6495
   ClientLeft      =   1620
   ClientTop       =   435
   ClientWidth     =   5250
   HasDC           =   0   'False
   LinkTopic       =   "frmMain"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   433
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   350
   Begin VB.ComboBox cmbInherit 
      Enabled         =   0   'False
      Height          =   315
      Left            =   1170
      Style           =   2  'Dropdown List
      TabIndex        =   13
      Top             =   5550
      Width           =   3930
   End
   Begin VB.CommandButton cmdSave 
      Caption         =   "保存文件夹权限(&S)"
      Enabled         =   0   'False
      Height          =   345
      Left            =   3405
      TabIndex        =   4
      Top             =   405
      Width           =   1710
   End
   Begin VB.CommandButton cmdOpenDir 
      Caption         =   "打开(&O)"
      Height          =   345
      Left            =   2535
      TabIndex        =   3
      Top             =   405
      Width           =   855
   End
   Begin VB.CommandButton cmdDel 
      Caption         =   "删除项目(&D)"
      Enabled         =   0   'False
      Height          =   390
      Left            =   3915
      TabIndex        =   16
      Top             =   6000
      Width           =   1230
   End
   Begin VB.CommandButton cmdModify 
      Caption         =   "修改项目(&M)"
      Enabled         =   0   'False
      Height          =   390
      Left            =   2670
      TabIndex        =   15
      Top             =   6000
      Width           =   1230
   End
   Begin VB.CommandButton cmdAdd 
      Caption         =   "添加到权限项目列表(&A)"
      Enabled         =   0   'False
      Height          =   390
      Left            =   135
      TabIndex        =   14
      Top             =   6000
      Width           =   2220
   End
   Begin VB.ListBox lstAccess 
      Enabled         =   0   'False
      Height          =   1860
      Left            =   135
      Style           =   1  'Checkbox
      TabIndex        =   11
      Top             =   3630
      Width           =   4965
   End
   Begin VB.CommandButton cmdUserCheck 
      Caption         =   "检查(&C)"
      Enabled         =   0   'False
      Height          =   300
      Left            =   4395
      TabIndex        =   9
      Top             =   2985
      Width           =   720
   End
   Begin VB.TextBox txtUser 
      Enabled         =   0   'False
      Height          =   285
      Left            =   915
      TabIndex        =   8
      Top             =   3000
      Width           =   3435
   End
   Begin VB.ListBox lstAces 
      Enabled         =   0   'False
      Height          =   1620
      Left            =   135
      TabIndex        =   6
      Top             =   1155
      Width           =   4965
   End
   Begin VB.CommandButton cmdDir 
      Caption         =   "&..."
      Height          =   300
      Left            =   4770
      TabIndex        =   2
      Top             =   45
      Width           =   345
   End
   Begin VB.TextBox txtDir 
      Height          =   300
      Left            =   1020
      OLEDropMode     =   1  'Manual
      TabIndex        =   1
      Top             =   60
      Width           =   3690
   End
   Begin VB.Label lblInherit 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "应用到(&P)："
      Enabled         =   0   'False
      Height          =   195
      Left            =   150
      TabIndex        =   12
      Top             =   5610
      Width           =   915
   End
   Begin VB.Line lneSeparator 
      BorderColor     =   &H80000015&
      Index           =   3
      X1              =   6
      X2              =   344
      Y1              =   192
      Y2              =   192
   End
   Begin VB.Line lneSeparator 
      BorderColor     =   &H80000014&
      Index           =   2
      X1              =   6
      X2              =   344
      Y1              =   193
      Y2              =   193
   End
   Begin VB.Label lblAccess 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "权限（允许）(&E)："
      Enabled         =   0   'False
      Height          =   195
      Left            =   150
      TabIndex        =   10
      Top             =   3360
      Width           =   1455
   End
   Begin VB.Label lblUser 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "名称(&N)："
      Enabled         =   0   'False
      Height          =   195
      Left            =   150
      TabIndex        =   7
      Top             =   3045
      Width           =   750
   End
   Begin VB.Label lblAces 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "文件夹权限项目(&I)："
      Enabled         =   0   'False
      Height          =   195
      Left            =   120
      TabIndex        =   5
      Top             =   885
      Width           =   1575
   End
   Begin VB.Line lneSeparator 
      BorderColor     =   &H80000015&
      Index           =   1
      X1              =   6
      X2              =   344
      Y1              =   53
      Y2              =   53
   End
   Begin VB.Line lneSeparator 
      BorderColor     =   &H80000014&
      Index           =   0
      X1              =   6
      X2              =   344
      Y1              =   54
      Y2              =   54
   End
   Begin VB.Label lblDir 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "文件夹(&R)："
      Height          =   195
      Left            =   105
      TabIndex        =   0
      Top             =   120
      Width           =   930
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''
' James
'
Option Explicit
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDest As Any, ByRef pSrc As Any, ByVal iCb As Long)
Private Declare Function FormatMessageW Lib "kernel32" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As Long, ByVal nSize As Long, Arguments As Any) As Long
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Enum SE_OBJECT_TYPE
  SE_UNKNOWN_OBJECT_TYPE = 0&
  SE_FILE_OBJECT
  SE_SERVICE
  SE_PRINTER
  SE_REGISTRY_KEY
  SE_LMSHARE
  SE_KERNEL_OBJECT
  SE_WINDOW_OBJECT
  SE_DS_OBJECT
  SE_DS_OBJECT_ALL
  SE_PROVIDER_DEFINED_OBJECT
  SE_WMIGUID_OBJECT
  SE_REGISTRY_WOW64_32KEY
End Enum
Private Const OWNER_SECURITY_INFORMATION = (&H1&)
Private Const GROUP_SECURITY_INFORMATION = (&H2&)
Private Const DACL_SECURITY_INFORMATION = (&H4&)
Private Const SACL_SECURITY_INFORMATION = (&H8&)
Private Const PROTECTED_DACL_SECURITY_INFORMATION = (&H80000000)
Private Const PROTECTED_SACL_SECURITY_INFORMATION = (&H40000000)
Private Const UNPROTECTED_DACL_SECURITY_INFORMATION = (&H20000000)
Private Const UNPROTECTED_SACL_SECURITY_INFORMATION = (&H10000000)
Private Declare Function SetNamedSecurityInfoW Lib "advapi32" (ByVal pObjectName As Long, ByVal ObjectType As SE_OBJECT_TYPE, ByVal SecurityInfo As Long, ByRef psidOwner As Any, ByRef psidGroup As Any, ByRef pDacl As Any, ByRef pSacl As Any) As Long
Private Declare Function GetNamedSecurityInfoW Lib "advapi32" (ByVal pObjectName As Long, ByVal ObjectType As SE_OBJECT_TYPE, ByVal SecurityInfo As Long, ByRef psidOwner As Any, ByRef psidGroup As Any, ByRef pDacl As Any, ByRef pSacl As Any, ByRef ppSecurityDescriptor As Any) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Const BIF_RETURNONLYFSDIRS = &H1&       ' For finding a folder to start document searching
Private Const BIF_DONTGOBELOWDOMAIN = &H2&      ' For starting the Find Computer
Private Const BIF_STATUSTEXT = &H4&              ' Top of the dialog has 2 lines of text for BROWSEINFO.lpszTitle and one line if
                                        ' this flag is set.  Passing the message BFFM_SETSTATUSTEXTA to the hwnd can set the
                                        ' rest of the text.  This is not used with BIF_USENEWUI and BROWSEINFO.lpszTitle gets
                                        ' all three lines of text.
Private Const BIF_RETURNFSANCESTORS = &H8&
Private Const BIF_EDITBOX = &H10&                ' Add an editbox to the dialog
Private Const BIF_VALIDATE = &H20&               ' insist on valid result (or CANCEL)
Private Const BIF_NEWDIALOGSTYLE = &H40&         ' Use the new dialog layout with the ability to resize
                                        ' Caller needs to call OleInitialize() before using this API
Private Const BIF_USENEWUI& = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
Private Const BIF_BROWSEINCLUDEURLS = &H80&      ' Allow URLs to be displayed or entered. (Requires BIF_USENEWUI)
Private Const BIF_UAHINT = &H100&                ' Add a UA hint to the dialog, in place of the edit box. May not be combined with BIF_EDITBOX
Private Const BIF_NONEWFOLDERBUTTON = &H200&     ' Do not add the "New Folder" button to the dialog.  Only applicable with BIF_NEWDIALOGSTYLE.
Private Const BIF_NOTRANSLATETARGETS = &H400&    ' don't traverse target as shortcut
Private Const BIF_BROWSEFORCOMPUTER = &H1000&   ' Browsing for Computers.
Private Const BIF_BROWSEFORPRINTER = &H2000&    ' Browsing for Printers
Private Const BIF_BROWSEINCLUDEFILES = &H4000&  ' Browsing for Everything
Private Const BIF_SHAREABLE = &H8000&           ' sharable resources displayed (remote shares, requires BIF_USENEWUI)
Private Type BROWSEINFO
  hwndOwner As Long
  pidlRoot As Long
  pszDisplayName As Long
  lpszTitle As Long
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
Private Declare Function SHBrowseForFolderW Lib "shell32" (ByRef lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDListW Lib "shell32" (ByVal pidl As Long, ByVal pszPath As Long) As Long
Private Declare Function CoTaskMemAlloc Lib "ole32" (ByVal cb As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Enum ACL_INFORMATION_CLASS
  AclRevisionInformation = 1&
  AclSizeInformation
End Enum
Private Type ACL_SIZE_INFORMATION
  AceCount As Long
  AclBytesInUse As Long
  AclBytesFree As Long
End Type
Private Declare Function GetAclInformation Lib "advapi32" (ByVal pAcl As Long, ByRef pAclInformation As Any, ByVal nAclInformationLength As Long, ByVal dwAclInformationClass As ACL_INFORMATION_CLASS) As Long
Private Const ACCESS_ALLOWED_ACE_TYPE = (&H0)
Private Const ACCESS_DENIED_ACE_TYPE = (&H1)
Private Const SYSTEM_AUDIT_ACE_TYPE = (&H2)
Private Const SYSTEM_ALARM_ACE_TYPE = (&H3)
Private Type ACE_HEADER
  AceType As Byte
  AceFlags As Byte
  AceSize As Integer
End Type
Private Type ACCESS_ALLOWED_ACE
  Header As ACE_HEADER
  Mask As Long
  SidStart As Long
End Type
Private Const MAX_DWORD = (&HFFFFFFFF)
Private Declare Function InitializeAcl Lib "advapi32" (ByVal pAcl As Long, ByVal nAclLength As Long, ByVal dwAclRevision As Long) As Long
Private Declare Function AddAce Lib "advapi32" (ByVal pAcl As Long, ByVal dwAceRevision As Long, ByVal dwStartingAceIndex As Long, ByRef pAceList As Any, ByVal nAceListLength As Long) As Long
Private Declare Function GetAce Lib "advapi32" (ByVal pAcl As Long, ByVal dwAceIndex As Long, ByRef pAce As Long) As Long
Private Declare Function DeleteAce Lib "advapi32" (ByVal pAcl As Long, ByVal dwAceIndex As Long) As Long
Private Const ACL_REVISION = (2&)
Private Const ACL_REVISION_DS = (4&)
Private Declare Function LookupAccountSidW Lib "advapi32" (ByVal lpSystemName As Long, ByVal lpSid As Long, ByVal lpName As Long, ByRef cchName As Long, ByVal lpReferencedDomainName As Long, ByRef cchReferencedDomainName As Long, ByRef peUse As Long) As Long
Private Declare Function LookupAccountNameW Lib "advapi32" (ByVal lpSystemName As Long, ByVal lpAccountName As Long, ByVal Sid As Long, ByRef cbSid As Long, ByVal ReferencedDomainName As Long, ByRef cchReferencedDomainName As Long, ByRef peUse As Long) As Long
Private Const FILE_DELETE = (&H10000)
Private Const FILE_READ_CONTROL = (&H20000)
Private Const FILE_WRITE_DAC = (&H40000)
Private Const FILE_WRITE_OWNER = (&H80000)
Private Const FILE_LIST_DIRECTORY = (&H1&)             ' directory
Private Const FILE_ADD_FILE = (&H2&)                   ' directory
Private Const FILE_ADD_SUBDIRECTORY = (&H4&)           ' directory
Private Const FILE_READ_EA = (&H8&)                    ' file & directory
Private Const FILE_WRITE_EA = (&H10&)                  ' file & directory
Private Const FILE_TRAVERSE = (&H20&)                  ' directory
Private Const FILE_DELETE_CHILD = (&H40&)              ' directory
Private Const FILE_READ_ATTRIBUTES = (&H80&)           ' all
Private Const FILE_WRITE_ATTRIBUTES = (&H100&)         ' all
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 MAX_PATH = 260&
Private Const TRUEAPI = 1&
Private Const FALSEAPI = 0&
Private Const NULLAPI = 0&
Private Const ERROR_SUCCESS = 0&
Private Const DOMAIN_SEP = "/"
Private Const MAX_DACL = &HFFFF&
Dim m_dirDacl As Long, m_dirDaclBytes(0& To MAX_DACL - 1&) As Byte
Private Function GetSid(ByVal sAccount As String) As Byte()
  Dim bSid() As Byte, lSid As Long, sDom As String, lDom As Long, lUse As Long
  LookupAccountNameW ByVal NULLAPI, ByVal StrPtr(sAccount), _
      ByVal NULLAPI, lSid, ByVal NULLAPI, lDom, lUse
  ReDim bSid(0& To 0&)
  If lSid > 0& Then
    ReDim bSid(0& To lSid - 1&)
    If lDom > 0& Then sDom = Space$(lDom - 1&)
    If LookupAccountNameW(ByVal NULLAPI, ByVal StrPtr(sAccount), _
        ByVal VarPtr(bSid(0&)), lSid, ByVal StrPtr(sDom), lDom, lUse) Then
    End If
  End If
  GetSid = bSid
End Function
Private Function GetName(ByRef bSid() As Byte) As String
  GetName = GetNameEx(VarPtr(bSid(0&)))
End Function
Private Function GetNameEx(ByVal pSid As Long) As String
  Dim sAcc As String, lAcc As Long, sDom As String, lDom As Long, lUse As Long
  LookupAccountSidW ByVal NULLAPI, ByVal pSid, _
      ByVal NULLAPI, lAcc, ByVal NULLAPI, lDom, lUse
  GetNameEx = vbNullString
  If lAcc > 1& Then
    sAcc = Space$(lAcc - 1&)
    If lDom > 0& Then sDom = Space$(lDom - 1&)
    If LookupAccountSidW(ByVal NULLAPI, ByVal pSid, _
        ByVal StrPtr(sAcc), lAcc, ByVal StrPtr(sDom), lDom, lUse) Then
      If sDom = sAcc Then
        GetNameEx = sAcc
      Else
        GetNameEx = sDom & DOMAIN_SEP & sAcc
      End If
    End If
  End If
End Function
Private Function CheckName() As Boolean
  Dim tSid() As Byte, tAcc As String
  tSid = GetSid(txtUser.Text)
  If UBound(tSid) > 0& Then
    tAcc = GetName(tSid)
    If tAcc <> vbNullString Then
      txtUser.Text = tAcc
      CheckName = True
      Exit Function
    End If
  End If
  MsgBox "无效名称！", vbExclamation
  CheckName = False
End Function
Private Sub CopyDacl(ByVal pDaclSrc As Long, ByVal pDaclDest As Long, ByVal iDestLen As Long)
  Dim daclSize As ACL_SIZE_INFORMATION, srcFAce As Long, i As Long, aceH As ACE_HEADER
  If GetAclInformation(pDaclSrc, daclSize, Len(daclSize), AclSizeInformation) Then
    If InitializeAcl(pDaclDest, iDestLen, ACL_REVISION) Then
      For i = 0& To daclSize.AceCount - 1&
        If GetAce(pDaclSrc, i, srcFAce) Then
          CopyMem aceH, ByVal srcFAce, Len(aceH)
          AddAce pDaclDest, ACL_REVISION, MAX_DWORD, ByVal srcFAce, CLng(aceH.AceSize)
        End If
      Next
    End If
  End If
End Sub
Private Sub cmbInherit_Click()
  With cmbInherit
    If (.ListIndex = 0) Or (.ListIndex = 8) Then
      cmdAdd.Enabled = False
    Else
      cmdAdd.Enabled = True
    End If
  End With
End Sub
Private Function AddAceAt(ByVal iIndex As Long) As Boolean
  Dim nAce() As Byte, bSid() As Byte, lAceS As Long, nAceH As ACCESS_ALLOWED_ACE, i As Long
  If CheckName Then
    With nAceH
      .Header.AceType = ACCESS_ALLOWED_ACE_TYPE
      .Header.AceFlags = cmbInherit.ItemData(cmbInherit.ListIndex)
      For i = 0& To lstAccess.ListCount - 1&
        If lstAccess.Selected(i) Then .Mask = .Mask Or lstAccess.ItemData(i)
      Next
      bSid = GetSid(txtUser.Text)
      lAceS = Len(nAceH) - Len(nAceH.SidStart) + UBound(bSid) + 1&
      .Header.AceSize = lAceS
      ReDim nAce(lAceS - 1&)
      CopyMem nAce(0&), nAceH, Len(nAceH) - Len(nAceH.SidStart)
      CopyMem nAce(Len(nAceH) - Len(nAceH.SidStart)), bSid(0&), UBound(bSid) + 1&
      If AddAce(m_dirDacl, ACL_REVISION, iIndex, nAce(0&), lAceS) Then
        AddAceAt = True
        Exit Function
      End If
    End With
  End If
  AddAceAt = False
  MsgBox "添加权限时发生错误！", vbExclamation
End Function
Private Sub cmdAdd_Click()
  AddAceAt MAX_DWORD
  BuildAceList m_dirDacl
End Sub
Private Sub cmdDel_Click()
  DeleteAce m_dirDacl, lstAces.ItemData(lstAces.ListIndex)
  BuildAceList m_dirDacl
End Sub
Private Sub cmdDir_Click()
cmdDir_Start:
  Dim bi As BROWSEINFO, lpidl As Long, sDName As String
  With bi
    .hwndOwner = Me.hWnd
    .lpfn = NULLAPI
    .lpszTitle = StrPtr("请选择要打开的文件夹")
    .pidlRoot = NULLAPI
    .pszDisplayName = NULLAPI
    .ulFlags = BIF_NEWDIALOGSTYLE Or BIF_RETURNFSANCESTORS Or BIF_RETURNONLYFSDIRS
  End With
  lpidl = SHBrowseForFolderW(bi)
  If lpidl Then
    sDName = String$(MAX_PATH, vbNullChar)
    If SHGetPathFromIDListW(lpidl, StrPtr(sDName)) Then
      txtDir.Text = Left$(sDName, lstrlenW(StrPtr(sDName)))
    Else
      MsgBox "无效目录！", vbExclamation
      CoTaskMemFree lpidl
      GoTo cmdDir_Start
    End If
    CoTaskMemFree lpidl
  End If
End Sub
Private Sub cmdModify_Click()
  Dim lPos As Long
  lPos = lstAces.ItemData(lstAces.ListIndex)
  If AddAceAt(lPos) Then
    DeleteAce m_dirDacl, lPos + 1&
    BuildAceList m_dirDacl
  End If
End Sub
Private Sub cmdOpenDir_Click()
  Dim sDir As String, tSD As Long, tAcl As Long, lErr As Long
  sDir = txtDir.Text
  'If Right$(sDir, 1&) <> "/" Then sDir = sDir & "/"
  lErr = GetNamedSecurityInfoW(StrPtr(sDir), _
      SE_FILE_OBJECT, DACL_SECURITY_INFORMATION, _
      ByVal NULLAPI, ByVal NULLAPI, tAcl, ByVal NULLAPI, tSD)
  If lErr = _
      ERROR_SUCCESS Then
    EnableAces True
    m_dirDacl = VarPtr(m_dirDaclBytes(0&))
    CopyDacl tAcl, m_dirDacl, MAX_DACL
    BuildAceList m_dirDacl
    LocalFree tSD
    cmdSave.Enabled = True
  Else
    MsgBox "无法获得文件夹权限信息！" & vbNewLine & _
           "错误：" & Hex(lErr) & "," & vbTab & GetLastErrorString(lErr), _
           vbExclamation
    EnableAces False
    lstAces.Clear
  End If
End Sub
Private Sub BuildAceList(ByVal pAcl As Long)
  Dim i  As Long, acli As ACL_SIZE_INFORMATION, pAce As Long, sAcc As String
  Dim aceHeader As ACE_HEADER, aceAllow As ACCESS_ALLOWED_ACE, lUse As Long
  With lstAces
    If pAcl Then
      If GetAclInformation(pAcl, acli, Len(acli), AclSizeInformation) Then
        .Clear
        EnableAccesses False
        For i = 0& To acli.AceCount - 1&
          If GetAce(pAcl, i, pAce) Then
            CopyMem aceHeader, ByVal pAce, Len(aceHeader)
            If (aceHeader.AceType = ACCESS_ALLOWED_ACE_TYPE) Then
              sAcc = GetNameEx(pAce + (VarPtr(aceAllow.SidStart) - VarPtr(aceAllow)))
              If sAcc <> vbNullString Then
                .AddItem sAcc
                .ItemData(.ListCount - 1&) = i
              End If
            End If
          End If
        Next
      End If
    End If
  End With
End Sub
  
Private Sub cmdSave_Click()
  Dim sDir As String, lErr As Long
  sDir = txtDir.Text
  lErr = SetNamedSecurityInfoW(StrPtr(sDir), SE_FILE_OBJECT, DACL_SECURITY_INFORMATION, _
      ByVal NULLAPI, ByVal NULLAPI, ByVal m_dirDacl, ByVal NULLAPI)
  If lErr = ERROR_SUCCESS Then
    MsgBox "成功保存文件夹权限！", vbInformation
  Else
    MsgBox "保存文件夹权限时发生错误！" & vbNewLine & _
           "错误：" & Hex(lErr) & "," & vbTab & GetLastErrorString(lErr), _
           vbExclamation
  End If
End Sub
Private Sub cmdUserCheck_Click()
  CheckName
End Sub
Private Sub Form_Load()
  With lstAccess
    .AddItem "遍历文件夹", 0&
    .ItemData(0&) = FILE_TRAVERSE
    .AddItem "列出文件夹", 1&
    .ItemData(1&) = FILE_LIST_DIRECTORY
    .AddItem "创建文件", 2&
    .ItemData(2&) = FILE_ADD_FILE
    .AddItem "创建文件夹", 3&
    .ItemData(3&) = FILE_ADD_SUBDIRECTORY
    .AddItem "删除子文件夹和文件", 4&
    .ItemData(4&) = FILE_DELETE_CHILD
    .AddItem "删除", 5&
    .ItemData(5&) = FILE_DELETE
    .AddItem "读取属性", 6&
    .ItemData(6&) = FILE_READ_ATTRIBUTES
    .AddItem "读取扩展属性", 7&
    .ItemData(7&) = FILE_READ_EA
    .AddItem "写入属性", 8&
    .ItemData(8&) = FILE_WRITE_ATTRIBUTES
    .AddItem "写入扩展属性", 9&
    .ItemData(9&) = FILE_WRITE_EA
    .AddItem "读取权限", 10&
    .ItemData(10&) = FILE_READ_CONTROL
    .AddItem "更改权限", 11&
    .ItemData(11&) = FILE_WRITE_DAC
    .AddItem "取得所有权", 12&
    .ItemData(12&) = FILE_WRITE_OWNER
  End With
  With cmbInherit
    .AddItem "其它", 0&
    .ItemData(0&) = 0&
    .AddItem "该文件夹", 1&
    .ItemData(1&) = 0&
    .AddItem "该文件夹和子文件夹", 2&
    .ItemData(2&) = CONTAINER_INHERIT_ACE
    .AddItem "该文件夹和文件", 3&
    .ItemData(3&) = OBJECT_INHERIT_ACE
    .AddItem "该文件夹，子文件夹和文件", 4&
    .ItemData(4&) = CONTAINER_INHERIT_ACE Or OBJECT_INHERIT_ACE
    .AddItem "子文件夹", 5&
    .ItemData(5&) = CONTAINER_INHERIT_ACE Or INHERIT_ONLY_ACE
    .AddItem "该文件夹的文件", 6&
    .ItemData(6&) = OBJECT_INHERIT_ACE Or INHERIT_ONLY_ACE
    .AddItem "子文件夹及文件", 7&
    .ItemData(7&) = CONTAINER_INHERIT_ACE Or OBJECT_INHERIT_ACE Or INHERIT_ONLY_ACE
    .AddItem "（此权限项目由父文件夹继承而来）", 8&
    .ItemData(8&) = INHERITED_ACE
    .ListIndex = 1&
    cmdAdd.Enabled = False
  End With
End Sub
Private Sub EnableAces(ByVal bEnable As Boolean)
  lblAces.Enabled = bEnable
  lstAces.Enabled = bEnable
  lblUser.Enabled = bEnable
  txtUser.Enabled = bEnable
  cmdUserCheck.Enabled = bEnable
  lblAccess.Enabled = bEnable
  lstAccess.Enabled = bEnable
  lstAccess.Refresh
  cmdAdd.Enabled = bEnable
  lblInherit.Enabled = bEnable
  cmbInherit.Enabled = bEnable
End Sub
Private Sub EnableAccesses(ByVal bEnable As Boolean, Optional ByVal bNoModify As Boolean = False)
  If bNoModify Then
    cmdModify.Enabled = False
    cmdDel.Enabled = False
  Else
    cmdModify.Enabled = bEnable
    cmdDel.Enabled = bEnable
  End If
End Sub
Private Function SetAccess(ByVal pAcl As Long, ByVal iAceIndex As Long) As Boolean
  Dim pAce As Long, aceAllow As ACCESS_ALLOWED_ACE, i As Long, osel As Integer
  Dim sAcc As String
  SetAccess = False
  If pAcl Then
    If GetAce(pAcl, iAceIndex, pAce) Then
      CopyMem aceAllow, ByVal pAce, Len(aceAllow)
      sAcc = GetNameEx(pAce + (VarPtr(aceAllow.SidStart) - VarPtr(aceAllow)))
      If sAcc <> vbNullString Then
        txtUser.Text = sAcc
      End If
      With lstAccess
        osel = .ListIndex
        For i = 0& To .ListCount - 1&
          If (aceAllow.Mask And .ItemData(i)) = .ItemData(i) Then
            .Selected(i) = True
          Else
            .Selected(i) = False
          End If
        Next
        .ListIndex = osel
        .Refresh
      End With
      With cmbInherit
        If aceAllow.Header.AceFlags And INHERITED_ACE Then
          .ListIndex = 8
          .ItemData(8) = aceAllow.Header.AceFlags
          SetAccess = True
        Else
          .ListIndex = 0
          For i = 1& To .ListCount - 1&
            If ((aceAllow.Header.AceFlags And VALID_INHERIT_FLAGS) = .ItemData(i)) Then
              .ListIndex = i
              Exit For
            End If
          Next
        End If
      End With
    End If
  End If
End Function
Private Sub lstAces_Click()
  If (lstAces.ListIndex > 0) And (lstAces.ListIndex < lstAces.ListCount) Then
    EnableAccesses True, SetAccess(m_dirDacl, lstAces.ItemData(lstAces.ListIndex))
  End If
End Sub
Public Function GetLastErrorString(Optional ByVal uiError As Long = 0&) As String
  Const LAST_ERROR_BUFER_SIZE = 260&
  On Error GoTo getlasterrorstring_exit
  If uiError = 0& Then uiError = Err.LastDllError
  GetLastErrorString = String$(LAST_ERROR_BUFER_SIZE, vbNullChar)
  GetLastErrorString = Left$(GetLastErrorString, _
      FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM, ByVal NULLAPI, uiError, 0&, _
          StrPtr(GetLastErrorString), LAST_ERROR_BUFER_SIZE, ByVal NULLAPI))
getlasterrorstring_exit:
End Function
Private Sub txtDir_KeyPress(KeyAscii As Integer)
  If KeyAscii = vbKeyReturn Then
    cmdOpenDir_Click
    KeyAscii = 0
  End If
End Sub
Private Sub txtDir_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Data.GetFormat(vbCFFiles) Then
    txtDir.Text = Data.Files(1&)
  End If
End Sub
Private Sub txtUser_KeyPress(KeyAscii As Integer)
  If KeyAscii = vbKeyReturn Then
    cmdUserCheck_Click
    KeyAscii = 0
  End If
End Sub

    

---

P.S. 可以在“文件夹”文本框里输入一个文件名，这样的话可以修改文件的访问权限。