Macro not working for fetching data from Active Directory
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)
Code:
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
