I have this piece of code which I would like to show and hide some Shape objects one by one, in order to make a little animation. However, nothing happens as the code executes, all images are shown by once when the code stops running.
Sub test()
For i = 1 To 4
Sheets("Game").Shapes("North" & i).Visible = True
Sleep 500
'Sheets("Game").Shapes("North" & i).Visible = False
'by setting it to false i'd like to achieve the animation effect
Debug.Print i
DoEvents
Next i
End Sub
DoEvents allows other code (e.g. Excel's own) to run and handle things like user clicking on another worksheet (which invokes any Worksheet.Change or Workbook.WorksheetChange handler)... or just repainting itself.
By invoking DoEvents once per loop, Excel doesn't get a chance to repaint between the visibility toggles: it's already busy running your loop.
So you need to toggle visibility on, let Excel repaint (DoEvents), sleep for your animation delay (500ms seems a tad slow IMO), then toggle visibility off and let Excel repaint again, i.e. invoke DoEvents one more time.
If the Game worksheet is in ThisWorkbook, then I'd warmly recommend you give it a CodeName - select it in the Project Explorer, then look at its properties (F4) and change its (Name) to, say, GameSheet.
This gives you a global-scope object variable so that you don't need to dereference the same worksheet twice per iteration - heck you could even dereference its Shapes collection only once:
Private Const ANIMATION_DELAY As Long = 100
Sub test()
With GameSheet.Shapes
For i = 1 To 4
Dim currentShape As Shape
Set currentShape = .Item("North" & i)
currentShape.Visible = True
DoEvents
Sleep ANIMATION_DELAY
currentShape.Visible = False
DoEvents
Debug.Print i
Next
End With
End Sub
Amended the code by setting DoEvents after toggling True and Falseand now it works:
Sub test()
For i = 1 To 4
Sheets("Game").Shapes("North" & i).Visible = True
DoEvents
Sleep 100
Sheets("Game").Shapes("North" & i).Visible = False
DoEvents
'by setting it to false i'd like to achieve the animation effect
Debug.Print i
Next i
End Sub
Related
My Excel tool performs a long task, and I'm trying to be kind to the user by providing a progress report in the status bar, or in some cell in the sheet, as shown below. But the screen doesn't refresh, or stops refreshing at some point (e.g. 33%). The task eventually completes but the progress bar is useless.
What can I do to force a screen update?
For i=1 to imax ' imax is usually 30 or so
fractionDone=cdbl(i)/cdbl(imax)
Application.StatusBar = Format(fractionDone, "0%") & "done..."
' or, alternatively:
' statusRange.value = Format(fractionDone, "0%") & "done..."
' Some code.......
Next i
I'm using Excel 2003.
Add a DoEvents function inside the loop, see below.
You may also want to ensure that the Status bar is visible to the user and reset it when your code completes.
Sub ProgressMeter()
Dim booStatusBarState As Boolean
Dim iMax As Integer
Dim i As Integer
iMax = 10000
Application.ScreenUpdating = False
''//Turn off screen updating
booStatusBarState = Application.DisplayStatusBar
''//Get the statusbar display setting
Application.DisplayStatusBar = True
''//Make sure that the statusbar is visible
For i = 1 To iMax ''// imax is usually 30 or so
fractionDone = CDbl(i) / CDbl(iMax)
Application.StatusBar = Format(fractionDone, "0%") & " done..."
''// or, alternatively:
''// statusRange.value = Format(fractionDone, "0%") & " done..."
''// Some code.......
DoEvents
''//Yield Control
Next i
Application.DisplayStatusBar = booStatusBarState
''//Reset Status bar display setting
Application.StatusBar = False
''//Return control of the Status bar to Excel
Application.ScreenUpdating = True
''//Turn on screen updating
End Sub
Text boxes in worksheets are sometimes not updated
when their text or formatting is changed, and even
the DoEvent command does not help.
As there is no command in Excel to refresh a worksheet
in the way a user form can be refreshed, it is necessary
to use a trick to force Excel to update the screen.
The following commands seem to do the trick:
- ActiveSheet.Calculate
- ActiveWindow.SmallScroll
- Application.WindowState = Application.WindowState
Put a call to DoEvents in the loop.
This will affect performance, so you might want to only call it on each, say, 10th iteration.
However, if you only have 30, that's hardly an issue.
#Hubisans comment worked best for me.
ActiveWindow.SmallScroll down:=1
ActiveWindow.SmallScroll up:=1
Specifically, if you are dealing with a UserForm, then you might try the Repaint method. You might encounter an issue with DoEvents if you are using event triggers in your form. For instance, any keys pressed while a function is running will be sent by DoEvents The keyboard input will be processed before the screen is updated, so if you are changing cells on a spreadsheet by holding down one of the arrow keys on the keyboard, then the cell change event will keep firing before the main function finishes.
A UserForm will not be refreshed in some cases, because DoEvents will fire the events; however, Repaint will update the UserForm and the user will see the changes on the screen even when another event immediately follows the previous event.
In the UserForm code it is as simple as:
Me.Repaint
This worked for me:
ActiveWindow.SmallScroll down:=0
or more simply:
ActiveWindow.SmallScroll 0
I couldn't gain yet the survey of an inherited extensive code. And exact this problem bugged me for months. Many approches with DoEnvents were not helpful.
Above answer helped. Placeing this Sub in meaningful positions in the code worked even in combination with progress bar
Sub ForceScreenUpdate()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Wait Now + #12:00:01 AM#
Application.ScreenUpdating = False
Application.EnableEvents = False
End Sub
This is not directly answering your question at all, but simply providing an alternative. I've found in the many long Excel calculations most of the time waiting is having Excel update values on the screen. If this is the case, you could insert the following code at the front of your sub:
Application.ScreenUpdating = False
Application.EnableEvents = False
and put this as the end
Application.ScreenUpdating = True
Application.EnableEvents = True
I've found that this often speeds up whatever code I'm working with so much that having to alert the user to the progress is unnecessary. It's just an idea for you to try, and its effectiveness is pretty dependent on your sheet and calculations.
On a UserForm two things worked for me:
I wanted a scrollbar in my form on the left. To do that, I first had to add an Arabic language to "Change administrative language" in the Language settings of Windows 10 (Settings->Time & Language->Change Administrative Language). The setting is actually for "Change the language of Non-Unicode Programs," which I changed to Arabic (Algerian). Then in the properties of the form I set the "Right to Left" property to True. From there the form still drew a partial ghost right scrollbar at first, so I also had to add an unusual timed message box:
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
'Set the message box to close after 10 seconds
AckTime = 1
Select Case InfoBox.Popup("Please wait.", AckTime, "This is your Message Box", 0)
Case 1, -1
End Select
I tried everything to get the screen to redraw again to show the first text box in it's proper alignment in the form, instead of partially underneath or at least immediately adjacent to the scrollbar instead of 4 pixels to the right where I wanted it. Finally I got this off another Stackoverflow post (which I now can't find or I would credit it) that worked like a charm:
Me.Frame1.Visible = False
Me.Frame1.Visible = True
In my case the problem was in trying to make one shape visible and another one invisible on a worksheet.
This is my approach to "inactivating" a button [shape] once the user has clicked it. The two shapes are the same size and in the same place, but the "inactive" version has dimmer colors, which was a good approach, but it didn't work, because I could never get the screen to update after changing .visible = FALSE to = TRUE and vice versa.
None of the relevant tricks in this thread worked. But today I found a solution that worked for me, at this link on Reddit
Essentially you just call DoEvents twice in immediate succession after the code that makes the changes. Now why? I can't say, but it did work.
I've been trying to solve this Force a screen update on a Worksheet (not a userform) for many years with limited success with
doevents and scrolling etc.. This CH Oldie solutions works best with a slight mod.
I took out the Wait and reset ScreenUpdating and EnableEvents back to true.
This works office excel 2002 through to office 365
Sub Sheet1Mess(Mess1 As String)
Sheet1.Range("A6").Value = Mess1
ForceScreenUpdate
End Sub
Sub ForceScreenUpdate()
Application.ScreenUpdating = True
Application.EnableEvents = True
' Application.Wait Now + #12:00:01 AM#
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Some background, I had a VBA loop creating PPT slides with various filters/views on an Excel pivot table. It was working (after I added DoEvents). I have recently added functionality to create a new PPT file from scratch with multiple sides before they are populated with the data. It's not working anymore.
Two theories:
1) Somehow the memory got bogged down in the new PPT file creation loop and now the data population loop is erroring out.
2) Something about how the default chart is formatted is messed up. If I edit the charts manually, save, and populate, there is no error. However if I create and then automatically try to populate, there's an error.
Due to complexity of the scripts, the loop to create the slides is completely separate from the loop to reopen and populate the slides.
Here's the section that errors out:
'Paste the final temp dataset into PPT
Range("A1000").Activate
tempdata = Range(Selection, Selection.Offset(months, categories - 1)).Value
Set oChart = oPres.Slides(pages(b)).Shapes(metrics(a)).Chart
oChart.ChartData.Activate
Set wb = oChart.ChartData.Workbook
Set ws = wb.Worksheets(1)
ws.Range("A1:Z1000").ClearContents
ws.Range("A1", Range("A1").Offset(months, categories - 1)).Value = tempdata
'Let code catch up
Application.Wait (Now + TimeValue("00:00:02"))
DoEvents
'Redraw the selected dataset of the chart based on the # of categories and rows
oChart.SetSourceData Source:="='Sheet1'!$A$1:" & toChar(categories + 0) & months + 1, PlotBy:=xlColumns
Despite using both Application.Wait and DoEvents, it is still hanging up.
This is purely a timing issue because if I click Debug and continue running the code with no changes, it works fine. I am also using late binding (maybe?) through the Set Object statement and at the end of the loop I always Set oChart = Nothing.
Sometimes it works to write DoEvents multiple times, but as the process has gotten more complex, even this doesn't work. I'm all out of ideas. Any suggestions?
'Let code catch up
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
'Redraw the selected dataset of the chart based on the # of categories and rows
oChart.SetSourceData Source:="='Sheet1'!$A$1:" & toChar(categories + 0) & months + 1, PlotBy:=xlColumns
You may try:
Using Sleep, with this line at the top of your module (outside of your function):
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Then add this line in place of, or in addition to, DoEvents:
Sleep 1 ' Pause for 1 ms
See:
https://stackoverflow.com/a/3891017/2707864
See also:
https://www.myonlinetraininghub.com/pausing-or-delaying-vba-using-wait-sleep-or-a-loop
Using loops with DoEvents:
Dim PauseTime, Start, Finish, TotalTime
PauseTime = 4 ' Set duration.
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
DoEvents ' Yield to other processes.
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
See:
https://www.mrexcel.com/forum/excel-questions/36052-when-how-use-doevents-solved-post166114.html#post166114
See also:
https://www.myonlinetraininghub.com/pausing-or-delaying-vba-using-wait-sleep-or-a-loop
Using combinations thereof, which can improve performance of your system depending on the wait time.
Public Sub WaitSeconds(intSeconds As Integer)
On Error GoTo PROC_ERR
Dim datTime As Date
datTime = DateAdd("s", intSeconds, Now)
Do
Sleep 100
DoEvents
Loop Until Now >= datTime
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , "modDateTime.WaitSeconds"
Resume PROC_EXIT
End Sub
See:
http://www.fmsinc.com/microsoftaccess/modules/examples/avoiddoevents.asp
#sancho.s, thanks for your help. So it turns out the error had nothing to do with DoEvents. I had been using that as a sloppy fix without understanding its functionality. Given that, none of the three options worked. I spent all day trying various combinations with no success. Instead, I had to brute force close the embedded PPT workbook, set oChart to Nothing, reinstantiate oChart, reopen the workbook, and close it again.
This made the process 2x slower (but no slower than forcing it to wait on a timer??), and it completely eliminated all errors. Apparently it just didn't like pasting the raw data and reselecting the data the first time the workbook was opened. No idea why.
Sub UpdateChart(ByVal a As Integer, ByVal b As Integer, ByVal months As Integer, ByVal categories As Integer, ByRef pages() As Integer, ByRef metrics() As String, ByVal oPres As Object, ByVal legend_flag As Boolean)
Dim tempdata As Variant
'Paste the final temp dataset into PPT
tempdata = Range(Worksheets("calc").Range("A1000"), Worksheets("calc").Range("A1000").Offset(months, categories - 1)).Value
If legend_flag Then
Set oChart = oPres.Slides(pages(b)).Shapes("legend").Chart
Else
Set oChart = oPres.Slides(pages(b)).Shapes(metrics(a)).Chart
End If
oChart.ChartData.Activate
Set wb = oChart.ChartData.Workbook
Set ws = wb.Worksheets(1)
ws.Range("A1:Z1000").ClearContents
ws.Range(ws.Range("A1"), ws.Range("A1").Offset(months, categories - 1)).Value = tempdata
'Close workbook
wb.Close
Set oChart = Nothing
If legend_flag Then
Set oChart = oPres.Slides(pages(b)).Shapes("legend").Chart
Else
Set oChart = oPres.Slides(pages(b)).Shapes(metrics(a)).Chart
End If
oChart.ChartData.Activate
'Redraw the selected dataset of the chart based on the # of categories and rows
oChart.SetSourceData Source:="='Sheet1'!$A$1:" & toChar(categories + 0) & months + 1, PlotBy:=xlColumns
'Close workbook
oChart.ChartData.Workbook.Close
Set oChart = Nothing
Exit Sub
End Sub
I also put the code snippet in a subroutine and added Exit Sub at the end to hard reset all parameters in an earlier attempt that didn't work. So all objects and parameters have definitely been cleared for good measure.
Does anyone have any ideas why the object definition/open workbook was tripping up like that? And why DoEvents doesn't actually work for this problem?
I have a procedure that consists of several do and for loops and i would like to find an easy way to 'pause' the routine and allow the user to edit the sheet, with a msgbox or userform to resume execution where it left off.
I would like to do something like this
dim pause as boolean
pause=false
For i = 1 To 40
Worksheets("sheet1").Range("A" & i) = i
If i = 20 Then
UserForm1.Show vbmodeless
Pause = true
Do until pause = false
loop
Else
End If
Next i
End Sub
Where the pause condition would be set by a sub on the userform. This do loop just crashes.
Ideally i would like the userform to have buttons that can run subs but also allow direct editing of cells while execution is paused.
Here is a typical control structure that allows the user to perform some actions in the middle of a macro. When the user is done, they run OKToContinue to allow the macro to continue with the second part:
Dim AllowedToContinue As Boolean
Sub FirstPartSecondPart()
AllowedToContinue = False
MsgBox "allow user to perform actions"
Do Until AllowedToContinue
DoEvents
Loop
MsgBox "doing second part"
End Sub
Sub OKToContinuw()
AllowedToContinue = True
End Sub
I'm using DoEvents to force an update of a progress indicator in the status bar (or in some cell in the sheet) as in the example code below. But the screen doesn't refresh, or stops refreshing at some point. The task eventually completes but the progress bar is useless.
Why won't DoEvents "do the events"? What else can I do to force a screen update?
Edit: I'm using Excel 2003 on Windows XP.
This is a follow up to an earlier question; thanks to Robert Mearns for his answer and the sample code below.
Sub ProgressMeter()
Dim booStatusBarState As Boolean
Dim iMax As Integer
Dim i As Integer
iMax = 100
Application.ScreenUpdating = False
''//Turn off screen updating
booStatusBarState = Application.DisplayStatusBar
''//Get the statusbar display setting
Application.DisplayStatusBar = True
''//Make sure that the statusbar is visible
For i = 1 To iMax ''// imax is usually 30 or so
fractionDone = CDbl(i) / CDbl(iMax)
Application.StatusBar = Format(fractionDone, "0%") & " done..."
''// or, alternatively:
''// statusRange.value = Format(fractionDone, "0%") & " done..."
''// Some code.......
DoEvents
''//Yield Control
Next i
Application.DisplayStatusBar = booStatusBarState
''//Reset Status bar display setting
Application.StatusBar = False
''//Return control of the Status bar to Excel
Application.ScreenUpdating = True
''//Turn on screen updating
End Sub
I've found DoEvents is not always completely reliable. I would suggest trying two different things.
First, try placing the DoEvents call immediately after the Status Bar update (ie, before your Some code .... line).
If that does not work, I've found in some cases that using the Sleep API is a more reliable way to yield processor time. It's usually the first thing I try if DoEvents is not working as I'd like. You'll need to add the following line at the top of your module (outside of your function):
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Then add this line in place of, or in addition to, DoEvents:
Sleep 1 'This will pause execution of your program for 1 ms
You might try increasing the length of time you pause the program using sleep if 1 ms doesn't work.
I've found that calling DoEvents before updating the status bar, rather than after, yields more predictable/desirable results.
The code snippet from above would be:
fractionDone = CDbl(i) / CDbl(iMax)
DoEvents
Application.StatusBar = Format(fractionDone, "0%") & " done..."
My Excel tool performs a long task, and I'm trying to be kind to the user by providing a progress report in the status bar, or in some cell in the sheet, as shown below. But the screen doesn't refresh, or stops refreshing at some point (e.g. 33%). The task eventually completes but the progress bar is useless.
What can I do to force a screen update?
For i=1 to imax ' imax is usually 30 or so
fractionDone=cdbl(i)/cdbl(imax)
Application.StatusBar = Format(fractionDone, "0%") & "done..."
' or, alternatively:
' statusRange.value = Format(fractionDone, "0%") & "done..."
' Some code.......
Next i
I'm using Excel 2003.
Add a DoEvents function inside the loop, see below.
You may also want to ensure that the Status bar is visible to the user and reset it when your code completes.
Sub ProgressMeter()
Dim booStatusBarState As Boolean
Dim iMax As Integer
Dim i As Integer
iMax = 10000
Application.ScreenUpdating = False
''//Turn off screen updating
booStatusBarState = Application.DisplayStatusBar
''//Get the statusbar display setting
Application.DisplayStatusBar = True
''//Make sure that the statusbar is visible
For i = 1 To iMax ''// imax is usually 30 or so
fractionDone = CDbl(i) / CDbl(iMax)
Application.StatusBar = Format(fractionDone, "0%") & " done..."
''// or, alternatively:
''// statusRange.value = Format(fractionDone, "0%") & " done..."
''// Some code.......
DoEvents
''//Yield Control
Next i
Application.DisplayStatusBar = booStatusBarState
''//Reset Status bar display setting
Application.StatusBar = False
''//Return control of the Status bar to Excel
Application.ScreenUpdating = True
''//Turn on screen updating
End Sub
Text boxes in worksheets are sometimes not updated
when their text or formatting is changed, and even
the DoEvent command does not help.
As there is no command in Excel to refresh a worksheet
in the way a user form can be refreshed, it is necessary
to use a trick to force Excel to update the screen.
The following commands seem to do the trick:
- ActiveSheet.Calculate
- ActiveWindow.SmallScroll
- Application.WindowState = Application.WindowState
Put a call to DoEvents in the loop.
This will affect performance, so you might want to only call it on each, say, 10th iteration.
However, if you only have 30, that's hardly an issue.
#Hubisans comment worked best for me.
ActiveWindow.SmallScroll down:=1
ActiveWindow.SmallScroll up:=1
Specifically, if you are dealing with a UserForm, then you might try the Repaint method. You might encounter an issue with DoEvents if you are using event triggers in your form. For instance, any keys pressed while a function is running will be sent by DoEvents The keyboard input will be processed before the screen is updated, so if you are changing cells on a spreadsheet by holding down one of the arrow keys on the keyboard, then the cell change event will keep firing before the main function finishes.
A UserForm will not be refreshed in some cases, because DoEvents will fire the events; however, Repaint will update the UserForm and the user will see the changes on the screen even when another event immediately follows the previous event.
In the UserForm code it is as simple as:
Me.Repaint
This worked for me:
ActiveWindow.SmallScroll down:=0
or more simply:
ActiveWindow.SmallScroll 0
I couldn't gain yet the survey of an inherited extensive code. And exact this problem bugged me for months. Many approches with DoEnvents were not helpful.
Above answer helped. Placeing this Sub in meaningful positions in the code worked even in combination with progress bar
Sub ForceScreenUpdate()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Wait Now + #12:00:01 AM#
Application.ScreenUpdating = False
Application.EnableEvents = False
End Sub
This is not directly answering your question at all, but simply providing an alternative. I've found in the many long Excel calculations most of the time waiting is having Excel update values on the screen. If this is the case, you could insert the following code at the front of your sub:
Application.ScreenUpdating = False
Application.EnableEvents = False
and put this as the end
Application.ScreenUpdating = True
Application.EnableEvents = True
I've found that this often speeds up whatever code I'm working with so much that having to alert the user to the progress is unnecessary. It's just an idea for you to try, and its effectiveness is pretty dependent on your sheet and calculations.
On a UserForm two things worked for me:
I wanted a scrollbar in my form on the left. To do that, I first had to add an Arabic language to "Change administrative language" in the Language settings of Windows 10 (Settings->Time & Language->Change Administrative Language). The setting is actually for "Change the language of Non-Unicode Programs," which I changed to Arabic (Algerian). Then in the properties of the form I set the "Right to Left" property to True. From there the form still drew a partial ghost right scrollbar at first, so I also had to add an unusual timed message box:
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
'Set the message box to close after 10 seconds
AckTime = 1
Select Case InfoBox.Popup("Please wait.", AckTime, "This is your Message Box", 0)
Case 1, -1
End Select
I tried everything to get the screen to redraw again to show the first text box in it's proper alignment in the form, instead of partially underneath or at least immediately adjacent to the scrollbar instead of 4 pixels to the right where I wanted it. Finally I got this off another Stackoverflow post (which I now can't find or I would credit it) that worked like a charm:
Me.Frame1.Visible = False
Me.Frame1.Visible = True
In my case the problem was in trying to make one shape visible and another one invisible on a worksheet.
This is my approach to "inactivating" a button [shape] once the user has clicked it. The two shapes are the same size and in the same place, but the "inactive" version has dimmer colors, which was a good approach, but it didn't work, because I could never get the screen to update after changing .visible = FALSE to = TRUE and vice versa.
None of the relevant tricks in this thread worked. But today I found a solution that worked for me, at this link on Reddit
Essentially you just call DoEvents twice in immediate succession after the code that makes the changes. Now why? I can't say, but it did work.
I've been trying to solve this Force a screen update on a Worksheet (not a userform) for many years with limited success with
doevents and scrolling etc.. This CH Oldie solutions works best with a slight mod.
I took out the Wait and reset ScreenUpdating and EnableEvents back to true.
This works office excel 2002 through to office 365
Sub Sheet1Mess(Mess1 As String)
Sheet1.Range("A6").Value = Mess1
ForceScreenUpdate
End Sub
Sub ForceScreenUpdate()
Application.ScreenUpdating = True
Application.EnableEvents = True
' Application.Wait Now + #12:00:01 AM#
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub