I'm trying to add an ImageCombo-ActiveX control to an Excel worksheet by using the VBA-function .OLEObjects.Add(classtype:="MSComctlLib.ImageComboCtl.2", Top:=TopPos, Left:=LeftPos, Height:=0, Width:=0).
When doing so, the ImageCombo control is displayed on the worksheet in a preloaded state:
ImageCombo Preloaded State
When doing a check with Winspector Spy, it turned out then the ActiveX-Window is loaded as a child-window of an invisible window within Excel named as 'CtlFrameworkParking':
ActiveX control window
instead of being diplayed as an ImageCombo-control. To force this, I first have to make the worksheet window invisble and then redisplay it:
Status after Re-displaying the worksheet window
Finally, after manually scrolling down a line, the ImageCombo-control is diplayed at the desired location with the desired size.
Status after worksheet scroll
Reinspecting with Winspector Spy the ActiveX-Window now is located within the worksheet window:
final correct status
Is there any way to programatically force the ActiveX-Window to show in final state on the worksheet window, probably with some api calls?
I Solved the problem doing it the dirty way by adding the following lines:
Function ShowLanguageDropDown(TargetSheetName As String, Optional TopPos As Single = 0#, Optional LeftPos As Single = 0#, Optional SetVisible As Boolean = False) As MSComctlLib.ImageCombo
'---------------------------------------------------------------------------------------
' Procedure : ShowLanguageDropDown
' Author : Bernd Birkicht
' Date : 05.11.2022
' Purpose : inserts an image dropdown on the target sheet, requires prelodad OLE-objects on a SourceSheet
' containing the ImageDropdown and the to be associated pre-set ImageList-activeX control
'---------------------------------------------------------------------------------------
'
'........
Set TargetSheet = ActiveWorkbook.Sheets(TargetSheetName)
'........
With TargetSheet
.Visible = xlSheetHidden
.Visible = xlSheetVisible
.Activate
End With
Set TargetSheet = Nothing
CurrentScrollRow = ActiveWindow.ScrollRow
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = CurrentScrollRow
End function
These commands now do programmatically what I did manually before resulting in now correctly displaying the ImageDropdown control at the desired location on the worksheet.
I would welcome a more elegant solution.
I finally decided to to drop the approach of using an ImageCombo-ActiveX control directly on an Excel worksheet due to i encounterd a big bunch of problems with the ImageCombo-control further on.
When stopping the screen update, the Drop-down arrow within the control occasionally disappears and the control repaints not always fully. I was not able to fix this.
At the end of the day, I used the ImageCombo-ActiveX control within a modeless userform which is not affected at all from application screen updating or events processed by the application while the userform is displayed.
To prevent the userform from floating on the windows screen, I now attached the userform to the Excel-application window and cropped the userform frame around the ImageCombo-control.
Please find below the code:
Private Sub UserForm_Initialize()
'---------------------------------------------------------------------------------------
' Procedure : UserForm_Initialize
' Author : Bernd Birkicht
' Date : 10.11.2022
' Purpose : fills the image-Dropdownbox valid lnaguage entries
'---------------------------------------------------------------------------------------
'
Static BasicInit As Boolean
On Error GoTo UserForm_Initialize_Error
If BasicInit Then Exit Sub 'already initialised?
....
'adapt userform window to Dropbox size
Me.Height = Me!LanguageDropBox.Height
Me.Width = Me!LanguageDropBox.Width
With Me.LanguageDropBox
Set .ImageList = Nothing 'delete image list and import again
If .ImageList Is Nothing Then Set .ImageList = Me.LanguageSmallIconImageList
mlngptrCtlHwnd = .hwnd
.Locked = True
End With
PopulateComboItems Translate:=bTranslate
UserForm_Initialize_Exit:
Crop_UF_Frame
BasicInit = MakeChild(Me)
Exit Sub
UserForm_Initialize_Error:
Select Case Err.Number
Case Else
'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Prozedur UserForm_Initialize aus Formular LanguageDropBoxForm"
'LogError Err.Number, Err.Description, "in Prozedur UserForm_Initialize aus Formular LanguageDropBoxForm"
ErrEx.CallGlobalErrorHandler ' Call the global error handler to deal with unhandled errors
Resume UserForm_Initialize_Exit:
End Select
End Sub
Private Sub Crop_UF_Frame()
'---------------------------------------------------------------------------------------
' Procedure : Crop_UF_Frame
' Author : Nepumuk https://www.herber.de/forum/archiv/1456to1460/1459854_Userform_komplett_ohne_Rand.html
' Date : 21.11.2015
' Purpose : crop the userform frame
' geändert : 11.11.2022 Bernd Birkicht
' ergänzt: Region eingrenzen auf einzelnes Control in der Userform
'---------------------------------------------------------------------------------------
'
Dim udtRect As RECT, udtPoint As POINTAPI
Dim lngptrStyle As LongPtr, lngptrRegion As LongPtr, lngParenthWnd As LongPtr
Static BasicInit As Boolean
On Error GoTo Crop_UF_Frame_Error
mlngptrHwnd = FindWindowA(GC_CLASSNAMEMSFORM, Caption)
lngptrStyle = GetWindowLongA(mlngptrHwnd, GWL_STYLE)
Call SetWindowLongA(mlngptrHwnd, GWL_STYLE, lngptrStyle And Not WS_CAPTION)
Call DrawMenuBar(mlngptrHwnd)
Call GetWindowRect(mlngptrHwnd, udtRect)
udtPoint.x = udtRect.right
udtPoint.y = udtRect.bottom
Call ScreenToClient(mlngptrHwnd, udtPoint)
'11.11.2022 set region
If mlngptrCtlHwnd = 0 Then 'Control in Userform gewählt?
'remove userform frame
With udtRect
.bottom = udtPoint.y
.left = 4
.right = udtPoint.x
.top = 4
End With
Else
'set region to WindowRect of the selected control
Call GetWindowRect(mlngptrCtlHwnd, udtRect)
End If
lngptrRegion = CreateRectRgnIndirect(udtRect)
Call SetWindowRgn(mlngptrHwnd, lngptrRegion, 1&)
Crop_UF_Frame_Exit:
Exit Sub
Crop_UF_Frame_Error:
Select Case Err.Number
Case Else
ErrEx.CallGlobalErrorHandler ' Call the global error handler to deal with unhandled errors
Resume Crop_UF_Frame_Exit:
End Select
End Sub
Private Function MakeChild(ByVal UF As UserForm) As Boolean
Dim DeskHWnd As LongPtr
Dim WindowHWnd As LongPtr
Dim UFhWnd As LongPtr
MakeChild = False
' get the window handle of the Excel desktop
DeskHWnd = FindWindowEx(Application.hwnd, 0&, "XLDESK", vbNullString)
If DeskHWnd > 0 Then
' get the window handle of the ActiveWindow
WindowHWnd = FindWindowEx(DeskHWnd, 0&, "EXCEL7", ActiveWindow.Caption)
If WindowHWnd > 0 Then
' ok
Else
MsgBox "Unable to get the window handle of the ActiveWindow."
Exit Function
End If
Else
MsgBox "Unable to get the window handle of the Excel Desktop."
Exit Function
End If
' get the window handle of the userform
Call IUnknown_GetWindow(UF, VarPtr(UFhWnd))
mlngptrOldParenthWnd = GetParent(UFhWnd)
If mlngptrOldParenthWnd = WindowHWnd Then Exit Function 'Assignment to Excel window already done
'make the userform a child window of the MDIForm
If (UFhWnd > 0) And (WindowHWnd > 0) Then
' make the userform a child window of the ActiveWindow
If SetParent(UFhWnd, WindowHWnd) = 0 Then
''''''''''''''''''''
' an error occurred.
''''''''''''''''''''
MsgBox "The call to SetParent failed."
Exit Function
End If
End If
MakeChild = True
End Function
call:
If Wb.ActiveSheet.Name = Translate_To_OriginalText(InitSheetName) And LanguageDropBoxUForm Is Nothing Then
LanguageDropBoxForm.Hide 'Lädt das Window ohne es anzuzeigen
If UserForms.count > 0 Then Set LanguageDropBoxUForm = UserForms(UserForms.count - 1)
LanguageDropBoxForm.Move 660#, 85#
LanguageDropBoxForm.Show vbModeless 'show Language-Select-Window modeless
endif
The following should happen:
1. UserForm with 2 RefEdit controls is shown
2. The first RefEdit is used to select a range
3. The RefEdit_Change event adjusts the second RefEdit control to .offset(0,1) of the range
Here my code until now:
Module1:
Dim frmSelectXY As New frmSelectImportData
With frmSelectXY
.Show
.DoStuffWithTheSelectedRanges
End With
UserForm: frmSelectImportData
Option Explicit
Private Type TView
IsCancelled As Boolean
xrng As Range
yrng As Range
End Type
Private this As TView
Public Property Get IsCancelled() As Boolean
IsCancelled = this.IsCancelled
End Property
Public Property Get yrng() As Range
Set yrng = this.yrng
End Property
Public Property Get xrng() As Range
Set xrng = this.xrng
End Property
'Here is where the fun happens
Private Sub RefEdit1_Change()
'RefEdit2.Value = RefEdit1.Value
If InStr(1, RefEdit1.Value, "[") <> 0 And InStr(1, RefEdit1.Value, "!") <> 0 Then
RefEdit2.Value = Range(RefEdit1.Value).offset(0, 1).Address(External:=True)
ElseIf InStr(1, RefEdit1.Value, "!") <> 0 Then
RefEdit2.Value = Range(RefEdit1.Value).offset(0, 1).Parent.Name & "!" & Range(RefEdit1.Value).offset(0, 1).Address(External:=False)
Else
RefEdit2.Value = Range(RefEdit1.Value).offset(0, 1).Address(External:=False)
End If
End Sub
Private Sub SaveBTN_Click()
Set this.xrng = Range(RefEdit1.Value)
Set this.yrng = Range(RefEdit2.Value)
If Not validate Then
MsgBox "x-values and y-values need to have the same size."
Else
Me.Hide
End If
End Sub
Function validate() As Boolean
validate = False
If this.xrng.count = this.yrng.count Then validate = True
End Function
RefEdit1_Change should adjust the value of RefEdit2 such that it will show the reference to the column just next to it or better .offest(0,1) to it.
But that isn't what happens.. the value doesn't get changed. As soon as the User clicks into RefEdit2 if RefEdit1 has already been changed, the program aborts without error message. If you Cancle the UserForm I have also experienced hard crashes of excel. I have temporarily fixed the problem by rebuilding the UserForm from scratch and renaming the RefEdits. But at some point it reapeared. It seems as if it is an Excel/VBA inherent problem.
Does anybody know how to fix this?
Ugly hacks and workarounds are welcome, anything is better than, abort without error message.
you need to enclose Range(RefEdit1.Value).offset(0, 1).Parent.Name in ' so
="'" & Range(RefEdit1.Value).offset(0, 1).Parent.Name & "'!"
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.
I'm trying to avoid Event loops by disabling Events at crucial points. However, it doesn't always work. For instance, this code for a Combo box:
Private Sub TempComboS_Change()
Dim e
e = Application.EnableEvents
Application.EnableEvents = False
'
Application.EnableEvents = e
End Sub
The blank line is where the useful code goes; as it stands it obviously doesn't do anything. However, when I run it this way (with the blank line), it reaches "End Sub", then it goes back to the beginning and runs again. (This would make the useful code run twice).
Why is this happening?
EDIT: To clarify for the folks who've been helping me.
I have a macro that opens the dropdown list of the Combo box, activates it, then ends. It works properly. When I select an item from the open list, the Change event runs. This is the current version of the change event:
Private Sub TempComboS_Change()
End Sub
I put a breakpoint on the Private Sub line. It shows that this Change event runs, then runs again. I suspect that it has been doing this all along, and I noticed it now because I need to add code here.
I have no class modules or userforms. The controls are on a worksheet.
I'm going to try the "Run Once" suggestion, and I'll let you know if it works.
I tried the "Run Once" code you suggested. It sort of works, but I seem to have a bigger issue. When I select a drop-down list from a data-validated cell, the TempComboS_Change event triggers -- but not only didn't I touch this combo box, the cell isn't the LinkedCell for the combo box. In other words, it seems to be triggering by actions unconnected to the combo box!
Got to find out about that Call Stack thing...
Here is a bit of code to help investigate "sequence of events" issues
In a Standard Module
Public Enum eNewLine
No
Before
After
Both
End Enum
Public Function timeStamp(Optional d As Double = 0, Optional newLine As eNewLine = No, Optional Indent As Long = 0, _
Optional Caller As String, Optional Context As String, Optional message As String) As String
Dim errorMessage As String
If Err.number <> 0 Then
errorMessage = "ERROR: " & Err.number & ": " & Err.Description
Err.Clear
End If
If d = 0 Then d = Time
With Application.WorksheetFunction
timeStamp = .Text(Hour(d), "00") & ":" & .Text(Minute(d), "00") & ":" & .Text(Second(d), "00") & ":" & .rept(Chr(9), Indent)
End With
If Len(Caller) <> 0 Then timeStamp = timeStamp & Chr(9) & Caller
If Len(Context) <> 0 Then timeStamp = timeStamp & ": " & Chr(9) & Context
If Len(message) <> 0 Then timeStamp = timeStamp & ": " & Chr(9) & message
Select Case newLine
Case Before
timeStamp = Chr(10) & timeStamp
Case After
timeStamp = timeStamp & Chr(10)
Case Both
timeStamp = Chr(10) & timeStamp & Chr(10)
Case Else
End Select
If Len(errorMessage) <> 0 Then
timeStamp = timeStamp & Chr(9) & errorMessage
End If
End Function
At the top of each Module
'Module level Trace Hearder
Const debugEvents as Boolean = True
Const cModuleName As String = "myModuleName"
Const cModuleIndent As Long = 1
You can assign a module level indent for each module to organise the hierarchy an make it easy to understand.
In each Sub or Function (or property if you need)...
sub mySubName()
Const cMyName As String = "mySubName"
If debugEvents Then Debug.Print timeStamp(NewLine:=Before,Indent:=cModuleIndent, Caller:=cModuleName, Context:=cMyName, Message:="Start")
'Do stuff
If debugEvents Then Debug.Print timeStamp(NewLine:=After,Indent:=cModuleIndent, Caller:=cModuleName, Context:=cMyName, Message:="End")
End Sub
...Or you can use Me.Name for the Context if its a form or a sheet etc. and you can put whatever message or variable values you like in the Message.
You can also use a Timer (eg MicroTimer) and put the result in the Message section.
Here is an example output:
15:54:07: Roll-Up Select: Worksheet_Activate: Start: 3.24591834214516E-03
15:54:07: cDataViewSheet: Class_Initialize: Start
15:54:07: cRevealTarget: Class_Initialize: START
15:54:07: cRevealTarget: Class_Initialize: END
15:54:09: cDataViewSheet: startTimer: : START
15:54:09: cDataViewSheet: startTimer: init Timer
15:54:09: cOnTime: Class_Initialize
15:54:09: cOnTime: Let PulseTime: Inheret PulseTime from host sheet
15:54:09: cDataViewSheet: startTimer: : END
15:54:09: Roll-Up Select: Worksheet_Activate: END: 1.38736216780671
Private Sub cmbOrder_Change()
If cmbOrder = "" Then Exit Sub
Dim arr As Variant, maxorder As Integer
arr = Range("rngOrder")
maxorder = WorksheetFunction.Max(arr)
Dim errmsg As String, err As Boolean
err = False
errmsg = "This value must be a whole number between 1 and " & maxorder + 1
Dim v As Variant
v = cmbOrder.Value
If IsNumeric(v) = False Or (IsNumeric(v) = True And (v > maxorder + 1) Or v < 1)
Then
MsgBox errmsg
cmbOrder = ""
err = False
Else
txtOrder.Value = cmbOrder.Value
End If
End Sub
A bit late to the party but the problem of code repetition can be shown here in similar circumstances. Remove the first line of code and any error messages are dished out twice. This is because of the line that clears the ComboBox that is regarded as a change and picks up another error as null input is an error! May help someone with similar issue.
The Combobox_Change() will fire whenever there is a change in the combobox. For example
Option Explicit
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
End Sub
Private Sub CommandButton1_Click()
'~~> If something is selected in the combo then
'~~> this line will cause ComboBox1_Change to fire
ComboBox1.Clear
End Sub
Private Sub ComboBox1_Change()
MsgBox "A"
End Sub
So if you load the userform and select an item ComboBox1_Change will fire. You then use the commanbutton to clear the combo the ComboBox1_Change will again fire.
There is one more scenario when the change will again fire. When you change the combobox from the ComboBox1_Change event itself. Here is an example. And I believe this is what is happening in your case.
Scenario 1
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
End Sub
Private Sub ComboBox1_Change()
MsgBox "A"
ComboBox1.Clear
End Sub
Scenario 2
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
ComboBox1.AddItem "Bah Blah Blah"
End Sub
Private Sub ComboBox1_Change()
MsgBox "A"
ComboBox1.ListIndex = 1
End Sub
In the first scenario you can getaway with
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
End Sub
Private Sub ComboBox1_Change()
If ComboBox1 <> "" Then
MsgBox "A"
End If
End Sub
In the 2nd Scenario, you can use something like this
Dim boolRunOnce As Boolean
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
ComboBox1.AddItem "Bah Blah Blah"
End Sub
Private Sub ComboBox1_Change()
If boolRunOnce = False Then
MsgBox "A"
boolRunOnce = True
ComboBox1.ListIndex = 1
Else
boolRunOnce = False
End If
End Sub
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.