Form with progress bar freezes until function is complete

Question

I've looked at several examples of code for making a progress bar, and I ultimately decided on basing it on one that simply changes the width of a shaded rectangle until it reaches full length.  I added it to an existing procedure that already loops through a table of file names ([tFiles] through ListFilesToTable), imports each file in turn, imports that file's data into a temporary table, and then decodes the data into an order request from a customer.  (FYI - The files are Electronic Data Interchange order files - EDI 850's).  The entire process can take a couple of minutes if there are a lot of orders, hence the progress bar.

My current problem is that the import form freezes after only getting about 20% of the way done, but the code continues to run, with the immediate window reporting as it starts each new record.  Up until it freezes, the progress bar grows as it's supposed to through the first 6-8 records or so.  Here's the code:

Private Sub FilestoTable_Click()

Dim db                     As DAO.Database

Dim rs                   As DAO.Recordset

Dim rsLog               As DAO.Recordset

Dim stPath               As String

Dim stFileName           As String

Dim stRecordCount       As Integer

Dim stProgress           As Long

Dim stProgressIncr       As Long

Dim Progress_Amount   As Integer

Dim RetVal               As Variant

Call ListFilesToTable(Me.TxtInitDir, "*." & Me.TxtExtension)

Set db = CurrentDb

Set rs = db.OpenRecordset("SELECT * FROM [tFiles]")

Set rsLog = db.OpenRecordset("SELECT * FROM tEDIImportLog")

rs.MoveLast

rs.MoveFirst

Me.OriginalWidth = Me.ProgressBar.Width

Me.ProgressBox.Visible = True

Me.ProgressBar.Width = 0

Me.Repaint

Me.ProgressBar.Visible = True

stRecordCount = rs.RecordCount

stProgress_Amount = 1 / stRecordCount

stProgressIncr = stProgress_Amount * 5760

Do Until rs.EOF

stPath = Me.TxtInitDir

stFileName = rs!fName

If Not Create_tRaw850(stFileName, stPath) Then

MsgBox "There was a problem creating the blank table - tRaw850."

Exit Sub

End If

If Not Decode_850(stFileName, stPath, stImportResult) Then

Shell "notepad.exe " & stPath & "" & stFileName, vbNormalFocus ' open original txt document for review

MsgBox stImportResult

rs.MoveNext

End If

If IsNull(stImportLog) Then

Dim fso

Set fso = CreateObject("Scripting.FileSystemObject")

fso.MoveFile stPath & "" & stFileName, "\internetstorage\commondocuments\edi\850"

rs.Edit

rs!DateCreated = Now()

rs.Update

End If

rsLog.AddNew

rsLog!FileName = stPath & "" & stFileName

rsLog!ImportDate = Now()

rsLog!Result = stImportResult

rsLog.Update

Me.ProgressBar.Width = Me.ProgressBar.Width + stProgressIncr

Me.Repaint

rs.MoveNext

Loop

Me.ProgressBox.Visible = False

Me.ProgressBar.Visible = False

rs.Close

rsLog.Close

Set db = Nothing

End Sub

Full disclosure: I'm running Access 2010 32-bit in a Win7 64-bit VM inside MAC OSX  (don't even begin to ask why).

-Cevin

Answer 1

You can try to add a DoEvents right before and right after the Me.Repaint. but that may not be enough.

Answer 2

Adding a DoEvents right after the Me.Repaint did the trick.  Thank you very, very much!

I also added a text box that I put in the middle of the progress bar (rectangle) that updates with the percentage completed by adding this line right before the Me.Repaint:

Me.ImportStatus = Me.ProgressBar.Width / 5760