home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 27 / IOPROG_27.ISO / SOFT / ADSDK.ZIP / Samples / Exchange / MailBox / mailbox.bas next >
Encoding:
BASIC Source File  |  1998-08-13  |  21.6 KB  |  619 lines
  1. Attribute VB_Name = "MailFuncs"
  2. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  3. ''
  4. '' ADSI Sample to create and delete Exchange 5.5 Mailboxes
  5. ''
  6. '' Richard Ault, Jean-Philippe Balivet, Neil Wemple -- 1998
  7. ''
  8. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  9. Option Explicit
  10.  
  11. ' Mailbox property settings
  12. Public Const LOGON_CMD = "logon.cmd"
  13. Public Const INCOMING_MESSAGE_LIMIT = 1000
  14. Public Const OUTGOING_MESSAGE_LIMIT = 1000
  15. Public Const WARNING_STORAGE_LIMIT = 8000
  16. Public Const SEND_STORAGE_LIMIT = 12000
  17. Public Const REPLICATION_SENSITIVITY = 20
  18. Public Const COUNTRY = "US"
  19.  
  20. ' Mailbox rights for Exchange security descriptor (home made)
  21. Public Const RIGHT_MODIFY_USER_ATTRIBUTES = &H2
  22. Public Const RIGHT_MODIFY_ADMIN_ATTRIBUTES = &H4
  23. Public Const RIGHT_SEND_AS = &H8
  24. Public Const RIGHT_MAILBOX_OWNER = &H10
  25. Public Const RIGHT_MODIFY_PERMISSIONS = &H80
  26. Public Const RIGHT_SEARCH = &H100
  27.  
  28. ' win32 constants for security descriptors (from VB5 API viewer)
  29. Public Const ACL_REVISION = (2)
  30. Public Const SECURITY_DESCRIPTOR_REVISION = (1)
  31. Public Const SidTypeUser = 1
  32.  
  33. Type ACL
  34.         AclRevision As Byte
  35.         Sbz1 As Byte
  36.         AclSize As Integer
  37.         AceCount As Integer
  38.         Sbz2 As Integer
  39. End Type
  40.  
  41. Type ACE_HEADER
  42.         AceType As Byte
  43.         AceFlags As Byte
  44.         AceSize As Long
  45. End Type
  46.  
  47. Type ACCESS_ALLOWED_ACE
  48.         Header As ACE_HEADER
  49.         Mask As Long
  50.         SidStart As Long
  51. End Type
  52.  
  53. Type SECURITY_DESCRIPTOR
  54.         Revision As Byte
  55.         Sbz1 As Byte
  56.         Control As Long
  57.         Owner As Long
  58.         Group As Long
  59.         Sacl As ACL
  60.         Dacl As ACL
  61. End Type
  62.  
  63. ' Just an help to allocate the 2dim dynamic array
  64. Private Type mySID
  65.     x() As Byte
  66. End Type
  67.  
  68.  
  69. ' Declares : modified from VB5 API viewer
  70. Declare Function InitializeSecurityDescriptor Lib "advapi32.dll" _
  71.         (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
  72.         ByVal dwRevision As Long) As Long
  73.  
  74. Declare Function SetSecurityDescriptorOwner Lib "advapi32.dll" _
  75.         (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
  76.         pOwner As Byte, _
  77.         ByVal bOwnerDefaulted As Long) As Long
  78.  
  79. Declare Function SetSecurityDescriptorGroup Lib "advapi32.dll" _
  80.         (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
  81.         pGroup As Byte, _
  82.         ByVal bGroupDefaulted As Long) As Long
  83.  
  84. Declare Function SetSecurityDescriptorDacl Lib "advapi32.dll" _
  85.         (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
  86.         ByVal bDaclPresent As Long, _
  87.         pDacl As Byte, _
  88.         ByVal bDaclDefaulted As Long) As Long
  89.  
  90. Declare Function SetSecurityDescriptorSacl Lib "advapi32.dll" _
  91.         (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
  92.         ByVal bSaclPresent As Long, _
  93.         pSacl As Byte, _
  94.         ByVal bSaclDefaulted As Long) As Long
  95.  
  96. Declare Function MakeSelfRelativeSD Lib "advapi32.dll" _
  97.         (pAbsoluteSecurityDescriptor As SECURITY_DESCRIPTOR, _
  98.         pSelfRelativeSecurityDescriptor As Byte, _
  99.         ByRef lpdwBufferLength As Long) As Long
  100.  
  101. Declare Function GetSecurityDescriptorLength Lib "advapi32.dll" _
  102.         (pSecurityDescriptor As SECURITY_DESCRIPTOR) As Long
  103.  
  104. Declare Function IsValidSecurityDescriptor Lib "advapi32.dll" _
  105.         (pSecurityDescriptor As Byte) As Long
  106.  
  107. Declare Function InitializeAcl Lib "advapi32.dll" _
  108.         (pACL As Byte, _
  109.         ByVal nAclLength As Long, _
  110.         ByVal dwAclRevision As Long) As Long
  111.  
  112. Declare Function AddAccessAllowedAce Lib "advapi32.dll" _
  113.         (pACL As Byte, _
  114.         ByVal dwAceRevision As Long, _
  115.         ByVal AccessMask As Long, _
  116.         pSid As Byte) As Long
  117.  
  118. Declare Function IsValidAcl Lib "advapi32.dll" _
  119.         (pACL As Byte) As Long
  120.  
  121. Declare Function GetLastError Lib "kernel32" _
  122.         () As Long
  123.  
  124. Declare Function LookupAccountName Lib "advapi32.dll" _
  125.         Alias "LookupAccountNameA" _
  126.         (ByVal IpSystemName As String, _
  127.          ByVal IpAccountName As String, _
  128.          pSid As Byte, _
  129.          cbSid As Long, _
  130.          ByVal ReferencedDomainName As String, _
  131.          cbReferencedDomainName As Long, _
  132.          peUse As Integer) As Long
  133.  
  134. Declare Function NetGetDCName Lib "NETAPI32.DLL" _
  135.         (ServerName As Byte, _
  136.          DomainName As Byte, _
  137.          DCNPtr As Long) As Long
  138.                                          
  139. Declare Function NetApiBufferFree Lib "NETAPI32.DLL" _
  140.         (ByVal Ptr As Long) As Long
  141.         
  142. Declare Function PtrToStr Lib "kernel32" _
  143.         Alias "lstrcpyW" (RetVal As Byte, ByVal Ptr As Long) As Long
  144.  
  145. Declare Function GetLengthSid Lib "advapi32.dll" _
  146.         (pSid As Byte) As Long
  147.  
  148.  
  149. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  150. ''
  151. '' Create_NT_Account() -- creates an NT user account
  152. ''
  153. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  154. Public Function Create_NT_Account(strDomain As String, _
  155.                                   strAdmin As String, _
  156.                                   strPassword As String, _
  157.                                   UserName As String, _
  158.                                   FullName As String, _
  159.                                   NTServer As String _
  160.                                   ) As Boolean
  161.  
  162. Dim oNS As IADsOpenDSObject
  163. Dim User As IADsUser
  164. Dim Domain As IADsDomain
  165.  
  166.     On Error GoTo Create_NT_Account_Error
  167.  
  168.     Create_NT_Account = False
  169.     
  170.     If (strPassword = "") Then
  171.         strPassword = ""
  172.     End If
  173.     
  174.     Set oNS = GetObject("WinNT:")
  175.     Set Domain = oNS.OpenDSObject("WinNT://" & strDomain, strDomain & "\" & strAdmin, strPassword, 0)
  176.     
  177.     Set User = Domain.Create("User", UserName)
  178.     With User
  179.         .Description = "User created by ADSI"
  180.         .FullName = FullName
  181.         .HomeDirectory = "\\" & NTServer & "\" & UserName
  182.         .LoginScript = LOGON_CMD
  183.         .SetInfo
  184.         ' First password = username
  185.         .SetPassword UserName
  186.     End With
  187.     
  188.     Debug.Print "Successfully created NT Account for user " & UserName
  189.     Create_NT_Account = True
  190.     Exit Function
  191.  
  192. Create_NT_Account_Error:
  193.     
  194.     Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred creating NT account for user " & UserName
  195.  
  196. End Function
  197.  
  198. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  199. ''
  200. '' Delete_NT_Account() -- deletes an NT user account
  201. ''
  202. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  203. Public Function Delete_NT_Account(strDomain As String, _
  204.                                   strAdmin As String, _
  205.                                   strPassword As String, _
  206.                                   UserName As String _
  207.                                   ) As Boolean
  208.  
  209. Dim Domain As IADsDomain
  210. Dim oNS As IADsOpenDSObject
  211.  
  212.     On Error GoTo Delete_NT_Account_Error
  213.     
  214.     Delete_NT_Account = False
  215.     
  216.     If (strPassword = "") Then
  217.         strPassword = ""
  218.     End If
  219.  
  220.     Set oNS = GetObject("WinNT:")
  221.     Set Domain = oNS.OpenDSObject("WinNT://" & strDomain, strDomain & "\" & strAdmin, strPassword, 0)
  222.     
  223.     Domain.Delete "User", UserName
  224.     
  225.     Debug.Print "Successfully deleted NT Account for user " & UserName
  226.     Delete_NT_Account = True
  227.     Exit Function
  228.     
  229. Delete_NT_Account_Error:
  230.     
  231.     Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred deleting NT account for user " & UserName
  232.     
  233. End Function
  234.  
  235. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  236. ''
  237. '' Create_Exchange_Mailbox() -- creates an Exchange mailbox, sets mailbox
  238. ''                           properties and and associates the mailbox with
  239. ''                           an existing NT user account
  240. ''
  241. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  242. Public Function Create_Exchange_MailBox( _
  243.     IsRemote As Boolean, _
  244.     strServer As String, _
  245.     strDomain As String, _
  246.     strAdmin As String, _
  247.     strPassword As String, _
  248.     UserName As String, _
  249.     EMailAddress As String, _
  250.     strFirstName As String, _
  251.     strLastName As String, _
  252.     ExchangeServer As String, _
  253.     ExchangeSite As String, _
  254.     ExchangeOrganization As String _
  255.    ) As Boolean
  256.  
  257. Dim Container As IADsContainer
  258. Dim strRecipContainer As String
  259. Dim Mailbox As IADs
  260. Dim rbSID(1024) As Byte
  261. Dim OtherMailBox() As Variant
  262. Dim sSelfSD() As Byte
  263. Dim encodedSD() As Byte
  264. Dim I As Integer
  265.  
  266. Dim oNS As IADsOpenDSObject
  267.  
  268.     On Error GoTo Create_Exchange_MailBox_Error
  269.     
  270.     Create_Exchange_MailBox = False
  271.     
  272.     If (strPassword = "") Then
  273.         strPassword = ""
  274.     End If
  275.  
  276.     ' Recipients container for this server
  277.     strRecipContainer = "LDAP://" & ExchangeServer & _
  278.                         "/CN=Recipients,OU=" & ExchangeSite & _
  279.                         ",O=" & ExchangeOrganization
  280.     Set oNS = GetObject("LDAP:")
  281.     Set Container = oNS.OpenDSObject(strRecipContainer, "cn=" & strAdmin & ",dc=" & strDomain, strPassword, 0)
  282.     
  283.     ' This creates both mailboxes or remote dir entries
  284.     If IsRemote Then
  285.         Set Mailbox = Container.Create("Remote-Address", "CN=" & UserName)
  286.         Mailbox.Put "Target-Address", EMailAddress
  287.     Else
  288.         Set Mailbox = Container.Create("OrganizationalPerson", "CN=" & UserName)
  289.         Mailbox.Put "MailPreferenceOption", 0
  290.     End If
  291.     
  292.     With Mailbox
  293.         .SetInfo
  294.         
  295.         ' As an example two other addresses
  296.         ReDim OtherMailBox(1)
  297.         OtherMailBox(0) = "MS$" & ExchangeOrganization & _
  298.                           "/" & ExchangeSite & _
  299.                           "/" & UserName
  300.         
  301.         OtherMailBox(1) = "CCMAIL$" & UserName & _
  302.                           " at " & ExchangeSite
  303.                           
  304.         If Not (IsRemote) Then
  305.             ' Get the SID of the previously created NT user
  306.             Get_Exchange_Sid strDomain, UserName, rbSID
  307.             .Put "Assoc-NT-Account", rbSID
  308.             ' This line also initialize the "Home Server" parameter of the Exchange admin
  309.             .Put "Home-MTA", "cn=Microsoft MTA,cn=" & ExchangeServer & ",cn=Servers,cn=Configuration,ou=" & ExchangeSite & ", o = " & ExchangeOrganization
  310.             .Put "Home-MDB", "cn=Microsoft Private MDB,cn=" & ExchangeServer & ",cn=Servers,cn=Configuration,ou=" & ExchangeSite & ",o=" & ExchangeOrganization
  311.             .Put "Submission-Cont-Length", OUTGOING_MESSAGE_LIMIT
  312.             .Put "MDB-Use-Defaults", False
  313.             .Put "MDB-Storage-Quota", WARNING_STORAGE_LIMIT
  314.             .Put "MDB-Over-Quota-Limit", SEND_STORAGE_LIMIT
  315.             .Put "MAPI-Recipient", True
  316.             
  317.             ' Security descriptor
  318.             ' The rights choosen make a normal user role
  319.             ' The other user is optionnal, delegate for ex.
  320.             
  321.             Call MakeSelfSD(sSelfSD, _
  322.                             strServer, _
  323.                             strDomain, _
  324.                             UserName, _
  325.                             UserName, _
  326.                             RIGHT_MAILBOX_OWNER + RIGHT_SEND_AS + _
  327.                             RIGHT_MODIFY_USER_ATTRIBUTES _
  328.                            )
  329.  
  330.             ReDim encodedSD(2 * UBound(sSelfSD) + 1)
  331.             For I = 0 To UBound(sSelfSD) - 1
  332.                 encodedSD(2 * I) = AscB(Hex$(sSelfSD(I) \ &H10))
  333.                 encodedSD(2 * I + 1) = AscB(Hex$(sSelfSD(I) Mod &H10))
  334.             Next I
  335.             
  336.             .Put "NT-Security-Descriptor", encodedSD
  337.         Else
  338.             
  339.             ReDim Preserve OtherMailBox(2)
  340.             OtherMailBox(2) = EMailAddress
  341.             .Put "MAPI-Recipient", False
  342.         End If
  343.         
  344.         ' Usng PutEx for array properties
  345.         .PutEx ADS_PROPERTY_UPDATE, "otherMailBox", OtherMailBox
  346.         
  347.         .Put "Deliv-Cont-Length", INCOMING_MESSAGE_LIMIT
  348.         ' i : initials
  349.         .Put "TextEncodedORaddress", "c=" & COUNTRY & _
  350.                                      ";a= " & _
  351.                                      ";p=" & ExchangeOrganization & _
  352.                                      ";o=" & ExchangeSite & _
  353.                                      ";s=" & strLastName & _
  354.                                      ";g=" & strFirstName & _
  355.                                      ";i=" & Mid(strFirstName, 1, 1) & Mid(strLastName, 1, 1) & ";"
  356.         
  357.         .Put "rfc822MailBox", UserName & "@" & ExchangeSite & "." & ExchangeOrganization & ".com"
  358.         .Put "Replication-Sensitivity", REPLICATION_SENSITIVITY
  359.         .Put "uid", UserName
  360.         .Put "name", UserName
  361.  
  362.         .Put "GivenName", strFirstName
  363.         .Put "Sn", strLastName
  364.         .Put "Cn", strFirstName & " " & strLastName
  365.         .Put "Initials", Mid(strFirstName, 1, 1) & Mid(strLastName, 1, 1)
  366.         
  367.         ' Any of these fields are simply descriptive and optional, not included in
  368.         ' this sample and there are many other fields in the mailbox
  369.         .Put "Mail", EMailAddress
  370.         'If 0 < Len(Direction) Then .Put "Department", Direction
  371.         'If 0 < Len(FaxNumber) Then .Put "FacsimileTelephoneNumber", FaxNumber
  372.         'If 0 < Len(City) Then .Put "l", City
  373.         'If 0 < Len(Address) Then .Put "PostalAddress", Address
  374.         'If 0 < Len(PostalCode) Then .Put "PostalCode", PostalCode
  375.         'If 0 < Len(Banque) Then .Put "Company", Banque
  376.         'If 0 < Len(PhoneNumber) Then .Put "TelephoneNumber", PhoneNumber
  377.         'If 0 < Len(Title) Then .Put "Title", Title
  378.         'If 0 < Len(AP1) Then .Put "Extension-Attribute-1", AP1
  379.         'If 0 < Len(Manager) Then .Put "Extension-Attribute-2", Manager
  380.         'If 0 < Len(Agence) Then .Put "Extension-Attribute-3", Agence
  381.         'If 0 < Len(Groupe) Then .Put "Extension-Attribute-4", Groupe
  382.         'If 0 < Len(Secteur) Then .Put "Extension-Attribute-5", Secteur
  383.         'If 0 < Len(Region) Then .Put "Extension-Attribute-6", Region
  384.         'If 0 < Len(GroupeBanque) Then .Put "Extension-Attribute-7", GroupeBanque
  385.         'If 0 < Len(AP7) Then .Put "Extension-Attribute-8", AP7
  386.         'If 0 < Len(AP8) Then .Put "Extension-Attribute-9", AP8
  387.         .SetInfo
  388.     End With
  389.     
  390.     Debug.Print "Successfully created mailbox for user " & UserName
  391.     Create_Exchange_MailBox = True
  392.     Exit Function
  393.  
  394. Create_Exchange_MailBox_Error:
  395.     
  396.     Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred creating Mailbox for user " & UserName
  397.     
  398. End Function
  399.  
  400. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  401. ''
  402. '' Delete_Exchange_Mailbox() -- deletes an Exchange mailbox
  403. ''
  404. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  405. Public Function Delete_Exchange_Mailbox( _
  406.     IsRemote As Boolean, _
  407.     strDomain As String, _
  408.     strAdmin As String, _
  409.     strPassword As String, _
  410.     UserName As String, _
  411.     ExchangeServer As String, _
  412.     ExchangeSite As String, _
  413.     ExchangeOrganization As String _
  414.    ) As Boolean
  415.  
  416. Dim strRecipContainer As String
  417. Dim Container As IADsContainer
  418. Dim oNS As IADsOpenDSObject
  419.  
  420.     If (strPassword = "") Then
  421.         strPassword = ""
  422.     End If
  423.  
  424.     On Error GoTo Delete_Exchange_MailBox_Error
  425.     Delete_Exchange_Mailbox = False
  426.     
  427.     ' Recipients container for this server
  428.     strRecipContainer = "LDAP://" & ExchangeServer & _
  429.                         "/CN=Recipients,OU=" & ExchangeSite & _
  430.                         ",O=" & ExchangeOrganization
  431.     Set oNS = GetObject("LDAP:")
  432.     Set Container = oNS.OpenDSObject(strRecipContainer, "cn=" & strAdmin & ",dc=" & strDomain, strPassword, 0)
  433.  
  434.     If Not (IsRemote) Then
  435.         Container.Delete "OrganizationalPerson", "CN=" & UserName
  436.     Else
  437.         Container.Delete "Remote-Address", "CN=" & UserName
  438.     End If
  439.     
  440.     Container.SetInfo
  441.     
  442.     Debug.Print "Successfully deleted mailbox for user " & UserName
  443.     Delete_Exchange_Mailbox = True
  444.     Exit Function
  445.  
  446. Delete_Exchange_MailBox_Error:
  447.     
  448.     Debug.Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred deleting Mailbox for user " & UserName
  449.  
  450. End Function
  451.  
  452. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  453. ''
  454. '' MakeSelfSD -- builds a self-relative Security Descriptor suitable for ADSI
  455. ''
  456. '' Return code : 1 = OK
  457. ''               0 = error
  458. '' In    sSelfSD     dynamic byte array, size 0
  459. ''       sServer     DC for the domain
  460. ''       sDomain     Domain name
  461. ''       sAssocUser  Primary NT account for the mail box (SD owner)
  462. ''       paramarray  Authorized accounts
  463. ''                   This is an array of (userid, role, userid, role...)
  464. ''                   where role is a combination of rights (cf RIGHTxxx constants)
  465. '' Out   sSelfSD     Self relative SD allocated and initalized
  466. ''
  467. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  468. Public Function MakeSelfSD(sSelfSD() As Byte, _
  469.         sServer As String, sDomain As String, _
  470.         sAssocUSer As String, _
  471.         ParamArray ACEList() As Variant) As Long
  472. Dim SecDesc As SECURITY_DESCRIPTOR
  473. Dim I As Integer
  474. Dim tACL As ACL
  475. Dim tACCESS_ALLOWED_ACE As ACCESS_ALLOWED_ACE
  476. Dim pSid() As Byte
  477. Dim pACL() As Byte
  478. Dim pACESID() As mySID
  479. Dim Longueur As Long
  480. Dim rc As Long
  481.     
  482.     On Error GoTo SDError
  483.     ' Initializing abolute SD
  484.     rc = InitializeSecurityDescriptor(SecDesc, SECURITY_DESCRIPTOR_REVISION)
  485.     If (rc <> 1) Then
  486.         Err.Raise -12, , "InitializeSecurityDescriptor"
  487.     End If
  488.     
  489.     rc = GetSID(sServer, sDomain, sAssocUSer, pSid)
  490.     If (rc <> 1) Then
  491.         Err.Raise -12, , "GetSID"
  492.     End If
  493.     
  494.     rc = SetSecurityDescriptorOwner(SecDesc, pSid(0), 0)
  495.     If (rc <> 1) Then
  496.         Err.Raise -12, , "SetSecurityDescriptorOwner"
  497.     End If
  498.     
  499.     ' I don't know why we had to do this one, but it works for us
  500.     rc = SetSecurityDescriptorGroup(SecDesc, pSid(0), 0)
  501.     If (rc <> 1) Then
  502.         Err.Raise -12, , "SetSecurityDescriptorGroup"
  503.     End If
  504.     
  505.     ' Getting SIDs for all the other users, and computing of total ACL length
  506.     ' (famous formula from MSDN)
  507.     Longueur = Len(tACL)
  508.     ReDim Preserve pACESID((UBound(ACEList) - 1) / 2)
  509.     For I = 0 To UBound(pACESID)
  510.         If 1 <> GetSID(sServer, sDomain, CStr(ACEList(2 * I)), pACESID(I).x) Then Err.Raise -12, , "GetSID"
  511.         Longueur = Longueur + GetLengthSid(pACESID(I).x(0)) + Len(tACCESS_ALLOWED_ACE) - 4
  512.     Next I
  513.     
  514.     ' Initalizing ACL, and adding one ACE for each user
  515.     ReDim pACL(Longueur)
  516.     If 1 <> InitializeAcl(pACL(0), Longueur, ACL_REVISION) Then Err.Raise -12, , "InitializeAcl"
  517.     For I = 0 To UBound(pACESID)
  518.         If 1 <> AddAccessAllowedAce(pACL(0), ACL_REVISION, CLng(ACEList(2 * I + 1)), pACESID(I).x(0)) Then Err.Raise -12, , "AddAccessAllowedAce"
  519.     Next I
  520.     If 1 <> SetSecurityDescriptorDacl(SecDesc, 1, pACL(0), 0) Then Err.Raise -12, , "SetSecurityDescriptorDacl"
  521.     
  522.     ' Allocation and conversion in the self relative SD
  523.     Longueur = GetSecurityDescriptorLength(SecDesc)
  524.     ReDim sSelfSD(Longueur)
  525.     If 1 <> MakeSelfRelativeSD(SecDesc, sSelfSD(0), Longueur) Then Err.Raise -12, , "MakeSelfRelativeSD"
  526.     MakeSelfSD = 1
  527.     Exit Function
  528.  
  529. SDError:
  530.     MakeSelfSD = 0
  531. End Function
  532.  
  533. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  534. ''
  535. '' GetSID -- gets the Security IDentifier for the specified account name
  536. ''
  537. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  538. Public Function GetSID(sServer As String, sDomain As String, sUserID As String, pSid() As Byte) As Long
  539. Dim rc As Long
  540. Dim pDomain() As Byte
  541. Dim lSID As Long, lDomain As Long
  542. Dim sSystem As String, sAccount As String
  543.  
  544.     On Error GoTo SIDError
  545.     
  546.     ReDim pSid(0)
  547.     ReDim pDomain(0)
  548.     lSID = 0
  549.     lDomain = 0
  550.     sSystem = "\\" & sServer
  551.     sAccount = sDomain & "\" & sUserID
  552.     
  553.     rc = LookupAccountName(sSystem, sAccount, pSid(0), lSID, pDomain(0), lDomain, SidTypeUser)
  554.     
  555.     If (rc = 0) Then
  556.         ReDim pSid(lSID)
  557.         ReDim pDomain(lDomain + 1)
  558.  
  559.         rc = LookupAccountName(sSystem, sAccount, pSid(0), lSID, pDomain(0), lDomain, SidTypeUser)
  560.         If (rc = 0) Then
  561.             GoTo SIDError
  562.         End If
  563.     End If
  564.     
  565.     GetSID = 1
  566.     Exit Function
  567.  
  568. SIDError:
  569.     GetSID = 0
  570. End Function
  571.  
  572. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  573. ''
  574. '' Get_Primary_DCName -- gets the name of the Primary Domain Controller for
  575. ''                       the NT domain
  576. ''
  577. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  578. Function Get_Primary_DCName(ByVal MName As String, ByVal DName As String) As String
  579.  
  580. Dim Result As Long
  581. Dim DCName As String
  582. Dim DCNPtr As Long
  583. Dim DNArray() As Byte
  584. Dim MNArray() As Byte
  585. Dim DCNArray(100) As Byte
  586.  
  587.     MNArray = MName & vbNullChar
  588.     DNArray = DName & vbNullChar
  589.     Result = NetGetDCName(MNArray(0), DNArray(0), DCNPtr)
  590.     If Result <> 0 Then
  591.         Exit Function
  592.     End If
  593.     Result = PtrToStr(DCNArray(0), DCNPtr)
  594.     Result = NetApiBufferFree(DCNPtr)
  595.     DCName = DCNArray()
  596.     Get_Primary_DCName = DCName
  597.     
  598. End Function
  599.  
  600. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  601. ''
  602. '' Get_Exchange_Sid -- gets the NT user's Security IDentifier for Exchange
  603. ''
  604. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  605. Sub Get_Exchange_Sid(strNTDomain As String, strNTAccount As String, rbSID() As Byte)
  606.  
  607. Dim pSid(512) As Byte
  608. Dim pDomain(512) As Byte
  609. Dim IReturn As Long
  610. Dim I As Integer
  611.  
  612.     IReturn = LookupAccountName(Get_Primary_DCName("", strNTDomain), strNTAccount, pSid(0), 512, pDomain, 512, 1)
  613.     
  614.     For I = 0 To GetLengthSid(pSid(0)) - 1
  615.         rbSID(2 * I) = AscB(Hex$(pSid(I) \ &H10))
  616.         rbSID(2 * I + 1) = AscB(Hex$(pSid(I) Mod &H10))
  617.     Next I
  618. End Sub
  619.