Consulting

Results 1 to 8 of 8

Thread: Macro not working for fetching data from Active Directory

  1. #1
    VBAX Newbie
    Joined
    Aug 2018
    Posts
    3
    Location

    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)


    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

  2. #2
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,697
    Quote Originally Posted by Negi1984 View Post
    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.
    If ldapstr is blank (note it starts with a lower case L not an upper case i) it means that line isn't executed at all; it would show at least something even if other variables are blank.
    Therefore the line If signum <> "" And updateFlag = 1 Then is returning FALSE so I'd point you to looking at whether signum isn't "" and updateFlag is 1.

    Also, before stepping through the code, remove or comment-out the line On Error Resume Next as it is hiding errors that you want to know about while debugging.
    Last edited by p45cal; 11-26-2022 at 09:42 AM.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  3. #3
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    795
    Location
    P45cal probably has already resolved your difficulties but I thought I would suggest that you place Option Explicit at the top of your code as some variables are not declared (eg. "name"). Also, in light of P45cal's suggestions the following declaration...
    Dim signum, name, ldapstr, relation As String

    only declares "relation" as a string variable which seems
    relevant. HTH. Dave

  4. #4
    VBAX Newbie
    Joined
    Aug 2018
    Posts
    3
    Location
    Hi P45cal,

    I have tested the as you suggested and getting the error as per attached snapshot.

    " run time Error -2147023541 (8007054b)
    Automation Error
    The Specified domain either does not exist or could not be contacted."

    and step where getting error now is "Set x = GetObject(ldapstr)"

    And when I again check same file in my old machine then there is no error.
    Could you please suggest further , how to solve this issue. I am basic VBA user so difficult to identify how to solve this.

  5. #5
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,697
    Sorry, I don't don't know anything about Active Directories and LDAP.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  6. #6
    VBAX Newbie
    Joined
    Aug 2018
    Posts
    3
    Location
    Quote Originally Posted by Dave View Post
    P45cal probably has already resolved your difficulties but I thought I would suggest that you place Option Explicit at the top of your code as some variables are not declared (eg. "name"). Also, in light of P45cal's suggestions the following declaration...
    Dim signum, name, ldapstr, relation As String

    only declares "relation" as a string variable which seems
    relevant. HTH. Dave
    Hi Dave,

    I have tested same as well and getting the error as per attached snapshot.

    " run time Error -2147023541 (8007054b)
    Automation Error
    The Specified domain either does not exist or could not be contacted."

    and step where getting error now is "Set x = GetObject(ldapstr)"

    And when I again check same file in my old machine then there is no error.
    Could you please suggest further , how to solve this issue. I am basic VBA user so difficult to identify how to solve this.

  7. #7
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    795
    Location
    Have you properly declared all of your variables as suggested? I too have no specific knowledge, but I would suggest that you google stack overflow and post your query and a link to this thread there. The volunteers their seemed to have resolved many similar difficulties. HTH. Dave

  8. #8
    VBAX Regular
    Joined
    May 2018
    Location
    Sydney
    Posts
    49
    Location
    To use the ADODB.Connection object in the code, you can add the following line of code at the beginning of the code, after the declaration of the variables:



    Dim adoconn As New ADODB.Connection


    This will create a new instance of the ADODB.Connection object, which can be used to establish a connection to a data source using ActiveX Data Objects (ADO). You can then use the Open method of the adoconn object to open a connection to the desired data source.


    For example, to open a connection to a Microsoft SQL Server database, you can use the following code:


    adoconn.Open "Provider=SQLOLEDB;Data Source=myServerAddress;Initial Catalog=myDataBase;User Id=myUsername;Password=myPassword;"
    Once the connection is open, you can use the Execute method of the adoconn object to execute SQL queries or stored procedures on the data source.


    However, it is worth noting that the code you provided does not appear to use a database or any other data source that would require a connection. Instead, it appears to be using the GetObject function to retrieve information about an Active Directory user, based on the user's signum. In that case, you do not need to use the ADODB.Connection object.


    As for the issue with the idapstr line, it is difficult to say without more information. It is possible that there is a problem with the data being passed to the GetObject function, or with the way the ldapstr variable is constructed. I would recommend checking the values of the signum and other variables that are used to construct the ldapstr variable, to make sure they are correct and valid. You may also want to try using the Debug.Print statement to print the value of the ldapstr variable, to see if it is correct.
    If you only ever do what you can , you'll only ever be what you are.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •