• 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...

  • 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

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
 

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 …
​
 
Thanks a lot for reply Mr. MarcL
I thought deeply and could reach a good point till now
Here's the final code
Code: 
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
 
Now I could extract the desired results ..
Code: 
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 ..
 

Attachments

  • ShowAll.png
    ShowAll.png
    50.7 KB · Views: 0
Before the first line If Instr(........ I put these lines
Code: 
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: 
e.Selected = True
Can you guide me of how to select this option?
 
I have solved this point by this line
Code: 
e.Value = "alle"
I am working by try and fail :)

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

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 …
​
 
You must log in or register to reply here.
Back
Top