Read text from .txt by the listbox request - text

I want to make something like this
Example : Something like planer i write things i need to do for specific days and when i choose in a listbox day it show's me what i need to do.
So because it will remember data it need's to be saved on some kind of .txt or database .
I can add/load items from listbox like this
Private Sub Command1_Click()
Open "Listbox.txt" For Output As #1
For i = 0 To list1.ListCount - 1
Print #1, list1.List(i)
Next
Close
End Sub
Private Sub Form_Load()
list1.AddItem "Monday"
list1.AddItem "Tuesday"
list1.AddItem "Wednesday"
list1.AddItem "Thursday"
list1.AddItem "Friday"
list1.AddItem "Saturday"
list1.AddItem "Sunday"
End Sub
But the main problem is text save. How can i save the text from a textbox for a specific day or edit it . So when i click on Monday it show's me the custom text i entered for monday.
Do i need to make a new file for each day in a week like 7 files or there is a easier way ??

It's not necessary to make separate files for each listbox item.
Here's my sample project; I made a couple of changes to your form layout:
When an item is clicked in the list at the left, the text field will provide the text associated with the item. Update the item by typing something into / changing the same field.
Option Explicit
Private FileStr As String, StrArr() As String
Private Sub cmdSave_Click()
Dim I As Long
Open FileStr For Output As #1
For I = 0 To lbxItems.ListCount - 1
Print #1, lbxItems.List(I) & "," & StrArr(I)
Next I
Close #1
End Sub
Private Sub cmdUpdate_Click()
StrArr(lbxItems.ListIndex) = txtDescript
End Sub
Private Sub Form_Load()
Dim I As Long, J As Long
Dim TempStr As String
FileStr = App.Path & "\planner.txt"
Open FileStr For Input As #1
Do Until EOF(1)
Line Input #1, TempStr
J = InStr(TempStr, ",")
lbxItems.AddItem Left$(TempStr, J - 1)
TempStr = Mid$(TempStr, J + 1)
ReDim Preserve StrArr(I)
StrArr(I) = TempStr
I = I + 1
Loop
Close #1
End Sub
Private Sub lbxItems_Click()
txtDescript = StrArr(lbxItems.ListIndex)
End Sub
The code is designed so that it can be used with other items that are inserted into the "planner.txt" file manually. If you do this, make sure that you follow the item name with a comma ( , ).
If you copy and paste the code straight into your form code module as is, make sure to update the control names as necessary.

Related

How to store a variable in a .txt file and use it in multiple workbooks to auto-fill a userform text box

I have created a userform to save and print paperwork with incremented serial numbers on each copy. The userform prompts the user for the next available serial number and how many copies to create. Once the user clicks the "create" button it fills in a cell, saves a new copy, prints the copy, then adds 1 to the serial number before looping. What I want to do is store the final serial number in a .txt file saved in the network folder, and then retrieve that number in another workbook to autofill the serial number text box in the userform. Is this possible? Can a variale be used to autofill a userform text box?
Module to open useform:
Sub start()
'''Retrieve stored serial number to autofill userform'''
WO_BulkCreate.Show
End Sub
Code for userform buttons (nextWOnumber and createAmount comefrom the userform text boxes):
Private Sub Cancel_Click()
Unload WO_BulkCreate
End Sub
Private Sub Create_Click()
'Variables
Dim Amount As Integer 'Number of WOs to be created
Dim WO_Name As String 'WO number
Dim i As Integer 'loop tracker
Dim saveName As String 'New File Name
'initialize variables
Amount = createAmount
i = 0
'Begin loop
Do While i < Amount
'Assemble WO number and filename
WO_Name = "Customer Code-" & nextWOnumber
saveName = WO_Name & " - part number - part description"
'Update WO number Cell
Sheets("WO Charge Sheet").Range("WO") = WO_Name
'Save New Copy
ActiveWorkbook.SaveAs Filename:="C:\filepath\" & saveName
'Set orientation to landscape
Worksheets("WO Charge Sheet").PageSetup.Orientation = xlLandscape
Worksheets("Ops Planning").PageSetup.Orientation = xlLandscape
'Print WO
Sheets(Array("WO Charge Sheet", "Ops Planning")).PrintOut
'Increment WO number
nextWOnumber = nextWOnumber + 1
'Step loop
i = i + 1
'End loop
Loop
'''Store final serial number in text file'''
'Close form
Unload WO_BulkCreate
End Sub
I hope that makes sense. Sorry if this is tmi, this is my first time posting on SO
Bread Doughlas
Something like this could work but you need to be aware of possible contention issues which would require a slightly more complex approach, possible using a "lock" file to ensure only one user can read at a time...
Sub Tester()
Debug.Print NextSequence()
End Sub
Function NextSequence() As String
Const SEQ_FILE As String = "C:\Tester\seq.txt" '<<location of the sequence file
Dim txt As String, seq As Long
With CreateObject("scripting.filesystemobject")
If .fileexists(SEQ_FILE) Then '<< does the file exist ?
txt = Trim(.opentextfile(SEQ_FILE, 1).readall())
If IsNumeric(txt) Then
seq = CLng(txt)
End If
Else
seq = 1 '<< no file yet, start with 1
End If
With .createtextfile(SEQ_FILE)
.writeline seq + 1 '<<write the next sequence
End With
End With
NextSequence = seq
End Function
Here's the way I solved this problem.
Storing the Variable:
'Store next serial number
Dim fileNo As Integer, serialNo As String
fileNo = FreeFile
Open "C:\filepath\nextSerialNumber.txt" For Output As #fileNo
Write #fileNo, serialNo; 'I had to add this semicolon to prevent it from writing a linebreak
'Close file
Close #fileNo
This worked to store my variable, but it did add a comma after it. I was able to find a workaround for the comma in my code for retrieving the variable:
Private Sub UserForm_Initialize()
'Variables
Dim serialNo As String, fileNo As Integer
'Intialize
fileNo = FreeFile
'Read next serial number
Open "C:\filepath\nextSerialNumber.txt" For Input As #fileNo
serialNo = Input$(LOF(fileNo), fileNo)
'Remove Comma
If (Right(serialNo, 1)) = "," Then
serialNo = Left(serialNo, Len(serialNo) - 1)
End If
'Fill Text Boxes
nextSerialNumber.Value = serialNo
'End Read File
Close #fileNo
End Sub
This works great for me, hope it helps ppl in the future.

vba trouble working with cutomizable multiple Listbox with multiple macro

So here's my objective: I need to execute different macros deppending on a multiple choice ListBox. I am a begginner with vba and some tasks get a bit harder for me at the moment.
there's a multiple choice ListBox with 9 options. If you choose the option "Exfoliación", it executes the macro called "macro4". This is fully customizable, so if I choose from the ListBox the option "Exfoliación" and "Estanqueidad", it will execute the macros 4 and 3 (the ones related to them).
I've seen some example surfinf the Internet, but they're about ListBox's working with columns, sheets, and so on. But there weren't much explanations working with macros.
The user selects the options and presses a Submit button in the worksheet called "Botón". the choices from the Listbox are marked with vector(i)=1. With a for loop the choices are read and executes the corresponding macros to those choices with the array a(i) that contains the names of those macros.
Sub Submit()
'Getting selected items in ListBox1
Dim vector(1 To 11) As Integer
Dim i As Integer
Dim a(1 To 9) As String
'Private Sub CommandButton1_Click()
For i = LBound(a) To UBound(a)
vector(i) = 0
Next i
With Sheets("Botón").ListBox1
Select Case (ListBox1.Text)
Case "Tornillo Resorte": vector(1) = 1
Case "Categoría Manguito": vector(2) = 1
Case "Estanqueidad": vector(3) = 1
Case "Exfoliación": vector(4) = 1
Case "Material vaina": vector(5) = 1
Case "Diseño EC": vector(6) = 1
Case "Curva Q vs Enriquecimiento": vector(7) = 1
Case "Curva Criticidad": vector(8) = 1
Case "Curva de carga t. enfriamiento": vector(9) = 1
Case "Condicioón de transporte": vector(10) = 1
Case "ATI": vector(11) = 1
Case ""
MsgBox "nothing selected"
Case Else
MsgBox Me.ListBox1.Text
End Select
Dim MN As String
For i = 1 To N 'Fill the array
a(i) = "macro" & i
Next
MN = "Módulo5" 'Module where i have the worksheet I'm working with
Dim N As Integer
N = 11
For i = LBound(a) To UBound(a)
If vector(i) = 1 Then
Application.Run MN & "." & a(i)
End If
Next i
End Sub
I find trouble with the Select Case (ListBox1.Text) statement.
It doesn't compile and don't know how to call the listBox with Select Case.
thank you in advance for your help :)
Edit: with a new code. Method with selection:
`Private Sub Command Button1_Click() 'This is a button that opens the multilist with the different options. It works correctly
Worksheets("Botón").ListBox1.Clear
ListBox1.Height=200
ListBox1.Width=250
Dim mylist As Variant
mylist=Array("Tornillo Resorte",...,"Condicioón de transporte")
ListBox1.List=mylist
End Sub
Sub Submit() ''here's the macro with the button assigned to execute the selection. This is where I get the problem.
With Sheets("Botón").ListBox1
MN = "Módulo5" 'Module where i have the worksheet I'm working with
For X = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(X) = True Then
Application.Run MN & "." & .ListIndex + 1
Else
MsgBox "No se ha seleccionado ningún filtro"
End If
Next X
End With
End Sub
If you only wanted to select one macro - and assuming the macros are named sequentially macro1 to macrox, then you can just do this:
Sub Submit()
With Sheets("Botón").ListBox1
if .listindex = -1 then
MsgBox "nothing selected"
Else
MN = "Módulo5" 'Module where i have the worksheet I'm working with
Application.Run MN & "." & .listindex +1
End If
End With
End Sub
If you want to do more than one then you need to loop through the .selected array calling the macros sequentially

How do I put the value of check boxes in a textbox when i click a command button?

I'm quite new in using VBA Userforms. I have a series of check boxes and I want to put the value of the ticked checkboxes inside a text box when I click a command button. I have already renamed the check boxes and when I enter a code/formula I'm encountering an error. I hope you can help me with this.
Private Sub CommandButton1_Click()
Call Level1
End Sub
Sub Level1()
Dim n As Long
For n = 26 To 89
'UserForm1.Controls("CheckBox" & n) = False
Next
Dim i As Long, txt As String
For i = 1 To 3
**If UserForm1.Controls("Checkbox" & i) = True Then** (Error Here)
txt = txt & UserForm1.Controls("Checkbox" & i).Caption & ", "
End If
Next
txt = Left(txt, Len(txt) - 2)
'Cells(1, 1) = txt
TextBox1.Value = txt
End Sub
My Userform looks like this.
When I click the Add to QA Form, the values that I ticked should be entered in the textbox
Is there anyway that this can be simplified? I have other check boxes that I need to enter and they are more than 50. Thank you.

Select variable object with counter

Background:
I have a collection of objects (for this example Listbox objects) in a userform using standardized names, I would like to rename them dynamically using a counter cycle.
Problem:
I have not figured a way if what I am asking is even possible, however, I would like to confirm it.
Solution approach:
Nothing so far, like I said (refer to the image above) I need a way to set the values of the objects within the for cycle, something like this:
For CounterItems = 1 To 18 'Hours in Template
ListBox_Time(CounterItems).Value="Dummy" & CounterItems
Next CounterHours
However, I am clueless on how to do so (or if it is achievable).
Question:
Is there any way to use a counter to cast a variable/object?
No, you can't edit the name while the userform is in use, you'll get error 382
What you'd like to do is this
Option Explicit
Sub test()
Dim myForm As UserForm
Set myForm = UserForm1
Dim myCtrl As Control
Dim i As Long
Dim myCount As Long
myCount = 1
For Each myCtrl In myForm.Controls
If TypeName(myCtrl) = "ListBox" Then
myCtrl.Name = "Dummy" & myCount 'error
myCount = myCount + 1
End If
Next
End Sub
But you'll error when you try to write to the name property. You can print the names or set other properties, but this isn't something you can do as far as I know.
For use with ListBox controls on a UserForm
If you want to change only certain ListBox controls by number:
Public Sub ListBoxNameChange()
Dim ctrl As Control
Dim ctrlName As String, ctrlNum As Integer
For Each ctrl In Me.Controls
If TypeName(ctrl) = "ListBox" Then
ctrlName = ctrl.Name
ctrlNum = CInt(Replace(ctrlName, "ListBox_Time", ""))
If ctrlNum > 0 And ctrlNum < 19 Then
ctrl.AddItem "Dummy" & ctrlNum, 0
End If
End If
Next ctrl
End Sub
If you want to change ALL ListBox controls:
Public Sub ListBoxNameChange2()
Dim ctrl As Control
Dim ctrlName As String
For Each ctrl In Me.Controls
If TypeName(ctrl) = "ListBox" Then _
ctrl.AddItem "Dummy" & Replace(ctrl.Name, "ListBox_Time", ""), 0
Next ctrl
End Sub
I treat them like Shapes and test their pre-defined Names:
Sub ShapeRenamer()
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Name = "List Box 6" Then s.Name = "Sixth"
Next s
End Sub
Before:
and after:
You would update this to examine the Shapes in your userform.
You could also do this with an indexing counter.

Formatting MM/DD/YYYY dates in textbox in VBA

I'm looking for a way to automatically format the date in a VBA text box to a MM/DD/YYYY format, and I want it to format as the user is typing it in. For instance, once the user types in the second number, the program will automatically type in a "/". Now, I got this working (as well as the second dash) with the following code:
Private Sub txtBoxBDayHim_Change()
If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
End Sub
Now, this works great when typing. However, when trying to delete, it still enters in the dashes, so its impossible for the user to delete past one of the dashes (deleting a dash results in a length of 2 or 5, and the sub is then run again, adding in another dash). Any suggestions on a better way to do this?
I never suggest using Textboxes or Inputboxes to accept dates. So many things can go wrong. I cannot even suggest using the Calendar Control or the Date Picker as for that you need to register the mscal.ocx or mscomct2.ocx and that is very painful as they are not freely distributable files.
Here is what I recommend. You can use this custom made calendar to accept dates from the user
PROS:
You don't have to worry about user inputting wrong info
You don't have to worry user pasting in the textbox
You don't have to worry about writing any major code
Attractive GUI
Can be easily incorporated in your application
Doesn't use any controls for which you need to reference any libraries like mscal.ocx or mscomct2.ocx
CONS:
Ummm...Ummm... Can't think of any...
HOW TO USE IT (File missing from my dropbox. Please refer to the bottom of the post for an upgraded version of the calendar)
Download the Userform1.frm and Userform1.frx from here.
In your VBA, simply import Userform1.frm as shown in the image below.
Importing the form
RUNNING IT
You can call it in any procedure. For example
Sub Sample()
UserForm1.Show
End Sub
SCREEN SHOTS IN ACTION
NOTE: You may also want to see Taking Calendar to new level
This is the same concept as Siddharth Rout's answer. But I wanted a date picker which could be fully customized so that the look and feel could be tailored to whatever project it's being used in.
You can click this link to download the custom date picker I came up with. Below are some screenshots of the form in action.
To use the date picker, simply import the CalendarForm.frm file into your VBA project. Each of the calendars above can be obtained with one single function call. The result just depends on the arguments you use (all of which are optional), so you can customize it as much or as little as you want.
For example, the most basic calendar on the left can be obtained by the following line of code:
MyDateVariable = CalendarForm.GetDate
That's all there is to it. From there, you just include whichever arguments you want to get the calendar you want. The function call below will generate the green calendar on the right:
MyDateVariable = CalendarForm.GetDate( _
SelectedDate:=Date, _
DateFontSize:=11, _
TodayButton:=True, _
BackgroundColor:=RGB(242, 248, 238), _
HeaderColor:=RGB(84, 130, 53), _
HeaderFontColor:=RGB(255, 255, 255), _
SubHeaderColor:=RGB(226, 239, 218), _
SubHeaderFontColor:=RGB(55, 86, 35), _
DateColor:=RGB(242, 248, 238), _
DateFontColor:=RGB(55, 86, 35), _
SaturdayFontColor:=RGB(55, 86, 35), _
SundayFontColor:=RGB(55, 86, 35), _
TrailingMonthFontColor:=RGB(106, 163, 67), _
DateHoverColor:=RGB(198, 224, 180), _
DateSelectedColor:=RGB(169, 208, 142), _
TodayFontColor:=RGB(255, 0, 0), _
DateSpecialEffect:=fmSpecialEffectRaised)
Here is a small taste of some of the features it includes. All options are fully documented in the userform module itself:
Ease of use. The userform is completely self-contained, and can be imported into any VBA project and used without much, if any additional coding.
Simple, attractive design.
Fully customizable functionality, size, and color scheme
Limit user selection to a specific date range
Choose any day for the first day of the week
Include week numbers, and support for ISO standard
Clicking the month or year label in the header reveals selectable comboboxes
Dates change color when you mouse over them
Add something to track the length and allow you to do "checks" on whether the user is adding or subtracting text. This is currently untested but something similar to this should work (especially if you have a userform).
'add this to your userform or make it a static variable if it is not part of a userform
private oldLength as integer
Private Sub txtBoxBDayHim_Change()
if ( oldlength > txboxbdayhim.textlength ) then
oldlength =txtBoxBDayHim.textlength
exit sub
end if
If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
end if
oldlength =txtBoxBDayHim.textlength
End Sub
I too, one way or another stumbled on the same dilemma, why the heck Excel VBA doesn't have a Date Picker. Thanks to Sid, who made an awesome job to create something for all of us.
Nonetheless, I came to a point where I need to create my own. And I am posting it here since a lot of people I'm sure lands on this post and benefit from it.
What I did was very simple as what Sid does except that I do not use a temporary worksheet. I thought the calculations are very simple and straight forward so there's no need to dump it somewhere else. Here's the final output of the calendar:
How to set it up:
Create 42 Label controls and name it sequentially and arranged left to right, top to bottom (This labels contains greyed 25 up to greyed 5 above). Change the name of the Label controls to Label_01,Label_02 and so on. Set all 42 labels Tag property to dts.
Create 7 more Label controls for the header (this will contain Su,Mo,Tu...)
Create 2 more Label control, one for the horizontal line (height set to 1) and one for the Month and Year display. Name the Label used for displaying month and year Label_MthYr
Insert 2 Image controls, one to contain the left icon to scroll previous months and one to scroll next month (I prefer simple left and right arrow head icon). Name it Image_Left and Image_Right
The layout should be more or less like this (I leave the creativity to anyone who'll use this).
Declaration: We need one variable declared at the very top to hold the current month selected.
Option Explicit
Private curMonth As Date
Private Procedure and Functions:
Private Function FirstCalSun(ref_date As Date) As Date
'/* returns the first Calendar sunday */
FirstCalSun = DateSerial(Year(ref_date), _
Month(ref_date), 1) - (Weekday(ref_date) - 1)
End Function
Private Sub Build_Calendar(first_sunday As Date)
'/* This builds the calendar and adds formatting to it */
Dim lDate As MSForms.Label
Dim i As Integer, a_date As Date
For i = 1 To 42
a_date = first_sunday + (i - 1)
Set lDate = Me.Controls("Label_" & Format(i, "00"))
lDate.Caption = Day(a_date)
If Month(a_date) <> Month(curMonth) Then
lDate.ForeColor = &H80000011
Else
If Weekday(a_date) = 1 Then
lDate.ForeColor = &HC0&
Else
lDate.ForeColor = &H80000012
End If
End If
Next
End Sub
Private Sub select_label(msForm_C As MSForms.Control)
'/* Capture the selected date */
Dim i As Integer, sel_date As Date
i = Split(msForm_C.Name, "_")(1) - 1
sel_date = FirstCalSun(curMonth) + i
'/* Transfer the date where you want it to go */
MsgBox sel_date
End Sub
Image Events:
Private Sub Image_Left_Click()
If Month(curMonth) = 1 Then
curMonth = DateSerial(Year(curMonth) - 1, 12, 1)
Else
curMonth = DateSerial(Year(curMonth), Month(curMonth) - 1, 1)
End If
With Me
.Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
Build_Calendar FirstCalSun(curMonth)
End With
End Sub
Private Sub Image_Right_Click()
If Month(curMonth) = 12 Then
curMonth = DateSerial(Year(curMonth) + 1, 1, 1)
Else
curMonth = DateSerial(Year(curMonth), Month(curMonth) + 1, 1)
End If
With Me
.Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
Build_Calendar FirstCalSun(curMonth)
End With
End Sub
I added this to make it look like the user is clicking the label and should be done on the Image_Right control too.
Private Sub Image_Left_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Image_Left.BorderStyle = fmBorderStyleSingle
End Sub
Private Sub Image_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Image_Left.BorderStyle = fmBorderStyleNone
End Sub
Label Events: All of this should be done for all 42 labels (Label_01 to Lable_42) Tip: Build the first 10 and just use find and replace for the remaining.
Private Sub Label_01_Click()
select_label Me.Label_01
End Sub
This is for hovering over dates and clicking effect.
Private Sub Label_01_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Label_01.BorderStyle = fmBorderStyleSingle
End Sub
Private Sub Label_01_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Label_01.BackColor = &H8000000B
End Sub
Private Sub Label_01_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Label_01.BorderStyle = fmBorderStyleNone
End Sub
UserForm Events:
Private Sub UserForm_Initialize()
'/* This is to initialize everything */
With Me
curMonth = DateSerial(Year(Date), Month(Date), 1)
.Label_MthYr = Format(curMonth, "mmmm, yyyy")
Build_Calendar FirstCalSun(curMonth)
End With
End Sub
Again, just for the hovering over dates effect.
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
With Me
Dim ctl As MSForms.Control, lb As MSForms.Label
For Each ctl In .Controls
If ctl.Tag = "dts" Then
Set lb = ctl: lb.BackColor = &H80000005
End If
Next
End With
End Sub
And that's it. This is raw and you can add your own twist to it.
I've been using this for awhile and I have no issues (performance and functionality wise). No Error Handling yet but can be easily managed I guess. Actually, without the effects, the code is too short. You can manage where your dates go in the select_label procedure. HTH.
Just for fun I took Siddharth's suggestion of separate textboxes and did comboboxes. If anybody's interested, add a userform with three comboboxes named cboDay, cboMonth and cboYear and arrange them left to right. Then paste the code below into the UserForm's code module. The required combobox properties are set in UserFormInitialization, so no additional prep should be required.
The tricky part is changing the day when it becomes invalid because of a change in year or month. This code just resets it to 01 when that happens and highlights cboDay.
I haven't coded anything like this in a while. Hopefully it will be of interest to somebody, someday. If not it was fun!
Dim Initializing As Boolean
Private Sub UserForm_Initialize()
Dim i As Long
Dim ctl As MSForms.Control
Dim cbo As MSForms.ComboBox
Initializing = True
With Me
With .cboMonth
' .AddItem "month"
For i = 1 To 12
.AddItem Format(i, "00")
Next i
.Tag = "DateControl"
End With
With .cboDay
' .AddItem "day"
For i = 1 To 31
.AddItem Format(i, "00")
Next i
.Tag = "DateControl"
End With
With .cboYear
' .AddItem "year"
For i = Year(Now()) To Year(Now()) + 12
.AddItem i
Next i
.Tag = "DateControl"
End With
DoEvents
For Each ctl In Me.Controls
If ctl.Tag = "DateControl" Then
Set cbo = ctl
With cbo
.ListIndex = 0
.MatchRequired = True
.MatchEntry = fmMatchEntryComplete
.Style = fmStyleDropDownList
End With
End If
Next ctl
End With
Initializing = False
End Sub
Private Sub cboDay_Change()
If Not Initializing Then
If Not IsValidDate Then
ResetMonth
End If
End If
End Sub
Private Sub cboMonth_Change()
If Not Initializing Then
ResetDayList
If Not IsValidDate Then
ResetMonth
End If
End If
End Sub
Private Sub cboYear_Change()
If Not Initializing Then
ResetDayList
If Not IsValidDate Then
ResetMonth
End If
End If
End Sub
Function IsValidDate() As Boolean
With Me
IsValidDate = IsDate(.cboMonth & "/" & .cboDay & "/" & .cboYear)
End With
End Function
Sub ResetDayList()
Dim i As Long
Dim StartDay As String
With Me.cboDay
StartDay = .Text
For i = 31 To 29 Step -1
On Error Resume Next
.RemoveItem i - 1
On Error GoTo 0
Next i
For i = 29 To 31
If IsDate(Me.cboMonth & "/" & i & "/" & Me.cboYear) Then
.AddItem Format(i, "0")
End If
Next i
On Error Resume Next
.Text = StartDay
If Err.Number <> 0 Then
.SetFocus
.ListIndex = 0
End If
End With
End Sub
Sub ResetMonth()
Me.cboDay.ListIndex = 0
End Sub
For a quick solution, I usually do like this.
This approach will allow the user to enter date in any format they like in the textbox, and finally format in mm/dd/yyyy format when he is done editing. So it is quite flexible:
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If TextBox1.Text <> "" Then
If IsDate(TextBox1.Text) Then
TextBox1.Text = Format(TextBox1.Text, "mm/dd/yyyy")
Else
MsgBox "Please enter a valid date!"
Cancel = True
End If
End If
End Sub
However, I think what Sid developed is a much better approach - a full fledged date picker control.
You could use an input mask on the text box, too. If you set the mask to ##/##/#### it will always be formatted as you type and you don't need to do any coding other than checking to see if what was entered was a true date.
Which just a few easy lines
txtUserName.SetFocus
If IsDate(txtUserName.text) Then
Debug.Print Format(CDate(txtUserName.text), "MM/DD/YYYY")
Else
Debug.Print "Not a real date"
End If
While I agree with what's mentioned in the answers below, suggesting that this is a very bad design for a Userform unless copious amounts of error checks are included...
to accomplish what you need to do, with minimal changes to your code, there are two approaches.
Use KeyUp() event instead of Change event for the textbox. Here is an example:
Private Sub TextBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim TextStr As String
TextStr = TextBox2.Text
If KeyCode <> 8 Then ' i.e. not a backspace
If (Len(TextStr) = 2 Or Len(TextStr) = 5) Then
TextStr = TextStr & "/"
End If
End If
TextBox2.Text = TextStr
End Sub
Alternately, if you need to use the Change() event, use the following code. This alters the behavior so the user keeps entering the numbers, as
12072003
while the result as he's typing appears as
12/07/2003
But the '/' character appears only once the first character of the DD i.e. 0 of 07 is entered. Not ideal, but will still handle backspaces.
Private Sub TextBox1_Change()
Dim TextStr As String
TextStr = TextBox1.Text
If (Len(TextStr) = 3 And Mid(TextStr, 3, 1) <> "/") Then
TextStr = Left(TextStr, 2) & "/" & Right(TextStr, 1)
ElseIf (Len(TextStr) = 6 And Mid(TextStr, 6, 1) <> "/") Then
TextStr = Left(TextStr, 5) & "/" & Right(TextStr, 1)
End If
TextBox1.Text = TextStr
End Sub
Private Sub txtBoxBDayHim_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then 'only numbers and backspace
If KeyAscii = 8 Then 'if backspace, ignores + "/"
Else
If txtBoxBDayHim.TextLength = 10 Then 'limit textbox to 10 characters
KeyAscii = 0
Else
If txtBoxBDayHim.TextLength = 2 Or txtBoxBDayHim.TextLength = 5 Then 'adds / automatically
txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
End If
End If
End If
Else
KeyAscii = 0
End If
End Sub
This works for me. :)
Your code helped me a lot. Thanks!
I'm brazilian and my english is poor, sorry for any mistake.

Resources