On Error Resume Next
Const ADS_SCOPE_SUBTREE = 2 ' Search target object and all sub levels
Dim objRootDSE : Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = Replace(Replace(objRootDSE.Get("defaultNamingContext"), ",DC=", "."), "DC=", "")
strADsPath = "LDAP://" & objRootDSE.Get("defaultNamingContext")
'Connect to Active Directory
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Dim objOU : Set objOU = GetObject("LDAP://" & TARGET_OU)
Dim objExcel : Set objExcel = CreateObject("Excel.Application")
Dim objWorkbook : Set objWorkbook = objExcel.Workbooks.Open(EXCEL_FILE)
' Start at Row 2, after the header.
Dim intRow : intRow = 2
Do Until objExcel.Cells(intRow, 1).Value = ""
Dim strUserName : strUserName = objExcel.Cells(intRow, 1).Value
Dim strDisplayName : strDisplayName = objExcel.Cells(intRow, 2).Value
Dim strFirstName : strFirstName = objExcel.Cells(intRow, 3).Value
Dim strLastName : strLastName = objExcel.Cells(intRow, 4).Value
Dim strDS : strDS = objExcel.Cells(intRow, 5).Value
'Dim strOffice : strOffice = objExcel.Cells(intRow, 6).Value
Dim strPWD : strPWD = objExcel.Cells(intRow, 7).Value
'Search AD Domain to verify user Common Name does not already exist
objCommand.CommandText = "SELECT distinguishedName FROM '" & strADsPath & _
"' WHERE objectCategory='user' AND cn='" & strDisplayName & "'"
Set objRecordSet = objCommand.Execute
If objRecordSet.EOF Then
Dim objUser : Set objUser = objOU.Create("user", "CN=" & strDisplayName)
objUser.Put "sAMAccountName", strUserName
objUser.Put "userPrincipalName", strUserName & "@" & strDNSDomain
objUser.Put "displayName", strDisplayName
objUser.Put "sn", strLastName
objUser.Put "givenName", strFirstName
objUser.Put "description", strDS
'objUser.Put "physicalDeliveryOfficeName", strOffice
objUser.Put "homeDrive", "X:"
objUser.Put "homeDirectory", "\\shadowcom.local\system\profiles\" & strUsername
objUser.SetInfo
' Separat sektion til import af password til brugerne
objUser.userAccountControl = 512
objUser.SetPassword strPWD
objUser.AccountDisabled = False
objUser.SetInfo
End If
intRow = intRow + 1
Loop
objExcel.ActiveWorkbook.Save EXCEL_FILE
objExcel.ActiveWorkbook.Close
objExcel.Quit
|