PDA

View Full Version : Help needed - Memory leak in VBA script



holyfetzer
07-16-2009, 06:50 AM
I created a VBA script that is used for interpreting HTML Code of a distributor's website. I have a list of components I search on the website and try to extract info from the HTM Code returned.
This process is done in a loop that runs trough every row of my list. I have the problem that my script is using up all my memory after a short amount of time. I have managed to encircle the cause of this to a sub function that is called once in one loop run. I kept my eyes on deleting every object after use but nevertheless the memory consumption is exploding.
I hope someone has a clue about what exactly causes the extensive meory usage. Thx in advance for any help

This is the function which is probably the cause of my problem (returns the html-Code I want to analyze):



Public Function loadHTMLCode(ByRef uri) As String


Dim dummy As New HTMLDocument
Dim dok As IHTMLDocument2


Set dok = dummy.createDocumentFromUrl(uri, "")

Do While Not dok.readyState = "complete"
DoEvents

Loop

loadHTMLCode = CStr(dok.body.outerHTML)
dok.Close
dummy.Close
Set dummy = Nothing
Set dok = Nothing

End Function
This is the process in which I call the function (as additional info):



Public Const SAVE_ITERATIONS = 20


Public Sub Mindestbestellmenge()

Dim i As Integer
Dim articleNumber As String
Dim uri As String
Dim htmlCode As String

Dim minOrderNumber As String
Dim numberInStore As String

Dim positionOfCell As String
Dim starterCell As String
Dim dataCheck As Boolean
Dim rowNumber As Integer

Dim checkCodeMinOrder As Integer
Dim checkCodeNumberInStore As Integer
Dim checkMultipleResults As Integer

Dim positionInCode As Integer
Dim endOfData As Integer

Dim numberOfIterations As Integer

Application.CutCopyMode = False

dataCheck = True
rowNumber = ActiveCell.Row
starterCell = "A" + CStr(rowNumber)
Range(starterCell).Select

numberOfIterations = 0

Do
articleNumber = Selection.Value
uri = "http : / / xyz . de" + articleNumber
htmlCode = loadHTMLCode(uri)
checkCodeMinOrder = InStr(1, htmlCode, "Mindestbestellmenge")
checkMultipleResults = InStr(1, htmlCode, "In Ergebnissen suchen")

If (checkCodeMinOrder <> 0) Or (checkMultipleResults <> 0) Then
If (checkCodeMinOrder <> 0) Then
' Mindestbestellmenge ermitteln
positionInCode = checkCodeMinOrder + 25
minOrderNumber = Mid(htmlCode, positionInCode, 4)
endOfData = InStr(1, minOrderNumber, "<")
If endOfData <> 0 Then
minOrderNumber = Mid(minOrderNumber, 1, endOfData - 1)
End If

' Verfügbarkeit ermitteln
checkCodeNumberInStore = InStr(1, htmlCode, "<P><B>Verfügbare Menge</B>")
positionInCode = checkCodeNumberInStore + 28
numberInStore = Mid(htmlCode, positionInCode, 30)
endOfData = InStr(1, numberInStore, "<")
If endOfData <> 0 Then
numberInStore = Mid(numberInStore, 1, endOfData - 1)
End If

Else
numberInStore = "Mehrere Treffer"
minOrderNumber = ""
End If
' Link einfügen
positionOfCell = "D" + CStr(rowNumber)
With ActiveSheet
.Range(positionOfCell).Clear
.Hyperlinks.Add Anchor:=.Range(positionOfCell), _
Address:=uri, _
TextToDisplay:="Link"
End With

htmlCode = ""

Else
numberInStore = "nicht gefunden"
minOrderNumber = ""
End If


' Verfügbarkeit eintragen
positionOfCell = "B" + CStr(rowNumber)
Range(positionOfCell).Select
ActiveCell.Value = numberInStore

' Mindestbestellmenge eintragen
positionOfCell = "C" + CStr(rowNumber)
Range(positionOfCell).Select
ActiveCell.Value = minOrderNumber

rowNumber = rowNumber + 1
positionOfCell = "A" + CStr(rowNumber)
Range(positionOfCell).Select

If ActiveCell.Value = "" Then
dataCheck = False
End If

numberOfIterations = numberOfIterations + 1
If (numberOfIterations = SAVE_ITERATIONS) Then
ActiveWorkbook.Save
numberOfIterations = 0
End If
Loop While (dataCheck = True)

End Sub

Zack Barresse
07-16-2009, 08:42 AM
I believe you'll have some residual memory issues with creating multiple objects. My advice would be to create 1 object and re-use it. You can pass it as a variable, but there's no need to keep creating/destroying it in a sub procedure, at least none that I can see.

holyfetzer
07-20-2009, 01:21 AM
Sadly the problem stayed the same. The memory is still going nuts. Nobody has an idea?

Simon Lloyd
07-20-2009, 02:30 AM
You need to first take a look at Charles Williams site http://www.decisionmodels.com/memlimitsc.htm and then perhaps rebuild the way you use your variables.

Jan Karel Pieterse
07-20-2009, 03:08 AM
What does your new code look like?

Zack Barresse
07-21-2009, 12:31 PM
Sadly the problem stayed the same. The memory is still going nuts. Nobody has an idea?
I'm with Jan, post your code.

holyfetzer
07-21-2009, 01:44 PM
Public dummy As HTMLDocument
Public dok As HTMLDocument


Public Const SAVE_ITERATIONS = 20


Public Sub checkDist()

Dim i As Integer
Dim articleNumber As String
Dim uri As String
Dim htmlCode As String

Dim minOrderNumber As String
Dim numberInStore As String
Dim pricing As String

Dim positionOfCell As String
Dim starterCell As String
Dim dataCheck As Boolean
Dim rowNumber As Integer

Dim checkCodeMinOrder As Integer
Dim checkCodeNumberInStore As Integer
Dim checkPricing As Integer
Dim checkMultipleResults As Integer

Dim positionInCode As Integer
Dim endOfData As Integer

Dim numberOfIterations As Integer

Application.CutCopyMode = False

dataCheck = True
rowNumber = ActiveCell.Row
starterCell = "A" + CStr(rowNumber)
Range(starterCell).Select

numberOfIterations = 0

Set dummy = New HTMLDocument


Do
articleNumber = Selection.Value
uri = "http : // xyz . com=" + articleNumber
htmlCode = loadHTMLCode(uri)
checkCodeMinOrder = InStr(1, htmlCode, "Mindestbestellmenge")
checkMultipleResults = InStr(1, htmlCode, "In Ergebnissen suchen")

If (checkCodeMinOrder <> 0) Or (checkMultipleResults <> 0) Then

' Genau ein Treffer
If (checkCodeMinOrder <> 0) Then

' Mindestbestellmenge ermitteln
positionInCode = checkCodeMinOrder + 25
minOrderNumber = Mid(htmlCode, positionInCode, 4)
endOfData = InStr(1, minOrderNumber, "<")
If endOfData <> 0 Then
minOrderNumber = Mid(minOrderNumber, 1, endOfData - 1)
End If

' Verfügbarkeit ermitteln
checkCodeNumberInStore = InStr(1, htmlCode, "<P><B>Verfügbare Menge</B>")
positionInCode = checkCodeNumberInStore + 28
numberInStore = Mid(htmlCode, positionInCode, 30)
endOfData = InStr(1, numberInStore, "<")
If endOfData <> 0 Then
numberInStore = Mid(numberInStore, 1, endOfData - 1)
End If

' Preis ermitteln
checkPricing = InStr(1, htmlCode, "<!--item.LIST_POP_UP--><!--item.LIST_POP_UP-->")
positionInCode = checkPricing + 46
pricing = Mid(htmlCode, positionInCode, 10)
endOfData = InStr(1, pricing, "€")
If endOfData <> 0 Then
pricing = Mid(pricing, 1, endOfData)
End If

' Mehrfachtreffer
Else
numberInStore = "Mehrere Treffer"
minOrderNumber = ""
pricing = ""
End If
' Link einfügen
positionOfCell = "E" + CStr(rowNumber)
With ActiveSheet
.Range(positionOfCell).Clear
.Hyperlinks.Add Anchor:=.Range(positionOfCell), _
Address:=uri, _
TextToDisplay:="Link"
End With

htmlCode = ""

' Kein Treffer
Else
numberInStore = "nicht gefunden"
minOrderNumber = ""
pricing = ""
End If


' Verfügbarkeit eintragen
If (InStr(1, numberInStore, "Lieferzeit auf Anfrage")) Then
numberInStore = "Import aus USA"
End If
positionOfCell = "B" + CStr(rowNumber)
Range(positionOfCell).Select
ActiveCell.Value = numberInStore

' Mindestbestellmenge eintragen
positionOfCell = "C" + CStr(rowNumber)
Range(positionOfCell).Select
ActiveCell.Value = minOrderNumber

' Preis eintragen
positionOfCell = "D" + CStr(rowNumber)
Range(positionOfCell).Select
ActiveCell.Value = pricing

rowNumber = rowNumber + 1
positionOfCell = "A" + CStr(rowNumber)
Range(positionOfCell).Select

If ActiveCell.Value = "" Then
dataCheck = False
End If

numberOfIterations = numberOfIterations + 1
If (numberOfIterations = SAVE_ITERATIONS) Then
ActiveWorkbook.Save
numberOfIterations = 0
End If
Loop While (dataCheck = True)

End Sub


Public Function loadHTMLCode(ByRef uri) As String
' Unter Extras/Verweise... Referenz auf Microsoft HTML Object Library setzen



Set dok = dummy.createDocumentFromUrl(uri, vbNullString)

While dok.readyState <> "complete"
DoEvents
' Sleep 32
' a = 1
Wend

loadHTMLCode = CStr(dok.body.outerHTML)
dok.Close
dummy.Close
' Set dummy = Nothing
' Set dok = Nothing

End Function

holyfetzer
08-25-2009, 09:39 AM
Ok, I am out of clues what to do to fix this problem. :dunno
I have posted my Excel-File along with the script as an attachment for the Electronics Distributor Farnell below of this text. Maybe someone could load the Excel-File and see exactly where the problem is.
You just need to execute the macro 'Farnell' after opening the Excel File. When you then parallel monitor the memory consumption in the task manager you see the problem.