Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 832
  • Last Modified:

Display a changing message on a userform while a macro waits

Hello
I have a Macro that runs a SQL Stored Procedure and a userform that displays "Updating" while the Macro waits for the result from the SQL Server then changes to "Updated".
What I need is to constantly update the Message while the Macro is still waiting for the result.

Thanks
0
p-plater
Asked:
p-plater
  • 20
  • 10
  • 3
  • +1
2 Solutions
 
dlmilleCommented:
You could use an OnTime function to achieve that.  Basically, you trigger a macro to run so many seconds from NOW, when it runs, it also triggers itself to run again so many seconds from the then NOW, etc.  Upon completion, its important to turn the On Timer OFF BEFORE you close the Userform - make it part of the userform close process, perhaps....

Here's my most recent soltuion with On Time, modified for this situation...
Public runWhen As Double

Sub startTimer()
Dim refreshTime As Double
Dim waitMins As Long

    Call myMacro
    waitMins = 5
    refreshTime = 15 ' after testing at 15 seconds, then change to -> waitMins * 60 'time in seconds
    runWhen = Now() + refreshTime / 86400 '# seconds in 24 hours
    Application.OnTime earliesttime:=runWhen, procedure:="StartTimer", schedule:=True

End Sub
Sub StopTimer()
    On Error Resume Next
    Application.OnTime earliesttime:=runWhen, procedure:="StartTimer", schedule:=False
    
End Sub
Sub myMacro()
    'update your Userform status message, here
End Sub

Open in new window


Please advise if further assistance is needed.

Dave
0
 
p-platerAuthor Commented:
I have the following code.

Call startTimer
Call ConSQL
Set cmd = New ADODB.Command
With cmd
    .ActiveConnection = SQLEx
    .CommandType = adCmdStoredProc
    .CommandText = "Command"
    .Parameters.Append .CreateParameter("@SALES_ORDER", adInteger, adParamInput, 20, 33)
    .Execute , , adExecuteNoRecords
End With
MsgBox "Ended"
Call StopTimer

But the Message on the Userform doesn't change from the Initial Message untill the SQL command is complete.
0
 
dlmilleCommented:
what did you set the refresh time to?
0
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
p-platerAuthor Commented:
refreshTime = 1
0
 
dlmilleCommented:
try something like 5 or 10 seconds, just to see if it works - or put a msgbox to advise.

We need to ensure that it DOES work, first - make it 10 seconds and have a messagebox popup (hold of on all other processing, till we ensure this is working and not some other issue we need to resolve).

OK?

Dave
0
 
dlmilleCommented:
A complete working example is in the attached.  Note where I placed the code.  Hit the TEST button on the worksheet and you'll see the refresh every 1 second

Let me know the test works for you, then after incorporating let me know if you have any issues.

See attached

Dave
userForm-Status-r1.xls
0
 
p-platerAuthor Commented:
This is the Calling Sub (Which is in another Userform

Private Sub update()
    Dim AAA As String
    Dim cmd As ADODB.Command
    lbMess.Caption = "Updating...."
    lbMess.Tag = "Updating"
MsgBox "BEFORE"
    Call startTimer
         Call ConSQL
        Set cmd = New ADODB.Command
        DoEvents
        With cmd
            .ActiveConnection = SQLEx
            .CommandType = adCmdStoredProc
            .CommandText = "X_REPRICE_QUOTE"
            .Parameters.Append .CreateParameter("@SALES_ORDER", adInteger, adParamInput, 20, Val(ufSolve.LBsalesord_hdr_seqno.Caption))
            .Parameters.Append .CreateParameter("@DONE", adChar, adParamOutput, 1)
            .Execute , , adExecuteNoRecords
        End With
    Call ufSolve.LoadDetails(Val(ufSolve.LBsalesord_hdr_seqno.Caption))
    Call StopTimer
    lbMess.Tag = "Finished"
    lbMess.Caption = "Updated"
MsgBox "after"
End Sub

This is the updating code from a Module

Public runWhen As Double
Sub startTimer()
Dim refreshTime As Double
Dim waitMins As Long
    Call myMacro
    waitMins = 5
    refreshTime = 1 ' after testing at 15 seconds, then change to -> waitMins * 60 'time in seconds
    runWhen = Now() + refreshTime / 86400 '# seconds in 24 hours
    Application.OnTime earliesttime:=runWhen, procedure:="StartTimer", schedule:=True

End Sub
Sub StopTimer()
    On Error Resume Next
    MsgBox "stop"
    Application.OnTime earliesttime:=runWhen, procedure:="StartTimer", schedule:=False
   
End Sub
Sub myMacro()
MsgBox "myMacro"
    'update your Userform status message, here
    ufConfirm.lbStatus = "Running... Timer = " & Timer
End Sub

The myMacro msgbox pops up once then nothing happens till the SQL is complete then the Stop msgbox pops up.

If I just run the "StartTimer" sub manualy it works
0
 
dlmilleCommented:
do you get the first update to ufComfirm.lbStatus???

Dave
0
 
p-platerAuthor Commented:
Yes - It shows the Start Time
0
 
p-platerAuthor Commented:
And this is the connection sub for the SQL command

Public Sub ConSQL()

On Error GoTo ConHandler

    Set SQLEx = New ADODB.Connection

    SQLEx.ConnectionString = "Provider=SQLOLEDB;Server=" & Serv & "\SQLEXPRESS;Database=" & Database & "; User ID=SA;password=" & Pass
    SQLEx.Open
    SQLEx.CommandTimeout = 1000
   
   
Exit Sub
ConHandler:
        On Error Resume Next
        Msg = "Connection to the Server not Found"
        MsgBox Msg
        On Error GoTo 0
End Sub
0
 
dlmilleCommented:
we need to kick off a couple threads, simultaneously.  The timer's not coming back and executing the myMacro() code, because your code is sitting waiting on the result of your query.

Is there a way to kick off the query, but only get results when you want to get results, as opposed to sitting in the code waiting?

E.g.,

call StartTimer
call doQuery

'both run...

then every time myMacro runs, it updates the status, but also checks on the query, then stops the timer and deals with the query once it gets a positive result back...

Not sure your query engine is that sophisticated, but its a thought.

Let me know...

Dave
0
 
dlmilleCommented:
I think I've got it.  We can kick off two threads.  We run an On Time timer to kickoff the update, say 5 seconds from now (just to kick it off, not have it re-initiate itself ever 5 seconds - just run one time, then run the StartTimer to kickoff the refresh cycle.  When the query is done, it stops the second timer and terminates.  

Here's the code to paste in the appropriate places.  Hopefully it works, otherwise, I'll try to build a test doing something like this so I can debug from here:
 
Private Sub update()
    Dim AAA As String
    Dim cmd As ADODB.Command
    lbMess.Caption = "Updating...."
    lbMess.Tag = "Updating"

        Call ConSQL
        Set cmd = New ADODB.Command
        DoEvents
        With cmd
            .ActiveConnection = SQLEx
            .CommandType = adCmdStoredProc
            .CommandText = "X_REPRICE_QUOTE"
            .Parameters.Append .CreateParameter("@SALES_ORDER", adInteger, adParamInput, 20, Val(ufSolve.LBsalesord_hdr_seqno.Caption))
            .Parameters.Append .CreateParameter("@DONE", adChar, adParamOutput, 1)
            .Execute , , adExecuteNoRecords
        End With
    Call ufSolve.LoadDetails(Val(ufSolve.LBsalesord_hdr_seqno.Caption))

    lbMess.Tag = "Finished"
    lbMess.Caption = "Updated"
    Call StopTimer
End Sub


Public runWhen As Double
Public runWhenQry As Double
Sub startQuery()
Dim refreshTime As Double
Dim waitMins As Long

    'macro waits the refreshTime number of seconds, then runs the update() macro
    refreshTime = 5 ' after testing at 15 seconds, then change to -> waitMins * 60 'time in seconds
    runWhen = Now() + refreshTime / 86400 '# seconds in 24 hours
    Application.OnTime earliesttime:=runWhenQry, procedure:="update", schedule:=True
    
    Call startTimer
End Sub
Sub startTimer()
Dim refreshTime As Double
Dim waitMins As Long
    Call myMacro
    waitMins = 5
    refreshTime = 1 ' after testing at 15 seconds, then change to -> waitMins * 60 'time in seconds
    runWhen = Now() + refreshTime / 86400 '# seconds in 24 hours
    Application.OnTime earliesttime:=runWhen, procedure:="StartTimer", schedule:=True

End Sub
Sub StopTimer()
    On Error Resume Next
    Application.OnTime earliesttime:=runWhen, procedure:="StartTimer", schedule:=False
    
End Sub
Sub myMacro()
    'update your Userform status message, here
    ufConfirm.lbStatus = "Running... Timer = " & Timer
End Sub

Open in new window


Dave
0
 
dlmilleCommented:
The macro to run from your userform would be called "startQuery"...

Dave
0
 
p-platerAuthor Commented:
As soon as it hits the "Update" sub the updating of ufConfirm.lbStatus stops
0
 
dlmilleCommented:
If this DOESN'T work, again because VBA is sitting running the other code, then there are a couple other optioins - first, my prior post asking whether you can kick off a query and then come back at a later time to check status (rather than waiting.  So if the last post didnt' work, let me know about the one before that, if your database engine allows such things as kicking off queries, but not waiting around - but getting an event or proactively testing if a cursor is available - at least that's the way it works on some engines, if memory serves (and I have to go back about 20 years but I remember that capability with remote databases like Oracle, etc.)....

let me know - I'll keep brainstorming.  If we get nowhere, tomorrow I'll call on some other E-E experts for their insights.

Dave
0
 
dlmilleCommented:
There must be a way to kick off the EXECUTE command, and let code keep running, where you can make another call to pull the data from your query...

Dave
0
 
p-platerAuthor Commented:
Maybe I need to use a different connection Provider to the SQL database?
0
 
dlmilleCommented:
Perhaps.  I started research on that, but its starting from scratch, as I'm not up to speed on SQLExpress.  I was a SQLServer/Oracle programmer, but that goes way back.  I'm sure it does.

I did do an experiment and was able to kick off and observe two processes going at the same time (see attached) position the debug window on half the screen, and position th espreadsheet on the other half.  When you hit start, another macro updates stuff in the immediate window, while the timer update on the userform is also updated.  So it can be done.

The BIG problem is that the VBA code executing the QUERY is stopped at EXECUTE and waiting.  You may not in the attached code, I have doEvents in both macros, which allow the timer events to work.  but DoEvents has to be run again, and again, and again, for this to work.

The only other alternative (to the revised, if possible, EXECUTE command) is to run a process that is not part of excel (like a compiled program with update status on it, or perhaps another instance of Excel).  Would you be interested in kicking off another instance of Excel as part of this process?  We MIGHT be able to make that elegant if nothing is visible but "hey, I'm running" messages updating...

Let me know.

Dave
userForm-Status-r3.xls
0
 
dlmilleCommented:
You aren't the only one pondering this problem:

http://www.tek-tips.com/viewthread.cfm?qid=1512799&page=4

Dave
0
 
Rory ArchibaldCommented:
You should, I think, be able to run the command asynchronously using:

.Execute , , adExecuteNoRecords + .Execute , , adExecuteNoRecords + adAsyncExecute

Open in new window


and then check its State in a loop until it's closed.
0
 
dlmilleCommented:
Thanks for that, rorya.

@p-plater - if rorya is correct, then change your code to this: paste in appropriate places:

 
Private Sub update()
    Dim AAA As String
    Dim cmd As ADODB.Command
    lbMess.Caption = "Updating...."
    lbMess.Tag = "Updating"

        Call ConSQL
        Set cmd = New ADODB.Command
        DoEvents
        With cmd
            .ActiveConnection = SQLEx
            .CommandType = adCmdStoredProc
            .CommandText = "X_REPRICE_QUOTE"
            .Parameters.Append .CreateParameter("@SALES_ORDER", adInteger, adParamInput, 20, Val(ufSolve.LBsalesord_hdr_seqno.Caption))
            .Parameters.Append .CreateParameter("@DONE", adChar, adParamOutput, 1)
            .Execute , , adExecuteNoRecords + .Execute , , adExecuteNoRecords + adAsyncExecute 
        End With
    Call ufSolve.LoadDetails(Val(ufSolve.LBsalesord_hdr_seqno.Caption))

    lbMess.Tag = "Finished"
    lbMess.Caption = "Updated"
    Call StopTimer
End Sub


Public runWhen As Double
Public runWhenQry As Double
Sub startQuery()
Dim refreshTime As Double
Dim waitMins As Long

    'macro waits the refreshTime number of seconds, then runs the update() macro
    refreshTime = 5 ' after testing at 15 seconds, then change to -> waitMins * 60 'time in seconds
    runWhen = Now() + refreshTime / 86400 '# seconds in 24 hours
    Application.OnTime earliesttime:=runWhenQry, procedure:="update", schedule:=True
    
    Call startTimer
End Sub
Sub startTimer()
Dim refreshTime As Double
Dim waitMins As Long
    Call myMacro
    waitMins = 5
    refreshTime = 1 ' after testing at 15 seconds, then change to -> waitMins * 60 'time in seconds
    runWhen = Now() + refreshTime / 86400 '# seconds in 24 hours
    Application.OnTime earliesttime:=runWhen, procedure:="StartTimer", schedule:=True

End Sub
Sub StopTimer()
    On Error Resume Next
    Application.OnTime earliesttime:=runWhen, procedure:="StartTimer", schedule:=False
    
End Sub
Sub myMacro()
    'update your Userform status message, here
    ufConfirm.lbStatus = "Running... Timer = " & Timer
End Sub

Open in new window


If this DOESN't work, I have an alternative solution guaranteed to work, though it involved me writing a VBA.NET compiled program that will give you the status bar with start time, current time, elapsed time and a message.  When Excel updates a txt file (old time semaphore approach) the compiled program checks that every so many seconds, when it sees "Quit", it ends.  Excel would update that text file when the query was done executing.  However, let's see if rorya's add to the code is sufficient, first.

Cheers,

Dave
0
 
Rory ArchibaldCommented:
I can't see anything in there that checks if the command has finished before running the stoptimer code?

Also, simpler to use something like:

runWhen = Now() + TimeSerial(0, 0, refreshTime)

when setting a timer, IMO.
0
 
dlmilleCommented:
Here is the alternative, in case you're up working this ahead of me.

Download the zip and put them in the SAME folder:

1. example XLS file
2. compiled VB.Net application (userformStatus.txt -> rename to an executable exe, as there were upload issues)
3. (doesn't exist yet, but): status.txt file will be generated initially by the example XLS file <- this is the semaphore that has text in it, whenever the text says "Quit" the compiled app (which displays the status) will terminate (re: when you initiate the Quit status update at the end of the query execute.

If you like it, you can model your SQL query code inside the SQLSimulator() routine

Here's the public module code:
 
Public runWhen As Double, myProc As Variant
Sub initiateUserform()
    Load UserForm1
    UserForm1.Show
End Sub
Sub doParallelThread()
    Call initializeStatusApp
    DoEvents
    myProc = Shell(ActiveWorkbook.Path & "\userformStatus.exe", vbNormalFocus)
    Call SQLSimulator
    Call terminateStatusApp
    Unload UserForm1
    DoEvents
    'here's where you'll continue processing, after a successful SQL query
End Sub
Sub terminateStatusApp()
Dim fName As String
Dim countErr As Long
    
    fName = ThisWorkbook.Path & "\status.txt"
    Open fName For Output As #1
    Print #1, "Quit"
    Close #1
    
End Sub
Sub initializeStatusApp()
Dim fName As String

    fName = ThisWorkbook.Path & "\status.txt"
    Open fName For Output As #1
    Print #1, "Please Wait, Query Running"
    Close #1
    
End Sub
Sub SQLSimulator()
Dim newHour As Long
Dim newMinute As Long
Dim newSecond As Long

    'here's where you'll put your SQL related code
    
    newHour = Hour(Now())
    newMinute = Minute(Now())
    newSecond = Second(Now()) + 10 '10 second wait to simulate a code "freeze" in VBA, while asynchronous timer is still displaying status
    waitTime = TimeSerial(newHour, newMinute, newSecond)
    Application.Wait waitTime
    
End Sub

Open in new window


Cheers,

Dave
userForm-Status-r4.zip
0
 
dlmilleCommented:
rorya - stoptimer on line 22
the refreshWhen time calculation is my standard approach to assist in time conversion, in case minutes or hours are wanted, so I use this regardless of even when I need seconds.  Maybe overkill for this, but I leave it there in case someone wants to adopt...

Dave
0
 
dlmilleCommented:
rorya - scratch my last comment.  I see what you did with TimeSerial and it just hit me.  Good one...

Dave
0
 
Rory ArchibaldCommented:
Dave,
I think you missed my point. I can see that you call stoptimer. What I can't see is anything that checks to see if the command has actually finished before calling stoptimer.
0
 
dlmilleCommented:
I believe the async execute will work.  Here's a tip online:  http://www.andreavb.com/tip120006.html

Using that learning, p-plater, please update at line 19, with the following:

@p-plater - you'll need to replace with this code, at line 18 to end of the sub, before wrapping things up.  Its a do-loop where you check the return status on the asynchronous query:
 
Do While (cmd.State And adStateExecuting) = adStateExecuting
       DoEvents
    Loop
    
    Call ufSolve.LoadDetails(Val(ufSolve.LBsalesord_hdr_seqno.Caption))

    lbMess.Tag = "Finished"
    lbMess.Caption = "Updated"
    Call StopTimer
End Sub

Open in new window


Cheers,

Dave
0
 
dlmilleCommented:
rorya - hope this works and thanks for the tip!  I'll use my VB.NET status updater at some point in the future, I'm sure.

:)

Dave
0
 
p-platerAuthor Commented:
THANKS
That works except for one thing - I want to update the message four thimes a second
0
 
dlmilleCommented:
Which solution is working?  The ontime one or the xompiled app?  Either is dooable but well probabluy need to use the api timer proc for the ontime replacement

Let me know and Ill turn it around for you

Dave
0
 
p-platerAuthor Commented:
The Ontime one.

I can use the Ontime or I can delete the Ontime and just use

Private Sub updateee()
    Dim AAA As String
   
    Dim cmd As ADODB.Command
    ufConfirm.lbMess.Caption = "Updating...."
    ufConfirm.lbMess.Tag = "Updating"
        Call ConSQL
        Set cmd = New ADODB.Command
        DoEvents
        With cmd
            .ActiveConnection = SQLEx
            .CommandType = adCmdStoredProc
            .CommandText = "X_REPRICE_QUOTE"
            .Parameters.Append .CreateParameter("@SALES_ORDER", adInteger, adParamInput, 20, Val(ufSolve.LBsalesord_hdr_seqno.Caption))
            .Parameters.Append .CreateParameter("@DONE", adChar, adParamOutput, 1)
            .Execute , , adExecuteNoRecords + adAsyncExecute
        End With
       
    Do While (cmd.State And adStateExecuting) = adStateExecuting
       DoEvents
       Call myMacro
       DoEvents
    Loop
   
    Call ufSolve.LoadDetails(Val(ufSolve.LBsalesord_hdr_seqno.Caption))

    ufConfirm.lbMess.Tag = "Finished"
    ufConfirm.lbMess.Caption = "Updated"
End Sub

But this just causes the message to flicker.

So I can either use the Ontime or something to make the macro pause for 1/4 a second in the MyMacro sub
0
 
dlmilleCommented:
you don't want it in the MyMacro sub as you wouldn't know when to leave it.  you could put it in the while statement -

Both OnTime and Wait have seconds as their lowest common demoninator, unless I'm misreading the documentation.

However, you can use a Windows API to get into milliseconds.

Consult this tip from Chip Pearson's website: http://www.cpearson.com/excel/OnTime.aspx

See Using Windows Timers, some of the dangers that are easily managed as long as you do manage them.  The setup is similar to how OnTime works
To use Windows timers, paste the following code into a standard code module:

Public Declare Function SetTimer Lib "user32" ( _
    ByVal HWnd As Long, _
    ByVal nIDEvent As Long, _
    ByVal uElapse As Long, _ 
    ByVal lpTimerFunc As Long) As Long

Public Declare Function KillTimer Lib "user32" ( _
    ByVal HWnd As Long, _
    ByVal nIDEvent As Long) As Long

Public TimerID As Long
Public TimerSeconds As Single

Sub StartTimer()
    TimerSeconds = 1 ' how often to "pop" the timer.
    TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc)
End Sub

Sub EndTimer()
    On Error Resume Next
    KillTimer 0&, TimerID
End Sub

Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, _
        ByVal nIDEvent As Long, ByVal dwTimer As Long)
    
    ''''''
    ' This procedure is called by Windows. Put your
    ' code here.
    ''''''
End Sub

Open in new window


Let me know if you need further assistance.

Cheers,

Dave
0
 
broro183Commented:
hi everyone,

It looks like you have a solution already... but just for giggles, I thought I would post the below ideas which I've come across in the past 6 months or so, although I have not tried to implement them myself:

- include something in the query which acts as a counter & increments the progressbar as the query returns data. My workmate showed me this awhile ago, so if I can dig out his example I will post it during the week.

- Use a With Events statement on the recordset, as per the below italicised section (+ the code) which is an extract from from: the http://oreilly.com/catalog/vbanut/chapter/booklet.html#sect12 section of http://oreilly.com/catalog/vbanut/chapter/booklet.html 

The following example demonstrates how to trap and respond to the events within an ADO recordset. An object variable is declared using the WithEvents keyword in the declarations section of a form module. This allows you to write event-handling code for the ADO's built-in events, in this case the FetchProgress event. (The FetchProgress event allows you to implement a Progress Bar control that shows progress in populating the recordset.)



Private WithEvents oADo As ADODB.Recordset
 
Private Sub oADo_FetchProgress(ByVal Progress As Long, _
                      ByVal MaxProgress As Long, _
                      adStatus As ADODB.EventStatusEnum, _
                      ByVal pRecordset As ADODB.Recordset)
    
   ProgressBar1.Max = MaxProgress
   ProgressBar1.Value = Progress
            
End Sub

Open in new window


hth
Rob
0
 
p-platerAuthor Commented:
Thanks
 100/100
0

Featured Post

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

  • 20
  • 10
  • 3
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now