Question

我一直试图解决这个问题很长一段时间。我的筹码显示：

VBAProject.RecebeContratos.ParseHTML3
[<The code isnt Basic>]
VBAProject.Módulo1.TodosContratosOrgao5
[<The code isnt Basic>] '(I don't know the exact translation for this, my excel is in portuguese)

然后它再次循环

Sub TodosContratosOrgao5(MacroLoop As Long, Z As Long)
    Dim URL As String
    Dim ultimo As Long
    Dim ultimoorgao As Long
    Set rng = Range("D2:D589")
    If MacroLoop = 0 Or MacroLoop = 1 Then
        MacroLoop = 3
    End If
    Do While MacroLoop <= 589
        If Plan4.Range("E1") = Plan5.Range("E" & MacroLoop) Then
            URL = Plan5.Range("C" & MacroLoop).Value
            Call ParseHTML3(URL, MacroLoop, Z, "") 'Here it stops with the stack error
        End If
        MacroLoop = MacroLoop + 1
    Loop
End Sub

有什么想法？我不知道如何阻止这些循环叠加。

谢谢大家！

Function ParseHTML3(URL As String, MacroLoop As Long, Z As Long, Teste As String)

    Dim htm As Object: Set htm = CreateObject("htmlfile")
    Dim tr As Object
    Dim td As Object
    Dim X As Long
    Dim i As Long
    Dim URL2 As Long
    Dim htmlColl As MSHTML.IHTMLElementCollection
    Dim htmlElem As MSHTML.IHTMLElementCollection
    Application.DisplayStatusBar = True
    Application.StatusBar = "Recebendo Contratos... Aguarde!"
    Dim shellWins As ShellWindows
    Dim IE As InternetExplorer
    Range("D1").Calculate
    Range("E1").Calculate
    Set shellWins = New ShellWindows

                            'Create IE
    Set IE = New InternetExplorer
    On Error Resume Next
    IE.Visible = True
    On Error GoTo 0
    If Teste = "" Then
        If URL = Plan4.Range("C1").Value Then
            GoTo Termina
        End If
    End If
    IE.Navigate URL
    'Aguarda IE completar o carregamento
    While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Wend


    ''''''''''''''''''''''''''''''''''Clica em "Pesquisar"

    Set htmlColl = IE.Document.getElementsByTagName("input")

    For Each Htmlinput In htmlColl

        If Trim(Htmlinput.Type) = "submit" Then
            Htmlinput.Click
            Do While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
                DoEvents
            Loop
            Exit For
        End If
    Next Htmlinput


    ''''''''''''''''''''''''''''''''''''''''''''''''''''''

        ''''''''''''''''''''''''''''''''' Exibe 100 resultados

    Set htmlColl = IE.Document.getElementsByTagName("select")

    Application.Wait Now + TimeValue("00:00:02")
    For Each HTMLSelect In htmlColl

        Application.Wait Now + TimeValue("00:00:01")

        If Trim(HTMLSelect.Value) = "20" Or Trim(HTMLSelect.Value) = "50" Then
            HTMLSelect.Value = "100"
            HTMLSelect.onchange

            Exit For
        End If
    Next HTMLSelect
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



''''''''''''''''''''''''''''''''''''''''''Pega o conteúdo da primeira página

    If Teste = "primeira" Then
        Z = 2
        Teste = "segunda"
    End If


    Application.Wait Now + TimeValue("00:00:02")
    With IE.Document.getElementsByTagName("tbody")(1)


        For Each tr In .Rows
        Dim newURL As String
        Dim newURL2 As String
        If tr.innerText <> "Nenhum resultado para esta consulta " Then
            newURL = Mid(tr.innerHTML, InStr(1, tr.innerHTML, ";") + 1, InStr(1, tr.innerHTML, "&amp;idContrato") - 1 - InStr(1, tr.innerHTML, ";"))
            newURL2 = Mid(tr.innerHTML, InStr(1, tr.innerHTML, "idContrato"), InStr(1, tr.innerHTML, "><u") - 2 - InStr(1, tr.innerHTML, ";idContrato"))
            newURL = "http://www3.transparencia.gov.br/TransparenciaPublica/jsp/contratos/contratoExtrato.jsf?consulta=3&" & newURL & "&" & newURL2
        End If
            For Each td In tr.Cells
                X = X + 1
                With Plan6.Range("a" & Z)
                    If X = 1 Then
                        Plan6.Cells(Z, X).Value = td.innerText
                    Else
                        If Left(td.innerText, 2) = " =" Then
                            Plan6.Cells(Z, X).Value = "..." & td.innerText
                        Else
                            Plan6.Cells(Z, X).Value = td.innerText
                        End If
                    End If
                End With
            Next td
        Plan6.Cells(Z, 7).Value = newURL
        Z = Z + 1
        X = 0
        Next tr
    End With

    If i = 0 Then
        i = 134     'Variável referente a páginas
    End If
    w = 136     'Variável referente ao orgão com mais de 10 paginas
    Do
        On Error Resume Next
        Teste = IE.Document.Links(135).innerText
        Teste2 = IE.Document.Links(134).innerText
        On Error GoTo 0
        If Teste2 = "[anterior]" Then
            If w = 146 Then         'Volta a contagem após clicar em [posterior]
                w = 136
            End If
            On Error GoTo Termina
            IE.Document.Links(w).Click
            On Error GoTo 0
            u = 1
            w = w + 1
            On Error GoTo 0

        ElseIf Teste = "[anterior]" Then
            If w = 146 Then         'Volta a contagem após clicar em [posterior]
                w = 135

            End If

        ElseIf Teste2 <> "[anterior]" And Teste = "[anterior]" Then     'Avança página
            IE.Document.Links(i).Click

        ElseIf Teste <> "[anterior]" And Teste2 = "[anterior]" And u <> 1 Then     'Avança página
                IE.Document.Links(i).Click
                u = 0

        ElseIf u <> i Then
            On Error GoTo Termina
                IE.Document.Links(i).Click
            On Error GoTo 0
                u = i

        Else
            IE.Document.Links(w).Click

        End If

        Do While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
            DoEvents
        Loop

    '''''''''''''''''''''''''''''Pega o conteúdo das demais páginas

    On Error GoTo Termina ''''''''''''Finaliza caso não tenha (mais) páginas.

    With IE.Document.getElementsByTagName("tbody")(1)

        For Each tr In .Rows
            newURL = "http://www3.transparencia.gov.br/TransparenciaPublica/jsp/contratos/contratoExtrato.jsf?consulta=3&" & Mid(tr.innerHTML, InStr(1, tr.innerHTML, ";") + 1, InStr(1, tr.innerHTML, "&amp;idContrato") - 1 - InStr(1, tr.innerHTML, ";")) & "&" & Mid(tr.innerHTML, InStr(1, tr.innerHTML, "idContrato"), InStr(1, tr.innerHTML, "><u") - 2 - InStr(1, tr.innerHTML, ";idContrato"))
                For Each td In tr.Cells
                    X = X + 1
                    With Plan6.Range("a" & Z)
                        If X = 1 Then
                        Plan6.Cells(Z, X).Value = td.innerText
                    Else
                        If Left(td.innerText, 2) = " =" Or Left(td.innerText, 1) = "=" Then
                            Plan6.Cells(Z, X).Value = "..." & td.innerText
                        Else
                            Plan6.Cells(Z, X).Value = td.innerText
                        End If
                    End If
                    End With
                Next td
            Plan6.Cells(Z, 7).Value = newURL
            Z = Z + 1
            X = 0
        Next tr
    i = i + 1
    End With
    Loop


''''''''''''''''''''''''''''''''''''''''''''''''''''''



Termina:
    IE.Quit
    If MacroLoop <> 0 Then
        MacroLoop = MacroLoop + 1
    End If
    i = 0
    Call TodosContratosOrgao5(MacroLoop, Z)
    Application.StatusBar = "Pronto."
    Exit Function

End Function



End Sub

很抱歉没有发布de PasteHTML3代码，就在这里。（它运行FINE，但一段时间后停止！）

我的工作表上有一个按钮，在ParseHTML之前运行宏：

Sub GetData()
    Dim Teste As String
    Plan6.UsedRange.ClearContents
    Range("D1").Calculate
    Range("E1").Calculate
    Range("C1").Calculate
    Teste = "primeira"
    Call ParseHTML3(Plan4.Range("C1").Value, 0, 0, Teste)

End Sub

Answer 1

您的ErrorHandler（Termina）似乎是堆栈溢出的情况：

您先拨打（1）ParseHTML3。如果出现问题，代码执行将在Termina中继续 - 使用TodosContratosOrgao5调用（2）MacroLoop+1。

在TodosContratosOrgao5中，然后从MacroLoop循环到589，调用（3）ParseHTML3。假设在第一次运行中发生同样的错误，ParseHTML3实际上会再次调用（4）TodosContratosOrgao5，依此类推！因此，堆栈将继续像这样增长：

ParseHTML3
TodosContratosOrgao5
ParseHTML3
TodosContratosOrgao5
...

您可能想要做的是首先调用TodosContratosOrgao5（使用正确的MacroLoop值） - 如果ParseHTML3导致错误，只需退出该函数 - 并让TodosContratosOrgao5拨打下一行！

另外，尝试在ParseHTML3中找到错误，使用 F8 逐步执行代码！

Answer 2

堆栈空间不足意味着您的程序中有太多嵌套调用。这通常是由循环引用引起的。

在这种情况下，在ParseHTML3中，您拨打TodosContratosOrgao5，在TodosContratosOrgao5中拨打ParseHTML3。这永远不会解决，但他们会一次又一次地互相打电话。

问题的一个更简单的例子是：

Sub DoFoo()
     Call DoBar
End Sub

Sub DoBar()
    Call DoFoo
End Sub

堆栈空间

2 个答案: