VB+AD: VB script does't fill attribute fields in "Organization" section of contact in AD

Question

Greetings.
Trying to make contacts from users of AD with VB script. Script makes them well, but doesn't fill "Organization" and other sections attributes from users, except "General". As I see it doesn't get that info from query.

'================================================================================================
Option Explicit
On error resume next

Dim objRootDSE, strDNSDomain, strBase, strDomain
Dim adoCommand, adoConnection, objRS, strFilter, strAttributes, strQuery
Dim objExcel, strName, strPhone, strMail, strMobile, strCountry, strCity, strCompany, strDepartment, strTitle, strIpPhone
Dim strGivenName, strSN, strDisplayName, strItem
Dim objRoot, objOU, objDomain, objContact
Dim strDNS, strContainer, strContactName, strEmail
Dim UserN, UserD
UserN = ""
UserD = ""

'==================================================================================
'Creating contacts from users
'==================================================================================

strDomain = "ou=users,dc=subdomain,dc=mydomain,dc=com"
Set objRootDSE = GetObject("GC://" & strDomain)
strDNSDomain = objRootDSE.Get("defaultNamingContext")

Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection
strBase = "<GC://" & strDomain & ">"

strFilter = "(&(objectCategory=person)(objectClass=user)(|(useraccountControl=66048)(useraccountcontrol=512)))"
strAttributes = "name,mail,sn,displayname,givenname,telephoneNumber,mobile,ipPhone,department,title,Company"

strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"

adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 1000
adoCommand.Properties("Timeout") = 307
adoCommand.Properties("Cache Results") = False
Set objRS = adoCommand.Execute

Do Until objRS.EOF
    strName = objRS.Fields("name").Value
    strMail = objRS.Fields("mail").Value
    strCompany = objRS.Fields("Company").Value
    strIpPhone = objRS.Fields("ipPhone").Value
    strPhone = objRS.Fields("telephoneNumber").Value
    strMobile = objRS.Fields("mobilePhone").Value
    strDepartment = objRS.Fields("department").Value
    strTitle = objRS.Fields("title").Value
    strGivenName=objRS.Fields("givenname").Value
    strSN=objRS.Fields("sn").Value
    strDisplayName=objRS.Fields("displayname").Value

    if strMail<>"" then
        Err.Clear
        strContainer = "OU=Subdivision,OU=Addressbook"
        strContactName = "cn=" & strName
        strEmail = strMail 

        Set objRoot = GetObject("LDAP://RootDSE")
        strDNS = objRoot.Get("defaultNamingContext")
        Set objDomain = GetObject("LDAP://" & strDNS)

        Set objOU = GetObject("LDAP://"& strContainer & "," & strDNS)
        Set objContact = objOU.Create("contact", strContactName)
        objContact.Put "Mail", strEmail
        if strGivenName <> "" then objContact.Put "givenname", strGivenName
        if strSN <> "" then objContact.Put "sn", strSN
        if strDisplayName <> "" then objContact.Put "displayname", strDisplayName
        if strPhone <> "" then objContact.Put "telephoneNumber", strPhone
        if strOtherPhone <> "" then objContact.Put "otherTelephone", strOtherPhone
        if strMobile <> "" then objContact.Put "mobile", strMobile
        if strCompany <> "" then objContact.Put "company", strCompany
        if strDepartment <> "" then objContact.Put "department", strDepartment
        if strTitle <> "" then objContact.Put "title", strTitle
        objContact.SetInfo
    end if

    objRS.MoveNext
Loop

Set objRS = Nothing
Set adoCommand = Nothing
Set adoConnection = Nothing
Set objOU = Nothing
WScript.Quit
'===========================================================================

Can anyone show me the mistake?..