Interrupt macro to process keystrokes for smooth user experience - vba

I'm working on a macro that displays cell info on the statusbar on each selection change within the excel application. It has grown with the addition of new features thanks to help from members in here. So now sometimes the focus sticks to a cell and I cant move on with the arrow keys to nearby cell before the cell info to be displayed has been calculated. But I do want the selection to move on for a smooth user experience. How should I interrupt the calculation?
It goes something like this in a class module:
Private Sub Appl_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim InfoAboutTarget
InfoAboutTarget = GetInfoAbout(Target)
WriteInfoToStatusbar(InfoAboutTarget)
End Sub
Is any of the following two options any good?
Have an application_onkey event raising an error flag with a user-defined error code and an error handler in the above sub that exits on this particular error
Measure the time elapsed since the above sub started at interesting points in the code and exit after a time large enough to threaten the user experience?

As Dirk says, you should use DoEvents to allow excel to process user input, and detect if you long running code is interrupted and if so, cancel the interrupted execution, while allowing the most recent call to complete.
Here's an example to demonstrate (coded in ThisWorkbook)
Option Explicit
Dim abort As Boolean
Dim CallCount As Long
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
test Target
End Sub
Sub test(r As Range)
Dim i As Long, n As Long, b As Long
CallCount = CallCount + 1
n = 100
' simulate long running code
For i = 1 To n
DoEvents
If abort Then
GoTo AbortSub
End If
Application.StatusBar = CallCount & " " & r.Address & " " & i
Next
AbortSub:
' Abort all interrupted calls
If CallCount > 1 Then
abort = True
Else
abort = False
End If
CallCount = CallCount - 1
End Sub

Not sure if it will work, but maybe something like this
Dim globalCounter As Long ' 0 by defaul
Private Sub Appl_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
globalCounter = globalCounter + 1
WriteInfoToStatusbar GetInfoAbout(Target)
End Sub
Function GetInfoAbout(Target As Range)
Dim localCounter As Long
localCounter = globalCounter
' .. some code
DoEvents
If localCounter <> globalCounter Then Exit Function
' .. some code
End Function

Related

Is there a way to check if a PowerPoint is being presented using VBA code?

I am working on a VBA Module for an interactive PowerPoint. Specifically, I would like a text box to display the current time and update every second (like a live clock) using VBA. I have created and implemented the clock just fine except the clock does not exit its loop when the presentation ends and will continue to update the text box while editing the PowerPoint outside of the presentation mode. I have tried using the sub App_SlideShowEnd(ByVal Pres As Presentation) ( https://learn.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshowend), sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow) (https://learn.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshownextslide), and even an add-in called AutoEvents (usage shown here http://www.mvps.org/skp/autoevents.htm#Use) to catch the end of the slide show, but to no avail.
So my question to you is: Is there a way to check if the current PowerPoint is actively presenting? If so, I could use it to check if the PowerPoint is presenting instead of checking my boolean variable clockstate that allows the clock to count or not. Here is the implementation of just the clock sub:
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Here is the implementation of just the App_SlideShowEnd event:
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
And here is all of my code all together if you want to see it in one piece:
Option Explicit
Dim indexA As Integer 'this variable contains the slide that Injury_Time is found on for use in the auto next slide event
Dim indexB As Integer 'this varaible contains the slide that Defect_Time is found on for use in the auto next slide event
Dim clockstate As Boolean 'this varaible dictates wether or not the clock is on and counting to save memory/processing resources.
Dim Injury As Shape 'this variable is used to reference the textbox that gets changed by the macro
Dim Defect As Shape 'this varaible is used to reference the other textbox that gets changed by the macro
Dim entryA As Date 'this holds the contents of the first entrybox on the config form so the form can be unloaded without losing the entries
Dim entryB As Date 'this holds the contents of the second entrybox on the config form so the form can be unloaded without losing the entries
Dim daysA As String 'this holds the number of days since last injury for auto-setting the textboxes in the config form
Dim daysB As String 'this holds the number of days since last defect for auto-setting the textboxes in the config form
Sub Auto_Open() 'runs on startup from AutoEvents add-in. runs the find function to locate the Macro-edited slides, then opens the config form
'declare clockstate as false until it is true and turned on
clockstate = False
'assign values the global Injury and Defect variables
Call Find
'try calling the name fields (need to assign it to a variable to try it). If Injury and Defect were found, then nothing happens. Otherwise it moves the the Not_Found label
On Error GoTo Not_Found
'setup daysA and daysB
daysA = Left(Injury.TextFrame.TextRange.text, Len(Injury.TextFrame.TextRange.text) - 8)
daysB = Left(Defect.TextFrame.TextRange.text, Len(Defect.TextFrame.TextRange.text) - 8)
'assign default values to the Config boxes
Config.TextBox1.Value = Date - daysA
Config.TextBox2.Value = Date - daysB
'show config
Config.Show
Exit Sub
'error messaging for if the textbox assignments were not found
Not_Found:
MsgBox "Error: The Macro-edited textbox(es) were not found! This is likely due to the most recent editing preformed on this Powerpoint. Please revert the changes, create a new textbox with the name """"Injury_Time"""" or """"Defect_time"""" (whichever is missing), contact your local VBA expert, or read the Documentation for help."
End Sub
Sub Find() 'locates the textbox that the global variables Injury and Defect are supposed to represent
'use a 2D for loop to iterate through each slide and it's shapes
Dim i As Integer
Dim j As Integer
For i = 1 To ActivePresentation.Slides.Count
For j = 1 To ActivePresentation.Slides(i).Shapes.Count
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Injury_Time") = 0 Then
Set Injury = ActivePresentation.Slides(i).Shapes(j)
indexA = i
End If
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Defect_Time") = 0 Then
Set Defect = ActivePresentation.Slides(i).Shapes(j)
indexB = i
End If
Next j
Next i
End Sub
Sub Save() 'saves the contents of the config form to the global varaibles entryA and entry B then unloads the form to save memory
'save the contents of the config form so we can unload it to save memory
entryA = Config.TextBox1.Value
entryB = Config.TextBox2.Value
'unload the form to save memory
Unload Config
End Sub
Sub Auto_ShowBegin() 'starts the clock for the timers when the show starts
'start clock
clockstate = True
Call clock
End Sub
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
Sub Auto_Close() 'this is run by the AutoEvents add-in. It displays an informative message when the powerpoint is closed with instructions for the next time the powerpoint is opened
'prevent clock from running after program is closed
clockstate = False
'message to configure the powerpoint when it is opened again
MsgBox "Thank you for using this Macro-Enabled PowerPoint!" & vbCrLf & vbCrLf & "Next time the PowerPoint is opened, you will be asked to re-enter the dates of the most recent injury and quality defect."
End Sub
Thank you for your help and May the 4th be with you!
I think your 'Wait' function is not reliable. The 'for' loop may not end in some case.
To control the clock ticking event, you can make use of Windows 'Timer' API. Though the Timer API is not that reliable or easy to use, it can be controlled and tailored.
The sample code goes like this:
Option Explicit
#If VBA7 Then
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Public TimerID As LongPtr
#Else
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long
#End If
Const Default As Integer = 1 'the target slide where the 'Clock' textbox exists
Dim Pause As Boolean
Sub StartNow()
StartTimer
End Sub
Sub StopNow()
StopTimer
End Sub
'main timer process : this sub-routine CANNOT be interrupted by any error or itself
Sub myTimer()
On Error Resume Next
If Pause Then Exit Sub
'the Default slide should have a textbox called 'Clock'
ActivePresentation.Slides(Default). _
Shapes("Clock").TextFrame.TextRange.Text = Format(Time, "hh:mm:ss")
End Sub
Function StartTimer()
If TimerID = 0& Then
TimerID = SetTimer(0&, 0&, 1000&, AddressOf myTimer) ' 1000 = 1sec
End If
End Function
Function StopTimer()
On Error Resume Next
KillTimer 0&, TimerID
TimerID = 0&
End Function
'the timer can be paused, if this macro is added to the 'Clock' textbox as an action trigger
Sub PauseTimer()
Pause = Not Pause
End Sub
'the timer must be stopped after finishing the show
Public Sub OnSlideShowTerminate(SSW As SlideShowWindow)
StopTimer
End Sub
'To start the clock automactically
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
If SSW.View.CurrentShowPosition = Default Then
StartTimer
Else
StopTimer
End If
End Sub
Requirement: A Textbox called 'Clock' should exist on Slide #1.
Warning:
The Timer must be stopped after closing the show. Otherwise, Powerpoint application might crash!
'myTimer' should not contain any error or call itself recursively.

Calling a Sub or Function that sometimes doesn't exist

I'm trying to create a macro (in PERSONAL.XLSB) that every time a workbook is opened, it checks a condition and in if it's true (this means the workbook opened contains an specific Sub), it calls this Sub.
Option Explicit
Private WithEvents App As Application
Private Sub Workbook_Open()
Set App = Application
End Sub
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
If condition Then Call Specific_Sub
End Sub
It runs fine when I open a file that contains that Sub, however, if the Sub is not in the file, the compiler returns the error “Sub or Function not defined”, naturally.
I’m trying very hard to find a way to do this and deal with the error, but On error GoTo doesn’t work because the compiler error is before the run time, so it’s not executed.
I guess I have to do this in a different way but I can’t picture how to do it, any help or ideas?
Thanks a lot!
Thanks to the answers I've discovered that the best way is to use Application.Run. To keep the code as simple as possible, I just changed the last part to look like this:
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
On Error Resume Next
If condition Then
Application.Run ("'" & ActiveWorkbook.FullName & "'!" & "Specific_Sub")
End If
End Sub
Thank you all.
I cobbled this together from a few web sites. The key is that your sub routines name is in a variable and application. run uses the variable. This gets past the compiler error you are running into
Sub SubExists()
Dim ByModule As Object
Dim ByModuleName As String
Dim BySub As String
Dim ByLine As Long
'
'Module and sub names
ByModuleName = "Module1"
BySub = "Specific_Sub"
On Error Resume Next
Set ByModule = ActiveWorkbook.VBProject.vbComponents(ByModuleName).CodeModule
ByLine = ByModule.ProcStartLine(BySub, vbext_pk_Proc)
If Err.Number = 0 Then
Application.Run BySub
End If
End Sub
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
SubExists
End Sub

Excel VBA Keep Userform Timer running when Userform or Excel are closed

Recently I've managed to find some code regarding a timer on a userform, my problem is that I need to keep the timer running even if the userform or excel file is closed... can someone take a look at the code and provide some feedback? My userform is: optionsForm
Dim dteStart As Date, dteFinish As Date
Dim dteStopped As Date, dteElapsed As Date
Dim boolStopPressed As Boolean, boolResetPressed As Boolean
Private Sub Reset_Timer_Click()
dteStopped = 0
dteStart = 0
dteElapsed = 0
Tech_Timer = "00:00:00"
boolResetPressed = True
End Sub
Private Sub Start_Timer_Click()
Start_Timer:
dteStart = Time
boolStopPressed = False
boolResetPressed = False
Timer_Loop:
DoEvents
dteFinish = Time
dteElapsed = dteFinish - dteStart + dteStopped
If Not boolStopPressed = True Then
Tech_Timer = dteElapsed
If boolResetPressed = True Then GoTo Start_Timer
GoTo Timer_Loop
Else
Exit Sub
End If
End Sub
Private Sub Stop_Timer_Click()
boolStopPressed = True
dteStopped = dteElapsed
End Sub
Private Sub optionsForm_Initialize()
Tech_Timer = "00:00:00"
End Sub
The idea of the timer is not that it runs, but that it remembers a point in time and can give you a difference between this point and the current moment. If you ask for this difference every second, then it would look like it is running like a watch.
Something like this would be a good start. In the xl_main write the following:
Option Explicit
Dim dtime As Date
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Cells(1, 1).Value = dtime
End Sub
Private Sub Workbook_Open()
If Cells(1, 1).Value = 0 Then
dtime = Now
Else
dtime = CDate(Cells(1, 1))
End If
End Sub
You may play around it and make it better as you wish. E.g. you may find a way to reset dtime or anything similar.
"Something" needs to be running to handle the timer procedure so if you want to use VBA then Excel can't be "closed" per se, however you could make it appear closed.
An obvious option is to minimize the Excel window (before showing the userform) with the WindowState property:
Application.WindowState = xlMinimized
...or, hide the Excel window completely with the Visible property:
Application.Visible = False
...or if the issue is that you need a "fresh" copy of Excel to work in, you could do so in a new instance by holding Alt while starting Excel.
            
I have posted code and a downloadable example of a countdown timer that displays the time remaining on a userform semi-independent of the Excel window, using the Windows Timer API (instead of Excel's procedure), in another answer here.
                   
That's not possible if the form is unloaded Unload optionsForm. But you can try to 'close' the form with optionsForm.hide() this only hides the form, the timer should keep running then.
The only way I see to calculate the time passed from a start time even if Excel is closed is to not save the start time in a variable dteStart but in an Excel cell.
Actually you can use a code that is placed in a module. The code is:
Option Explicit
Dim T
Sub stopTimer()
On Error Resume Next
Application.OnTime (T), Procedure:="Update", Schedule:=False
End Sub
Sub StartTimer()
T = Now + TimeValue("00:00:01")
Application.OnTime T, "Update"
End Sub
Sub Update()
UserForm1.TextBox1.Value = Format(Now - Sheets("Sheet1").Range("E11").Value,
"hh:mm:ss")
UserForm1.TextBox2.Value = Format(TimeValue("1:00:00") - (Now -
Sheets("Sheet1").Range("E11").Value), "hh:mm:ss")
Call StartTimer
End Sub
Thereafter, you can now reference it in the userform by calling it. Here is a typical example. It is
Private Sub Userform_Activate()
Sheet1.Activate
Sheets("Sheet1").Range("E11").Value = Now
Application.Run "StartTimer"
If Sheets("Sheet1").Range("K27").Value = "K29" Then
Me.CommandButton4.Caption = "Start"
Me.CommandButton2.Visible = False
End If
End Sub

Nested Macros: Scope: how to exit all?

I current have 2 Macros:
The second macro is called within the first to perform a task. However I have logic within the second macro that states if my variable LastRow < 3 then exit the sub. This of course takes us immediately back into macro 1. What I desire here is to then exit immediately macro 1 as well. The way I have attempted to do this is by making LastRow public within both macros.. so when we exit back into macro 1, we have:
sub macro1()
application.run("macro2")
if LastRow < 3 then
exit sub
end sub
where macro 2()
sub macro1()
Static LastRow As Long
if LastRow < 3 then
exit sub
else do something
end if
end sub
I believe I may the issue may be that Static is not giving macro 1 access to variable LastRow.
whats the best way to proceed?
Regards!
You could use End statement in this way:
sub macro2()
Static LastRow As Long
if LastRow < 3 then
'...here is End
End
else
'do something
end if
end sub
However, End has some disadvantages you should be aware of. Let me cite them base on MSDN:
Terminates execution immediately. Never required by itself but may be
placed anywhere in a procedure to end code execution, close files
opened with the Open statement and to clear variables.
When executed, the End statement resets all module-level variables and
all static local variables in all modules. To preserve the value of
these variables, use the Stop statement instead. You can then resume
execution while preserving the value of those variables.
The End statement provides a way to force your program to halt. For
normal termination of a Visual Basic program, you should unload all
forms. Your program closes as soon as there are no other programs
holding references to objects created from your public class modules
and no code executing.
You could use a Function instead of a Sub and return a Boolean for example.
Function macro2() As Boolean
'returns false if the last row is 2 or less, true otherwise
LastRow As Long
if LastRow >= 3 then
macro2 = True
'do something
end if
End Function
Then in your first macro:
sub macro1()
if Not macro2 Then Exit Sub
end sub
Declare the variable in the first macro and pass it ByRef to the second macro.
Sub Mac1()
Dim lLastRow As Long
Mac2 lLastRow
If Not IsTooBig(lLastRow) Then
'do stuff
End If
End Sub
Sub Mac2(ByRef lLastRow As Long)
lLastRow = 5
If IsTooBig(lLastRow) Then
Exit Sub
End If
End Sub
Function IsTooBig(ByVal lLastRow As Long) As Boolean
IsTooBig = lLastRow >= 5
End Function
ByRef means that whatever changes you make to lLastRow in Mac2 will be reflected in lLastRow in Mac1.

Do Action if user returns to Excel from another Application

I have an Excel workbook that has links to a webpage. The user can click on the links, which minimize the Excel window and open their browser. When they are done with the site, they minimize or close their browser, which returns them to Excel (as it was their previous active window).
I would like VBA to take an action (update a table) when the user is returned to Excel.
I've looked at the Workbook_WindowActivate event, but this only works if you are moving from one Excel Workbook to another within the Excel Application.
Maybe I could use Application.name or the Windows function GetActiveWindow somehow but I am not sure how best to do this.
Any ideas? Thanks!
You want to add an event handler for Workbook_SheetFollowHyperlink. You can then use the code below. This just checks to see if the webpage has focus. the ' DO EVENTS ' is where you would add your code and then exit the sub
'********************* References used
'* Microsoft Shell Controls An Automation : shell32.dll*
'* Microsoft HTML Objects Library: MSHTML.dll expand » *
'* Microsoft Internet Controls: IEFRAME.dll *
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Dim ie As InternetExplorer 'IE window variable
Dim sUrl 'url of the webpage
Dim dt As Date 'timer
'set the url to look for
sUrl = Target.Address
'set initial timeout period *used instead of browser ready due to page redirection.
'you should also check the browser ready status
dt = DateAdd("s", 5, DateTime.Now)
Do While dt > DateTime.Now
DoEvents
Loop
'reset the timeout period to allow time to view and select
dt = DateAdd("s", 30, DateTime.Now)
Dim shShell As New Shell ' windows shell variable
'continue loop until we hit the timeout or the webpage no longer has focus
Do While dt > DateTime.Now
'Loop through all the IE windows
For Each ie In shShell.Windows
'check to see if the URL's match
If InStr(ie.LocationURL, sUrl) Then
Dim hDoc As HTMLDocument
'get the webpage document
Set hDoc = ie.document
'check to see if it has focus
If Not hDoc.hasFocus Then
ThisWorkbook.Activate
'''''''''''''
' DO EVENTS '
'''''''''''''
Exit Sub
End If
Set hDoc = Nothing
End If
Next ie
Loop
End Sub
Here's what I've ended up doing. I borrowed quite a bit from this post: How to make a macro which executes periodically in Excel?
When the user clicks on a hyperlink, the code starts periodically checking whether Excel is their active window. I've found that the GetActiveWindow function returns zero if the user is not in the Excel application and some positive number if they are. If the code finds that the user returned to Excel from a different window (the previous check found that they were in a different window and the current one finds they are in Excel) then my table gets updated and the timer stops checking for the active window.
Doing it this way has the advantage of working for any web browser.
Option Explicit
Dim ExcelIsActive As Boolean
Private Declare Function GetActiveWindow Lib "user32" () As Long
Dim m_dtNextTime As Date
Dim m_dtInterval As Date
Dim DisableFlag As Boolean
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Call start
End Sub
Public Sub Enable(Interval As Date)
Call Disable
m_dtInterval = Interval
Call starttimer
End Sub
Private Sub starttimer()
m_dtNextTime = Now + m_dtInterval
Application.OnTime m_dtNextTime, "TestActive"
End Sub
Public Sub TestActive()
If GetActiveWindow > 0 Then
If ExcelIsActive = False Then
ExcelIsActive = True
Call RefreshQuery
End If
Else
ExcelIsActive = False
End If
If Not DisableFlag Then
Call starttimer
Else
Call Disable
End If
End Sub
Public Sub Disable()
Dim dtZero As Date
If m_dtNextTime <> dtZero Then
' Stop timer if it is running
On Error Resume Next
Application.OnTime m_dtNextTime, "TestActive", , False
On Error GoTo 0
m_dtNextTime = dtZero
End If
m_dtInterval = dtZero
End Sub
Sub start()
'Start the timer
DisableFlag = False
ExcelIsActive = True
'Sets the interval to be three seconds
Call Enable(#12:00:03 AM#)
End Sub
Public Sub RefreshQuery()
'I do my stuff here
'Stop the timer until the next time the user launches the browser
DisableFlag = True
End Sub