Display popup for a time period in Excel - excel

I am trying to generate a popup that closes after a given WaitTime in seconds.
I consulted this link and this link.
I tried to apply the method from "VBA Excel macro message box auto close"; my code is the following:
Sub TestSubroutine()
Dim TemporalBox As Integer
Dim WaitTime As Integer
Dim WScriptShell As Object
Set WScriptShell = CreateObject("WScript.Shell")
WaitTime = 1
TemporalBox = WScriptShell.Popup("The message box will close in 1 second.", _
WaitTime, "File processed")
End Sub
The popup is displayed but it never closes after one second.
Edit #1
Based on #Skip Intro comment, I have updated the code:
Sub TestSubroutine()
Dim WaitTime As Integer
WaitTime = 1
CreateObject("WScript.Shell").Popup "The message box will close in 1 second.", _
WaitTime, "File processed"
End Sub
However this does not solve the original issue, the popup does not close after 1 second.
Edit #2
This is the code suggested by #Glitch_Doctor, however it still doesn't work:
Sub TestSubroutine()
Dim TemporalBox As Integer
Dim WaitTime As Integer
Dim WScriptShell As Object
Dim test
Set WScriptShell = CreateObject("WScript.Shell")
WaitTime = 1
Select Case TemporalBox = WScriptShell.Popup("The message box will close in 1 second.", _
WaitTime, "File processed")
Case 1, -1
End Select
End Sub

I finally found a very simple solution - credits to #Orphid, see his answer in the following thread.
I did not solve the specific issue related to my original code, but I managed to create a PopUp that closes after a specified period of time. The code is the following:
Sub subClosingPopUp(PauseTime As Integer, Message As String, Title As String)
Dim WScriptShell As Object
Dim ConfigString As String
Set WScriptShell = CreateObject("WScript.Shell")
ConfigString = "mshta.exe vbscript:close(CreateObject(""WScript.Shell"")." & _
"Popup(""" & Message & """," & PauseTime & ",""" & Title & """))"
WScriptShell.Run ConfigString
End Sub
This works just fine.

Another approach (if your would not work at all).
Create a new userform named frm_Popup and add a label there named lbl_Message. Add the following void to userform code:
Public Sub StartProcess(iTime As Integer)
Me.lbl_Message.Caption = "The message box will close in " & iTime & " second(s)."
End Sub
then in your module:
Sub ShowMessage()
Dim iTimeToWait As Integer
iTimeToWait = 2
With frm_Popup
.Show False
Call .StartProcess(iTimeToWait)
End With
Application.OnTime Now + TimeValue("00:00:" & iTimeToWait), "HidePopup"
End Sub
Private Sub HidePopup()
Unload frm_Popup
End Sub

You're just missing the Select Case:
WaitTime = 1
Select Case TemporalBox = WScriptShell.Popup("The message box will close in 1 second.", _
WaitTime, "File processed")
Case 1, -1
End Select
I tested and it works...

Below code work for me, I added a 2-sec delay before the popup message appears. After 4-sec it auto disappear. I learn it from Mr. Dinesh Kumar Takyar. He added a 5-sec delay b4 popup appears. His youtube link
https://www.youtube.com/watch?v=x1nmqVRrq-Q&list=PLwC8syx0i_6nHjAogOm9m4oGBq40YHkXV&index=4
I think the key issue is you need a delay for the popup timer to work. Maybe the Excel application needs to run for a while b4 the popup appears.
Option Explicit
Const PopUpTime As Integer = 4
Sub ShellMessageBox()
Dim MsgBoxWithTimer As Integer
MsgBoxWithTimer=CreateObject("WScript.Shell").Popup("Put your message here", PopUpTime, _
"Notice!", 0)
End Sub
Sub startTimer()
Application.OnTime Now + TimeValue("00:00:02"), "ShellMessageBox"
End Sub
Private Sub Workbook_Open()
startTimer
End Sub

The following code works for me:
Sub TimeBasedPopUp()
Dim WaitTime As Integer
WaitTime = 1
Select Case CreateObject("WScript.Shell").Popup("The message box will close in 1 second.",_
WaitTime, "MS Excel")
Case 1, -1
End Select
End Sub

Related

add .SendKeys to an existing macro

I have a code that would help me with printing a document from Excel.
It has a couple dialogue questions for adding serial number sequence and number of copies.
Unfortunately, it doesn't open the Print dialogue, where I can select a printer and it's preferences.
The code would just immediately print to my default printer.
I need to add some custom features like 2-side printing and stapling in the top left corner.
For that purpose I want to use .Sendkeys
I tried adding the string Application.SendKeys "%fpr" (my printer preferences dialogue) here and there inside the code to no avail.
Please help inserting the sting.
Alternatively - maybe there is a command for .PrintOut that I could add for 2-side printing and a staple finish?
Private Sub CommandButton1_Click()
Dim xCount As Variant
Dim xJAC As Variant
Dim xID As Variant
Dim xScreen As Boolean
Dim I As Long
On Error Resume Next
Application.SendKeys "%fpr"
LInput:
xJAC = Application.InputBox("Please enter the job number (Leave Out JAC):", "")
xCount = Application.InputBox("Please enter the number of copies you want to print:", "")
xID = Application.InputBox("Please enter the Starting ID of the product:", "")
If TypeName(xJAC) = "Boolean" Then Exit Sub
If TypeName(xCount) = "Boolean" Then Exit Sub
If TypeName(xID) = "Boolean" Then Exit Sub
If (xCount = "") Or (Not IsNumeric(xCount)) Or (xCount < 1) Or (xID < 1) Or (xCount = "") Or (Not IsNumeric(xID)) Then
MsgBox "error entered, please enter again", vbInformation, "Kutools for Excel"
GoTo LInput
Else
xScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
For c = 0 To xCount - 1
ActiveSheet.Range("E2").Value = "JAC" & xJAC
ActiveSheet.Range("G2").Value = xID + c
ActiveSheet.PrintOut
Next
ActiveSheet.Range("E2").ClearContents
ActiveSheet.Range("G2").ClearContents
Application.ScreenUpdating = xScreen
End If
End Sub

Yes/NO Message Box - Automatically press No If there is no response for 5 seconds [duplicate]

I am trying to generate a popup that closes after a given WaitTime in seconds.
I consulted this link and this link.
I tried to apply the method from "VBA Excel macro message box auto close"; my code is the following:
Sub TestSubroutine()
Dim TemporalBox As Integer
Dim WaitTime As Integer
Dim WScriptShell As Object
Set WScriptShell = CreateObject("WScript.Shell")
WaitTime = 1
TemporalBox = WScriptShell.Popup("The message box will close in 1 second.", _
WaitTime, "File processed")
End Sub
The popup is displayed but it never closes after one second.
Edit #1
Based on #Skip Intro comment, I have updated the code:
Sub TestSubroutine()
Dim WaitTime As Integer
WaitTime = 1
CreateObject("WScript.Shell").Popup "The message box will close in 1 second.", _
WaitTime, "File processed"
End Sub
However this does not solve the original issue, the popup does not close after 1 second.
Edit #2
This is the code suggested by #Glitch_Doctor, however it still doesn't work:
Sub TestSubroutine()
Dim TemporalBox As Integer
Dim WaitTime As Integer
Dim WScriptShell As Object
Dim test
Set WScriptShell = CreateObject("WScript.Shell")
WaitTime = 1
Select Case TemporalBox = WScriptShell.Popup("The message box will close in 1 second.", _
WaitTime, "File processed")
Case 1, -1
End Select
End Sub
I finally found a very simple solution - credits to #Orphid, see his answer in the following thread.
I did not solve the specific issue related to my original code, but I managed to create a PopUp that closes after a specified period of time. The code is the following:
Sub subClosingPopUp(PauseTime As Integer, Message As String, Title As String)
Dim WScriptShell As Object
Dim ConfigString As String
Set WScriptShell = CreateObject("WScript.Shell")
ConfigString = "mshta.exe vbscript:close(CreateObject(""WScript.Shell"")." & _
"Popup(""" & Message & """," & PauseTime & ",""" & Title & """))"
WScriptShell.Run ConfigString
End Sub
This works just fine.
Another approach (if your would not work at all).
Create a new userform named frm_Popup and add a label there named lbl_Message. Add the following void to userform code:
Public Sub StartProcess(iTime As Integer)
Me.lbl_Message.Caption = "The message box will close in " & iTime & " second(s)."
End Sub
then in your module:
Sub ShowMessage()
Dim iTimeToWait As Integer
iTimeToWait = 2
With frm_Popup
.Show False
Call .StartProcess(iTimeToWait)
End With
Application.OnTime Now + TimeValue("00:00:" & iTimeToWait), "HidePopup"
End Sub
Private Sub HidePopup()
Unload frm_Popup
End Sub
You're just missing the Select Case:
WaitTime = 1
Select Case TemporalBox = WScriptShell.Popup("The message box will close in 1 second.", _
WaitTime, "File processed")
Case 1, -1
End Select
I tested and it works...
Below code work for me, I added a 2-sec delay before the popup message appears. After 4-sec it auto disappear. I learn it from Mr. Dinesh Kumar Takyar. He added a 5-sec delay b4 popup appears. His youtube link
https://www.youtube.com/watch?v=x1nmqVRrq-Q&list=PLwC8syx0i_6nHjAogOm9m4oGBq40YHkXV&index=4
I think the key issue is you need a delay for the popup timer to work. Maybe the Excel application needs to run for a while b4 the popup appears.
Option Explicit
Const PopUpTime As Integer = 4
Sub ShellMessageBox()
Dim MsgBoxWithTimer As Integer
MsgBoxWithTimer=CreateObject("WScript.Shell").Popup("Put your message here", PopUpTime, _
"Notice!", 0)
End Sub
Sub startTimer()
Application.OnTime Now + TimeValue("00:00:02"), "ShellMessageBox"
End Sub
Private Sub Workbook_Open()
startTimer
End Sub
The following code works for me:
Sub TimeBasedPopUp()
Dim WaitTime As Integer
WaitTime = 1
Select Case CreateObject("WScript.Shell").Popup("The message box will close in 1 second.",_
WaitTime, "MS Excel")
Case 1, -1
End Select
End Sub

UserForm Button Still Functioning When Disabled

I am disabling a button onclick, but it is still allowing the click.
Code is like below:
UsrForm.Field1.Value = ""
UsrForm.Field2.Value = ""
UsrForm.btn.Enabled = False
UsrForm.Repaint
/*Processing Occurs*/
UsrForm.Field1.Value = val1
UsrForm.Field2.Value = val2
UsrForm.btn.Enabled = True
However, if I double click or click a few times where the disabled button is, it still runs the method several times, despite being disabled.
I think we have a proper bug here. The solution posted by S Meaden does not work (at least, not in my testing). Here's what I trew together for testing:
Private Sub CommandButton1_Click()
Dim w As Date
Me.CommandButton1.Enabled = False
w = Now + TimeSerial(0, 0, 2)
Debug.Print "point 1: " & Now
Application.Wait w
Debug.Print "point 2: " & Now
Me.CommandButton1.Enabled = True
End Sub
Clicking it makes it gray out (as it should when disabling) and run the routine. Clicking twice however runs the routine twice. Because it prints the times, it is clear that the routines run in sequence, so it seams that excel (in my case excel, haven't tested with other applications) remembers the clicks, and when the routine finishes (and the button is enabled again) the routine is called. It runs 3 or 4 times in a row as well.
Because of this, implementing S Meaden's answer, like so:
Dim clicked as Boolean
Private Sub CommandButton1_Click()
Dim w As Date
If Not clicked Then
clicked = True
Me.CommandButton1.Enabled = False
w = Now + TimeSerial(0, 0, 2)
Debug.Print Now
Application.Wait w
Debug.Print "punt 2 (" & Now & ")"
Me.CommandButton1.Enabled = True
clicked = False
End If
End Sub
does not work either.
It seems that if the button is enabled after the routine is finished, the clicks that were placed during routine execution are discarded. So as a workaround, you could use:
Private Sub CommandButton1_Click()
Dim w As Date
Me.CommandButton1.Enabled = False
w = Now + TimeSerial(0, 0, 2)
Debug.Print "point 1: " & Now
Application.Wait w
Debug.Print "point 2: " & Now
Me.Button1_clicked = False
Application.OnTime (Now + 0.000001), "enable_commandbutton"
End Sub
with "enable_commandbutton" being:
Public Sub enable_commandbutton()
Dim uf As Object
Debug.Print "check"
For Each uf In VBA.UserForms
If uf.Name = "UserForm1" Then
uf.CommandButton1.Enabled = True
End If
Next uf
End Sub
in a normal codemodule.
It is not pretty, but it works.
That's interesting. I agree your code should work and I am puzzled by that. However, I'm the sort of guy who would code around and so here is some that uses a module level variable to keep note of whether the procedure is already running.
Option Explicit
Private mbAlreadyProcessing As Boolean
Private Sub btn_Click()
On Error GoTo ErrHandler
If Not mbAlreadyProcessing Then
mbAlreadyProcessing = True
'do some work
mbAlreadyProcessing = False
End If
Exit Sub
ErrHandler:
'here we remember to "re-enable"
mbAlreadyProcessing = False
'do some error handling
End Sub

Excel VBA: Why does event trigger twice?

I'm trying to avoid Event loops by disabling Events at crucial points. However, it doesn't always work. For instance, this code for a Combo box:
Private Sub TempComboS_Change()
Dim e
e = Application.EnableEvents
Application.EnableEvents = False
'
Application.EnableEvents = e
End Sub
The blank line is where the useful code goes; as it stands it obviously doesn't do anything. However, when I run it this way (with the blank line), it reaches "End Sub", then it goes back to the beginning and runs again. (This would make the useful code run twice).
Why is this happening?
EDIT: To clarify for the folks who've been helping me.
I have a macro that opens the dropdown list of the Combo box, activates it, then ends. It works properly. When I select an item from the open list, the Change event runs. This is the current version of the change event:
Private Sub TempComboS_Change()
End Sub
I put a breakpoint on the Private Sub line. It shows that this Change event runs, then runs again. I suspect that it has been doing this all along, and I noticed it now because I need to add code here.
I have no class modules or userforms. The controls are on a worksheet.
I'm going to try the "Run Once" suggestion, and I'll let you know if it works.
I tried the "Run Once" code you suggested. It sort of works, but I seem to have a bigger issue. When I select a drop-down list from a data-validated cell, the TempComboS_Change event triggers -- but not only didn't I touch this combo box, the cell isn't the LinkedCell for the combo box. In other words, it seems to be triggering by actions unconnected to the combo box!
Got to find out about that Call Stack thing...
Here is a bit of code to help investigate "sequence of events" issues
In a Standard Module
Public Enum eNewLine
No
Before
After
Both
End Enum
Public Function timeStamp(Optional d As Double = 0, Optional newLine As eNewLine = No, Optional Indent As Long = 0, _
Optional Caller As String, Optional Context As String, Optional message As String) As String
Dim errorMessage As String
If Err.number <> 0 Then
errorMessage = "ERROR: " & Err.number & ": " & Err.Description
Err.Clear
End If
If d = 0 Then d = Time
With Application.WorksheetFunction
timeStamp = .Text(Hour(d), "00") & ":" & .Text(Minute(d), "00") & ":" & .Text(Second(d), "00") & ":" & .rept(Chr(9), Indent)
End With
If Len(Caller) <> 0 Then timeStamp = timeStamp & Chr(9) & Caller
If Len(Context) <> 0 Then timeStamp = timeStamp & ": " & Chr(9) & Context
If Len(message) <> 0 Then timeStamp = timeStamp & ": " & Chr(9) & message
Select Case newLine
Case Before
timeStamp = Chr(10) & timeStamp
Case After
timeStamp = timeStamp & Chr(10)
Case Both
timeStamp = Chr(10) & timeStamp & Chr(10)
Case Else
End Select
If Len(errorMessage) <> 0 Then
timeStamp = timeStamp & Chr(9) & errorMessage
End If
End Function
At the top of each Module
'Module level Trace Hearder
Const debugEvents as Boolean = True
Const cModuleName As String = "myModuleName"
Const cModuleIndent As Long = 1
You can assign a module level indent for each module to organise the hierarchy an make it easy to understand.
In each Sub or Function (or property if you need)...
sub mySubName()
Const cMyName As String = "mySubName"
If debugEvents Then Debug.Print timeStamp(NewLine:=Before,Indent:=cModuleIndent, Caller:=cModuleName, Context:=cMyName, Message:="Start")
'Do stuff
If debugEvents Then Debug.Print timeStamp(NewLine:=After,Indent:=cModuleIndent, Caller:=cModuleName, Context:=cMyName, Message:="End")
End Sub
...Or you can use Me.Name for the Context if its a form or a sheet etc. and you can put whatever message or variable values you like in the Message.
You can also use a Timer (eg MicroTimer) and put the result in the Message section.
Here is an example output:
15:54:07: Roll-Up Select: Worksheet_Activate: Start: 3.24591834214516E-03
15:54:07: cDataViewSheet: Class_Initialize: Start
15:54:07: cRevealTarget: Class_Initialize: START
15:54:07: cRevealTarget: Class_Initialize: END
15:54:09: cDataViewSheet: startTimer: : START
15:54:09: cDataViewSheet: startTimer: init Timer
15:54:09: cOnTime: Class_Initialize
15:54:09: cOnTime: Let PulseTime: Inheret PulseTime from host sheet
15:54:09: cDataViewSheet: startTimer: : END
15:54:09: Roll-Up Select: Worksheet_Activate: END: 1.38736216780671
Private Sub cmbOrder_Change()
If cmbOrder = "" Then Exit Sub
Dim arr As Variant, maxorder As Integer
arr = Range("rngOrder")
maxorder = WorksheetFunction.Max(arr)
Dim errmsg As String, err As Boolean
err = False
errmsg = "This value must be a whole number between 1 and " & maxorder + 1
Dim v As Variant
v = cmbOrder.Value
If IsNumeric(v) = False Or (IsNumeric(v) = True And (v > maxorder + 1) Or v < 1)
Then
MsgBox errmsg
cmbOrder = ""
err = False
Else
txtOrder.Value = cmbOrder.Value
End If
End Sub
A bit late to the party but the problem of code repetition can be shown here in similar circumstances. Remove the first line of code and any error messages are dished out twice. This is because of the line that clears the ComboBox that is regarded as a change and picks up another error as null input is an error! May help someone with similar issue.
The Combobox_Change() will fire whenever there is a change in the combobox. For example
Option Explicit
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
End Sub
Private Sub CommandButton1_Click()
'~~> If something is selected in the combo then
'~~> this line will cause ComboBox1_Change to fire
ComboBox1.Clear
End Sub
Private Sub ComboBox1_Change()
MsgBox "A"
End Sub
So if you load the userform and select an item ComboBox1_Change will fire. You then use the commanbutton to clear the combo the ComboBox1_Change will again fire.
There is one more scenario when the change will again fire. When you change the combobox from the ComboBox1_Change event itself. Here is an example. And I believe this is what is happening in your case.
Scenario 1
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
End Sub
Private Sub ComboBox1_Change()
MsgBox "A"
ComboBox1.Clear
End Sub
Scenario 2
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
ComboBox1.AddItem "Bah Blah Blah"
End Sub
Private Sub ComboBox1_Change()
MsgBox "A"
ComboBox1.ListIndex = 1
End Sub
In the first scenario you can getaway with
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
End Sub
Private Sub ComboBox1_Change()
If ComboBox1 <> "" Then
MsgBox "A"
End If
End Sub
In the 2nd Scenario, you can use something like this
Dim boolRunOnce As Boolean
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
ComboBox1.AddItem "Bah Blah Blah"
End Sub
Private Sub ComboBox1_Change()
If boolRunOnce = False Then
MsgBox "A"
boolRunOnce = True
ComboBox1.ListIndex = 1
Else
boolRunOnce = False
End If
End Sub

Input Box Error Handling

I am having trouble handling the error associated with a input box "Cancel" click. Or in otherwords, it returns an error within the sub if the value of the input is null. I have tried looking around and still can't seem to get it quite right. Here is my attempt:
Private Sub bttnSavingsExpected_Click()
Dim expected() As String
Dim nPeriods As Integer
Dim counter As Integer
Dim savings As Single
With ActiveSheet.Range("A13")
nPeriods = Range(.Offset(1, 0), .End(xlDown)).Rows.Count
End With
ReDim expected(1 To nPeriods)
counter = 1
For counter = 1 To nPeriods
expected(counter) = Range("A13").Offset(counter, 0).Value
Next
TryAgain:
On Error GoTo ErrH
counter = 1
For counter = 1 To nPeriods
savings = InputBox("How much savings do you expect from " & expected(counter) & "?", "Savings?", Range("A13").Offset(counter, 1).Value)
If savings = "" Then
Exit Sub
Else
Range("A13").Offset(counter, 1).Value = savings
End If
Next
Exit Sub
ErrH:
MsgBox "Please enter value. If the default value is desired then please click 'OK'.", vbOKOnly, "Do Not Click Cancel"
GoTo TryAgain
End Sub
With this attempt, the MsgBox is displayed the first click whether there is a input or not and even if I click "Ok". The second try of clicking "OK" or "Cancel" leads to being kicked back to the editor.
You've got Dim savings As Single and If savings = "" Then. Thats always going to error
Try using Dim savings As Variant
Make sure the variable for the Inbox is set at "", then test the value for False. Much easier than anything else I have seen:
Sub WolfPackURL_input()
Dim TheURL As String
Dim SaveURL As Hyperlink
Set savedURL = Sheets("Data").Range("I1")
TheURL = ""
TheURL = Application.InputBox("Input the Sign-Up URL", "Wolfpack Weekly Players URL", "http://something", 1)
If TheURL = "False" Then
Exit Sub
End If
ThisWorkbook.Worksheets("Data").Activate
Sheets("Data").Range("I1").Hyperlinks.Delete
Sheets("Data").Range("I1").ClearContents
Sheets("Data").Range("I1").Clear
ActiveSheet.Hyperlinks.Add anchor:=Sheets("Data").Range("I1"), Address:=TheURL, ScreenTip:="Open file", TextToDisplay:=TheURL
End Sub

Resources