[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

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

Posted on 2011-09-13
7
Medium Priority
?
487 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 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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
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

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

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.
A quick Powershell script I wrote to find old program installations and check versions of a specific file across the network.
The goal of the tutorial is to teach the user how to use functions in C++. The video will cover how to define functions, how to call functions and how to create functions prototypes. Microsoft Visual C++ 2010 Express will be used as a text editor an…
In a recent question (https://www.experts-exchange.com/questions/29004105/Run-AutoHotkey-script-directly-from-Notepad.html) here at Experts Exchange, a member asked how to run an AutoHotkey script (.AHK) directly from Notepad++ (aka NPP). This video…
Suggested Courses
Course of the Month18 days, 21 hours left to enroll

834 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