I'm trying hard to solve that issue without any luck :(
Here is my code :
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private frm As Form
Public Sub GenerateForm()
Set frm = New myForm
With frm
.Width = 4000
.Height = 3000
.Caption = "Message"
End With
frm.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
frm.Show vbModal
Sleep 3000
Unload Me
Set frm = Nothing
End Sub
Private Sub Command1_Click()
GenerateForm
End Sub
I want to close the newly created form automatically after 3 seconds.
Windows opened in modal mode wait for user input, so the statements after
frm.Show vbModal
will not execute.
.
You have two solutions:
a) remove vbModal
b) add Timer on myForm and set Interval to 1000 (mean 1 second), next add this code in Timer event:
Private Sub Timer1_Timer()
Static sec As Integer
sec = sec + 1
If sec >= 3 Then
Timer1.Enabled = False
Unload Me
End If
End Sub
Last, you should use
Unload frm
since Unload Me is wrong.
You could use the timer like this, once it reaches 3 seconds (3000) it will close the form and open another one.
Private Sub Timer1_Timer()
If Timer1.Interval = 3000 Then
frm_Menu.Show
Unload frmSplash
Timer1.Enabled = False
End If
End Sub
Related
I have the following code to log off Access users automatically.
Most work will be completed in 5 minutes or less, but I would like to add a manual reset button below the counter that will restart the timer if needed.
I want to force the end user to manually start the timer over if needed.
Option Compare Database
Dim TimeCount As Long
Private Sub Form_Open(Cancel As Integer)
Me.TimerInterval = 1000
End Sub
Private Sub Form_Timer()
TimeCount = TimeCount + 1
Me.txtCounter.Value = 1200 - TimeCount
If TimeCount = 1201 Then
DoCmd.Quit acQuitSaveAll
End If
End Sub
How can I accomplish this task?
I have code to quit Access if the user is inactive. I know this isn't what you're looking for but it may help you out...if not, good luck!
Create a form called DetectIdleTime. Have it open when the database is loaded with the Window Mode set to Hidden.
On the OnTimer event in the DetectIdletime properties...
Sub Form_Timer()
Const IDLEMINUTES = 5
Static PrevControlName As String
Static PrevFormName As String
Static ExpiredTime
Dim ActiveFormName As String
Dim ActiveControlName As String
Dim ExpiredMinutes
On Error Resume Next
ActiveFormName = Screen.ActiveForm.Name
If Err Then
ActiveFormName = "No Active Form"
Err = 0
End If
ActiveControlName = Screen.ActiveControl.Name
If Err Then
ActiveControlName = "No Active Control"
Err = 0
End If
If (PrevControlName = "") Or (PrevFormName = "") _
Or (ActiveFormName <> PrevFormName) _
Or (ActiveControlName <> PrevControlName) Then
PrevControlName = ActiveControlName
PrevFormName = ActiveFormName
ExpiredTime = 0
Else
ExpiredTime = ExpiredTime + Me.TimerInterval
End If
ExpiredMinutes = (ExpiredTime / 1000) / 60
If ExpiredMinutes >= IDLEMINUTES Then
ExpiredTime = 0
IdleTimeDetected ExpiredMinutes
End If
End Sub
Set the Timer Interval event on the DetectIdleTime form to 1000
Now Access will close if the user doesn't move the mouse...
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've got two userforms - "PhaseHome" and "ModifyPhases".
I must go through the "PhaseHome" form in order to get to the "ModifyPhases" form. Once on the "ModifyPhases" form, I utilize a combo-box and button for the user to create a new & custom named userform that has a few controls. The code looks like this:
Please Note:
"Phasename" is the custom name the user entered in the earlier combo-box.
Sub New_form()
Dim Newphase As VBComponent
Dim ItemBox As MSForms.ComboBox
Dim AddItem As MSForms.CommandButton
Sheet1.Activate
'Creating the new form
Set Newphase = ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
With Newphase
.Properties("Height") = 250
.Properties("Width") = 350
.Properties("Caption") = Phasename
.Name = Phasename
End With
'Inserting the combobox into the dynamically created form
Set ItemBox = Newphase.Designer.Controls.Add("Forms.ComboBox.1")
With ItemBox
.Name = Phasename & "Box"
.Top = 60
.Left = 12
.Width = 140
.Height = 80
.Font.Size = 8
.Font.Name = "Tahoma"
.BorderStyle = fmBorderStyleOpaque
.SpecialEffect = fmSpecialEffectSunken
End With
'Inserting buttons into the dynamically created form
Set AddItem = Newphase.Designer.Controls.Add("Forms.commandbutton.1")
With AddItem
.Name = "cmd_1"
.Caption = "Add Line Item"
.Top = 5
.Left = 200
.Width = 110
.Height = 35
.Font.Size = 8
.Font.Name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
With that done and the userform created; I now want to add a button to the "PhaseHome" form that allows the user to get to the form we just created.
Sheet1.Select
Range("D5").Value = Range("D5").Value + 45
'Add button to Phase Home Form
Dim homeform_button As MSForms.CommandButton
Dim ufObj As UserForm
Set ufObj = ActiveWorkbook.VBProject.VBComponents("Phasehome").Designer
With ufObj
Set homeform_button = .Controls.Add("Forms.CommandButton.1")
With homeform_button
.Name = "cmd" + Phasename
.Caption = Phasename
.Top = Range("D5").Value
.Left = 45
.Width = 78
.Height = 36
.Font.Size = 8
.Font.Name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
End With
'Making sure we don't overwrite previously existing code when we insert this into PhaseHome
Dim linestart As Integer
linestart = Range("D8").Value
ThisWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "Private Sub cmd" & Phasename & "_Click()"
linestart = linestart + 1
ThisWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "Unload Me"
linestart = linestart + 1
ThisWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "Sheet2.Activate"
linestart = linestart + 1
ThisWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "" & Phasename & ".Show"
linestart = linestart + 1
ThisWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "End Sub"
linestart = linestart + 1
Range("D8").Value = linestart
Now the good news is that this code works!.... As long as I run it from the "ModifyPhases" form directly. Once, for the very first time in a session, that I open and close the "PhaseHome" form I start receiving an error 91 (Object variable or With block Variable not set) that points to the
Set homeform_button = .Controls.Add("Forms.CommandButton.1")
line everytime I attempt to run the macro again.
Things I've tried:
I've made sure that the "PhaseHome" form is unloaded. The button that goes between the userforms always includes an Unload Me, i've also tried unloading "PhaseHome" directly within the macro itself, and also used variables tied to "PhaseHome"'s terminate and Initialize functions to ensure it is unloaded without referencing it directly.
After noticing that refreshing the workbook fixed the issue, I discovered some code online (From a source I regretfully forget) that closes and reopens the workbook each time the "ModifyPhases" form is launched which fixes the issue.
Sub CloseMe()
Application.OnTime Now + TimeValue("00:00:02"), "OpenMe"
ThisWorkbook.Close True
End Sub
Sub OpenMe()
ModifyPhases.Show
End Sub
I don't know why the code tags aren't working right here.
This works but... causes corruption in the workbook and also seems rather unnecessary. Do you fellows have any theories on why this could be occurring? Thank you!
-Mano
Make no mistake about it: Modifying controls at run-time, and especially adding forms at run-time, is a high-level VBA exercise, and I think that it simply is beyond what you're currently capable of. (Please don't take this the wrong way, I don't mean to condescend)
I need a new custom button for each custom form added to "PhaseHome".
I'm gathering that this is the hang-up, and also source of error. So...
Is there an easier way??
Let's ditch that idea altogether!
Use a different control type that is more amenable to modifications at run-time. Buttons are tricky because they require each their own _Click event handler. Instead of adding buttons for each phase, just add a new item to a ComboBox control, and leverage its _Change (or some other) event as a method of user-input.
IOW, instead of expecting the user to press a button that displays a form, just let them select the form from a ComboBox!
Then, invoking that ComboBox's _Change event, refer back to the dict/collection of properties, and display the "Phaseform" object where you can modify it's controls at runtime, as needed.
Now you have a relatively generic form that will be used for any possible phase.
The List property of the Combobox is itself dynamic, and has a _Change event handler which you can use!
Private Sub cbox_PhaseNames_Change()
MsgBox Me.Value 'Show the value which is selected, for debugging
'Modify the Newphase userform. There is only one form, and its properties
' will be modified based on the selection from the cBox_Phasenames control
Newphase.Caption = Me.Value
'If you need to change other controls, you can probably do that here, too
End Sub
Example
I created some crude example (download from Google Drive if you'd like), using only two user forms. Phasehome implements described above, and the Phaseform can be modified (e.g., it's Caption) based on the selection in the ComboBox on PhaseHome.
NOTE: You're using 3 forms at least, please make note that I'm only using 2, what my example does for Pagehome really is probably more applicable to your ModifyPhases form, so take note of that and modify accordingly.
This would be how I set up the code for Phasehome:
Option Explicit
Private Sub cbox_Phasenames_Change()
Dim val$, bFound As Boolean
Dim i As Long
'crude validation:
val = Me.cbox_Phasenames.Value
For i = 0 To Me.cbox_Phasenames.ListCount - 1
If val = Me.cbox_Phasenames.List(i) Then
bFound = True
Exit For
End If
Next
If Not bFound Then Exit Sub 'Avoid errors
'Modify the PhaseForm:
With phaseForm
.Caption = val
.Show
End With
End Sub
Private Sub CommandButton1_Click()
'Very simple example, allows duplicates, which you probably want to avoid
Me.cbox_Phasenames.AddItem Me.TextBox1.Value
End Sub
And here is the code for Phaseform, I've commented a few items, but using the Initialize event to assign the properties you've set up:
Option Explicit
Private Sub UserForm_Initialize()
Me.Height = 250
Me.Width = 350
'Me.Caption = "" '## This is set in the calling procedure
With Me.ComboBox1
.Top = 60
.Left = 12
.Width = 140
.Height = 80
.Font.Size = 8
.Font.Name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
With Me.CommandButton1
'### There is no need to assign a dynamic Name property to this control
'.Name = "cmd" + Phasename
.Caption = ""
.Top = Range("D5").Value
.Left = 45
.Width = 78
.Height = 36
.Font.Size = 8
.Font.Name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
End Sub
Private Sub ComboBox1_Change()
MsgBox "Does something..."
End Sub
Note: If there are additional properties that you need to persist during runtime can be done via Static variables and using possibly Collection or Dictionary object to assist with organizing what's needed. Keep the "list" of phases in an Array, and keep their relevant properties in a dict/collection, etc. If absolutely necessary you can store some things in a hidden worksheet, or in a Name in the workbook, or in CustomXMLPart, etc. -- there's lots of ways you can conceivably persist metadata beyond the user session, so that the changes will be available tomorrow, next week, etc.
So I discovered the issue with my macro. Once my code had finished building my custom userforms at Design time - it was not exiting from design mode on the custom form when I attempted to switch it over to the design mode on the "PhaseHome" userform to edit my buttons resulting in the Error 91. I found that by manually entering design mode (Using code I found here from Mr. Peter Thornton) and then manually exiting design mode using a time delay macro (Shown below) right before my code began placing my button onto the "Phasehome" form worked every time without error.
I used the time delay macro because entering design mode ends macro execution.
I discovered this by using the .hasopendesigner property (here) to test my custom form variable right before I tried to enter design mode for my "Phasehome" userform to add my button and found that it was still open. Just manually exiting design mode did not seem to change this - which is the part I suspect is a bug. This is why I manually entered then manually exited design mode.
I'm not certain but i'm leaning towards this being a bug within VBA Userforms as it has aggressively resisted any other form of troubleshooting besides a workbook reload as described previously.
Here is my code after I have completed the design of my custom userform (Please note selections are done because I wanted to control what the user saw during this process and are mostly unnecessary):
Sheet1.Select
Dim linestart As Integer 'Making sure we don't overwrite our code when we insert it into PhaseHome
linestart = Range("D8").Value
ActiveWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "Private Sub cmd" & Phasename & "_Click()"
linestart = linestart + 1
ActiveWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "Unload Me"
linestart = linestart + 1
ActiveWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "Sheet2.Activate"
linestart = linestart + 1
ActiveWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "" & Phasename & ".Show"
linestart = linestart + 1
ActiveWorkbook.VBProject.VBComponents("PhaseHome").CodeModule.InsertLines linestart, "End Sub"
linestart = linestart + 1
Range("D8").Value = linestart
Range("D5").Value = Range("D5").Value + 45
Range("D10").Value = Phasename
Sheet2.Select
Range("A1").Select
Call Design_mode_on
End Sub
TIME DELAY MACRO:
Sub Design_mode_on()
Application.OnTime Now + TimeValue("00:00:01"), "Design_mode_off"
EnterExitDesignMode True 'Enter Design Mode
End Sub
Sub Design_mode_off()
EnterExitDesignMode False 'Exit Design Mode
Call second_newphase
End Sub
Sub EnterExitDesignMode(bEnter As Boolean)
Dim cbrs As CommandBars
Const sMsoName As String = "DesignMode"
Set cbrs = Application.CommandBars
If Not cbrs Is Nothing Then
If cbrs.GetEnabledMso(sMsoName) Then
If bEnter <> cbrs.GetPressedMso(sMsoName) Then
cbrs.ExecuteMso sMsoName
Stop
End If
End If
End If
End Sub
\TIME DELAY MACRO:
Sub second_newphase() 'Divided this module in 2 due to some weird form interactions
Sheet1.Select
Phasename = Range("D10").Value
Range("D10").Clear
Dim homeform_button As MSForms.CommandButton
Dim ufObj As UserForm
EnterExitDesignMode False 'Exit again just for good measure hehe
Set ufObj = ActiveWorkbook.VBProject.VBComponents("Phasehome").Designer
With ufObj
Set homeform_button = .Controls.Add("Forms.CommandButton.1")
With homeform_button
.Name = "cmd" + Phasename
.Caption = Phasename
.Top = Range("D5").Value
.Left = 45
.Width = 78
.Height = 36
.Font.Size = 8
.Font.Name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
End With
Sheet2.Select
Range("A1").Select
End Sub
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
Here's what I want to do and I have a problem.
I want to restrict what an user types in certain textboxes. I want to leave him type only numbers but after 3 numbers to add a ";". (eg. 007;123;003;005;).
The problem is that my textbox Controls are generated through a bunch of code. So I can't or I don't know how to set an action to these controls.
The code I'm using to generate the controls is:
Set cControl = form.Controls("io" & masina).Add(
"Forms.Label.1", "lreper" & l & pagina, True)
With cControl
.Caption = "Reper"
.Width = 35
.Height = 9
.Top = 25 + k
.Left = 5
End With
Any ideas?
Thanks a lot!
You can use the key press event to restrict only numbers and the ";". Along with check conditions.
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
'// Numbers 0-9
Case 48 To 57
If Len(TextBox1.Text) = 3 And Right(TextBox1.Text, 3) Like "###" Then
KeyAscii = 0
GoTo DisplayFormatError
End If
'// Key ;
Case 59
If Len(TextBox1.Text) < 3 Or Not Right(TextBox1.Text, 3) Like "###" Then
KeyAscii = 0
GoTo DisplayFormatError
End If
Case Else
KeyAscii = 0
GoTo DisplayFormatError
End Select
Exit Sub
DisplayFormatError:
MsgBox "Please enter serial number in the format '000;000;000'", vbInformation, "Alert!"
End Sub
A better way would be to use a regular expression instead of the like method.
If you need help adding the events for your controls at runtime have a look at:
Add controls and events to form at runtime
EDIT (REQUEST BY TIAGO)
Dynamic creation of Userform and Textbox with keypress event. Uses modified example of above link. Credit to original author.
Add reference - Under Available References, click "Microsoft Visual Basic for Applications Extensibility" and click OK.
Option Explicit
Sub MakeForm()
Dim TempForm As Object ' VBComponent
Dim FormName As String
Dim NewTextBox As MSForms.TextBox
Dim TextLocation As Integer
Dim TextBoxName As String
'** Additional variable
Dim X As Integer
'Locks Excel spreadsheet and speeds up form processing
Application.VBE.MainWindow.Visible = False
Application.ScreenUpdating = False
'Create the UserForm
Set TempForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
'Set Properties for TempForm
With TempForm
.Properties("Caption") = "Temporary Form"
.Properties("Width") = 200
.Properties("Height") = 100
End With
FormName = TempForm.Name
TextBoxName = "MyTextBox"
'Add a CommandButton
Set NewTextBox = TempForm.Designer.Controls _
.Add("Forms.TextBox.1")
With NewTextBox
.Name = TextBoxName
.Left = 60
.Top = 40
End With
'Add an event-hander sub for the CommandButton
With TempForm.CodeModule
'** Add/change next 5 lines
'This code adds the commands/event handlers to the form
X = .CountOfLines
.InsertLines X + 1, "Private Sub " & TextBoxName & "_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)"
.InsertLines X + 2, "KeyAscii = KeyPress(" & TextBoxName & ".Text, KeyAscii)"
.InsertLines X + 3, "End Sub"
End With
'Show the form
VBA.UserForms.Add(FormName).Show
'Delete the form
ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=TempForm
End Sub
Public Function KeyPress(ByVal strText As String, ByVal KeyAscii As Integer) As Integer
Select Case KeyAscii
'// Numbers 0-9
Case 48 To 57
If Len(strText) = 3 And Right(strText, 3) Like "###" Then
GoTo DisplayFormatError
End If
'// Key ;
Case 59
If Len(strText) < 3 Or Not Right(strText, 3) Like "###" Then
GoTo DisplayFormatError
End If
Case Else
GoTo DisplayFormatError
End Select
KeyPress = KeyAscii
Exit Function
DisplayFormatError:
KeyPress = 0
MsgBox "Please enter serial number in the format '000;000;000'", vbInformation, "Alert!"
End Function
ANOTHER METHOD (Using an event handler class)
Code in Userform:
Private colEventHandlers As Collection
Private Sub UserForm_Initialize()
'// New collection of events
Set colEventHandlers = New Collection
'// Add dynamic textbox
Set tbxNewTextbox = Me.Controls.Add("Forms.TextBox.1", "MyNewTextbox", True)
With tbxNewTextbox
.Top = 25
.Left = 5
End With
'// Add the event handler
Dim objEventHandler As TextboxEventHandler
Set objEventHandler = New TextboxEventHandler
Set objEventHandler.TextBox = tbxNewTextbox
colEventHandlers.Add objEventHandler
End Sub
And add a class module and rename it too "TextBoxEventHandler", then add the following code:
Private WithEvents tbxWithEvent As MSForms.TextBox
Public Property Set TextBox(ByVal oTextBox As MSForms.TextBox)
Set tbxWithEvent = oTextBox
End Property
Private Sub tbxWithEvent_Change()
End Sub
Private Sub tbxWithEvent_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
'// Numbers 0-9
Case 48 To 57
If Len(tbxWithEvent.Text) = 3 And Right(tbxWithEvent.Text, 3) Like "###" Then
GoTo DisplayFormatError
End If
'// Key ;
Case 59
If Len(tbxWithEvent.Text) < 3 Or Not Right(tbxWithEvent.Text, 3) Like "###" Then
GoTo DisplayFormatError
End If
Case Else
GoTo DisplayFormatError
End Select
Exit Sub
DisplayFormatError:
KeyAscii = 0
MsgBox "Please enter serial number in the format '000;000;000'", vbInformation, "Alert!"
End Sub
Try Dataannotations / metadata
More here: http://msdn.microsoft.com/en-us/library/ee256141.aspx
AFAIK and if i understood well, there is no way to handle this before user input.
Yet, you can use the TextBox_Exit event to format it afterwards. You can adapt this sample of code.
Although I'd never use dynamic controls unless strictly required, I got puzzled by this question... so I'm thinking of it as a challenge. :-)
Googled around and most answers falls into the same solution, however most of them comes with a 'I couldn't make it work' comment as well, including this one here in SO Assign on-click VBA function to a dynamically created button on Excel Userform.
Here's the code I built... which obviously does not work, otherwise I'd say it could be a solution. The problem on it is that the keypress method it creates dynamically is not called when should be. To test it, just paste the code into a VBA form named 'myForm'.
I kept the TextBox1_KeyPress only for testing purposes, to prove the usability of the text field validator (I'm sorry #Readfidy, your code didn't work for me as expected. I was able to add more than 3 numbers in a row).
In case anyone else is interested in making this code works... I'd be happy to thank ;-)
Option Explicit
Private Sub UserForm_Activate()
Dim sTextBoxName As String
Dim cControl As MSForms.TextBox
Dim sMetaFunction As String
Dim CodeModule
sTextBoxName = "lreper"
Set cControl = myForm.Controls.Add("Forms.TextBox.1", sTextBoxName, True)
With cControl
.Top = 25
.Left = 5
End With
sMetaFunction = "Private Sub " & sTextBoxName & "_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)" & vbCrLf & _
vbCrLf & _
vbTab & "Set KeyAscii = EvaluateText(myForm.Controls(" & sTextBoxName & "), KeyAscii)" & vbCrLf & _
vbCrLf & _
"End Sub"
Set CodeModule = ActiveWorkbook.VBProject.VBComponents.VBE.ActiveCodePane.CodeModule
CodeModule.InsertLines 60, sMetaFunction
End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Set KeyAscii = EvaluateText(myForm.Controls("TextBox1"), KeyAscii)
End Sub
Private Function EvaluateText(ByRef oTextBox As MSForms.TextBox, ByVal KeyAscii As MSForms.ReturnInteger) As MSForms.ReturnInteger
If ((Len(oTextBox.Text) + 1) / 4 = CInt((Len(oTextBox.Text) + 1) / 4)) Then
If KeyAscii <> 59 Then KeyAscii = 0
Else
If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End If
If KeyAscii = 0 Then
MsgBox "Please enter serial number in the format '000;000;000'", vbInformation, "Alert!"
End If
End Function
USE THIS CODE : NO CLASS NEEDED !
USERFORM CODE
Private Function QNumber(ByRef oTextBox As MSForms.TextBox, ByVal KeyAscii As MSForms.ReturnInteger) As MSForms.ReturnInteger
On Error Resume Next
Select Case KeyAscii
Case 45 '"-"
If InStr(1, oTextBox.Text, "-") > 0 Or oTextBox.SelStart > 0 Then
KeyAscii = 0
End If
Case 46 '"."
If InStr(1, oTextBox.Text, ".") > 0 Then
KeyAscii = 0
End If
Case 48 To 57 '0-9"
Case Else
KeyAscii = 0
End Select
End Function
TEXTBOX CODE
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Set KeyAscii = QNumber(Me.Controls("TextBox1"), KeyAscii)
End Sub