Making VBA Form specific TextBox accept Numbers only and also "." - vba

I want to block some specific textboxes has numeric values only and accept ".". However, it blocks almost all my textboxes in my userform. I don't understand why. What I forgot in my code?
Private Sub tbxHour_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'Making TextBox accept Numbers only
If Not IsNumeric(tbxHour.Value) Then
MsgBox "only numbers allowed"
Cancel = True
End If
End Sub
Private Sub tbxHour_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 46
If InStr(1, tbxHour, ".") > 0 Then KeyAscii = 0
Case 48 To 57
Case Else
KeyAscii = 0
End Select
End Sub

This one worked for me:
Private Sub tbxHour_AfterUpdate()
'Make sure the item is Numeric or has a "." in it
If Not IsNumeric(Me.tbxHour.Text) And Not Me.tbxHour.Text = "." Then
MsgBox "This is illegal!"
Me.tbxHour.Text = ""
End If
End Sub
Short. Simple. Effective and looks like what you're trying to do anyway.

I use this simply NumKeyValidator class for that, to simply prevent invalid input to be supplied by the user:
Option Explicit
Private Const vbKeyDot As Integer = 46
Public Function IsValidKeyAscii(ByVal keyAscii As Integer, ByVal value As String) As Boolean
'returns true if specified keyAscii is a number, or if it's a dot and value doesn't already contain one
IsValidKeyAscii = (keyAscii = vbKeyDot And InStr(1, value, Chr$(vbKeyDot)) = 0) Or (keyAscii >= vbKey0 And keyAscii <= vbKey9)
End Function
You can use it by simply declaring an instance field for it:
Private validator As New NumKeyValidator
And then you use it in each textbox' KeyPress handler, like this:
Private Sub tbxHour_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If Not validator.IsValidKeyAscii(keyAscii, tbxHour.Value) Then keyAscii = 0
End Sub
There's no need to handle Exit and pop a MsgBox then - either the box is empty, or it contains a valid number; you could have an IsValidForm property that returns True if all required textboxes contain numbers, and false otherwise - and then decide that the form's Ok button is disabled until the form is valid.
FWIW that validator class is quite thoroughly tested (using Rubberduck unit tests [disclaimer: I own that open-source VBE add-in project]):
Option Explicit
Option Private Module
'#TestModule
'' uncomment for late-binding:
Private Assert As Object
'' early-binding requires reference to Rubberduck.UnitTesting.tlb:
'Private Assert As New Rubberduck.AssertClass
'#TestMethod
Public Sub DotIsValidForEmptyValue()
On Error GoTo TestFail
'Arrange:
Dim actual As Boolean
Dim sut As New NumKeyValidator
'Act:
actual = sut.IsValidKeyAscii(Asc("."), vbNullString)
'Assert:
Assert.IsTrue actual
TestExit:
Exit Sub
TestFail:
Assert.Fail "Test raised an error: #" & Err.Number & " - " & Err.Description
End Sub
'#TestMethod
Public Sub DotIsValidForNonEmptyValueWithoutAnyDots()
On Error GoTo TestFail
'Arrange:
Dim actual As Boolean
Dim sut As New NumKeyValidator
'Act:
actual = sut.IsValidKeyAscii(Asc("."), "123")
'Assert:
Assert.IsTrue actual
TestExit:
Exit Sub
TestFail:
Assert.Fail "Test raised an error: #" & Err.Number & " - " & Err.Description
End Sub
'#TestMethod
Public Sub DotIsInvalidWhenValueHasDot()
On Error GoTo TestFail
'Arrange:
Dim actual As Boolean
Dim sut As New NumKeyValidator
'Act:
actual = sut.IsValidKeyAscii(Asc("."), "123.45")
'Assert:
Assert.IsFalse actual
TestExit:
Exit Sub
TestFail:
Assert.Fail "Test raised an error: #" & Err.Number & " - " & Err.Description
End Sub
'#TestMethod
Public Sub AllDigitsAreValid()
On Error GoTo TestFail
Dim sut As New NumKeyValidator
Assert.IsTrue sut.IsValidKeyAscii(Asc("0"), vbNullString)
Assert.IsTrue sut.IsValidKeyAscii(Asc("1"), vbNullString)
Assert.IsTrue sut.IsValidKeyAscii(Asc("2"), vbNullString)
Assert.IsTrue sut.IsValidKeyAscii(Asc("3"), vbNullString)
Assert.IsTrue sut.IsValidKeyAscii(Asc("4"), vbNullString)
Assert.IsTrue sut.IsValidKeyAscii(Asc("5"), vbNullString)
Assert.IsTrue sut.IsValidKeyAscii(Asc("6"), vbNullString)
Assert.IsTrue sut.IsValidKeyAscii(Asc("7"), vbNullString)
Assert.IsTrue sut.IsValidKeyAscii(Asc("8"), vbNullString)
Assert.IsTrue sut.IsValidKeyAscii(Asc("9"), vbNullString)
TestExit:
Exit Sub
TestFail:
Assert.Fail "Test raised an error: #" & Err.Number & " - " & Err.Description
End Sub
'#TestMethod
Public Sub AlphaIsInvalid()
On Error GoTo TestFail
'Arrange:
Dim actual As Boolean
Dim sut As New NumKeyValidator
'Act:
actual = sut.IsValidKeyAscii(Asc("a"), vbNullString)
'Assert:
Assert.IsFalse actual
TestExit:
Exit Sub
TestFail:
Assert.Fail "Test raised an error: #" & Err.Number & " - " & Err.Description
End Sub
'#TestMethod
Public Sub DollarSignIsInvalid()
On Error GoTo TestFail
'Arrange:
Dim actual As Boolean
Dim sut As New NumKeyValidator
'Act:
actual = sut.IsValidKeyAscii(Asc("$"), vbNullString)
'Assert:
Assert.IsFalse actual
TestExit:
Exit Sub
TestFail:
Assert.Fail "Test raised an error: #" & Err.Number & " - " & Err.Description
End Sub
'#TestMethod
Public Sub NegativeSignIsInvalid()
On Error GoTo TestFail
'Arrange:
Dim actual As Boolean
Dim sut As New NumKeyValidator
'Act:
actual = sut.IsValidKeyAscii(Asc("-"), vbNullString)
'Assert:
Assert.IsFalse actual
TestExit:
Exit Sub
TestFail:
Assert.Fail "Test raised an error: #" & Err.Number & " - " & Err.Description
End Sub
That said I don't see how the code you've shown could ever "block almost all textboxes in your userform".

Related

Voice Recognition in PowerPoint using VBA Macros

A week ago I had a presentation where I was making an AI using Voice Recognition with VBA. It worked perfectly (I took the code from this WebSite) till some day I was going to test it again and it didn't work. It returns an error
"Run-time error '70': Permission denied"
I checked my microphone and the VBA References needed that are mentioned in the WebSite. Then I went to the Site I took the code from and I saw a different version of the code (Public, Shared...) and when I ran it, another error appears
"Run-time error '-2147200905 (80045077)': Automation error"
So can someone please help me, the code used to work and I didn't change anything. Here's the code:
Option Explicit
Dim WithEvents RC As SpInProcRecoContext
Dim Recognizer As SpInprocRecognizer
Dim myGrammar As ISpeechRecoGrammar
Private Sub CommandButton1_Click()
'On Error GoTo EH
Set RC = New SpInProcRecoContext
Set Recognizer = RC.Recognizer
Set myGrammar = RC.CreateGrammar
myGrammar.DictationSetState SGDSActive
Dim Category As SpObjectTokenCategory
Set Category = New SpObjectTokenCategory
Category.SetId SpeechCategoryAudioIn
Dim Token As SpObjectToken
Set Token = New SpObjectToken
Token.SetId Category.Default()
Set Recognizer.AudioInput = Token
'EH:
' If Err.Number Then ShowErrMsg
End Sub
Private Sub RC_Recognition(ByVal StreamNumber As Long, ByVal StreamPosition As Variant, ByVal RecognitionType As SpeechLib.SpeechRecognitionType, ByVal Result As SpeechLib.ISpeechRecoResult)
On Error GoTo EH
TextBox1.text = Result.PhraseInfo.GetText
EH:
If Err.Number Then ShowErrMsg
End Sub
Private Sub ShowErrMsg()
' Declare identifiers:
Const NL = vbNewLine
Dim T As String
T = "Desc: " & Err.Description & NL
T = T & "Err #: " & Err.Number
MsgBox T, vbExclamation, "Run-Time Error"
'End
End Sub
'### Second version of the code (Shared, Public...)
Option Explicit
Public WithEvents RC As SpSharedRecoContext
Public myGrammar As ISpeechRecoGrammar
Private Sub CommandButton1_Click()
'On Error GoTo EH
Set RC = New SpSharedRecoContext
Set myGrammar = RC.CreateGrammar
myGrammar.DictationSetState SGDSActive
'EH:
'If Err.Number Then ShowErrMsg
End Sub
Private Sub RC_Recognition(ByVal StreamNumber As Long, ByVal StreamPosition As Variant, ByVal RecognitionType As SpeechLib.SpeechRecognitionType, ByVal Result As SpeechLib.ISpeechRecoResult)
Label1.Caption = Result.PhraseInfo.GetText
End Sub
Private Sub RC_StartStream(ByVal StreamNumber As Long, ByVal StreamPosition As Variant)
'Label2.Caption = Val(StreamNumber)
End Sub
Private Sub ShowErrMsg()
' Declare identifiers:
Const NL = vbNewLine
Dim T As String
T = "Desc: " & Err.Description & NL
T = T & "Err #: " & Err.Number
MsgBox T, vbExclamation, "Run-Time Error"
End
End Sub
That error is saying:
SPERR_RECOGNIZER_NOT_FOUND 0x80045077 -2147200905
No recognizer is installed.

Make a button visible if a key is press down

I am trying to make a button visible only if a key (example Control) is press down.
My code:
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 17 Then
Me.btn1.Visible = True
Else
Me.btn1.Visible = False
End If
End Sub
Private Sub Form_Load()
Me.btn1.Visible = False
End Sub
I need to have visible and active the button only when the CONTROL key is press down and the user click on btn1.
Thank you.
Update Code:
Option Compare Database
Option Explicit
Private Sub btnHide_Click()
DoCmd.Close acForm, "frmDemo", acSaveYes
End Sub
Private Sub btnFake_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo Err_Handler
If vbKeyControl = 17 Then
Me.btnHide.Visible = True
FormTimer
Me.btnFake.SetFocus
Me.btnHide.Visible = False
Else
Me.btnHide.Visible = False
End If
Exit_This_Sub:
Exit Sub
Err_Handler:
If Err = 2467 Then '<== Form is closed.
Resume Exit_This_Sub
Else
MsgBox "Error #: " & Err.Number & " " & Err.Description
End If
Resume Exit_This_Sub
End Sub
Private Sub Form_Load()
Me.btnHide.Visible = False
Me.btnFake.SetFocus
End Sub
Sub FormTimer()
Dim PauseTime, Start, Finish, TotalTime
PauseTime = 0.1 ' Set duration.
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
DoEvents ' Yield to other processes.
Loop
End Sub
I test it and it is working fine. Simple code.
If CONTROL is press btnHide is visible for 0.1sec.
Any ideas?

Excel VBA: Compile Error: Method or data member not found

EDIT: To clarify, the code seen below is within a module and the UserForm is all contained within its own code.
I have the following code. When I go to run it, Excel throws me a compile error: Method or data member not found and highlights the following piece of code: .showInputsDialog. I have no idea how to resolve this error.
To give more information, the sub sportUserForm is supposed to call up a UserForm sportsUsrFrm. Any help with this issue is greatly appreciated.
Option Explicit
Sub sportUserForm()
Dim sSport As String, sPreference As String
If sportsUsrFrm.showInputsDialog(sSport, sPreference) Then
MsgBox "Your favorite sport is " & sSport & ", and you usually " _
& sPreference & "."
Else
MsgBox "Sorry you don't want to play."
End If
End Sub
Public Function showInputsDialog(sSports As String, sPreference As String) As Boolean
Call Initialize
Me.Show
If Not cancel Then
If optBaseball.Value Then sSport = "Baseball"
ElseIf optBasketball.Value Then sSport = "Basketball"
Elss sSport = "Football"
End If
If optTV.Value Then sPreference = "watch on TV" _
Else: sPreference = "go to games"
End If
showInputsDialog = Not cancel
Unload Me
End Function
UserForm code for sportUsrFrm
Option Explicit
Private Sub cmdCnl_Click()
Me.Hide
cancel = True
End Sub
Private Sub cmdOK_Click()
If Valid Then Me.Hide
cancel = False
End Sub
You're getting the error because showInputsDialog isn't a member of the form, it's a member of the module you're calling it from. You should also be getting compiler errors on these two lines...
Call Initialize
Me.Show
...because you seem to be getting the module and form code mixed up.
That said, you're overthinking this. A UserForm is a class module, and it can be stored in a variable (or in this case, in a With block), and can have properties. I'd add a Cancelled property to the form:
'In sportsUsrFrm
Option Explicit
Private mCancel As Boolean
Public Property Get Cancelled() As Boolean
Cancelled = mCancel
End Property
Private Sub cmdCnl_Click()
Me.Hide
mCancel = True
End Sub
Private Sub cmdOK_Click()
If Valid Then Me.Hide '<-- You still need to implement `Valid`
End Sub
And then call it like this:
Sub sportUserForm()
With New sportsUsrFrm
.Show
Dim sSport As String, sPreference As String
If Not .Cancelled Then
If .optBaseball.Value Then
sSport = "Baseball"
ElseIf .optBasketball.Value Then
sSport = "Basketball"
Else
sSport = "Football"
End If
If .optTV.Value Then
sPreference = "watch on TV"
Else
sPreference = "go to games"
End If
MsgBox "Your favorite sport is " & sSport & ", and you usually " _
& sPreference & "."
Else
MsgBox "Sorry you don't want to play."
End If
End With
End Sub

Passing Listbox object in vba Access

I'm trying to pass a listbox to another sub to populate it, this is designed to allow multiple listboxes to use the same code by passing the name of the listbox, and the name of the table (which checks whether the input is valid) to the sub. At the moment the me.Autoclavelist (which is the name of the listbox on this particular form) in the below code displays 'null' when you hover over it.
1) What is the listbox object actually expecting as input?
2) Subs 1 and 2 appear to work even with the null being sent - however similar code using a .removeitem doesn't (3 & 4) why is this?
Thanks!
Edit: I found the issue here - I had locked the listboxes on the forms. This meant that it wasn't possible to select any items in them, and the value was therefore always null, so the second two subs failed.
Sub 1:
Private Sub cmdAutoClaveAddItem_Click()
On Error GoTo Errorhandler
Call AddtoList(Me.AutoClaveList, "[Autoclave Process]")
If Me.AutoClaveList.ListCount <> 0 Then
Me.cmdRunAutoclave.Enabled = True
Me.CmdRemoveItem.Enabled = True
End If
SubExit:
Exit Sub
Errorhandler:
MsgBox Error$
Resume SubExit
End Sub
Sub 2:
Private Sub AddtoList(ListName As Listbox, FormName As String)
On Error GoTo Errorhandler
Dim StrLabel_Id As String
Dim l As Long
ListName.RowSourceType = "Value List"
StrLabel_Id = InputBox("Scan Tray Label", "Scan")
If StrLabel_Id = "" Then
GoTo SubExit
Else
If Not IsNull(DLookup("[Tracking_Label_ID]", "Label_Production", "[Tracking_Label_ID]='" & StrLabel_Id & "'")) Then
If IsNull(DLookup("[Tracking_Label_ID]", FormName, "[Tracking_Label_ID]='" & StrLabel_Id & "'")) Then
l = 0
For l = 0 To (ListName.ListCount - 1) Step 1
If ListName.ItemData(l) = StrLabel_Id Then
Call MsgBox("Label is already in batch!", , "Error")
GoTo SubExit
End If
Next
ListName.AddItem StrLabel_Id
Else
Call MsgBox("Label has already been processed", , "Error")
End If
Else
Call MsgBox("Label does not exist. Make sure you create label in Label Production", , "Error")
End If
End If
SubExit:
Exit Sub
Errorhandler:
MsgBox Error$
Resume SubExit
End Sub
Sub 3:
Private Sub CmdRemoveItem_Click()
On Error GoTo Errorhandler
Call RemovelistItem(AutoClaveList)
SubExit:
Exit Sub
Errorhandler:
MsgBox Error$
Resume SubExit
End Sub
Sub 4:
Private Sub RemovelistItem(ListName As Listbox)
On Error GoTo Errorhandler
Dim strRemoveItem As String
If Not IsNull(ListName.Value) Then
strRemoveItem = ListName.Value
ListName.RemoveItem (strRemoveItem)
Else
GoTo SubExit
End If
SubExit:
ListName.Requery
Exit Sub
Errorhandler:
MsgBox Error$
Resume SubExit
End Sub
Don't worry about the Null. The object exists and is just fine. The default property of ListBox objects is Value; therefore the value of Value is what gets displayed when you mouse over Me.AutoClaveList. Its Value happens to be Null (which it is by default):
Null Indicates the item is in a null state, neither selected nor cleared.
For more info, you can have a look at ListName and its properties in the Locals window.
Of course, if you do this:
If Not IsNull(ListName.Value) Then
'do stuff
Else
GoTo SubExit
End If
then it "won't work" i.e. will not do anything because .Value is Null. Get rid of that condition.

VBA: subroutine with if statement and returning true or false?

SOLVED!
I have to validate that certain cells are not empty, so I want to create a subroutine and pass the variables I need checked.
This is what I came up with:
Sub errorMessage(errMsg As String, errRange As String)
If Range(errRange) = "" Then
MsgBox errMsg, , "Error:"
Range(errRange).Activate
'this is what i was looking for :doh:, the 'end' line terminates everything..
END
End Sub
Now when I call it from my button, will it actuall end the sub of the button?
i.e.
Private Sub CommandButton1_Click()
Call errorMessage("name is missing", "D4")
'this function shouldn't be called if there was a msgbox displayed with the above call
sendEmail
End Sub
How can i make this happen?
EDIT:
OK So this is how i sovled it, the reason i'm trying to do this is to avoid tons of lines of code in the buttonClick sub, what are your thoughts??
keep in mind that this thing has to check about 25 questions for blanks before executing the sendEmail sub....
Private Sub CommandButton1_Click()
Call validateEntry("Client Name is missing.", "D4")
Call validateEntry("# not complete.", "D5")
Call validateEntry("Address same as CV?", "D6")
Call validateEntry("Number missing.", "D8")
Call validateEntry("Type missing.", "D9")
Call validateEntry("Q1 requires a Yes or No.", "E19")
Call validateEntry("Q2 requires a Yes or No.", "E21")
Call validateEntry("Q3 requires a Yes or No.", "E23")
Call validateEntry("Q4 requires a Yes or No.", "E25")
Call validateEntry("Q5 requires a Date.", "D28")
Call validateEntry("Q6 requires a Yes or No.", "E30")
Call validateEntry("Q7 requires a Yes or No.", "E32")
MsgBox "passed"
'sendEmail
End Sub
Sub validateEntry(errMsg As String, errRange As String)
If Range(errRange) = "" Then
MsgBox errMsg, , "Error:"
Range(errRange).Activate
End
End If
End Sub
So, in your example, you're looking for the "passed" notification to only be sent when there is data in cell D4, right?
This should work:
Private Function errorMessage(errMsg As String, errRange As String) As Boolean
errorMessage = False
If Len(Trim(Range(errRange))) = 0 Then
MsgBox errMsg, , "Error:"
Range(errRange).Activate
errorMessage = True
End If
End Function
Public Sub CommandButton1_Click()
If errorMessage("name is missing", "D4") = False Then
MsgBox "passed"
End If
End Sub
Alternatively, you can handle all MsgBox notifications from within the function, to group similar logic together, and keep the Button Click Event Sub clean:
Private Function errorMessage(errMsg As String, errRange As String)
If Len(Trim(Range(errRange))) = 0 Then
MsgBox errMsg, , "Error:"
Range(errRange).Activate
Else
MsgBox "passed"
End If
End Function
Public Sub CommandButton1_Click()
Call errorMessage("name is missing", "D4")
End Sub
There are a number of misconceptions here.
First, no, it will not end the button routine by default. You will need to handle that within your button.
Next, you're missing an End If somewhere in here:
Sub errorMessage(errMsg As String, errRange As String)
If Range(errRange) = "" Then ' This may not be the best way to check for
' an empty range
MsgBox errMsg, , "Error:"
Range(errRange).Activate
Exit Sub
End Sub
You really don't even want a subroutine in the first place, you want a function that returns a boolean, like this:
Function errorMessage(errMsg As String, errRange As String) as Boolean
' Function returns True if an error occured
errorMessage = False
If Range(errRange) = "" Then
MsgBox errMsg, , "Error:"
Range(errRange).Activate
errorMessage = True
End If
End Sub
And then here:
Private Sub CommandButton1_Click()
If errorMessage("name is missing", "D4") Then
Exit Sub
End If
'this msgbox should not display if the above msgbox is displayed
MsgBox "passed"
' continue on with all of your fun processing here
End Sub