توقف البرنامج عن العمل، بالرغم من سلامة عمله!

لدي حوالي مليون صورة ... بعضها تالف حين التحميل ...

قمت ببرمجة بريمج، لفحص هذه الصور، وتخزين النتيجة في قاعدة بيانات .. ولكن المشكلة ان البرنامج يتوقف عن العمل بعد فحص حوالي 200-300 صورة ..

الكود كالتالي:

Set DB = SetDatabase(App.path & "\Pics.mdb")
Set RS = SetRecordset("Pics_Check", DB)
RS.MoveFirst
Pics_Path$ = "L:\Pics\"
DoEvents
For i = 1 To RS.RecordCount
    IMG_Path$ =Pics_Path$ & RS("File").Value & "\" & RS("Pic_name").Value
    RS("GoodPic").Value = isGoodPicture(IMG_Path$)
    RS("Exist").Value = True
    RS.Update
    RS.MoveNext
Next i

MsgBox "OK"

وكود دالة فحص الصور كالتالي:

Public Function isGoodPicture(ByVal PicPath As String) As Boolean
On Error Resume Next
    Dim pic As StdPicture
    Set pic = LoadPicture(PicPath)

    If Err = 0 Then isGoodPicture = True
    Set pic = Nothing
End Function

والمطلوب، حل مشكلة توقف البرنامج عن العمل ..

* الصورة التالية تبين مقادير استهلاك الذاكرة والمعالج ... ولا اشعر باي مشكلة في تشغيل سائر البرامج

للاتصال بقاعدة البيانات استخدم هذه في موديول

Public DB As Connection

Public Function SetDatabase(ByVal DBFileName As String, Optional ConnectionString As String = "MDB", Optional DBPassword As String = "") As Connection
    Dim mDB As New Connection
    Select Case ConnectionString
        Case "MDB"
            If DBPassword <> "" Then DBPassword = "pwd=" & DBPassword & ";"
            ConnectionString = "Driver={Microsoft Access Driver (*.mdb)};Dbq=" & DBFileName & ";" & DBPassword

    'y = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBFileName & ";"

    End Select

    mDB.CursorLocation = adUseClient
    mDB.Mode = adModeReadWrite

    mDB.Open ConnectionString

Set SetDatabase = mDB
End Function
Public Function SetRecordset(ByVal RecordSource As String, ByVal DBase As Connection) As Recordset
Set SetRecordset = Nothing
Dim RS As New Recordset 'adOpenDynamic
RS.Open RecordSource, DBase, adOpenDynamic, adLockOptimistic
Set SetRecordset = RS
End Function

تحياتي