Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

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

Posted on 2011-09-13
7
Medium Priority
?
476 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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 2000 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
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 
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

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

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

Go is an acronym of golang, is a programming language developed Google in 2007. Go is a new language that is mostly in the C family, with significant input from Pascal/Modula/Oberon family. Hence Go arisen as low-level language with fast compilation…
When we want to run, execute or repeat a statement multiple times, a loop is necessary. This article covers the two types of loops in Python: the while loop and the for loop.
The goal of the video will be to teach the user the concept of local variables and scope. An example of a locally defined variable will be given as well as an explanation of what scope is in C++. The local variable and concept of scope will be relat…
In this fourth video of the Xpdf series, we discuss and demonstrate the PDFinfo utility, which retrieves the contents of a PDF's Info Dictionary, as well as some other information, including the page count. We show how to isolate the page count in a…
Suggested Courses

609 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