Macro not working for fetching data from Active Directory

[Negi1984]

Hi All,

Recently I changed my laptop and below given macro is not working in it. where as in my old machine it is still working. I cross checked all the references and enable it as per my old machine. I also cross checked with some other guys and they told me to use ADODB.Connection line in below code.

Can anybody help me out how to add the "ADODB.Connection" code in below given code ?

Also When I checked macro line by line items by pressing F8 key its is showing blank in "idapstr" line where as in old machine when using same macro its working fine.

ldapstr = "LDAP://CN=" & signum & ",OU=CA,OU=User,OU=P001,OU=ID,OU=Data,DC=XXXXXXXX,DC=se"
Set x = GetObject(ldapstr)

Public Sub UpdateResourceInfoNew()
    Application.Calculation = xlCalculationManual
    Dim auxDoc As New MSHTML.HTMLDocument, HTMLDoc As MSHTML.HTMLDocument
    Dim rw As IHTMLTableRow
    Dim table1 As IHTMLTable
    Dim x As IADs
    Dim lo As Excel.ListObject
    Dim lr As Excel.ListRow
    Dim rng As Range
    Dim col As Column
    Dim signum, name, ldapstr, relation As String
    Dim urlText As Variant
    Dim keyVal As Variant
    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("ASSIGNMENTS")    
    Dim responseDict As Dictionary
    On Error Resume Next
    Dim answer As Integer
    answer = MsgBox("Did you updated the Authorization Key in sheet ?", vbQuestion + vbYesNo)
    If answer = vbYes Then
        Set lo = ActiveWorkbook.Worksheets("ASSIGNMENTS").ListObjects("ASSIGNMENTS")
        For Each lr In lo.ListRows
            Set rng = lr.Range
            signum = UCase(rng.Cells.Columns(lo.ListColumns("SIGNUM").Index).Value)
            name = rng.Cells.Columns(lo.ListColumns("NAME").Index).Value
            updateFlag = rng.Cells.Columns(lo.ListColumns("UPDATE_RES_INFO").Index).Value
            If signum <> "" And updateFlag = 1 Then
                ldapstr = "LDAP://CN=" & signum & ",OU=CA,OU=User,OU=P001,OU=ID,OU=Data,DC=XXXXXXXX,DC=se"
                Set x = GetObject(ldapstr)
                x.GetInfoEx Array("CN", "displayName", "givenName", , "email", "sn", "homePhone", "title", "department", "company", "l", "Manager", "country"), 0
                auxCN = UCase(x.Get("CN"))
                If (auxCN = signum) Then
                    rng.Cells.Columns(lo.ListColumns("SIGNUM").Index).Value = UCase(signum)
                    rng.Cells.Columns(lo.ListColumns("NAME").Index).Value = Application.WorksheetFunction.Proper(x.Get("displayName"))
                    rng.Cells.Columns(lo.ListColumns("RELATION").Index).Value = Application.WorksheetFunction.Proper(x.Get("homePhone"))
                    rng.Cells.Columns(lo.ListColumns("TITLE").Index).Value = x.Get("title")
                    rng.Cells.Columns(lo.ListColumns("DEPARTMENT").Index).Value = UCase(x.Get("department"))
                    rng.Cells.Columns(lo.ListColumns("COMPANY").Index).Value = UCase(x.Get("company"))
                    rng.Cells.Columns(lo.ListColumns("COUNTRY").Index).Value = UCase(x.Get("country"))
                    rng.Cells.Columns(lo.ListColumns("LAST NAME").Index).Value = Application.WorksheetFunction.Proper(x.Get("sn"))
                    rng.Cells.Columns(lo.ListColumns("FIRST NAME").Index).Value = Application.WorksheetFunction.Proper(x.Get("givenName"))
                    rng.Cells.Columns(lo.ListColumns("E-MAIL").Index).Value = x.Get("mail")
                    rng.Cells.Columns(lo.ListColumns("HOME BASE").Index).Value = UCase(x.Get("l"))
                    rng.Cells.Columns(lo.ListColumns("UPDATE_RES_INFO").Index).Value = 2
                    Set responseDict = New Dictionary
                    url_prefix = "XXXXXXX"
                    url_suffix = signum_rng        
                    Application.DisplayAlerts = False    
                    On Error Resume Next            
                    Dim returnVal As String    
                    Dim httpObject As Object, item As Object
                    Set httpObject = CreateObject("MSXML2.XMLHTTP")            
                    Url = url_prefix & Trim(signum)           
                    sAuthorization = Worksheets("Authentication key").Range("G4").Value            
                    httpObject.Open "GET", Url, False
                    httpObject.setRequestHeader "Authorization", sAuthorization & EncodeBase64
                    httpObject.Send
                    sGetResult = httpObject.responseText            
                    With CreateObject("MSXML2.XMLHTTP")
                        .Open "GET", Url, False
                        .Send
                        urlText = Split(Replace(Replace(Replace(Replace(.responseText, "{", ""), "[", ""), "}", ""), "]", ""), ",""")
                    End With            
                    responseDict.RemoveAll            
                    For i = 0 To UBound(urlText)
                        urlText(i) = Replace(urlText(i), Chr(34), "")
                        keyVal = Split(urlText(i), ":")
                        responseDict.Add keyVal(0), keyVal(1)
                   Next i
                   If Split(urlText(34), ":")(1) <> "null" Or Len(Split(urlText(34), ":")(1)) <> 0 Then
                       rng.Cells.Columns(lo.ListColumns("PERSONNEL NUMBER").Index).Value = Split(urlText(34), ":")(1)
                   End If            
                   If Split(urlText(11), ":")(1) <> "null" Or Len(Split(urlText(11), ":")(1)) <> 0 Then
                       rng.Cells.Columns(lo.ListColumns("JOB ROLE").Index).Value = Split(urlText(11), ":")(1)
                   End If           
                   If Split(urlText(30), ":")(1) <> "null" Or Len(Split(urlText(30), ":")(1)) <> 0 Then
                       rng.Cells.Columns(lo.ListColumns("POSITION NAME").Index).Value = Split(urlText(30), ":")(1)
                   End If           
                   If Split(urlText(4), ":")(1) <> "null" Or Len(Split(urlText(4), ":")(1)) <> 0 Then
                       rng.Cells.Columns(lo.ListColumns("LINE MANAGER").Index).Value = Split(urlText(4), ":")(1)
                   End If            
                   If Split(urlText(38), ":")(1) <> "null" Or Len(Split(urlText(38), ":")(1)) <> 0 Then            
                       rng.Cells.Columns(lo.ListColumns("COUNTRY").Index).Value = Split(urlText(38), ":")(1)
                   End If           
                   If Split(urlText(22), ":")(1) <> "null" Or Len(Split(urlText(22), ":")(1)) <> 0 Then
                   rng.Cells.Columns(lo.ListColumns("MOBILE").Index).Value = Split(urlText(22), ":")(1)
                   End If            
                   If Split(urlText(32), ":")(1) <> "null" Or Len(Split(urlText(32), ":")(1)) <> 0 Then
                   rng.Cells.Columns(lo.ListColumns("COST CENTRE").Index).Value = Split(urlText(32), ":")(1)
                   End If
                   Application.DisplayAlerts = True
               Else
                    rng.Cells.Columns(lo.ListColumns("UPDATE_RES_INFO").Index).Value = 3
                End If
             End If
            DoEvents
        Next lr
        MsgBox ("RP Updated")
     Else
        MsgBox "Please update the Authorization Key first"
    End If
End Sub