UserForm Button Still Functioning When Disabled - excel

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

Related

BeforeUpdate event validation control

Dears,
I want to make a simple userform to record some serial numbers into excel, it contains a textbox_serialNo., a command button “enter” and another command button “cancel”.
I made a validation control in that serialNo textbox so that only number can be entered. However, when I run the program and input some numbers into the textbox, both command buttons (the "enter" button named as label_enter,the "cancel" button named as label_cancel) have no reactions (e.g. the "cancel" button doesn't unload the form when press) , how should I correct the program? Below are the relevant codes, Thanks.
Private Sub TextBox_SerialNo_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Not IsNumeric(TextBox_SerialNo.Value) Then
TextBox_SerialNo.BackColor = rgbYellow
End If
Cancel = True
End Sub
Private Sub TextBox_SerialNo_AfterUpdate()
If TextBox_SerialNo.Value <> "" Then
TextBox_SerialNo.BackColor = rgbWhite
End If
End Sub
Private sub label_enter_click()
sheet1.Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value + 1
ActiveCell.Offset(0, 1) = TextBox_SerialNo.Value
TextBox_SerialNo.Value = ""
End Sub
Private Sub Label_Cancel_Click()
Unload Me
End Sub
Sorry to be posting as an answer, not enough rep.
Shouldn't Cancel=True be inside the if statement? You are locking it up regardless of entry being numeric or not as is.
Edit:
Actually upon further testing still not working proper. However, change event works better and you can get instant feedback for any non numerics.
Updated code would look like this, control names differ. I am used to working with .Text, same thing as .Value. Also, since I am not sure what you would do with an empty string, assumed it to be yellow background as well.
One concern would be, can you allow comma or period in there? Depending on locale settings, a decimal would also be considered a numeric.
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdEnter_Click()
If TextBox1.BackColor = rgbYellow Then Exit Sub
test4.Range("A1").Value = TextBox1.Text
End Sub
Private Sub TextBox1_Change()
If Not IsNumeric(TextBox1.Text) Or TextBox1.Text = "" Then
TextBox1.BackColor = rgbYellow
Else
If TextBox1.Text <> "" Then
TextBox1.BackColor = rgbWhite
End If
End If
End Sub
Edit 2: I use this piece of code to check for only numbers (assuming number Ascii codes are standard). Maybe it can help.
Public Function isnumber(ByVal strValue As Variant) As Boolean
On Error Resume Next
Dim i As Long
isnumber = True
If Not strValue = "" Then
For i = 1 To Len(CStr(strValue))
If Asc(Mid(strValue, i, 1)) > 57 Or Asc(Mid(strValue, i, 1)) < 48 Then
isnumber = False
Exit For
End If
Next i
Else
isnumber = False
End If
On Error GoTo 0
Err.Clear
End Function
Edit 3: I have revised the TextBox1_Change event code so all invalid characters are stripped right away. However, in this state if you copy paste a serial no with a non-allowed char, it will strip them leaving only the numbers. Not sure if it is acceptable.
Private Sub TextBox1_Change()
If Not isnumber(TextBox1.Text) Or TextBox1.Text = "" Then
TextBox1.BackColor = rgbYellow
Dim i As Long
Dim strValue As String
strValue = ""
If Not TextBox1.Text = "" Then
For i = 1 To Len(CStr(TextBox1.Text))
If Not (Asc(Mid(TextBox1.Text, i, 1)) > 57 Or Asc(Mid(TextBox1.Text, i, 1)) < 48) Then
strValue = strValue & Mid(TextBox1.Text, i, 1)
End If
Next i
End If
TextBox1.Text = strValue
Else
If TextBox1.Text <> "" Then
TextBox1.BackColor = rgbWhite
End If
End If
End Sub

Glitch when using RefEdit_Change Event in a VBA UserForm

The following should happen:
1. UserForm with 2 RefEdit controls is shown
2. The first RefEdit is used to select a range
3. The RefEdit_Change event adjusts the second RefEdit control to .offset(0,1) of the range
Here my code until now:
Module1:
Dim frmSelectXY As New frmSelectImportData
With frmSelectXY
.Show
.DoStuffWithTheSelectedRanges
End With
UserForm: frmSelectImportData
Option Explicit
Private Type TView
IsCancelled As Boolean
xrng As Range
yrng As Range
End Type
Private this As TView
Public Property Get IsCancelled() As Boolean
IsCancelled = this.IsCancelled
End Property
Public Property Get yrng() As Range
Set yrng = this.yrng
End Property
Public Property Get xrng() As Range
Set xrng = this.xrng
End Property
'Here is where the fun happens
Private Sub RefEdit1_Change()
'RefEdit2.Value = RefEdit1.Value
If InStr(1, RefEdit1.Value, "[") <> 0 And InStr(1, RefEdit1.Value, "!") <> 0 Then
RefEdit2.Value = Range(RefEdit1.Value).offset(0, 1).Address(External:=True)
ElseIf InStr(1, RefEdit1.Value, "!") <> 0 Then
RefEdit2.Value = Range(RefEdit1.Value).offset(0, 1).Parent.Name & "!" & Range(RefEdit1.Value).offset(0, 1).Address(External:=False)
Else
RefEdit2.Value = Range(RefEdit1.Value).offset(0, 1).Address(External:=False)
End If
End Sub
Private Sub SaveBTN_Click()
Set this.xrng = Range(RefEdit1.Value)
Set this.yrng = Range(RefEdit2.Value)
If Not validate Then
MsgBox "x-values and y-values need to have the same size."
Else
Me.Hide
End If
End Sub
Function validate() As Boolean
validate = False
If this.xrng.count = this.yrng.count Then validate = True
End Function
RefEdit1_Change should adjust the value of RefEdit2 such that it will show the reference to the column just next to it or better .offest(0,1) to it.
But that isn't what happens.. the value doesn't get changed. As soon as the User clicks into RefEdit2 if RefEdit1 has already been changed, the program aborts without error message. If you Cancle the UserForm I have also experienced hard crashes of excel. I have temporarily fixed the problem by rebuilding the UserForm from scratch and renaming the RefEdits. But at some point it reapeared. It seems as if it is an Excel/VBA inherent problem.
Does anybody know how to fix this?
Ugly hacks and workarounds are welcome, anything is better than, abort without error message.
you need to enclose Range(RefEdit1.Value).offset(0, 1).Parent.Name in ' so
="'" & Range(RefEdit1.Value).offset(0, 1).Parent.Name & "'!"

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

Display popup for a time period in 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

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

Resources