Link to home
Start Free TrialLog in
Avatar of lightcross
lightcross

asked on

Progress / Status Meter for Query Export to Excel

Hi All,

Currently I have code that exports a query result to an excel sheet.  My problem is that sometimes this export can take lots of time.  I would like if I can give the user some kind of status saying that it is still working or an actual progress meter with 0%-100% would be even better.  Any Suggestions?

 The code is as follows:

'*********** FORM CODE
Private Sub Command29_Click()
Dim strSQL As String
Dim strDateIn As String, strDateEnd As String

strDateIn = "#" & Me.tbSTARTDATE & "#"
strDateEnd = "#" & Me.tbENDDATE & "#"

If "" & strDateIn = "" Then  ' Is null or zero length
    MsgBox "YOU MUST ENTER A VALUE IN BOTH FIELDS", vbCritical
        Exit Sub
End If
If "" & strDateEnd = "" Then  ' Is null or zero length
    MsgBox "YOU MUST ENTER A VALUE IN BOTH FIELDS", vbCritical
        Exit Sub
End If

strSQL = "SELECT [tblDieLevelInfo].[LotID], [tblDieLevelInfo].[WaferID], [tblDieLevelInfo].[DieID], [qryCrossIL].[TestType], [qryCrossPDL].[DateTimeTested], [qryCrossIL].[5] AS [Max IL Ch5], [qryCrossIL].[6] AS [Max IL Ch6], [qryCrossIL].[7] AS [Max IL Ch7], [qryCrossIL].[8] AS [Max IL Ch8], [qryCrossPDL].[5] AS [Max PDL Ch5], [qryCrossPDL].[6] AS [Max PDL Ch6], [qryCrossPDL].[7] AS [Max PDL Ch7], [qryCrossPDL].[8] AS [Max PDL Ch8] " _
& " FROM (((tblDieLevelInfo INNER JOIN tblDieStepDetailsData ON [tblDieLevelInfo].[DieLevelID]=[tblDieStepDetailsData].[DieLevelID]) INNER JOIN tblDieOpticalTestResultsPassive ON [tblDieStepDetailsData].[DieStepDetailsID]=[tblDieOpticalTestResultsPassive].[DieStepDetailsID]) INNER JOIN qryCrossIL ON [tblDieStepDetailsData].[DieStepDetailsID]=[qryCrossIL].[DieStepDetailsID]) INNER JOIN qryCrossPDL ON [tblDieStepDetailsData].[DieStepDetailsID]=[qryCrossPDL].[DieStepDetailsID]" _
& " GROUP BY [tblDieStepDetailsData].[DieStepDetailsID], [tblDieLevelInfo].[LotID], [tblDieLevelInfo].[WaferID], [tblDieLevelInfo].[DieID], [qryCrossIL].[TestType], [qryCrossPDL].[DateTimeTested], [qryCrossIL].[5], [qryCrossIL].[6], [qryCrossIL].[7], [qryCrossIL].[8], [qryCrossPDL].[5], [qryCrossPDL].[6], [qryCrossPDL].[7], [qryCrossPDL].[8] " _
& " HAVING (((qryCrossIL.TestType)=""Passive test post arc"") AND ((qryCrossPDL.DateTimeTested) Between " & strDateIn & "  And " & strDateEnd & ")) " _
& " ORDER BY [tblDieLevelInfo].[LotID], [tblDieLevelInfo].[WaferID], [tblDieLevelInfo].[DieID]; "

' see "module code below" for function "exporttoexcel"
  ExportToExcel strSQL
End Sub

'******** MODULE CODE
Public Function ExportToExcel(pstrSQL As String)
On Error GoTo err_handle
Dim objExcel As Excel.Application
Dim exlBook As Excel.Workbook
Dim exlSheet As Excel.Worksheet
Dim exlRange As Excel.Range

Dim rec As Recordset
Dim DB As Database
Dim fld As Field
Dim intCol As Integer

Set DB = CurrentDb()
Set rec = DB.OpenRecordset(pstrSQL, dbOpenSnapshot)

Set objExcel = New Excel.Application
Set exlBook = objExcel.Workbooks.Add
Set exlSheet = exlBook.Worksheets(1)
Set exlRange = exlSheet.Range("A1")
intCol = 1
For Each fld In rec.Fields
    exlRange.Cells(1, intCol) = fld.Name
    intCol = intCol + 1
Next
Set exlRange = exlSheet.Range("A2")
exlRange.CopyFromRecordset rec

objExcel.Visible = True
objExcel.WindowState = vbMaximizedFocus
objExcel.Cells.EntireColumn.AutoFit
err_handle:
Set exlRange = Nothing
Set exlSheet = Nothing

End Function
Avatar of harfang
harfang
Flag of Switzerland image

Hello,

You can create a progress meter only if the time is spent in a loop. If you were in a loop, the progress meter could be on a custom form or you could use the small status-bar progress meter (see "SysCmd acSysCmdInitMeter" and related commands). But I guess that the entire delay is taken by a single line (the CopyFromRecordset), so that you have no handle to manipulate anything.

At least you could have the hourglass (see docmd.hourglass) or a simple "please wait" form, without any close buttons, modal (stays on top).

Sub Example()

    DoCmd.OpenForm "fmodPleaseWait"

    ' do the processing

Exit_Example:
    DoCmd.Close acForm, "fmodPleaseWait"

Error_Example:
    ' handle error here
    Resume Exit_Example

End Sub

If your processing has different "steps" you could show that in the form, e.g.

    Forms!fmodPleaseWait!lblMessage.Caption = "Step 1 -- creating temp table"

I hope this helps
(°v°)
Avatar of lightcross
lightcross

ASKER

Thanks for your comment.  I understand that my single command, CopyFromRecordset, is preventing me from giving a progress indicator.  And I do currently have a label that shows before and after code is done on other forms.  It is used for code that generally only takes a few seconds to complete.  However, I am hoping to move away from it and give a better indicator of percentage complete.  

Is there a way to transform my existing module code into a more robust code that puts each record of the recordset into my excel sheet one by one?  That way I can count all records and say processing X or XX amount of records?  This type of code might slow the process down a bit but at least it will give a better status.  A simple "in process" label or form pop-up could mean the operator could be waiting for 10 seconds to 5 minutes but they will never know.
Well, you could do that, of course, but I'm not sure it's worth it. Something like:

    Set exlRange = exlSheet.Range("A2").Resize(1, rec.Fields.Count)
    Do Until rec.EOF
        ' do your bar coding here
        exlRange.CopyFromRecordset rec, 1
        Set exlRange = exlRange.Offset(1)
        rec.MoveNext
    Loop

To display the progress bar or simply the progress value, use rec.PercentPosition or rec.RecordCount and rec.AbsolutePosition. For example:

    Forms!fmodProgress!txtPercent = rec.PercentPosition / 100
    ' txtPercent being formatted as percent

If you like it visual, have two rectangles, recFull and recVoid one ontop the other and use

    With Forms!fmodProgress
        recFull.Width = recVoid.Width / 100 * rec.PercentPosition
    End With

Have fun!
(°v°)
why do you think it wouldnt be worth it?  because of speed?  just curious.
Well. Users get used to the way an application works. If they might be a little nervous the first time something takes five minutes, the soon start to expect it and work it into their routine. So, althought it's nice to have, and quite vital to have in very wide-spread applications with many untrained users (i.e. Outlook), it's not that important for business-related small applications with a limited number of communicating users.

That's for the background.

Then, I used to do Excel transfers cell-by-cell (before the .CopyFromRecordset method was added) and was so glad of the speed increase that I would not want to go back. This being said, row-by-row is better than cell-by-cell, so this might be a good balance.

Also, as you are going to try it anyway to judge for yourself (a good attitude in this case), you might end up keeping it, so much for the better. So even if it was not a top priority from a business or work-flow point of view, once you have the feature, it's probably worth keeping...

Cheers!
(°v°)
ok.. so i decided to use your rec.PercentPosition / 100 suggestion.

When I call my new module I want to be able to specify the Formname and Textbox name.  That way I can use the function on any form in the future.  As of now the code runs without error but I cannot figure out how to stick the variables in such a way to work nor can I figure out how to have the textbox display "Percent Complete - xx%".  And now for whatever reason the excel sheet is not opening up although it is in the task manager.  I have to keep killing it because they keep getting multiple instances.

Here is my current form code:

Private Sub Command29_Click()
Dim strSQL As String
Dim strDateIn As String, strDateEnd As String

strDateIn = "#" & Me.tbSTARTDATE & "#"
strDateEnd = "#" & Me.tbENDDATE & "#"

If "" & strDateIn = "" Then  ' Is null or zero length
    MsgBox "YOU MUST ENTER A VALUE IN BOTH FIELDS", vbCritical
        Exit Sub
End If
If "" & strDateEnd = "" Then  ' Is null or zero length
    MsgBox "YOU MUST ENTER A VALUE IN BOTH FIELDS", vbCritical
        Exit Sub
End If

DoEvents
Me.txtPercent.Visible = True

strSQL = "SELECT [tblDieLevelInfo].[LotID], [tblDieLevelInfo].[WaferID], [tblDieLevelInfo].[DieID], [qryCrossIL].[TestType], [qryCrossPDL].[DateTimeTested], [qryCrossIL].[5] AS [Max IL Ch5], [qryCrossIL].[6] AS [Max IL Ch6], [qryCrossIL].[7] AS [Max IL Ch7], [qryCrossIL].[8] AS [Max IL Ch8], [qryCrossPDL].[5] AS [Max PDL Ch5], [qryCrossPDL].[6] AS [Max PDL Ch6], [qryCrossPDL].[7] AS [Max PDL Ch7], [qryCrossPDL].[8] AS [Max PDL Ch8] " _
& " FROM (((tblDieLevelInfo INNER JOIN tblDieStepDetailsData ON [tblDieLevelInfo].[DieLevelID]=[tblDieStepDetailsData].[DieLevelID]) INNER JOIN tblDieOpticalTestResultsPassive ON [tblDieStepDetailsData].[DieStepDetailsID]=[tblDieOpticalTestResultsPassive].[DieStepDetailsID]) INNER JOIN qryCrossIL ON [tblDieStepDetailsData].[DieStepDetailsID]=[qryCrossIL].[DieStepDetailsID]) INNER JOIN qryCrossPDL ON [tblDieStepDetailsData].[DieStepDetailsID]=[qryCrossPDL].[DieStepDetailsID]" _
& " GROUP BY [tblDieStepDetailsData].[DieStepDetailsID], [tblDieLevelInfo].[LotID], [tblDieLevelInfo].[WaferID], [tblDieLevelInfo].[DieID], [qryCrossIL].[TestType], [qryCrossPDL].[DateTimeTested], [qryCrossIL].[5], [qryCrossIL].[6], [qryCrossIL].[7], [qryCrossIL].[8], [qryCrossPDL].[5], [qryCrossPDL].[6], [qryCrossPDL].[7], [qryCrossPDL].[8] " _
& " HAVING (((qryCrossIL.TestType)=""Passive test post arc"") AND ((qryCrossPDL.DateTimeTested) Between " & strDateIn & "  And " & strDateEnd & ")) " _
& " ORDER BY [tblDieLevelInfo].[LotID], [tblDieLevelInfo].[WaferID], [tblDieLevelInfo].[DieID]; "

Me.txtPercent.Value = "loading query..."
DoCmd.Hourglass True

DoEvents

  ExportToExcelProgress strSQL, "frmDieTestResultsTimeframe", "txtPercent"

Me.txtPercent.Visible = False
DoCmd.Hourglass False

 
End Sub

Here is my current module code:

Public Function ExportToExcelProgress(pstrSQL As String, varFormName As String)
On Error GoTo err_handle
Dim objExcel As Excel.Application
Dim exlBook As Excel.Workbook
Dim exlSheet As Excel.Worksheet
Dim exlRange As Excel.Range

Dim rec As Recordset
Dim DB As Database
Dim fld As Field
Dim intCol As Integer
Dim varPercent As String



Set DB = CurrentDb()
Set rec = DB.OpenRecordset(pstrSQL, dbOpenSnapshot)

Set objExcel = New Excel.Application
Set exlBook = objExcel.Workbooks.Add
Set exlSheet = exlBook.Worksheets(1)
Set exlRange = exlSheet.Range("A1")

intCol = 1

For Each fld In rec.Fields
    exlRange.Cells(1, intCol) = fld.Name
    intCol = intCol + 1
Next

Set exlRange = exlSheet.Range("A2").Resize(1, rec.Fields.Count)


    Do Until rec.EOF
        exlRange.CopyFromRecordset rec, 1
        Set exlRange = exlRange.Offset(1)
        rec.MoveNext
        DoEvents
        Forms!frmDieTestResultsTimeframe!txtPercent = rec.PercentPosition / 100
'currently the form name and text box name is hardcoded because I cant figure out how to use the variables in the line.
       
            Loop

objExcel.Visible = True
objExcel.WindowState = vbMaximizedFocus
objExcel.Cells.EntireColumn.AutoFit


err_handle:
Set exlRange = Nothing
Set exlSheet = Nothing

ASKER CERTIFIED SOLUTION
Avatar of harfang
harfang
Flag of Switzerland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
OK.. Here is my current module code.  It works with the exception of three problems.

1. I cannot get the textbox to change its value prior to the actual export.  Im guessing my doevents is in a wrong place.

2. I want to format the textbox to show "Percent Completed - 44.00%" or "Processing 44 of 9777 records".  Currently I can only format it to "Percent Completed - 0.44478488484"???

and last but not least...
3. Now the export formats my columns as if they were all dates.  Before with my batch copyrecordset it showed numbers when they were supposed to be numbers and dates when they were dates.

I will increase the points because I think you have helped me pretty extensively already.  Thanks again.


Public Function ExportToExcelProgress(pstrSQL As String, ptxtPercent As TextBox)
On Error GoTo err_handle
Dim objExcel As Excel.Application
Dim exlBook As Excel.Workbook
Dim exlSheet As Excel.Worksheet
Dim exlRange As Excel.Range

Dim rec As Recordset
Dim DB As Database
Dim fld As Field
Dim intCol As Integer
Dim varPercent As String

'changes status of form textbox
DoEvents
ptxtPercent.Value = "Loading Query..."
ptxtPercent.Visible = True

'initiates database recordset
Set DB = CurrentDb()
Set rec = DB.OpenRecordset(pstrSQL, dbOpenSnapshot)

'initiates Excel app and Worksheet
Set objExcel = New Excel.Application
Set exlBook = objExcel.Workbooks.Add
Set exlSheet = exlBook.Worksheets(1)
Set exlRange = exlSheet.Range("A1")

'Places field names into excel sheet as first row
intCol = 1
For Each fld In rec.Fields
    exlRange.Cells(1, intCol) = fld.Name
    intCol = intCol + 1
Next

DoEvents
ptxtPercent.Value = "Executing Export..."


'Sets Excel Sheet to Next Row and begins copying records one row at a time.
Set exlRange = exlSheet.Range("A2").Resize(1, rec.Fields.Count)
    Do Until rec.EOF
        ptxtPercent.Value = "Percent completed - " & rec.PercentPosition / 100     ' see below for this syntax
        exlRange.CopyFromRecordset rec, 1   ' no need for rec.movenext because it automatically movesnext
        Set exlRange = exlRange.Offset(1)   'shifts (offsets) to next 1 row
        DoEvents
    Loop
ptxtPercent.Value = ""
ptxtPercent.Visible = False

'Makes Excel sheet visible with maximized focus and Autofits columns
objExcel.Visible = True
objExcel.WindowState = vbMaximizedFocus
objExcel.Cells.EntireColumn.AutoFit

Exit Function

'duh... error handling
err_handle:
Set exlRange = Nothing
Set exlSheet = Nothing
ptxtPercent.Value = ""
ptxtPercent.Visible = False
MsgBox "Error has occured during data export"
End Function
ok.. i figured it out thanks to you!  here is my final module code.  I think I will end up using this or similar code for lots of my recordset processing code.  This was the line I was having problems with.  

ptxtPercent.Value = "Processing " & rec.AbsolutePosition + 1 & " of " & rec.RecordCount & " records"

*****************
begin module code here:
---------------------------

Public Function ExportToExcelProgress(pstrSQL As String, ptxtPercent As TextBox)
On Error GoTo err_handle
Dim objExcel As Excel.Application
Dim exlBook As Excel.Workbook
Dim exlSheet As Excel.Worksheet
Dim exlRange As Excel.Range

Dim rec As Recordset
Dim DB As Database
Dim fld As Field
Dim intCol As Integer
Dim varPercent As String

'changes status of form textbox
ptxtPercent.Value = "Loading Query..."
ptxtPercent.Visible = True
DoEvents

'initiates database recordset
Set DB = CurrentDb()
Set rec = DB.OpenRecordset(pstrSQL, dbOpenSnapshot)

'initiates Excel app and Worksheet
Set objExcel = New Excel.Application
Set exlBook = objExcel.Workbooks.Add
Set exlSheet = exlBook.Worksheets(1)
Set exlRange = exlSheet.Range("A1")

'Places field names into excel sheet as first row
intCol = 1
For Each fld In rec.Fields
    exlRange.Cells(1, intCol) = fld.Name
    intCol = intCol + 1
Next


ptxtPercent.Value = "Executing Export..."


'Sets Excel Sheet to Next Row and begins copying records one row at a time.
Set exlRange = exlSheet.Range("A2").Resize(1, rec.Fields.Count)
rec.MoveFirst

    Do Until rec.EOF
        'ptxtPercent.Value = "Percent completed - " & rec.PercentPosition
        ptxtPercent.Value = "Processing " & rec.AbsolutePosition + 1 & " of " & rec.RecordCount & " records"
        exlRange.CopyFromRecordset rec, 1   ' no need for rec.movenext because it automatically movesnext
           Set exlRange = exlRange.Offset(1)   'shifts (offsets) to next 1 row
        DoEvents
    Loop
   
ptxtPercent.Value = ""
ptxtPercent.Visible = False

'Makes Excel sheet visible with maximized focus and Autofits columns
objExcel.Visible = True
objExcel.WindowState = vbMaximizedFocus
objExcel.Cells.EntireColumn.AutoFit

Exit Function

'duh... error handling
err_handle:
Set exlRange = Nothing
Set exlSheet = Nothing
ptxtPercent.Value = ""
ptxtPercent.Visible = False
MsgBox "Error has occured during data export"
End Function
Glad it works now. About your questions before:

1. You moved the DoEvents, that was the thing to do.

2. To get a percent, you actually need to format it explicitely, as the format of the control will not work with a mixture of text and numbers:
    .... = "Pr0cessing... " & Format( rec.PercentCompleted/100, "0%" )
But I see that you have gone to another design, that does not require formatting.

3. This I do not understand. From your code, it appears that you use a new sheet, so that there is no prior formatting, and the CopyFormRecordset uses variants internally and should apply correct formatting for two specific number fields only: dates and currency. All other should have "Standard" formatting.

Do you still have that problem #3?

Cheers!
(°v°)
Yes, the problem is still there.  After shifting the date to be the last column and some number fields before the date columns it is formated correctly.  somehow the date column was changing the following columns to date as well.  I would like to fix this issue still.  as i said, it doesnt happen when i just use copyfromrecordset all at once to excel.

Vic
YABOMS!

Well, I made the test and it seems we decovered yet another bug in a MS application (or YABOMS). Indeed, it seems that the date format gets carried over from left to right after  the first date field. I can actually viisualize the piece of code with the lazy omission of a variable reset in a loop...

Anyway, we need to do it by hand.

Ideally, the format of the field sould be used. But this is quite a feat, because due to the persistant incompatibility between most Microsoft products and most other Microsoft products, the format strings need to be converted.

If that doesn't work, the field type can be used to force a default XL format for each Access field type. Combined, the function returning such a format string for each field would be:


Function FormatXL(pfld As DAO.Field) As String

On Error Resume Next

    FormatXL = pfld.Properties("Format")
    Select Case FormatXL
        ' Standard formats
        Case "Percent":         FormatXL = "0.0%"
        Case "General Date":    FormatXL = "d.mmm.yyyy hh:mm"
        Case "Short Date":      FormatXL = "d.mm.yy"
        ' etc...
       
        ' Custom formats...
        Case Else
            If InStr(FormatXL, "%") Then
            ElseIf InStr(FormatXL, "€") Then
            ElseIf InStr(FormatXL, "#") Then
            Else
                ' unknown... let's not use it.
                FormatXL = ""
            End If
           
    End Select
   
    ' if no format found, use field type
    If FormatXL = "" Then
        Select Case pfld.Type
            Case dbDate:        FormatXL = "d.mmm.yyyy hh:mm"
            Case dbCurrency:    FormatXL = "€ #,##0.00"
        End Select
    End If

End Function


Or just use the simple version:


Function FormatXL(pfld As DAO.Field) As String

    Select Case pfld.Type
        Case dbDate:        FormatXL = "d.mmm.yyyy hh:mm"
        Case dbCurrency:    FormatXL = "€ #,##0.00"
    End Select

End Function


After all rows have been transfered, you can then add something like this:

    Set xlrngCell = xlwksTarget.Range("A1")
    For Each fld In rs.Fields
        xlrngCell.EntireColumn.NumberFormat = FormatXL(fld)
        Set xlrngCell = xlrngCell.Offset(, 1)
    Next fld

Another option would be to use XL styles instead of formats (it would be more portable in international environments), but let's not go into that here.

I hope this helps.
(°v°)
Oops, didn't replace my variable names with yours. You'll manage :)
(°v°)