1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Using post data and xlmlhttp

Discussion in 'VBA Macros' started by YasserKhalil, Feb 12, 2018.

  1. YasserKhalil

    YasserKhalil Active Member

    Messages:
    968
    Now it is perfect till now

    I need one more thing here .. The results are links for more data .. How can I get this data for each link ? I didn't find any clue at this point
  2. Marc L

    Marc L Excel Ninja

    Messages:
    4,010

    As for the moment I can't reach the website - don't know if the issue is
    on my side (so I would have to restart routers) or on the website server -
    at least post an expected result workbook …
  3. YasserKhalil

    YasserKhalil Active Member

    Messages:
    968
    Thanks a lot for reply Mr. MarcL
    I thought deeply and could reach a good point till now
    Here's the final code
    Code (vb):
    Sub Test()
        Dim http As New XMLHTTP60
        Dim ihttp As New XMLHTTP60
        Dim html As New HTMLDocument
        Dim ihtml As New HTMLDocument
        Dim post As Object
        Dim tdElem As Object
        Dim myUrl As String
        Dim strUrl As String
        Dim postData As String
        Dim dt As Date
        Dim lDay As Integer
        Dim lMnth As Integer
        Dim lYear As Integer
        Dim r As Long

        dt = Date - 1
        lDay = Day(dt): lMnth = Month(dt): lYear = Year(dt)

        myUrl = "http://www.handelsregisterbekanntmachungen.de/?aktion=suche"
        postData = "suchart=uneingeschr&button=Suche+starten&land=&gericht=&gericht_name=&seite=&l=&r=&all=false&vt=" & lDay & "&vm=" & lMnth & "&vj=" & lYear & "&bt=" & lDay & "&bm=" & lMnth & "&bj=" & lYear & "&fname=&fsitz=&rubrik=&az=&gegenstand=1&anzv=10&order=1"

        With http
            .Open "POST", myUrl, False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .send postData
            html.body.innerHTML = .responseText
        End With

        For Each post In html.getElementsByTagName("li")
            With post.getElementsByTagName("a")
                If .Length And InStr(.Item(0).href, "javascript") Then
                    'r = r + 1
                   strUrl = "http://www.handelsregisterbekanntmachungen.de/skripte/hrb.php?" & Replace(Replace(Split(.Item(0).href, "(")(1), ")", ""), "'", "")
                    With ihttp
                        .Open "GET", strUrl, False
                        '.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
                       .send
                        ihtml.body.innerHTML = .responseText
                        'Debug.Print strUrl & vbNewLine & ihtml.body.innerHTML & vbNewLine & "*****"
                       r = r + 1
                        For Each tdElem In ihtml.getElementsByTagName("td")
                            Debug.Print tdElem.innerText
                            If InStr(tdElem.innerText, "Aktenzeichen") > 0 Then
                                Cells(r, 1).Value = Trim(Split(tdElem.innerText, "Aktenzeichen")(0))
                                Cells(r, 3).Value = Trim(Replace(Split(tdElem.innerText, "Aktenzeichen")(1), ":", ""))
                            ElseIf InStr(tdElem.innerText, "Bekannt gemacht am:") > 0 Then
                                Cells(r, 2).Value = Trim(Mid(tdElem.innerText, 20))
                            ElseIf InStr(tdElem.innerText, Cells(r, 3).Value) > 0 Then
                                'Stuck here
                           End If
                     
                        Next tdElem
                    End With

                End If
            End With
        Next post
    End Sub
    Example.png
  4. YasserKhalil

    YasserKhalil Active Member

    Messages:
    968
    Now I could extract the desired results ..
    Code (vb):
    Sub Test()
        Dim http        As New XMLHTTP60
        Dim ihttp      As New XMLHTTP60
        Dim html        As New HTMLDocument
        Dim ihtml      As New HTMLDocument
        Dim post        As Object
        Dim tdElem      As Object
        Dim s          As Variant
        Dim v          As Variant
        Dim myUrl      As String
        Dim strUrl      As String
        Dim postData    As String
        Dim dt          As Date
        Dim lDay        As Integer
        Dim lMnth      As Integer
        Dim lYear      As Integer
        Dim r          As Long

        dt = #2/12/2018#
        lDay = Day(dt): lMnth = Month(dt): lYear = Year(dt)

        myUrl = "http://www.handelsregisterbekanntmachungen.de/?aktion=suche"
        postData = "suchart=uneingeschr&button=Suche+starten&land=&gericht=&gericht_name=&seite=&l=&r=&all=false&vt=" & lDay & "&vm=" & lMnth & "&vj=" & lYear & "&bt=" & lDay & "&bm=" & lMnth & "&bj=" & lYear & "&fname=&fsitz=&rubrik=&az=&gegenstand=1&anzv=10&order=1"

        With http
            .Open "POST", myUrl, False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .send postData
            html.body.innerHTML = .responseText
        End With

        If InStr(html.body.innerHTML, "Es wurden 0 Treffer gefunden.") > 0 Then MsgBox "No Results Found", vbExclamation: Exit Sub

        For Each post In html.getElementsByTagName("li")
            With post.getElementsByTagName("a")
                If .Length And InStr(.Item(0).href, "javascript") Then
                    strUrl = "http://www.handelsregisterbekanntmachungen.de/skripte/hrb.php?" & Replace(Replace(Split(.Item(0).href, "(")(1), ")", ""), "'", "")
                    With ihttp
                        .Open "GET", strUrl, False
                        .send
                        ihtml.body.innerHTML = .responseText
                        r = r + 1

                        For Each tdElem In ihtml.getElementsByTagName("td")
                            If InStr(tdElem.innerText, "Aktenzeichen") > 0 Then
                                Cells(r, 1).Value = Trim(Split(tdElem.innerText, "Aktenzeichen")(0))
                                Cells(r, 3).Value = Trim(Replace(Split(tdElem.innerText, "Aktenzeichen")(1), ":", ""))
                            ElseIf InStr(tdElem.innerText, "Bekannt gemacht am:") > 0 Then
                                Cells(r, 2).Value = Trim(Mid(tdElem.innerText, 20))
                            ElseIf InStr(tdElem.innerText, Cells(r, 3).Value) > 0 Then
                                Cells(r, 4).Value = MyUDF(tdElem.innerText, CStr(Cells(r, 3).Value & ":"), ",")
                                Cells(r, 6).Value = GetPostCode(tdElem.innerText)
                                Cells(r, 7).Value = Replace(MyUDF(tdElem.innerText, CStr(Cells(r, 6).Value), "."), ")", "")
                               
                                Cells(r, 5).Value = MyUDF(tdElem.innerText, CStr(Cells(r, 4).Value), CStr(Cells(r, 6).Value))
                                Cells(r, 5).Value = Application.Trim(Replace(Replace(Replace(Cells(r, 5).Value, Cells(r, 7).Value, ""), "(", ""), ",", ""))
                               
                                If InStr(tdElem.innerText, "Vorstand: ") > 0 Then
                                    s = MyUDF(tdElem.innerText, "Vorstand: ", ";")
                                    Cells(r, 8).Value = Trim(Split(s, ",")(0) & "," & Split(s, ",")(1))
                                ElseIf InStr(tdElem.innerText, "Gesellschafter: ") > 0 Then
                                    Cells(r, 8).Value = MyUDF(tdElem.innerText, "Gesellschafter: ", ",")
                                Else
                                    v = Split(tdElem.innerText, ". ")
                                    s = Split(v(UBound(v)), ": ")(1)
                                    Cells(r, 8).Value = Split(s, ",")(0) & "," & Split(s, ",")(1)
                                End If
                            End If
                        Next tdElem
                    End With
                End If
            End With
        Next post
    End Sub

    Function MyUDF(s As String, b As String, a As String) As String
        Dim arr()      As String
        Dim r          As String

        arr = Split(s, b)

        If UBound(arr) > 0 Then
            r = arr(1)
            arr = Split(r, a)

            If UBound(arr) > 0 Then r = arr(0)
        End If

        MyUDF = Trim(r)
    End Function

    Function GetPostCode(strAdd As String)
        Dim regex      As Object
        Dim allM        As Object
        Dim result      As String

        Set regex = CreateObject("VBScript.Regexp")
        With regex
            .Pattern = "(\s\d{5}\s)"
            .Global = True
            .IgnoreCase = True
        End With
        Set allM = regex.Execute(strAdd)

        If allM.Count <> 0 Then result = allM.Item(0).SubMatches.Item(0)

        GetPostCode = result
    End Function

    As for the date existing in the code has a lot results .. but I could get only ten results ..

    I think this could be solved if I select "Alle" so as to show all the results in one page ..

    Attached Files:

  5. YasserKhalil

    YasserKhalil Active Member

    Messages:
    968
    Before the first line If Instr(........ I put these lines
    Code (vb):
    Dim e As Variant
    For Each e In html.getElementsByTagName("select")
            If Left(e.innerText, 2) = "1-" And Right(e.innerText, 4) = "alle" Then
                Debug.Print e.innerText
                e.Selected = True
                Exit For
            End If
        Next e
    But I got an error at this line
    Code (vb):
    e.Selected = True
    Can you guide me of how to select this option?
  6. YasserKhalil

    YasserKhalil Active Member

    Messages:
    968
    I have solved this point by this line
    Code (vb):
    e.Value = "alle"
    I am working by try and fail :)

    But now I didn't get the html page that has all the results :(
  7. Marc L

    Marc L Excel Ninja

    Messages:
    4,010


    How manually with your webbrowser do you get this page with all results ?
  8. YasserKhalil

    YasserKhalil Active Member

    Messages:
    968
    By selecting the option "alle" .. in the page of results after clicking the search button from the main page
  9. Marc L

    Marc L Excel Ninja

    Messages:
    4,010

    So just before selecting this option, open webbrowser inspector tool and
    activate Network tab in order to foresee which request is used for alle
    First operation to accomplish before writing any codeline !
    As scrapping = observing, reading …

Share This Page