VBA XMLHTTP“内存不足”状态

Question

这是一段应该连接到网页的代码，内容如下：link1, description1, otherdata1, link2, description2, otherdata2, ..., linkN, descriptionN, otherdataN 其中 N 是 30 000 +。

从这些链接中，程序使用正则表达式找到一个感兴趣的链接，转到该链接，并从那里下载一个文件。

我的问题是：在 htmlWebInterfaceXML.send 程序经常但并非总是会耗尽内存（'out-of-memory' 错误）。我很难测试不同的解决方案，因为通常程序运行平稳，如果有变化也很难注意到。

附加信息：

• 它在某些 PC 上运行流畅，在其他 PC 上运行不流畅
• 它通常运行到下午然后抛出错误

其他可能有用的信息：

• 显示的代码是类的私有方法，类本身是源代码的一小部分
• 其他我不解释的调用的subs不相关并且运行顺利，problem总是出现在htmlWebInterfaceXML.send。

我的一个猜测是，我在一个函数内部声明了局部变量，该函数包含一个非常大的对象并可能导致堆栈溢出，但似乎不太可能，因为 VBA 应该自己处理这些事情。 也许您发现了一个我没有发现的问题？谢谢。

Private Sub FileUpload()
    ' THE FUNCTION CANNOT BE CONNECTING FOR EACH CONTRACT ID! WILL TAKE TOO MUCH TIME - NEED TO ALTER
    Dim member As Variant
    Dim byteCounter As Byte
    Dim byteMaxID As Byte
    Dim strPathToXMLFile As String
    Dim strURLToXMLFile    
    Dim strXMLFileStorageName As String    
    Dim domdocXMLText As New MSXML2.DOMDocument
    Dim clctStrFoundMatches As New Collection
    Dim clctInternalIDs As New Collection
    Dim vrntContractID As Variant
    Dim htmlHTMLMainPageXMLInterface As New MSHTML.HTMLDocument
    Dim htmlTagElement As Variant
    Dim htmclctFoundXMLs As MSHTML.IHTMLElementCollection
    Dim htmlWebInterfaceXML As MSXML2.XMLHTTP60
    Dim intNumberOfTradeUnderProcessing As Integer

    UpdateProgressStatus "LOADING SERVER WITH SOURCE XML..." '<----------- UPDATE PROGRESS!


    '----------------------> OPEN AND LOAD THE WEB SERVER, AND STORE ITS HTML INTO AN OBJECT
    Set htmlWebInterfaceXML = New MSXML2.XMLHTTP
    With htmlWebInterfaceXML
        .Open "GET", p_cstrWebInterfaceXMLRootDirectory, False
        .setRequestHeader "Authorization", "Basic" & Base64Encode( _
                                          p_cstrXMLWebInterfaceAuthenticationUser & ":" & p_cstrXMLWebInterfaceAuthenticationPassword)
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
    End With
    htmlHTMLMainPageXMLInterface.body.innerHTML = htmlWebInterfaceXML.responseText ' how much text is the htmldocument able to store??
    Set htmlWebInterfaceXML = Nothing

    SetUpDirectory                               ' ------------> create or set directory where to store XML files

    If Me.ContractiDs.Count <> Me.MailParts.Count And Me.ContractiDs.Count <> Me.MailParts.Count * 2 Then
        Err.Raise 1504, "FileUpload", p_cstrError1504Message
    Else
        For Each vrntContractID In Me.ContractiDs

            intNumberOfTradeUnderProcessing = intNumberOfTradeUnderProcessing + 1
            UpdateProgressStatus "LOADING XML FOR THE TRADE NUMBER " & intNumberOfTradeUnderProcessing & "..." ' ----------------> UPDATE STATUS BAR

            ' ------------------------> find the tags containing the needed contract id in their names

            Set htmclctFoundXMLs = htmlHTMLMainPageXMLInterface.getElementsByTagName("a")
            Set clctStrFoundMatches = New Collection
            For Each htmlTagElement In htmclctFoundXMLs
                If htmlTagElement.getAttribute("href") Like "*" & vrntContractID & "*" Then
                    clctStrFoundMatches.Add htmlTagElement
                End If
            Next htmlTagElement

            If clctStrFoundMatches.Count = 0 Then Err.Raise 1506, "FileUpload", p_cstrError1506Message

            ' -----------------------> exclude the archives from the collection

            byteCounter = 0
            For byteCounter = 1 To clctStrFoundMatches.Count
                If blnContainsPattern("\.gz$", clctStrFoundMatches(byteCounter).innerText) Then
                    clctStrFoundMatches.Remove byteCounter
                End If
            Next byteCounter

            ' ----------------------> extract the contract ids and find the last contract id

            Set clctInternalIDs = New Collection

            For Each member In clctStrFoundMatches
                clctInternalIDs.Add strReturnSingleMatch("\d{9}", member.innerText)
                If clctInternalIDs(clctInternalIDs.Count) = "False" Then Err.Raise 1505, "FileUpload", p_cstrError1505Message
            Next member
            byteMaxID = FindMaximum(clctInternalIDs)
            strPathToXMLFile = clctStrFoundMatches(byteMaxID).innerText

            ' -----------------------> check whether such file exists, and, if not, download it

            If blnFileExists(strPathToXMLFile, p_cstrXMLDestination) Then
            Else
                strURLToXMLFile = p_cstrWebInterfaceXMLRootDirectory & strPathToXMLFile
                Set htmlWebInterfaceXML = Nothing: Set htmlWebInterfaceXML = New MSXML2.XMLHTTP
                htmlWebInterfaceXML.Open "GET", strURLToXMLFile, False
                htmlWebInterfaceXML.setRequestHeader "Authorization", "Basic" & Base64Encode( _
                                                                     p_cstrXMLWebInterfaceAuthenticationUser & ":" & p_cstrXMLWebIntervaceAuthenticationPassword)
                htmlWebInterfaceXML.send
                With domdocXMLText
                    .validateOnParse = False
                    .async = False
                End With
                domdocXMLText.LoadXML htmlWebInterfaceXML.responseText
                domdocXMLText.Save p_cstrXMLDestination & "\" & strPathToXMLFile
            End If
        Next vrntContractID

    End If

    Set htmlHTMLMainPageXMLInterface = Nothing

End Sub

Answer 1

我有一个类似的问题，我解决了。我的脚本通过服务器运行并在数千个文本文件中查找字符串。

我解决它的方法是（使用 ascync ServerXMLHTTP60）在响应处理程序中设置一个 if 条件以中止 xmlhttp 对象。在我完成数据比较之后，对象会从内存中“删除”，现在我可以（实际上）查询任意数量的数据。 （花了我大约一个月的时间来测试很多解决方案，这是正确的）

这可能对您有用，因此只需在完成该数据集后添加 htmlWebInterfaceXML.abort。

希望这会有所帮助！干杯！