I am doing an assignment for my class and I'm a supeeeer beginner at coding. This assignment calls for me to select services and a discount rate and then show them in a total text box beneath the two.
My issue is, I'm supposed to be able to select multiple services and have them total together, but I just can't figure it out. I'll post the code below:
Public Class Form1
Dim CurrentServicesDec As Decimal
Dim CurrentServicesTotal As Decimal
Private DiscountServicesDec As Decimal
Private Sub CalculateButton_Click(sender As Object, e As EventArgs) Handles CalculateButton.Click
'Calculate the Service(s) selected and add the discount if any.
If MakeOverCheckBox.Checked = True Then
CurrentServicesDec = 125
ElseIf Val(HairStylingCheckBox.Checked) = True Then
CurrentServicesDec = 60
ElseIf Val(ManicureCheckBox.Checked) = True Then
CurrentServicesDec = 35
ElseIf Val(MakeupCheckbox.Checked) = True Then
CurrentServicesDec = 200
End If
If (TenPercentRadio.Checked) = True Then
DiscountServicesDec = 0.1
ElseIf TwentyPercentRadio.Checked = True Then
DiscountServicesDec = 0.2
End If
CurrentServicesTotal = CurrentServicesDec - (CurrentServicesDec * DiscountServicesDec)
txtTotal.Text = FormatCurrency(CurrentServicesTotal)
End Sub
Private Sub ClearButton_Click(sender As Object, e As EventArgs) Handles ClearButton.Click
'Clear the options on the form.
txtTotal.Text = ""
TenPercentRadio.Checked = False
TwentyPercentRadio.Checked = False
End Sub
Private Sub ExitButton_Click(sender As Object, e As EventArgs) Handles ExitButton.Click
'Close the program
Me.Close()
End Sub
Private Sub PrintButton_Click(sender As Object, e As EventArgs) Handles PrintButton.Click
'Print Preview the Form
PrintForm1.PrintAction = Printing.PrintAction.PrintToPreview
PrintForm1.Print()
End Sub
End Class
This is what I have, as far as the program being able to select one service and add the discount, it works perfectly but not for multiple services selected!
Thank you in advance.
Your program flow has some issues to get your intended behavior, since with your If block starting with If MakeOverCheckBox.Checked = True Then, using ElseIf for subsequent branches will cause them to skip.
You're also just assigning the value of CurrentServicesDec when I think you should be adding it together - so declare the variable inside your Calculate function and then use +=.
So to get the behavior of checking for multiples in your checkbox control - change the ElseIf to If blocks.
Private Sub CalculateButton_Click(sender As Object, e As EventArgs) Handles CalculateButton.Click
Dim CurrentServicesDec As Decimal
If MakeOverCheckBox.Checked = True Then
CurrentServicesDec += 125
End If
If HairStylingCheckBox.Checked = True Then
CurrentServicesDec += 60
End If
If ManicureCheckBox.Checked = True Then
CurrentServicesDec += 35
End If
If MakeupCheckbox.Checked = True Then
CurrentServicesDec += 200
End If
Related
I am somewhat new to vba, and I'm trying to create a somewhat more complex conditional format than access 2013 allows from the conditional formatting menu. I have a form with 22 target date and actual date fields. for each pair I need to:
if the target date is more than 7 days in the future, color it green.
If the target date is less than 7 days in the future or is today, color it yellow
If the target date in the past, color it red.
UNLESS there is an actual date it was accomplished, in which case:
If the actual date is before the target date, color both dates green
If the actual date is after the target date, color both dates red.
Because I have to do this on form load, and on the change of any date field (the target dates are calculated, but will change if other data is changed in the form), I wanted to write a public sub that takes form name, target date, and actual date as variables. I was able to code each box to do this on the local form module with 'Me.txtbox'
However, when I try to reference the form and text boxes from the public sub, it seems like I'm not properly referencing the text boxes on the form. I've tried 3 or 4 different ways of doing this (string, textbox.name, etc) and I feel like I'm close, but ...
Code that works as desired in the form module
Private Sub txtFreqReqDate_AfterUpdate()
If Me.txtFreqReqDate <= Me.txtFreqReq Then
Me.txtFreqReq.Format = "mm/dd/yyyy[green]"
Me.txtFreqReqDate.Format = "mm/dd/yyyy[green]"
ElseIf Me.txtFreqReqDate > Me.txtFreqReq Then
Me.txtFreqReq.Format = "mm/dd/yyyy[red]"
Me.txtFreqReqDate.Format = "mm/dd/yyyy[red]"
ElseIf IsNull(Me.txtFreReqDate) = True Then
If Me.txtFreqReq < Now() Then
Me.txtFreqReq.Format = "mm/dd/yyyy[red]"
ElseIf Me.txtFreqReq >= (Now()+7) Then
Me.txtFreqReq.Format = "mm/dd/yyyy[yellow]"
ElseIf Me.txtFreqReq > (Now()+7) Then
Me.txtFreqReq.Format = "mm/dd/yyyy[green]"
Else
Me.txtFreqReq.Format = "mm/dd/yyyy[black]"
End If
Else
Exit Sub
End If
End Sub
Perhaps not the prettiest, but I'm always open to constructive criticism. I'd have to write this 22+ times for each pair, changing the name of the text boxes each time. I want to write a public sub that just takes the names of the text boxes, but I can't seem to find the right combination:
Private Sub txtFreqReqDate_AfterUpdate()
FormatBoxes(Me, me.txtFreqReqDate, me.txtFreqReq)
End Sub
And in another module:
Public Sub FormatBoxes(CurrentForm As Form, txtActual as Textbox, txtTarget as Textbox)
frmName = CurrentForm.name
tbActual = txtActual.Name
tbTarget = txtTarget.Name
If frmName.tbActual <= frmName.tbTarget Then
frmName.tbTarget.Format = "mm/dd/yyyy[green]"
frmName.tbActual.Format = "mm/dd/yyyy[green]"
ElseIf frmName.tbActual > frmName.tbTarget Then
frmName.tbTarget.Format = "mm/dd/yyyy[red]"
frmName.tbActual.Format = "mm/dd/yyyy[red]"
ElseIf IsNull(frmName.tbActual) = True Then
If frmName.tbTarget < Now() Then
frmName.tbTarget.Format = "mm/dd/yyyy[red]"
ElseIf frmName.tbTarget >= (Now()+7) Then
frmName.tbTarget.Format = "mm/dd/yyyy[yellow]"
ElseIf frmName.tbTarget > (Now()+7) Then
frmName.tbTarget.Format = "mm/dd/yyyy[green]"
Else
frmName.tbTarget.Format = "mm/dd/yyyy[black]"
End If
Else
Exit Sub
End If
End Sub
Sorry if this is a bit long, I'm just at my wit's end...
Also, apologies for any typos. I had to re-type this from another machine.
You can simply use the textbox parameters directly in your sub.
It is not even necessary to pass the form as parameter.
Public Sub FormatBoxes(txtActual as Textbox, txtTarget as Textbox)
If txtActual.Value <= txtTarget.Value Then
txtTarget.Format = "mm/dd/yyyy[green]"
etc.
Note that when calling it, you need either Call or remove the parentheses.
Private Sub txtFreqReqDate_AfterUpdate()
Call FormatBoxes(me.txtFreqReqDate, me.txtFreqReq)
' or
' FormatBoxes me.txtFreqReqDate, me.txtFreqReq
End Sub
CurrentForm.name is a string. It is the Name property of the CurrentForm object. The CurrentForm object also has a controls collection in which the texboxes live. You can refer to them by name in there like CurrentForm.Controls("tbTarget") but you can also say CurrentForm.tbTarget. So you're very close and on the right track.
Change
frmName = CurrentForm.name
tbActual = txtActual.Name
tbTarget = txtTarget.Name
to
set frmName = CurrentForm
if frmName is not nothing then
set tbActual = txtActual
set tbTarget = txtTarget
end if
Alternatively if your signature on your method is
Public Sub FormatBoxes(CurrentForm As string, txtActual as string, txtTarget as string)
then your set up will look like
set frmName = forms(CurrentForm)
if frmName is not nothing then
set tbActual = frmName.controls(txtActual)
set tbTarget = frmName.controls(txtTarget)
end if
But I think the first one will work better.
I wanted to post the finished code to help out anyone else who searches for this subject. I did a couple thins to make this sub more universal.
First, Instead of using the date format, I only changed the .ForeColor, allowing me to use this sub for any type of textbox.
Public Sub FormatBoxes(txtActual As TextBox, txtTarget As TextBox, chkRequired As CheckBox, _
Optional intOption as Integer)
Dim intRed As Long, intYellow As Long, intGreen As Long, inBlack As Long, intGray As Long
intBlack = RGB(0, 0, 0)
intGray = RGB(180, 180, 180)
intGreen = RGB (30, 120, 30)
intYellow = RGB(217, 167, 25)
intRed = RGB(255, 0, 0)
If (chkRequired = False) Then
txtTarget.ForeColor = intGray
txtActual.ForeColor = intGray
If intOption <> 1 Then
txtTarget.Enabled = False
txtActual.Enabled = False
txtTarget.TabStop = False
txtActual.TabStop = False
End If
Else
If intOption <> 1 Then
txtTarget.Enabled = True
txtActual.Enabled = True
txtTarget.Locked = True
txtActual.Locked = False
txtTarget.TabStop = False
txtActual.TabStop = True
End If
If IsBlank(txtActual) = True Then
If txtTarget < Now() Then
txtTarget.ForeColor = intRed
ElseIf txtTarget > (Now() + 7) Then
txtTarget.ForeColor = intGreen
ElseIf txtTarget >= Now() And txtTarget <= (Now() +7) Then
txtTarget.ForeColor = intYellow
Else
txtTarget.ForeColor = intBlack
End If
ElseIf intOption - 1 Then
txtTarget.ForeColor = intBlack
txtActual.ForeColor = intBlack
ElseIf txtActual <= txtTarget Then
txtTarget.ForeColor = intGreen
txtActual.ForeColor = intGreen
ElseIf txtActual > txtTarget Then
txtTarget.ForeColor = intRed
txtActual.ForeColor = intRed
End If
End If
End Sub
In case you were wondering, IsBlank() is a function that checks for a null or zero length string:
Public Function IsBlank(str_in As Variant) As Long
If Len(str_in & "") = 0 Then
IsBlank = -1
Else
IsBlank = 0
End If
End Function
Thanks for all the help, and I hope this is useful for someone.
I would like to filter results at sheet and create Listbox with this result,
this code works on listbox on sheet but not works on form, any idea ?
Sub MyListBox()
Dim rng As Range
Dim vArr As Variant
Dim ListBox1 As Object ---> this works on sheet but not works on form
Dim x As Single
Dim y As String
y = Worksheets("Sheet2").Cells(1, 12).Value
x = Worksheets("Sheet2").Cells(2, 12).Value
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Set rng = Range("TestMaterial")
Set ListBox1 = ActiveSheet.OLEObjects(1).Object ---> this works on sheet but not works on form
rng.AutoFilter field:=13, Criteria1:=y
rng.AutoFilter field:=12, Criteria1:=x
Worksheets.Add
rng.SpecialCells(xlCellTypeVisible).Copy Range("a1")
vArr = ActiveSheet.UsedRange
With ListBox1
.List = (vArr)
End With
ActiveSheet.Delete
Worksheets("TRAINING").AutoFilterMode = False
'rng.AutoFilter.Clear
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
I found this code but this creates new listbox but do not fill listbox with data, only headers, could not find what is incorrect and how can I fill existing listbox with this code ?
Sub MyListBox()
Dim rng As Range
Dim vArr As Variant
Dim ListBox1 As MSForms.Control
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Set rng = Range("TestMaterial")
Set ListBox1 = frmplan.Controls.Add("Forms.ListBox.1") ---> adds new Listbox to form even I have some one with name "Listbox1"
rng.AutoFilter field:=13, Criteria1:=txtsdept.Value
rng.AutoFilter field:=12, Criteria1:=txtsgrade
Worksheets.Add
rng.SpecialCells(xlCellTypeVisible).Copy Range("a1")
vArr = ActiveSheet.UsedRange
With ListBox1
.List = (vArr)
End With
ActiveSheet.Delete
Worksheets("TRAINING").AutoFilterMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
try the following code for the "Userform" case:
Sub MyListBox()
With Range("TestMaterial")
.AutoFilter Field:=13, criteria1:=txtsdept.value
.AutoFilter Field:=12, criteria1:=txtsgrade
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then FillListBox .SpecialCells(xlCellTypeVisible), Me.ListBox1
.Parent.AutoFilterMode = False
End With
End Sub
Sub FillListBox(filteredRng As Range, LB As msforms.ListBox)
Dim vArr As Variant
vArr = GetArray(filteredRng) '<--| fill array
With LB
.ColumnCount = UBound(vArr, 2)
.List = vArr
End With
End Sub
Function GetArray(filteredRng As Range) As Variant
Dim calculation As XlCalculation
ApplicationBoost True, calculation '<--| boost application "up"
With filteredRng
Worksheets.Add
.Copy Range("A1")
GetArray = ActiveSheet.UsedRange '<--| fill returned array
Application.DisplayAlerts = False '<--| disable alerts for what strictly needed
ActiveSheet.Delete
Application.DisplayAlerts = True '<--| enable alerts back
End With
ApplicationBoost False, calculation '<--| boost application "back"
End Function
Sub ApplicationBoost(boost As Boolean, calculation As XlCalculation)
With Application
If boost Then
calculation = .calculation '<--| retrieve current calculation setting
.calculation = xlCalculationManual '<--| turn calculation off
Else
.calculation = calculation '<--| restore current calculation setting
End If
.ScreenUpdating = Not boost
.EnableEvents = Not boost
End With
End Sub
as you can see, I refactored your code and split in more little bits you can more easily handle and both enhance and maintain your code
In LibreOffice Basic sub I use a bunch of uno properties in an array. Which is the simplest Unostructure or UnoService that I must "embed" them, in order to use the getByName "function"?
Example:
dim props(1) as new com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
I want to be able to use something like:
b = props.getByName("blahblah2").Value
or something like (assuming I "assigned" them in a structure-like-object called "somestruct") :
b = somestruct.getprops.getByName("blahblah2").Value
As I understand that this can be done by creating a "UnoService" which supports the getByName and then, somehow, assigning these props to this service
Which is the "lightest" such service?
(I mean the service that uses less resources)
Thanks in advance.
Really supporting the interface XNameAccess is not as easy. The services which implement this interface are supposed using this interface for existing named properties, not for own created ones.
But you can use the service EnumerableMap to achieve what you probably want.
Example:
sub testEnumerableMap
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
oEnumerableMap.put("blahblah1", "blahblah1Value")
oEnumerableMap.put("blahblah2", 3000)
oEnumerableMap.put("blahblah3", 1234.67)
msgbox oEnumerableMap.get("blahblah1")
msgbox oEnumerableMap.get("blahblah2")
msgbox oEnumerableMap.get("blahblah3")
'msgbox oEnumerableMap.get("blahblah4") 'will throw error
msgbox oEnumerableMap.containsKey("blahblah2")
msgbox oEnumerableMap.containsValue(3000)
if oEnumerableMap.containsKey("blahblah4") then
msgbox oEnumerableMap.get("blahblah4")
end if
end sub
But starbasic with option Compatible is also able supporting Class programming like VBA does.
Example:
Create a module named myPropertySet. Therein put the following code:
option Compatible
option ClassModule
private aPropertyValues() as com.sun.star.beans.PropertyValue
public sub setProperty(oProp as com.sun.star.beans.PropertyValue)
bUpdated = false
for each oPropPresent in aPropertyValues
if oPropPresent.Name = oProp.Name then
oPropPresent.Value = oProp.Value
bUpdated = true
exit for
end if
next
if not bUpdated then
iIndex = ubound(aPropertyValues) + 1
redim preserve aPropertyValues(iIndex)
aPropertyValues(iIndex) = oProp
end if
end sub
public function getPropertyValue(sName as string) as variant
getPropertyValue = "N/A"
for each oProp in aPropertyValues
if oProp.Name = sName then
getPropertyValue = oProp.Value
exit for
end if
next
end function
Then within a standard module:
sub testClass
oPropertySet = new myPropertySet
dim prop as new com.sun.star.beans.PropertyValue
prop.Name = "blahblah1"
prop.Value = "blahblah1Value"
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 3000
oPropertySet.setProperty(prop)
prop.Name = "blahblah3"
prop.Value = 1234.56
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 8888
oPropertySet.setProperty(prop)
msgbox oPropertySet.getPropertyValue("blahblah1")
msgbox oPropertySet.getPropertyValue("blahblah2")
msgbox oPropertySet.getPropertyValue("blahblah3")
msgbox oPropertySet.getPropertyValue("blahblah4")
end sub
LibreOffice Basic supports the vb6 Collection type.
Dim coll As New Collection
coll.Add("blahblah1Value", "blahblah1")
coll.Add(3000, "blahblah2")
MsgBox(coll("blahblah1"))
Arrays of property values are the only thing that will work for certain UNO interfaces such as dispatcher calls. If you simply need a better way to deal with arrays of property values, then use a helper function.
Sub DisplayMyPropertyValue
Dim props(0 To 1) As New com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
MsgBox(GetPropertyByName(props, "blahblah1"))
End Sub
Function GetPropertyByName(props As Array, propname As String)
For Each prop In props
If prop.Name = propname Then
GetPropertyByName = prop.Value
Exit Function
End If
Next
GetPropertyByName = ""
End Function
XNameAccess is used for UNO containers such as Calc sheets. Normally these containers are obtained from the UNO interface, not created.
oSheet = ThisComponent.Sheets.getByName("Sheet1")
May UNO objects support the XPropertySet interface. Normally these are also obtained from the UNO interface, not created.
paraStyleName = cellcursor.getPropertyValue("ParaStyleName")
It may be possible to create a new class in Java that implements XPropertySet. However, Basic uses helper functions instead of class methods.
I think the serviceEnumerableMap is the answer (so far). Creating the values and searching them was much faster then creating props in a dynamic array and searching them with a for loop in basic.
(I do not "dare" to use "option Compatible", although I was a big fun of VB6 and VBA, because of the problems in code that maybe arise).
I used this code to test time in a form:
SUB testlala(Event)
TESTPROPS(Event)
' TESTENUM(Event)
MSGBOX "END OF TEST"
END SUB
SUB TESTENUM(Event)
DIM xcounter AS LONG
'b = now()
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
FOR xcounter= 0 TO 10000
oEnumerableMap.put("pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g =oEnumerableMap.get("pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
SUB TESTPROPS(Event)
DIM props()
DIM xcounter AS LONG
'b = now()
FOR xcounter= 0 TO 10000
AppendProperty(props,"pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g = GetValueFromName(props,"pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
REM FROM Andrew Pitonyak's OpenOffice Macro Information ------------------
Sub AppendToArray(oData(), ByVal x)
Dim iUB As Integer 'The upper bound of the array.
Dim iLB As Integer 'The lower bound of the array.
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Sub
Function CreateProperty(sName$, oValue) As com.sun.star.beans.PropertyValue
Dim oProperty As New com.sun.star.beans.PropertyValue
oProperty.Name = sName
oProperty.Value = oValue
CreateProperty() = oProperty
End Function
Sub AppendProperty(oProperties(), sName As String, ByVal oValue)
AppendToArray(oProperties(), CreateProperty(sName, oValue))
End Sub
I'm trying to write a lottery application and have written out all the code. Everything seems to be fine except the part where it's supposed to show the winning numbers and the user's numbers. When the ResultsForm pops up, all the labels are blank instead of having the numbers filled in. Any help would be greatly appreciated. I will include the code for the MainForm, the ResultsForm and the Module I used.
Public Class MainForm
Dim rand As New Random
Private Sub MainForm_Load(ByVal sender As System.Object, ByVal e As System.EventArgs)
GenerateNewLotteryNumbers()
End Sub
Private Sub btnCheckNumbers_Click(sender As Object, e As EventArgs) Handles btnCheckNumbers.Click
If ValidateUserPicks() Then
DisplayResults()
End If
End Sub
Private Sub btnPlayAgain_Click(sender As Object, e As EventArgs) Handles btnPlayAgain.Click
GenerateNewLotteryNumbers()
Reset()
End Sub
Private Sub btnExit_Click(sender As Object, e As EventArgs) Handles btnExit.Click
Me.Close()
End Sub
Sub GenerateNewLotteryNumbers()
For intCount = 0 To g_intUPPER_SUB
g_intNumbers(intCount) = rand.Next(10)
Next
End Sub
Sub Reset()
txtDigit1.Clear()
txtDigit2.Clear()
txtDigit3.Clear()
txtDigit4.Clear()
txtDigit5.Clear()
txtDigit1.Focus()
End Sub
Sub DisplayResults()
Dim frmResults As New ResultsForm
frmResults.ShowDialog()
End Sub
Function ValidateUserPicks() As Boolean
Dim blnIsValid As Boolean = False
If Integer.TryParse(txtDigit1.Text, g_intUserPicks(0)) And
g_intUserPicks(0) >= 0 And g_intUserPicks(0) <= 9 Then
If Integer.TryParse(txtDigit2.Text, g_intUserPicks(1)) And
g_intUserPicks(1) >= 0 And g_intUserPicks(1) <= 9 Then
If Integer.TryParse(txtDigit3.Text, g_intUserPicks(2)) And
g_intUserPicks(2) >= 0 And g_intUserPicks(2) <= 9 Then
If Integer.TryParse(txtDigit4.Text, g_intUserPicks(3)) And
g_intUserPicks(3) >= 0 And g_intUserPicks(3) <= 9 Then
If Integer.TryParse(txtDigit5.Text, g_intUserPicks(4)) And
g_intUserPicks(4) >= 0 And g_intUserPicks(4) <= 9 Then
End If
blnIsValid = True
Else
MessageBox.Show("Digit 5: Enter a number between 0 and 9.")
txtDigit5.Focus()
txtDigit5.SelectAll()
End If
Else
MessageBox.Show("Digit 4: Enter a number between 0 and 9.")
txtDigit4.Focus()
txtDigit5.SelectAll()
End If
Else
MessageBox.Show("Digit 3: Enter a number between 0 and 9.")
txtDigit3.Focus()
txtDigit3.SelectAll()
End If
Else
MessageBox.Show("Digit 2: Enter a number between 0 and 9.")
txtDigit2.Focus()
txtDigit2.SelectAll()
End If
Return blnIsValid
End Function
End Class
ResultsForm:
Public Class ResultsForm
Private Sub ResultsForm_Load(ByVal sender As System.Object, ByVal e As System.EventArgs)
DisplayLotteryNumbers()
ShowResults()
End Sub
Private Sub btnOk_Click(sender As Object, e As EventArgs) Handles btnOk.Click
Me.Close()
End Sub
Sub DisplayLotteryNumbers()
lblWinningNumber1.Text = g_intNumbers(0).ToString
lblWinningNumber2.Text = g_intNumbers(1).ToString
lblWinningNumber3.Text = g_intNumbers(2).ToString
lblWinningNumber4.Text = g_intNumbers(3).ToString
lblWinningNumber5.Text = g_intNumbers(4).ToString
lblYourNumber1.Text = g_intNumbers(0).ToString
lblYourNumber2.Text = g_intNumbers(1).ToString
lblYourNumber3.Text = g_intNumbers(2).ToString
lblYourNumber4.Text = g_intNumbers(3).ToString
lblYourNumber5.Text = g_intNumbers(4).ToString
End Sub
Sub DisplayWinnerForm()
Dim frmWinner As New WinnerForm
frmWinner.ShowDialog()
End Sub
Sub ShowResults()
Select Case MatchingDigits()
Case 1
lblResults.Text = "One Matching Digit."
Case 2
lblResults.Text = "Two Matching Digits."
Case 3
lblResults.Text = "Three Matching Digits."
Case 4
lblResults.Text = "Four Matching Digits."
Case 5
lblResults.Text = "All Digits Match!"
DisplayWinnerForm()
Case Else
lblResults.Text = "No Matching Digits."
End Select
End Sub
Function MatchingDigits() As Integer
Dim numMatches As Integer
For intCount = 0 To g_intUPPER_SUB
If g_intNumbers(intCount) = g_intUserPicks(intCount) Then
numMatches += 1
End If
Next
Return numMatches
End Function
End Class
Module:
Module LotteryModule
Public Const g_intUPPER_SUB As Integer = 4
Public g_intNumbers(g_intUPPER_SUB) As Integer
Public g_intUserPicks(g_intUPPER_SUB) As Integer
End Module
Access 2010: I have a table that includes 3 Boolean fields - call them Field_A, Field_B, and Field_C.
On the data entry form, a user should be able to check (make the value TRUE) any one of those options, but only one option can be TRUE at any time. If Field_B is already true and the user wants to change it so Field_C is the option selected to be TRUE, he should first have to unselect Field_B (reset it to FALSE) before he can check the box on the form for Field_C.
So I need some validation code for each of these fields which, if the user tries to set one field to TRUE, checks the status of the other two fields. If both other fields are currently FALSE, it allows the current field to be changed to TRUE. But if either of the other fields is currently TRUE, it should create a popup message saying there's already another selection and the other field must first be changed to FALSE before he can proceed.
I tried this using the numerical values for the Yes/No option, setting a conditional validation that required the sum of the other two values to be zero before allowing the field of interest (e.g. Field_A) to be changed to TRUE (value = -1) (just something like ([Field_B] + [Field_C]) =0, but I kept getting syntax errors. I'm new enough to this that I don't know if it really is just a simple syntax problem, or if a completely different approach is needed.
Last piece of info-- it's acceptable to have all 3 fields set to FALSE, so I don't want something that forces one of them to become TRUE if another is changed back from TRUE to FALSE.
You have two acceptable combinations for those 3 check boxes:
all are False (unchecked)
only one can be True (checked)
So that means the sum of those check box values must be either 0 or -1.
? False + False + False
0
? False + False + True
-1
You can add a function in the form's code module ...
Private Function checkBoxProblem() As Boolean
Dim blnReturn As Boolean
Dim intSum As Integer
Dim strPrompt As String
intSum = Nz(Me.Field_A, 0) + Nz(Me.Field_B, 0) + Nz(Me.Field_C, 0)
If Not (intSum = 0 Or intSum = -1) Then
strPrompt = "only one box can be checked"
MsgBox strPrompt
blnReturn = True
Else
blnReturn = False
End If
checkBoxProblem = blnReturn
End Function
Then call the function from the before update events of each of those 3 check boxes.
Private Sub Field_A_BeforeUpdate(Cancel As Integer)
Cancel = checkBoxProblem
End Sub
Private Sub Field_B_BeforeUpdate(Cancel As Integer)
Cancel = checkBoxProblem
End Sub
Private Sub Field_C_BeforeUpdate(Cancel As Integer)
Cancel = checkBoxProblem
End Sub
A bit of code behind your data-entry form should do the trick. Try something along these lines:
Option Compare Database
Option Explicit
Private Sub Field_A_BeforeUpdate(Cancel As Integer)
Const ThisField = "Field_A"
If Me.Field_A.Value Then
If Me.Field_B.Value Then
ShowMyMessage "Field_B", ThisField
Cancel = True
ElseIf Me.Field_C.Value Then
ShowMyMessage "Field_C", ThisField
Cancel = True
End If
End If
End Sub
Private Sub Field_B_BeforeUpdate(Cancel As Integer)
Const ThisField = "Field_B"
If Me.Field_B.Value Then
If Me.Field_A.Value Then
ShowMyMessage "Field_A", ThisField
Cancel = True
ElseIf Me.Field_C.Value Then
ShowMyMessage "Field_C", ThisField
Cancel = True
End If
End If
End Sub
Private Sub Field_C_BeforeUpdate(Cancel As Integer)
Const ThisField = "Field_C"
If Me.Field_C.Value Then
If Me.Field_B.Value Then
ShowMyMessage "Field_B", ThisField
Cancel = True
ElseIf Me.Field_A.Value Then
ShowMyMessage "Field_A", ThisField
Cancel = True
End If
End If
End Sub
Private Sub ShowMyMessage(OtherField As String, CurrentField As String)
MsgBox _
"You must un-select """ & OtherField & """" & _
" before you can select """ & CurrentField & """", _
vbExclamation, _
"Mutually exclusive options conflict"
End Sub