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