Access out of memory on looped code

[MrDeej]

Hello!

I have code wich scans the through 10 computers on a LAN for files and import them into different tabels. This code aproximitly imports 10 000 files (with 1 to 20 rows of info) a day and is running looped (i have 'do' and 'loop' in the top and bottom of the code) and have to be started and stopped manually.

Because i want the files to be imported almost instantly when they are created i let the code just loop and go through as fast as the computer manages. But after about 10 000 - 12 000 loops the application starts to act weird. The code stops with error that it is out of memory.

Do you have any experience with this kind of import? Maybe i should do i another way.



Here is the code, if required

Dim Maskinplassering As String
Dim MaskinNr As Long
Dim Path As String
Do
 
Dim rst As New ADODB.Recordset
    rst.Open "SELECT * from [Maskinoversikt] where aktiv =-1", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
 
    If rst.EOF And rst.BOF Then
    MsgBox "Finner ikke maskin!"
    Else
    Do Until rst.EOF
    Maskinplassering = rst!Maskinplassering
    MaskinNr = rst!MaskinNr
    Path = rst!Path
    Call Hent_fra_atf(MaskinNr, Maskinplassering, Path)
    rst.MoveNext
    Loop
 
    End If
    rst.Close
Set rst = Nothing
 
Loop

And the Module

Option Compare Database
 
Public Function Overfør_fil_r(PathName As String, MaskinNr As Long, Maskinplassering As String)
 
Dim oFSO As New FileSystemObject
Dim oFS
 
Dim Conveyor As String
Dim Varenr As Long
Dim Batch As String
Dim Anttab As Long
Dim Flyttet_tid As Date
Dim Pasientnavn As String
Dim Kundegruppe As String
 
Dim rst As New ADODB.Recordset
Dim RstHist As New ADODB.Recordset
 
Set oFS = oFSO.OpenTextFile(PathName)
RstHist.Open "SELECT * from [LOK Loksummer - flytthistorikk]", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
 
Do Until oFS.AtEndOfStream
    stext = oFS.ReadLine
    If Not Len(stext) = 62 Then
    Pasientnavn = Left(stext, 20)
    Kundegruppe = Mid(stext, 35, 6)
    Else
    Conveyor = Left(stext, 1)
    Varenr = Mid(stext, 2, 6)
    Batch = Mid(stext, 17, 15)
    Anttab = Mid(stext, 32, 3) & "," & Mid(stext, 36, 3)
    Flyttet_tid = GetCreateDate(PathName)
 
    With rst
        If Not Conveyor = "C" Then
        .Open "SELECT * from [Lok Loksummer] where varenr=" & Varenr & " AND lokasjon Like '" & Maskinplassering & " ATF " & MaskinNr & " MDK%'", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
        If .EOF And .BOF Then
        .AddNew
        !Varenr = Varenr
        !lokasjon = Maskinplassering & " ATF " & MaskinNr & " MDK"
        ![antall tabletter] = -Anttab
        Else
        ![antall tabletter] = ![antall tabletter] - Anttab
        End If
        .Update
        .Close
        End If
        RstHist.AddNew
        RstHist!Conveyor = Conveyor
        RstHist!Pasient = Pasientnavn
        RstHist!Kundegruppe = Kundegruppe
        RstHist!hendelse = "Batchpakking"
        RstHist!Varenr = Varenr
        RstHist![antall tabletter] = Anttab
        RstHist![fra lokasjon] = Maskinplassering & " ATF " & MaskinNr
        RstHist![til lokasjon] = "Til pose"
        RstHist![flyttet av] = "ATF"
        RstHist![flyttet tid] = Flyttet_tid
        RstHist.Update
 
    End With
    End If
Loop
 
    RstHist.Close
    Set rst = Nothing
Set oFSO = Nothing
 
 
End Function
 
 
Public Function Overfør_fil_f(PathName As String, MaskinNr As Long, Maskinplassering As String)
 
Dim rst As New ADODB.Recordset
 
Dim Varenr As String
Dim Varenr2 As String
Dim Varenrbruk As Long
Dim Overskudd As Long
Dim behandlingstype As String
Dim Cellelok As String
Dim BoksBatch As String
Dim Kassett As String
Dim Bruker As String
Dim Antall As String
Dim Flyttet_tid As Date
 
Dim oFSO As New FileSystemObject
Dim oFS
Set oFS = oFSO.OpenTextFile(PathName)
 
Do Until oFS.AtEndOfStream
stext = oFS.ReadLine
 
Kassett = Mid(stext, 2, 3)
Varenr = Mid(stext, 5, 6)
Bruker = Mid(stext, 28, 3)
Batch = Mid(stext, 31, 15)
Antall = Mid(stext, 46, 7)
Varenr2 = Mid(stext, 53, 6)
Flyttet_tid = GetCreateDate(PathName)
 
If Varern1 <> Varenr2 Then
    Varenrbruk = Varenr2
    Else
    Varenrbruk = varenr1
End If
 
 
 
 
    With rst
        If Left(Batch, 3) = "MDB" Then
        .Open "SELECT * from [TBB Tablettboks] where boksid='" & Batch & "'", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
        behandlingstype = !behandlingstype
        BoksBatch = !Batch
        Cellelok = ![tilhører lokasjon]
        .Close
        Else
        behandlingstype = Finn_behandlingstype(Varenrbruk, Maskinplassering)
        Cellelok = Finn_lokasjon(Varenrbruk, Maskinplassering, behandlingstype)
        End If
 
        .Open "SELECT * from [LOK Loksummer] where varenr=" & Varenrbruk & " AND lokasjon ='" & Cellelok & "'", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
            If .EOF And .BOF Then
            .AddNew
            !Varenr = Varenrbruk
            ![antall tabletter] = -(Left(Antall, 4) & "," & Right(Antall, 2))
            !lokasjon = Cellelok
            Else
            ![antall tabletter] = ![antall tabletter] - (Left(Antall, 4) & "," & Right(Antall, 2))
            .Update
            End If
            .Update
        .Close
 
        .Open "SELECT * from [LOK Loksummer - flytthistorikk]", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
        .AddNew
        !hendelse = "Maskinpåfylling"
        !Varenr = Varenrbruk
        ![antall tabletter] = Left(Antall, 4) & "," & Right(Antall, 2)
        If Left(Batch, 3) = "MDB" Then
            !boksid = Batch
            !Batch = BoksBatch
            Else
            !Batch = Batch
        End If
        ![behandlingstype] = behandlingstype
        ![fra lokasjon] = Cellelok
        ![til lokasjon] = Maskinplassering & " " & MaskinNr
        ![flyttet av] = Bruker
        ![flyttet tid] = Flyttet_tid
        .Update
        .Close
 
        If IsNumeric(Kassett) Then
            .Open "SELECT * from [LOK Loksummer] where varenr=" & Varenr & " AND lokasjon ='" & Maskinplassering & " " & MaskinNr & " MDK " & Kassett & "'", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
            If .EOF And .BOF Then
            .AddNew
            !Kassett = Kassett
            !Varenr = Varenrbruk
            ![antall tabletter] = ![antall tabletter] + Left(Antall, 4) & "," & Right(Antall, 2)
            !lokasjon = Maskinplassering & " " & MaskinNr & " MDK " & Kassett
            Else
            Overskudd = ![antall tabletter]
            ![antall tabletter] = Left(Antall, 4) & "," & Right(Antall, 2)
            .Update
            End If
            .Update
            .Close
        End If
        If Not Overskudd = 0 Then
            .Open "SELECT * from [LOK Loksummer] where varenr=" & Varenr & " AND lokasjon ='" & Maskinplassering & " " & MaskinNr & " Maskindiff" & "'", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
            If .EOF And .BOF Then
            .AddNew
            !Varenr = Varenrbruk
            ![antall tabletter] = Overskudd
            !lokasjon = Maskinplassering & " " & MaskinNr & " Maskindiff"
            Else
            ![antall tabletter] = ![antall tabletter] + Overskudd
            End If
            .Update
            .Close
 
            .Open "SELECT * from [LOK Loksummer - flytthistorikk]", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
            .AddNew
            !hendelse = "Maskinpåfylling overskudd"
            !Varenr = Varenrbruk
            ![antall tabletter] = Overskudd
            ![fra lokasjon] = Maskinplassering & " " & MaskinNr
            ![til lokasjon] = Cellelok
            ![flyttet av] = Bruker
            ![flyttet tid] = Flyttet_tid
            .Update
            .Close
        End If
 
 
 
    End With
Loop
 
 
Set rst = Nothing
 
 
End Function
 
Public Function GetCreateDate(Path As String) As Date
    Dim fso As Scripting.FileSystemObject
    Dim fsoFile As Scripting.File
    Set fso = New Scripting.FileSystemObject
    Set fsoFile = fso.GetFile(Path)
    GetCreateDate = fsoFile.DateCreated
End Function
 
 
Function Hent_fra_atf(MaskinNr As Long, Maskinplassering As String, Path As String)
 
Dim fsoFileSearch As FileSearch
Set fsoFileSearch = Application.FileSearch
With fsoFileSearch
 
Dim FoundFiles As Long
Dim Cellelok As String
 
Dim i As Long
Dim Tid As Date
Dim Tidbrukt As Date
Dim Tiddiff As Long
Dim Stnr As Long
 
Call Fremdriftsindikator_v2("ja", , , "Initierer overførsel fra maskin " & MaskinNr)
 
Dim rst As New ADODB.Recordset
    rst.Open "SELECT * from [ATF oppdateringslogg]", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
    rst.AddNew
    rst!maskin = Maskinplassering & " " & MaskinNr
    rst!Path = Path
    rst![start tid] = Now
 
 
Dim MaskinStatus As New ADODB.Recordset
    MaskinStatus.Open "SELECT * from [main oppetid]", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
 
 
 
.LookIn = Path
.FileType = msoFileTypeAllFiles
'.FileName = "*.st1"
If .Execute(msoSortByLastModified) > 0 Then
 
FoundFiles = .FoundFiles.Count
 
Call Fremdriftsindikator_v2(, , FoundFiles)
    rst![antall filer] = FoundFiles
For i = 1 To FoundFiles
 
Call Fremdriftsindikator_v2(, , , , "Overfører " & .FoundFiles(i) & " (" & Len(.FoundFiles(i)) & ")", , , i)
 
    If Right(.FoundFiles(i), 2) = "F" & MaskinNr Or Right(.FoundFiles(i), 3) = "F" & MaskinNr Then
    Call Overfør_fil_f(.FoundFiles(i), MaskinNr, Maskinplassering)
    Kill (.FoundFiles(i))
    End If
 
    If Right(.FoundFiles(i), 3) = "ST" & MaskinNr Or Right(.FoundFiles(i), 4) = "ST" & MaskinNr Then
    Stnr = Stnr + 1
    slashfrontpos = InStrRev(.FoundFiles(i), "\")
    leng = Len(.FoundFiles(i)) - slashfrontpos
    navn = Right(.FoundFiles(i), leng)
 
    Tid = GetCreateDate(.FoundFiles(i))
    If Not Tidbrukt = 0 Then
    Tiddiff = DateDiff("s", Tidbrukt, Tid)
    End If
    Tidbrukt = Tid
 
    Pnop = Mid(navn, 31, 3)
    ATF_status = Mid(navn, 35, 1)
    Machine_status = Mid(navn, 36, 1)
    Paper_alarm = Mid(navn, 37, 1)
    Ink_alarm = Mid(navn, 38, 1)
    Shelf_open = Mid(navn, 39, 1)
    Conveyor_alarm = Mid(navn, 40, 1)
    Reserved = Mid(navn, 41, 1)
    If Len(navn) <> 54 Then
    casette_alarm = Mid(navn, 51, 4)
    Else
    casette_alarm = ""
    End If
 
 
    MaskinStatus.AddNew
    MaskinStatus!MaskinNr = MaskinNr
    MaskinStatus!Tid = Tid
    MaskinStatus!Pnop = Pnop
    MaskinStatus![atf-status] = ATF_status
    MaskinStatus![machine status] = Machine_status
    MaskinStatus![paper alarm] = Paper_alarm
    MaskinStatus![ink alarm] = Ink_alarm
    MaskinStatus![shelf open] = Shelf_open
    MaskinStatus![conveyor alarm] = Conveyor_alarm
    MaskinStatus![Reserved] = Reserved
    MaskinStatus![casette alarm] = casette_alarm
    If Not Stnr = 1 Then
    MaskinStatus.Update
    MaskinStatus.MoveLast
    MaskinStatus.MovePrevious
    MaskinStatus![sekunder siden forrige rad] = Tiddiff
    MaskinStatus.Update
    End If
    'Kill .FoundFiles(i)
    End If
 
    If Right(.FoundFiles(i), 2) = "C" & MaskinNr Or Right(.FoundFiles(i), 3) = "C" & MaskinNr Then
    Call Overfør_fil_c(.FoundFiles(i), MaskinNr, Maskinplassering)
    Kill (.FoundFiles(i))
    End If
    If Right(.FoundFiles(i), 2) = "R" & MaskinNr Or Right(.FoundFiles(i), 3) = "R" & MaskinNr Then
    Call Overfør_fil_r(.FoundFiles(i), MaskinNr, Maskinplassering)
    Kill (.FoundFiles(i))
    End If
Next i
End If
End With
 
Call Fremdriftsindikator_v2(, , , , , "ja")
 
    rst![slutt tid] = Now
    rst![tid brukt] = DateDiff("n", rst![start tid], rst![slutt tid])
    rst.Update
    rst.Close
Set rst = Nothing
End Function
 
Public Function Overfør_fil_c(PathName As String, MaskinNr As Long, Maskinplassering As String)
Dim Kasettnr As Integer
Dim Varenr As Long
Dim Antall As Long
Dim Overskudd As Long
 
Dim oFSO As New FileSystemObject
Dim oFS
Set oFS = oFSO.OpenTextFile(PathName)
 
Dim rst As New ADODB.Recordset
With rst
 
Do Until oFS.AtEndOfStream
Overskudd = 0
stext = oFS.ReadLine
Kassett = Left(stext, 3)
Varenr = Mid(stext, 4, 6)
Antall = Mid(stext, 59, 4)
 
.Open "SELECT * from [LOK Loksummer] where varenr=" & Varenr & " AND lokasjon ='" & Maskinplassering & " " & MaskinNr & " MDK " & Kassett & "'", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
    If .EOF And .BOF Then
    .AddNew
    !Kassett = Kassett
    !Varenr = Varenr
    ![antall tabletter] = Antall
    !lokasjon = Maskinplassering & " " & MaskinNr & " MDK " & Kassett
    Overskudd = Antall
    .Update
    Else
    If Not ![antall tabletter] = Antall Then
    Overskudd = ![antall tabletter] - Antall
    ![antall tabletter] = Antall
    .Update
    End If
    End If
    .Close
    If Not Overskudd = 0 Then
    .Open "SELECT * from [LOK Loksummer] where varenr=" & Varenr & " AND lokasjon ='" & Maskinplassering & " " & MaskinNr & " Maskindiff" & "'", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
        If .EOF And .BOF Then
        .AddNew
        !Varenr = Varenr
        ![antall tabletter] = Overskudd
        !lokasjon = Maskinplassering & " " & MaskinNr & " Maskindiff"
        Else
        ![antall tabletter] = ![antall tabletter] + Overskudd
        End If
        .Update
        .Close
 
        .Open "SELECT * from [LOK Loksummer - flytthistorikk]", CurrentProject.Connection, adOpenForwardOnly, adLockPessimistic
        .AddNew
        !hendelse = "Maskinlager overskudd"
        !Varenr = Varenr
        ![antall tabletter] = Overskudd
        ![fra lokasjon] = Maskinplassering & " " & MaskinNr & " MDK " & Kassett
        ![til lokasjon] = Maskinplassering & " " & MaskinNr & " Maskindiff"
        ![flyttet av] = "LogiDose"
        ![flyttet tid] = Now
        .Update
        .Close
    End If
 
Loop
End With
 
End Function
 

[NeoPa]

Move your "Do" line (#4) after the "Dim" line (#6), and move your "Loop" line (#24) before the "Set" line (#22).

There is no need to create a new recordset variable each time through the loop. This is time and resource intensive (very much so in fact), even though you tidy up the variable within the loop.

[NeoPa]

I should add that proper indenting of code is not only important for usability in a forum, but also for your own benefit. Frankly, wrongly done indenting is worse than none at all when trying to understand code.

All code within blocks (anything with a start and end marker like If ... Else; If ... End If; Do ... Loop; etc) should be indented from the surrounding code. This helps a reader to see easily which code is effected by the grouping.

As an illustration your code should be (including my suggested changes) :

Dim Maskinplassering As String
Dim MaskinNr As Long
Dim Path As String
Dim rst As New ADODB.Recordset
 
  Do
    rst.Open "SELECT * from [Maskinoversikt] where aktiv =-1", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
 
    If rst.EOF And rst.BOF Then
      MsgBox "Finner ikke maskin!"
    Else
      Do Until rst.EOF
        Maskinplassering = rst!Maskinplassering
        MaskinNr = rst!MaskinNr
        Path = rst!Path
        Call Hent_fra_atf(MaskinNr, Maskinplassering, Path)
        rst.MoveNext
      Loop
 
    End If
    rst.Close
 
  Loop
  Set rst = Nothing

I used a simple two-space indentation to fit more easily on the forum. In your own modules I'd use the normal four.

[MrDeej]

Yes, i was meaning to 'clean' up the code before using the application. This is something you can call an Alpha edition of the finished product.

I will move the loop and do and test it out next week. Will post a feedback of the result :)

[NeoPa]

That's cool.

The point I was trying to make though, is that having tidy code is a fundamental part of the development process. Specifically NOT a job to leave till afterwards as it is so closely involved with getting it right in the first place.

We all make our own choices of course, but that would be my advice.

[MrDeej]

now it loops in all eternity :)

Thank you for your help

[NeoPa]

My pleasure MrD :)

I'm glad to see that fixed the problem.