Solved

Code that creates users and contacts. Want to restrict to create just contacts

Posted on 2011-09-13
7
456 Views
Last Modified: 2012-08-14
Hi,
Code that creates users and contacts. Want to restrict to create just contacts

Can anyone remove the other code and give me a way to just create the contact with an external email address added into it

Thanks
'====================
If LCase(Right(Wscript.FullName, 11)) = "wscript.exe" Then
      strPath = Wscript.ScriptFullName
      strCommand = "%comspec% /k cscript  """ & strPath & """"
      Set objShell = CreateObject("Wscript.Shell")
      objShell.Run(strCommand), 1, True
      Wscript.Quit
End If

' Bind to Active Directory.
Set objRootLDAP = GetObject("LDAP://rootDSE")

' CONFIGURATION PARAMETERS FOR THE SCRIPT
' ******** USERS *************
strExcelFile = Replace(WScript.ScriptFullName, WScript.ScriptName, "") & "Users_and_Contacts_Sharath.xls"

strUserOUPath = "OU=contacts,OU=User Accounts,OU=UI,OU=Offices," & objRootLDAP.Get("defaultNamingContext")
strPassword = "Passw@rd1234^&%"
' ******** CONTACTS *************

strContactOUPath = "OU=contacts,OU=User Accounts,OU=UI,OU=Offices," & objRootLDAP.Get("defaultNamingContext")
' END CONFIGURATION PARAMETERS

Const xlUp = -4162
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Const ADS_PROPERTY_CLEAR = 1
Const ADS_PROPERTY_UPDATE = 2
Const ADS_PROPERTY_APPEND = 3
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Open strExcelFile

Set objNetwork = CreateObject("WScript.Network")
strDomainName = objNetwork.UserDomain

For intRow = 2 To objExcel.ActiveSheet.Cells(65536, "A").End(xlUp).Row

      strFirstName = Trim(objExcel.ActiveSheet.Cells(intRow, "A").Value)
      strLastName = Trim(objExcel.ActiveSheet.Cells(intRow, "B").Value)
      strFullName = Trim(objExcel.ActiveSheet.Cells(intRow, "C").Value)
      strUserNameHeading = Mid(Trim(objExcel.ActiveSheet.Cells(1, "D").Value), InStr(Trim(objExcel.ActiveSheet.Cells(1, "D").Value), "@"),Len(Trim(objExcel.ActiveSheet.Cells(1, "D").Value)) - InStr(Trim(objExcel.ActiveSheet.Cells(1, "D").Value), "@"))
      strUserName = Trim(objExcel.ActiveSheet.Cells(intRow, "D").Value) & strUserNameHeading
      strEmail = Trim(objExcel.ActiveSheet.Cells(intRow, "E").Value)
      strGroups = Trim(objExcel.ActiveSheet.Cells(intRow, "F").Value)
      strDescription = Trim(objExcel.ActiveSheet.Cells(intRow, "G").Value)
      strAlias = strFirstName & strLastName
      strOffice = Trim(objExcel.ActiveSheet.Cells(intRow, "H").Value)
      strMobile = Trim(objExcel.ActiveSheet.Cells(intRow, "I").Value)
      strTitle = Trim(objExcel.ActiveSheet.Cells(intRow, "J").Value)
      strDepartment = Trim(objExcel.ActiveSheet.Cells(intRow, "K").Value)
      strCompany = Trim(objExcel.ActiveSheet.Cells(intRow, "L").Value)
      strAddress = Trim(objExcel.ActiveSheet.Cells(intRow, "M").Value)
      strCity = Trim(objExcel.ActiveSheet.Cells(intRow, "N").Value)
      strState = Trim(objExcel.ActiveSheet.Cells(intRow, "O").Value)
      strZipCode = Trim(objExcel.ActiveSheet.Cells(intRow, "P").Value)
      strCountry = Trim(objExcel.ActiveSheet.Cells(intRow, "Q").Value)
      strHomePhone = Trim(objExcel.ActiveSheet.Cells(intRow, "R").Value)
      
      'strFirstName = Trim(Left(strFullName, InStrRev(strFullName, " ") - 1))
      'strLastName = Trim(Mid(strFullName, InStrRev(strFullName, " ") + 1))
            
      If strFullName <> "" And strUserName <> "" Then
            
            WScript.Echo "About to create:" & VbCrLf &_
                  strFullName & VbCrLf &_
                  strFirstName & VbCrLf &_
                  strLastName & VbCrLf & _
                  strUserName & VbCrLf &_
                  strPassword & VbCrLf &_
                  "LDAP://" & strUserOUPath
                  
            ' This will add the user to eg. Domain.Local\Users
            Set objContainer = GetObject("LDAP://" & strUserOUPath) 
            
            ' Check if the user already exists
            On Error Resume Next
            
            Set objNewUser = GetObject("LDAP://cn=" & strFullName & "," & strUserOUPath)
            If Err.Number = 0 Then
                  WScript.Echo "User " & strFullName & " already exists."
                  On Error GoTo 0
            Else
                  Err.Clear
                  On Error GoTo 0
                  
                  ' Build the actual User.
                  ' Attributes listed here: http://support.microsoft.com/kb/555638
                  Set objNewUser = objContainer.Create("User", "cn= " & strFullName)
                  'objNewUser.Put "userPrincipalName", strUserName & "@" & Replace(Replace(objRootLDAP.Get("defaultNamingContext"), ",", "."), "DC=", "")
                  If InStr(strUserName, "@") > 0 Then
                        arrDomUserName = Split(strUserName, "@")
                        strUserName = arrDomUserName(0)
                        strSuffix = arrDomUserName(1)
                  Else
                        strUserName = strUserName
                        strSuffix = Replace(Replace(objRootLDAP.Get("defaultNamingContext"), ",", "."), "DC=", "")
                  End If
                  objNewUser.Put "userPrincipalName", strUserName & "@" & strSuffix
                  objNewUser.Put "sAMAccountName", strUserName
                  objNewUser.Put "givenName", strFirstName
                  objNewUser.Put "sn", strLastName
                  objNewUser.Put "displayName", strFullName
                  'If strEmail <> "" Then objNewUser.Put "mail", strEmail
                  If strDescription <> "" Then objNewUser.Put "description", strDescription
                  If strOffice <> "" Then objNewUser.Put "physicalDeliveryOfficeName", strOffice
                  If strMobile <> "" Then objNewUser.Put "mobile", strMobile
                  If strTitle <> "" Then objNewUser.Put "title", strTitle
                  If strDepartment <> "" Then objNewUser.Put "department", strDepartment
                  If strCompany <> "" Then objNewUser.Put "company", strCompany
                  If strAddress <> "" Then objNewUser.Put "streetAddress", strAddress
                  If strCity <> "" Then objNewUser.Put "l", strCity
                  If strState <> "" Then objNewUser.Put "st", strState
                  If strZipCode <> "" Then objNewUser.Put "postalCode", strZipCode
                  ' ISO Country Code list: http://www.iso.org/iso/english_country_names_and_code_elements
                  If strCountry <> "" Then objNewUser.Put "c", strCountry
                  If strHomePhone <> "" Then objNewUser.Put "homePhone", strHomePhone
                  objNewUser.SetInfo
                  objNewUser.SetPassword strPassword
                  objNewUser.AccountDisabled = False
                  objNewUser.SetInfo
                  
                  intUserAccountControl = objNewUser.Get("userAccountControl") 
                   If objNewUser.userAccountControl And ADS_UF_DONT_EXPIRE_PASSWD Then
                        objNewUser.Put "userAccountControl", objNewUser.userAccountControl XOR ADS_UF_DONT_EXPIRE_PASSWD
                        objNewUser.SetInfo
                  End If
                
                  If strGroups <> "" Then
                        arrGroups = Split(strGroups, ":")
                        For Each strGroupName In arrGroups
                              strGroupPath = Get_LDAP_User_Properties("group", "cn", strGroupName, "adsPath")
                              If strGroupPath <> "" Then
                                    Set objGroup = GetObject(strGroupPath)
                                    On Error Resume Next
                                    objGroup.Add objNewUser.AdsPath
                                    If Err.Number <> 0 Then
                                          WScript.Echo Err.Number & ": " & Err.Description & " - cannot add " & objNewUser.AdsPath & " to " & objGroup.adspath
                                          Err.Clear
                                          boolUserAdded = False
                                          arrSid = objNewUser.objectSid
                                          strSidHex = OctetToHexStr(arrSid)
                                          strSidDec = HexStrToDecStr(strSidHex)
                                          objGroup.Add "LDAP://<SID=" & strSidDec & ">"
                                          If Err.Number <> 0 Then
                                                WScript.Echo Err.Number & ": " & Err.Description & " - cannot add " & strSidDec & " to " & objGroup.adspath
                                                Err.Clear
                                                boolUserAdded = False
                                                objGroup.Add "LDAP://CN=" & strSidDec & ",CN=ForeignSecurityPrincipals," & Mid(objNewUser.AdsPath, InStr(objNewUser.AdsPath, "DC="))
                                                If Err.Number <> 0 Then
                                                      WScript.Echo Err.Number & ": " & Err.Description & " - cannot add LDAP://CN=" & strSidDec & ",CN=ForeignSecurityPrincipals," & Mid(objNewUser.AdsPath, InStr(objNewUser.AdsPath, "DC=")) & " to " & objGroup.adspath
                                                      Err.Clear
                                                      boolUserAdded = False
                                                Else
                                                      boolUserAdded = True
                                                End If
                                          Else
                                                boolUserAdded = True
                                          End If
                                    Else
                                          boolUserAdded = True
                                    End If
                                    On Error GoTo 0
                                    If boolUserAdded = True Then
                                          WScript.Echo "User " & strUserName & " was added to the group " & objGroup.AdsPath
                                    Else
                                          WScript.Echo "Could not add user " & strUserName & " to the group " & strGroupName
                                    End If
                                    Set objGroup = Nothing
                              Else
                                    WScript.Echo "Could not locate the group " & strGroupName & " to add the user " & objNewUser.samAccountName & " to."
                              End If
                        Next
                  End If
            End If
            
            ' ********** CONTACT CREATION *************
            Set objContactsContainer = GetObject("LDAP://" & strContactOUPath)
            
            ' Check if the contact already exists
            On Error Resume Next
            
            Set objNewContact = GetObject("LDAP://cn=" & strFullName & "," & strContactOUPath)
            If Err.Number = 0 Then
                  WScript.Echo "Contact " & strFullName & " already exists."
                  On Error GoTo 0
            Else
                  Err.Clear
                  On Error GoTo 0

                  ' Build the actual Contact.
                  Set objContact = objContactsContainer.Create("Contact","cn=" & strFullName)
                  objContact.Put "Mail", strEmail
                  objContact.Put "givenName", strFirstName
                  objContact.Put "sn", strLastName
                  objContact.Put "displayName", strFullName
                  objContact.Put "mailNickname", Cstr(strAlias)
                  objContact.Put "targetAddress", "SMTP:" & strEmail
                  On Error Resume Next
                  objGroup.PutEx ADS_PROPERTY_CLEAR, "proxyAddresses", 0
                  objContact.SetInfo
                  On Error GoTo 0
                  objContact.PutEx ADS_PROPERTY_APPEND, "proxyAddresses", Array("SMTP:" & strEmail,"SMTP:" & strAlias & "@" & Mid(Replace(objRootLDAP.Get("defaultNamingContext"), "DC=", "."), 2))
                  objContact.SetInfo
                  If strOffice <> "" Then objContact.Put "physicalDeliveryOfficeName", strOffice
                  If strDescription <> "" Then objContact.Put "description", strDescription
                  If strMobile <> "" Then objContact.Put "mobile", strMobile
                  If strTitle <> "" Then objContact.Put "title", strTitle
                  If strDepartment <> "" Then objContact.Put "department", strDepartment
                  If strCompany <> "" Then objContact.Put "company", strCompany
                  If strAddress <> "" Then objContact.Put "streetAddress", strAddress
                  If strCity <> "" Then objContact.Put "l", strCity
                  If strState <> "" Then objContact.Put "st", strState
                  If strZipCode <> "" Then objContact.Put "postalCode", strZipCode
                  ' ISO Country Code list: http://www.iso.org/iso/english_country_names_and_code_elements
                  If strCountry <> "" Then objContact.Put "c", strCountry
                  If strHomePhone <> "" Then objContact.Put "homePhone", strHomePhone
                  
                  objContact.SetInfo
                  WScript.Echo "Contact " & strAlias & " created."
            End If
      End If
Next

WScript.Echo "Done"
objExcel.ActiveWorkbook.Close False
objExcel.Quit
Set objExcel = Nothing

Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
      
      If InStr(strObjectToGet, "\") > 0 Then
            arrGroupBits = Split(strObjectToGet, "\")
            strDC = arrGroupBits(0)
            strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
            strObjectToGet = arrGroupBits(1)
      Else
            Set objRootDSE = GetObject("LDAP://RootDSE")
            'strDNSDomain = objRootDSE.Get("defaultNamingContext")
            strDNSDomain = objRootDSE.Get("RootDomainNamingContext")
      End If

      strBase = "<LDAP://" & strDNSDomain & ">"
      ' Setup ADO objects.
      Set adoCommand = CreateObject("ADODB.Command")
      Set adoConnection = CreateObject("ADODB.Connection")
      adoConnection.Provider = "ADsDSOObject"
      adoConnection.Open "Active Directory Provider"
      adoCommand.ActiveConnection = adoConnection

 
      ' Filter on user objects.
      'strFilter = "(&(objectCategory=person)(objectClass=user))"
      strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"

      ' Comma delimited list of attribute values to retrieve.
      strAttributes = strCommaDelimProps
      arrProperties = Split(strCommaDelimProps, ",")

      ' Construct the LDAP syntax query.
      strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
      adoCommand.CommandText = strQuery
      adoCommand.Properties("Page Size") = 100
      adoCommand.Properties("Timeout") = 30
      adoCommand.Properties("Cache Results") = False

      ' Run the query.
      On Error Resume Next
      Set adoRecordset = adoCommand.Execute
      If Err.Number = 0 Then
            On Error GoTo 0
            ' Enumerate the resulting recordset.
            Do Until adoRecordset.EOF
                ' Retrieve values and display.    
                For intCount = LBound(arrProperties) To UBound(arrProperties)
                      If strDetails = "" Then
                            strDetails = adoRecordset.Fields(intCount).Value
                      Else
                            strDetails = strDetails & VbCrLf & adoRecordset.Fields(intCount).Value
                      End If
                Next
                ' Move to the next record in the recordset.
                adoRecordset.MoveNext
            Loop
      
            ' Clean up.
            adoRecordset.Close
        Else
              Err.Clear
              On Error GoTo 0
            strDetails = ""
        End If
      adoConnection.Close
      If InStr(strDNSDomain, "/") > 0 Then
            Get_LDAP_User_Properties = Replace(strDetails, Left(strDNSDomain, InStr(strDNSDomain, "/")), "")
      Else
            Get_LDAP_User_Properties = strDetails
      End If

End Function

'Working VBScript Active Directory Binary SID conversion to String SID
' Source: http://forums.techarena.in/showthread.php?t=588078
'Function to convert OctetString (byte array) to Hex string.
Function OctetToHexStr(arrbytOctet)
Dim k
OctetToHexStr = ""
For k = 1 To Lenb(arrbytOctet)
OctetToHexStr = OctetToHexStr & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
Next
End Function

Function HexStrToDecStr(strSid)
' Function to convert Hex string Sid to Decimal string (SDDL) Sid.


' SID anatomy:
' Byte Position
' 0 : SID Structure Revision Level (SRL)
' 1 : Number of Subauthority/Relative Identifier
' 2-7 : Identifier Authority Value (IAV) [48 bits]
' 8-x : Variable number of Subauthority or Relative Identifier (RID) [32 bits]
'
' Example:
'
' <Domain/Machine>\Administrator
' Pos : 0 | 1 | 2 3 4 5 6 7 | 8 9 10 11 | 12 13 14 15 | 16 17 18 19 | 20 21 22 23 | 24 25 26 27
' Value: 01 | 05 | 00 00 00 00 00 05 | 15 00 00 00 | 06 4E 7D 7F | 11 57 56 7A | 04 11 C5 20 | F4 01 00 00
' str : S- 1 | | -5 | -21 | -2138918406 | -2052478737 | -549785860 | -500


Const BYTES_IN_32BITS = 4
Const SRL_BYTE = 0
Const IAV_START_BYTE = 2
Const IAV_END_BYTE = 7
Const RID_START_BYTE = 8
Const MSB = 3 'Most significant byte
Const LSB = 0 'Least significant byte


Dim arrbytSid, lngTemp, base, offset, i


ReDim arrbytSid(Len(strSid)/2 - 1)


' Convert hex string into integer array
For i = 0 To UBound(arrbytSid)
      arrbytSid(i) = CInt("&H" & Mid(strSid, 2 * i + 1, 2))
Next


' Add SRL number
HexStrToDecStr = "S-" & arrbytSid(SRL_BYTE)


' Add Identifier Authority Value
lngTemp = 0
For i = IAV_START_BYTE To IAV_END_BYTE
      lngTemp = lngTemp * 256 + arrbytSid(i)
Next
HexStrToDecStr = HexStrToDecStr & "-" & CStr(lngTemp)


' Add a variable number of 32-bit subauthority or
' relative identifier (RID) values.
' Bytes are in reverse significant order.
' i.e. HEX 01 02 03 04 => HEX 04 03 02 01
' = (((0 * 256 + 04) * 256 + 03) * 256 + 02) * 256 + 01
' = DEC 67305985
For base = RID_START_BYTE To UBound(arrbytSid) Step BYTES_IN_32BITS
      lngTemp = 0
      For offset = MSB to LSB Step -1
            lngTemp = lngTemp * 256 + arrbytSid(base + offset)
      Next
      HexStrToDecStr = HexStrToDecStr & "-" & CStr(lngTemp)
Next
End Function ' HexStrToDecStr
'=========================

Open in new window

0
Comment
Question by:bsharath
  • 4
  • 3
7 Comments
 
LVL 65

Expert Comment

by:RobSampson
ID: 36533767
Hi Sharath,

This version should create the contact only.

Regards,

Rob.
'====================
If LCase(Right(Wscript.FullName, 11)) = "wscript.exe" Then
      strPath = Wscript.ScriptFullName
      strCommand = "%comspec% /k cscript  """ & strPath & """"
      Set objShell = CreateObject("Wscript.Shell")
      objShell.Run(strCommand), 1, True
      Wscript.Quit
End If

' Bind to Active Directory.
Set objRootLDAP = GetObject("LDAP://rootDSE")

' CONFIGURATION PARAMETERS FOR THE SCRIPT
' ******** USERS *************
strExcelFile = Replace(WScript.ScriptFullName, WScript.ScriptName, "") & "Contacts_Sharath.xls"

' ******** CONTACTS *************
strContactOUPath = "OU=contacts,OU=User Accounts,OU=UI,OU=Offices," & objRootLDAP.Get("defaultNamingContext")
strPassword = "Passw@rd1234^&%"
' END CONFIGURATION PARAMETERS

Const xlUp = -4162
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Const ADS_PROPERTY_CLEAR = 1
Const ADS_PROPERTY_UPDATE = 2
Const ADS_PROPERTY_APPEND = 3
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Open strExcelFile

Set objNetwork = CreateObject("WScript.Network")
strDomainName = objNetwork.UserDomain

For intRow = 2 To objExcel.ActiveSheet.Cells(65536, "A").End(xlUp).Row

      strFirstName = Trim(objExcel.ActiveSheet.Cells(intRow, "A").Value)
      strLastName = Trim(objExcel.ActiveSheet.Cells(intRow, "B").Value)
      strFullName = Trim(objExcel.ActiveSheet.Cells(intRow, "C").Value)
      strUserNameHeading = Mid(Trim(objExcel.ActiveSheet.Cells(1, "D").Value), InStr(Trim(objExcel.ActiveSheet.Cells(1, "D").Value), "@"),Len(Trim(objExcel.ActiveSheet.Cells(1, "D").Value)) - InStr(Trim(objExcel.ActiveSheet.Cells(1, "D").Value), "@"))
      strUserName = Trim(objExcel.ActiveSheet.Cells(intRow, "D").Value) & strUserNameHeading
      strEmail = Trim(objExcel.ActiveSheet.Cells(intRow, "E").Value)
      strGroups = Trim(objExcel.ActiveSheet.Cells(intRow, "F").Value)
      strDescription = Trim(objExcel.ActiveSheet.Cells(intRow, "G").Value)
      strAlias = strFirstName & strLastName
      strOffice = Trim(objExcel.ActiveSheet.Cells(intRow, "H").Value)
      strMobile = Trim(objExcel.ActiveSheet.Cells(intRow, "I").Value)
      strTitle = Trim(objExcel.ActiveSheet.Cells(intRow, "J").Value)
      strDepartment = Trim(objExcel.ActiveSheet.Cells(intRow, "K").Value)
      strCompany = Trim(objExcel.ActiveSheet.Cells(intRow, "L").Value)
      strAddress = Trim(objExcel.ActiveSheet.Cells(intRow, "M").Value)
      strCity = Trim(objExcel.ActiveSheet.Cells(intRow, "N").Value)
      strState = Trim(objExcel.ActiveSheet.Cells(intRow, "O").Value)
      strZipCode = Trim(objExcel.ActiveSheet.Cells(intRow, "P").Value)
      strCountry = Trim(objExcel.ActiveSheet.Cells(intRow, "Q").Value)
      strHomePhone = Trim(objExcel.ActiveSheet.Cells(intRow, "R").Value)
      
      'strFirstName = Trim(Left(strFullName, InStrRev(strFullName, " ") - 1))
      'strLastName = Trim(Mid(strFullName, InStrRev(strFullName, " ") + 1))
            
      If strFullName <> "" And strUserName <> "" Then
            
            WScript.Echo "About to create:" & VbCrLf &_
                  strFullName & VbCrLf &_
                  strFirstName & VbCrLf &_
                  strLastName & VbCrLf & _
                  strUserName & VbCrLf &_
                  strPassword & VbCrLf &_
                  "LDAP://" & strContactOUPath
                              
            ' ********** CONTACT CREATION *************
            Set objContactsContainer = GetObject("LDAP://" & strContactOUPath)
            
            ' Check if the contact already exists
            On Error Resume Next
            
            Set objNewContact = GetObject("LDAP://cn=" & strFullName & "," & strContactOUPath)
            If Err.Number = 0 Then
                  WScript.Echo "Contact " & strFullName & " already exists."
                  On Error GoTo 0
            Else
                  Err.Clear
                  On Error GoTo 0

                  ' Build the actual Contact.
                  Set objContact = objContactsContainer.Create("Contact","cn=" & strFullName)
                  objContact.Put "Mail", strEmail
                  objContact.Put "givenName", strFirstName
                  objContact.Put "sn", strLastName
                  objContact.Put "displayName", strFullName
                  objContact.Put "mailNickname", Cstr(strAlias)
                  objContact.Put "targetAddress", "SMTP:" & strEmail
                  On Error Resume Next
                  objGroup.PutEx ADS_PROPERTY_CLEAR, "proxyAddresses", 0
                  objContact.SetInfo
                  On Error GoTo 0
                  objContact.PutEx ADS_PROPERTY_APPEND, "proxyAddresses", Array("SMTP:" & strEmail,"SMTP:" & strAlias & "@" & Mid(Replace(objRootLDAP.Get("defaultNamingContext"), "DC=", "."), 2))
                  objContact.SetInfo
                  If strOffice <> "" Then objContact.Put "physicalDeliveryOfficeName", strOffice
                  If strDescription <> "" Then objContact.Put "description", strDescription
                  If strMobile <> "" Then objContact.Put "mobile", strMobile
                  If strTitle <> "" Then objContact.Put "title", strTitle
                  If strDepartment <> "" Then objContact.Put "department", strDepartment
                  If strCompany <> "" Then objContact.Put "company", strCompany
                  If strAddress <> "" Then objContact.Put "streetAddress", strAddress
                  If strCity <> "" Then objContact.Put "l", strCity
                  If strState <> "" Then objContact.Put "st", strState
                  If strZipCode <> "" Then objContact.Put "postalCode", strZipCode
                  ' ISO Country Code list: http://www.iso.org/iso/english_country_names_and_code_elements
                  If strCountry <> "" Then objContact.Put "c", strCountry
                  If strHomePhone <> "" Then objContact.Put "homePhone", strHomePhone
                  
                  objContact.SetInfo
                  WScript.Echo "Contact " & strAlias & " created."
            End If
      End If
Next

WScript.Echo "Done"
objExcel.ActiveWorkbook.Close False
objExcel.Quit
Set objExcel = Nothing

Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
      
      If InStr(strObjectToGet, "\") > 0 Then
            arrGroupBits = Split(strObjectToGet, "\")
            strDC = arrGroupBits(0)
            strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
            strObjectToGet = arrGroupBits(1)
      Else
            Set objRootDSE = GetObject("LDAP://RootDSE")
            'strDNSDomain = objRootDSE.Get("defaultNamingContext")
            strDNSDomain = objRootDSE.Get("RootDomainNamingContext")
      End If

      strBase = "<LDAP://" & strDNSDomain & ">"
      ' Setup ADO objects.
      Set adoCommand = CreateObject("ADODB.Command")
      Set adoConnection = CreateObject("ADODB.Connection")
      adoConnection.Provider = "ADsDSOObject"
      adoConnection.Open "Active Directory Provider"
      adoCommand.ActiveConnection = adoConnection

 
      ' Filter on user objects.
      'strFilter = "(&(objectCategory=person)(objectClass=user))"
      strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"

      ' Comma delimited list of attribute values to retrieve.
      strAttributes = strCommaDelimProps
      arrProperties = Split(strCommaDelimProps, ",")

      ' Construct the LDAP syntax query.
      strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
      adoCommand.CommandText = strQuery
      adoCommand.Properties("Page Size") = 100
      adoCommand.Properties("Timeout") = 30
      adoCommand.Properties("Cache Results") = False

      ' Run the query.
      On Error Resume Next
      Set adoRecordset = adoCommand.Execute
      If Err.Number = 0 Then
            On Error GoTo 0
            ' Enumerate the resulting recordset.
            Do Until adoRecordset.EOF
                ' Retrieve values and display.    
                For intCount = LBound(arrProperties) To UBound(arrProperties)
                      If strDetails = "" Then
                            strDetails = adoRecordset.Fields(intCount).Value
                      Else
                            strDetails = strDetails & VbCrLf & adoRecordset.Fields(intCount).Value
                      End If
                Next
                ' Move to the next record in the recordset.
                adoRecordset.MoveNext
            Loop
      
            ' Clean up.
            adoRecordset.Close
        Else
              Err.Clear
              On Error GoTo 0
            strDetails = ""
        End If
      adoConnection.Close
      If InStr(strDNSDomain, "/") > 0 Then
            Get_LDAP_User_Properties = Replace(strDetails, Left(strDNSDomain, InStr(strDNSDomain, "/")), "")
      Else
            Get_LDAP_User_Properties = strDetails
      End If

End Function

'Working VBScript Active Directory Binary SID conversion to String SID
' Source: http://forums.techarena.in/showthread.php?t=588078
'Function to convert OctetString (byte array) to Hex string.
Function OctetToHexStr(arrbytOctet)
Dim k
OctetToHexStr = ""
For k = 1 To Lenb(arrbytOctet)
OctetToHexStr = OctetToHexStr & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
Next
End Function

Function HexStrToDecStr(strSid)
' Function to convert Hex string Sid to Decimal string (SDDL) Sid.


' SID anatomy:
' Byte Position
' 0 : SID Structure Revision Level (SRL)
' 1 : Number of Subauthority/Relative Identifier
' 2-7 : Identifier Authority Value (IAV) [48 bits]
' 8-x : Variable number of Subauthority or Relative Identifier (RID) [32 bits]
'
' Example:
'
' <Domain/Machine>\Administrator
' Pos : 0 | 1 | 2 3 4 5 6 7 | 8 9 10 11 | 12 13 14 15 | 16 17 18 19 | 20 21 22 23 | 24 25 26 27
' Value: 01 | 05 | 00 00 00 00 00 05 | 15 00 00 00 | 06 4E 7D 7F | 11 57 56 7A | 04 11 C5 20 | F4 01 00 00
' str : S- 1 | | -5 | -21 | -2138918406 | -2052478737 | -549785860 | -500


Const BYTES_IN_32BITS = 4
Const SRL_BYTE = 0
Const IAV_START_BYTE = 2
Const IAV_END_BYTE = 7
Const RID_START_BYTE = 8
Const MSB = 3 'Most significant byte
Const LSB = 0 'Least significant byte


Dim arrbytSid, lngTemp, base, offset, i


ReDim arrbytSid(Len(strSid)/2 - 1)


' Convert hex string into integer array
For i = 0 To UBound(arrbytSid)
      arrbytSid(i) = CInt("&H" & Mid(strSid, 2 * i + 1, 2))
Next


' Add SRL number
HexStrToDecStr = "S-" & arrbytSid(SRL_BYTE)


' Add Identifier Authority Value
lngTemp = 0
For i = IAV_START_BYTE To IAV_END_BYTE
      lngTemp = lngTemp * 256 + arrbytSid(i)
Next
HexStrToDecStr = HexStrToDecStr & "-" & CStr(lngTemp)


' Add a variable number of 32-bit subauthority or
' relative identifier (RID) values.
' Bytes are in reverse significant order.
' i.e. HEX 01 02 03 04 => HEX 04 03 02 01
' = (((0 * 256 + 04) * 256 + 03) * 256 + 02) * 256 + 01
' = DEC 67305985
For base = RID_START_BYTE To UBound(arrbytSid) Step BYTES_IN_32BITS
      lngTemp = 0
      For offset = MSB to LSB Step -1
            lngTemp = lngTemp * 256 + arrbytSid(base + offset)
      Next
      HexStrToDecStr = HexStrToDecStr & "-" & CStr(lngTemp)
Next
End Function ' HexStrToDecStr
'=========================

Open in new window

0
 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
ID: 36533846
You may need to change this:
                  objContact.PutEx ADS_PROPERTY_APPEND, "proxyAddresses", Array("SMTP:" & strEmail,"SMTP:" & strAlias & "@" & Mid(Replace(objRootLDAP.Get("defaultNamingContext"), "DC=", "."), 2))

to
                  objContact.PutEx ADS_PROPERTY_APPEND, "proxyAddresses", Array("SMTP:" & strEmail,"SMTP:" & strAlias & "@yourdomain.com"

if you have a different address suffix to your domain name.

If you want to hide the contact from the GAL, add this:
                  objContact.MSExchHideFromAddressLists = True

above this:
                  objContact.SetInfo

Regards,

Rob.
0
 
LVL 11

Author Comment

by:bsharath
ID: 36533852
Will i get the x400 and can alias have a special character
0
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
LVL 65

Expert Comment

by:RobSampson
ID: 36533885
If you want an X400 address, change this:
                  objContact.PutEx ADS_PROPERTY_APPEND, "proxyAddresses", Array("SMTP:" & strEmail,"SMTP:" & strAlias & "@yourdomain.com"


to this
                  objContact.PutEx ADS_PROPERTY_APPEND, "proxyAddresses", Array("SMTP:" & strEmail,"smtp:" & strAlias & "@yourdomain.com","x400:" & strAlias & "@yourdomain.com")

I don't know whether it can have a special character....I doubt it though....

Rob.
0
 
LVL 11

Author Comment

by:bsharath
ID: 36533899
Thanks a lot Rob
0
 
LVL 11

Author Comment

by:bsharath
ID: 36534339
Rob i get this


---------------------------
Windows Script Host
---------------------------
Script:      D:\Set Forwards.vbs
Line:      22
Char:      2
Error:      Subscript out of range: '[number: 1]'
Code:      800A0009
Source:       Microsoft VBScript runtime error

---------------------------
OK  
---------------------------
0
 
LVL 11

Author Comment

by:bsharath
ID: 36534342
Sorry wrong post
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

How to remove superseded packages in windows w60 or w61 installation media (.wim) or online system to prevent unnecessary space. w60 means Windows Vista or Windows Server 2008. w61 means Windows 7 or Windows Server 2008 R2. There are various …
Active Directory replication delay is the cause to many problems.  Here is a super easy script to force Active Directory replication to all sites with by using an elevated PowerShell command prompt, and a tool to verify your changes.
The viewer will learn how to clear a vector as well as how to detect empty vectors in C++.
This video will show you how to get GIT to work in Eclipse.   It will walk you through how to install the EGit plugin in eclipse and how to checkout an existing repository.

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now