Solved

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

Posted on 2011-09-13
7
461 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
3 Use Cases for Connected Systems

Our Dev teams are like yours. They’re continually cranking out code for new features/bugs fixes, testing, deploying, testing some more, responding to production monitoring events and more. It’s complex. So, we thought you’d like to see what’s working for us.

 
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Convert MSI to MSM 1 49
Windows 2008 Server File need to monitor folder anytime file added, move to Z:\test 10 61
rhino JavaScript import, load 25 69
Problem to open text file 11 74
Batch, VBS, and scripts in general are incredibly useful for repetitive tasks.  Some tasks can take a while to complete and it can be annoying to check back only to discover that your script finished 5 minutes ago.  Some scripts may complete nearly …
There is an easy way, in .NET, to centralize the treatment of all unexpected errors. First of all, instead of launching the application directly in a Form, you need first to write a Sub called Main, in a module. Then, set the Startup Object to th…
The viewer will learn how to use the return statement in functions in C++. The video will also teach the user how to pass data to a function and have the function return data back for further processing.
The viewer will be introduced to the member functions push_back and pop_back of the vector class. The video will teach the difference between the two as well as how to use each one along with its functionality.

867 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

22 Experts available now in Live!

Get 1:1 Help Now