Calender code error

[Sharid]

<title>FW: VB calendar</title>A work colleague updated this code for me so that a pop up calendar would input the date into an a text box, I no longer need it to do this. I now need it to input the date into a active cell. I have tried to update it so it would input the date into a active cell but can't get it to work. Also I have noticed that this only goes back as far as 1994, which is no good if I am using it to input a date of births before 1994. I would like it to start from 1900.


The bit that my work colleague updated are shown in red, if they don't show in red when posted then its the bits that start with frmTry



frmTry.txtDate = Format(Now(), "dd, mmmm yyyy")

Sadly this is the only calender that will operate at work. I have tried to use others but non work at work. The active cells are in column 1,3,4,7





Sub CalendarFrame_MakeVisible(objMe As MSForms.UserForm)
' Local Variables
Dim blnCalendarMade As Boolean

' Step 1 : Determine if calender has been created
If objMe.chb_LoadCalendar Then blnCalendarMade = True
' Step 2 : Update calendar if not previously done
If Not blnCalendarMade Then
objMe.chb_LoadCalendar = True
End If
' Step 3 : Set visibility status of calendar frame
objMe.fra_Calendar.Visible = Not objMe.fra_Calendar.Visible
End Sub
Sub UpdCalendar_Initialize(objMe As MSForms.UserForm)
' Local Variables
Dim ctrl As Control
Dim strMonth As String, strStartDate As String
Dim intCount As Integer
If objMe.cbo_Years.ListCount > 0 Then GoTo Step2
' Step 1 : Load the ComboBoxes for Year and Months
' 1a : Loading year values
For intCount = 1994 - Year(Now) To 30
objMe.cbo_Years.AddItem Year(Now()) + intCount
Next intCount
' 1b : Loading month values
For intCount = 1 To 12

'UK Date format has month in the middle of the format
' ALSO ALL DATES are in "dd, mmmm yyyy" format , rather than "mmmm,dd yyyy"
' so the following lines are changed
' the big gap is to allow for the changing size in the combo box of the date in words..
strMonth = Format(" 1/" & intCount & "/2004", "dd, mmmm yyyy")
strMonth = Mid(strMonth, 4, InStr(strMonth, "/") + 10)

'IF using US FORMAT then use the next two rows, instead of the above 2 rows

' strMonth = Format(intCount & "/1/2004", "mmmm,dd yyyy")
' strMonth = Mid(strMonth, 1, InStr(strMonth, ",") - 1)


objMe.cbo_Months.AddItem strMonth
Next intCount
objMe.cbo_Years = Year(Now())
objMe.cbo_Months.ListIndex = Month(Now()) - 1

' Following date format would be changed to "dd, mmmm yyyy" if using US format

objMe.lbl_LastSelDate = Format(Now(), "dd, mmmm yyyy")
frmTry.txtDate = Format(Now(), "dd, mmmm yyyy")
Call UpdCalendar_SetDateProperties(objMe)
Exit Sub
Step2:
' Step 2 : Update the visible date information in field
If objMe.cbo_Months.ListIndex = -1 Or objMe.cbo_Years.ListIndex = -1 Then Exit Sub
' 2a : Find the Sunday before or on the 1st of selected month


' IF USING US DATE FORMAT THEN THE FOLLOWING LINE IS
' AS FOLLOWS:
' strStartDate = objMe.cbo_Months.ListIndex + 1 & "/1/" & objMe.cbo_Years

strStartDate = "1/" & objMe.cbo_Months.ListIndex + 1 & "/" & objMe.cbo_Years
Do
strStartDate = DateAdd("d", -1, strStartDate)
Loop While Weekday(strStartDate, vbSunday) <> 1
' 2b : Update the label captions and tags
For intCount = 1 To 42
Set ctrl = objMe.Controls("lbl_Day" & intCount)
ctrl.Caption = Day(strStartDate)
ctrl.Tag = strStartDate
strStartDate = DateAdd("d", 1, strStartDate)
Next intCount
' 2c : Set the visual properties of date labels
Call UpdCalendar_SetDateProperties(objMe)
End Sub
Sub UpdCalendar_SetDateProperties(objMe As MSForms.UserForm)
' Local Variables
Dim ctrlFormat As MSForms.Label, ctrl As MSForms.Label
Dim intCount As Integer
' Step 0 : If the GoTo Today button was pressed multiple changes are being made.
' Wait until last change has been made then update display
If objMe.lbl_LastSelDate.Tag = "GotoToday" Then Exit Sub
' Step 1 : Loop through all labels and update visual settings
For intCount = 1 To 42
Set ctrl = objMe.Controls("lbl_Day" & intCount)
' 1a : Set default visual settings
Set ctrlFormat = objMe.Controls("lbl_Setup_DefaultDate")
ctrl.BackColor = ctrlFormat.BackColor
ctrl.SpecialEffect = ctrlFormat.SpecialEffect
ctrl.BorderStyle = ctrlFormat.BorderStyle
ctrl.ForeColor = 0
' 1b : Test : Is date is in current month
If Month(ctrl.Tag) - 1 <> objMe.cbo_Months.ListIndex Then
ctrl.ForeColor = 14737632
End If
' 1c : Test : Is date the current date
If DateValue(ctrl.Tag) = DateValue(Now()) Then
Set ctrlFormat = objMe.Controls("lbl_SetUp_CurrentDate")
ctrl.BackColor = ctrlFormat.BackColor
ctrl.SpecialEffect = ctrlFormat.SpecialEffect
End If
' 1d : Test : Is date selected by the user
If objMe.lbl_LastSelDate.Caption <> "" Then
If DateValue(ctrl.Tag) = DateValue(objMe.lbl_LastSelDate.Caption) Then
ctrl.BackColor = objMe.lbl_Setup_ActiveDate.BackColor
End If
End If
Next intCount
End Sub
Sub UpdCalendar_GotoToday(objMe As MSForms.UserForm)
' Local Variables

' Step 1 : Set SelDate Label to Indicate calendar is changing and to not update
objMe.lbl_LastSelDate.Tag = "DisplayChgInProgress"
' Step 2 : Chg Month/Year ComboBoxes to reflect current date
objMe.cbo_Months.ListIndex = Month(Now()) - 1
objMe.cbo_Years = Year(Now())
' Step 3 : Update display to match current selections
objMe.lbl_LastSelDate.Tag = ""

' Following date format would be changed to "dd, mmmm yyyy" if using US format
objMe.lbl_LastSelDate = Format(Now(), "dd, mmmm yyyy")
Dim strDate As String
strDate = Format(Now(), "dd, mmmm yyyy")
frmTry.txtDate = strDate
Call UpdCalendar_Initialize(objMe)
End Sub
Sub UpdCalendar_MonthYearChg(objMe As MSForms.UserForm, strActiveCtrlName As String)
' Local Variables
If objMe.fra_Calendar.Tag = "Loading" Then Exit Sub
' Step 1 : Changes if the ComboBoxes were the active control
' Only when the comboboxes change will the displayed calendar be updated
If InStr(strActiveCtrlName, "cbo_") > 0 Then
If strActiveCtrlName = "cbo_Months" Then objMe.spb_Months.Value = objMe.cbo_Months.ListIndex
If strActiveCtrlName = "cbo_Year" Then objMe.spb_Years.Value = objMe.cbo_Years.ListIndex
If objMe.lbl_LastSelDate.Tag = "DisplayChgInProgress" Then Exit Sub
Call UpdCalendar_Initialize(objMe)
objMe.spb_Year.Value = objMe.cbo_Years.ListIndex
End If
' Step 2 : Changes if the SpinButtons were the active control
If InStr(strActiveCtrlName, "spb_") > 0 Then
If strActiveCtrlName = "spb_Months" Then
If objMe.spb_Months.Value = -1 Then
objMe.spb_Months.Value = 11
objMe.spb_Year.Value = objMe.spb_Year.Value - 1
End If
If objMe.spb_Months.Value = 12 Then
objMe.spb_Months.Value = 0
objMe.spb_Year.Value = objMe.spb_Year.Value + 1
End If
objMe.cbo_Months.ListIndex = objMe.spb_Months.Value
End If
If strActiveCtrlName = "spb_Year" Then
If objMe.spb_Year.Value = -1 Then objMe.spb_Year.Value = 40
If objMe.spb_Year.Value = 41 Then objMe.spb_Year.Value = 0
objMe.cbo_Years.ListIndex = objMe.spb_Year.Value
End If
End If
End Sub
Sub UpdCalendar_Pointing(objMe As MSForms.UserForm, dblX As Double, dblY As Double)
' Local Variables
Dim ctrlLast As Control
Dim intCount As Integer
Dim dblTop As Double, dblHeight As Double, dblLeft As Double
Dim dblWidth As Double
' Step 1 : Adjust incomming X and Y values to reflect absolute location relative to frame
dblX = dblX + objMe.lbl_Mouser.Left
dblY = dblY + objMe.lbl_Mouser.Top
' Step 2 : Test to determine if mouse is pointing to a new control
If objMe.lbl_Mouser.Tag <> "" Then
Set ctrlLast = objMe.fra_Calendar.Controls(objMe.lbl_Mouser.Tag)
dblTop = ctrlLast.Top: dblHeight = ctrlLast.Height
dblLeft = ctrlLast.Left: dblWidth = ctrlLast.Width
If dblLeft <= dblX And dblX <= dblLeft + dblWidth And _
dblTop <= dblY And dblY <= dblTop + dblHeight Then Exit Sub
End If
' Step 2 : Loop through date labels either Reset or Set SpecialEffect
objMe.lbl_Mouser.Tag = ""
For intCount = 1 To 42
' 2a : Reset current label
objMe.fra_Calendar.Controls("lbl_Day" & intCount).SpecialEffect = _
objMe.lbl_Setup_DefaultDate.SpecialEffect
' 2b : Test current label location in relation to mouse coordinates
dblTop = objMe.fra_Calendar.Controls("lbl_Day" & intCount).Top
dblHeight = objMe.fra_Calendar.Controls("lbl_Day" & intCount).Height
dblLeft = objMe.fra_Calendar.Controls("lbl_Day" & intCount).Left
dblWidth = objMe.fra_Calendar.Controls("lbl_Day" & intCount).Width
If dblLeft <= dblX And dblX <= dblLeft + dblWidth And _
dblTop <= dblY And dblY <= dblTop + dblHeight Then
objMe.fra_Calendar.Controls("lbl_Day" & intCount).SpecialEffect = _
objMe.lbl_Setup_Point2MeDate.SpecialEffect
objMe.lbl_Mouser.Tag = "lbl_Day" & intCount
End If
Next intCount
End Sub
Sub UpdCalendar_SelectDate(objMe As MSForms.UserForm)
' Local Variables
Dim ctrlLast As Control
Dim strSaveDate As String
Dim intCount As Integer
' Step 1 : Retrieve control name from lbl_Mouser
If objMe.lbl_Mouser.Tag = "" Then Exit Sub
Set ctrlLast = objMe.fra_Calendar.Controls(objMe.lbl_Mouser.Tag)

' Step 2 : Make sure that the selected date is the current Month/Year
strSaveDate = ctrlLast.Tag
objMe.spb_Year.Value = objMe.spb_Year.Value + Year(strSaveDate) - objMe.cbo_Years
objMe.spb_Months.Value = Month(strSaveDate) - 1
' Step 3 : If Selected date caused Month and/or Year to change need to relocate selected date
For intCount = 1 To 42
If DateValue(objMe.fra_Calendar.Controls("lbl_Day" & intCount).Tag) = DateValue(strSaveDate) Then
objMe.lbl_Mouser.Tag = "lbl_Day" & intCount
Set ctrlLast = objMe.fra_Calendar.Controls(objMe.lbl_Mouser.Tag)
Exit For
End If
Next intCount

' Step 4 : Complete Selecting Date
If objMe.lbl_Mouser.Tag <> "" Then

' Following date format would be changed to "dd, mmmm yyyy" if using US format

objMe.lbl_LastSelDate.Caption = Format(ctrlLast.Tag, "dd, mmmm yyyy")
Dim strDate As String
strDate = Format(ctrlLast.Tag, "dd, mmmm yyyy")
frmTry.txtDate = strDate
Call UpdCalendar_SetDateProperties(objMe)
End If

End Sub

 

[northwolves]

Why not use dtpicker instead of "calendar+textbox"?

 

[Sharid]

I've fixed the year issue and now have the calender going back to 1900

If objMe.cbo_Years.ListCount > 0 Then GoTo Step2

' Step 1 : Load the ComboBoxes for Year and Months
' 1a : Loading year values
For intCount = 1900 - Year(Now) To 50
objMe.cbo_Years.AddItem Year(Now()) + intCount
Next intCount
' 1b : Loading month values
For intCount = 1 To 12


I still can't get it to paste the date into an active cell

can any one help

 

[Sharid]

I changed this part of the code
Dim strDate As String
strDate = Format(ctrlLast.Tag, "dd, mmmm yyyy")
frmTry.txtDate = strDate
Call UpdCalendar_SetDateProperties(objMe)

To the bit shown in black
Dim strDate As String
strDate = Format(ctrlLast.Tag, "dd, mmmm yyyy")
ActiveCell.Value = frmLib_Calendar.
Call UpdCalendar_SetDateProperties(objMe)

and it allows for a message to be input to the active cell but not the date.
how do i finish this off ActiveCell.Value = frmLib_Calendar. so that wgen the correct date is clicked, it in puts that date into the active cell *** dd/mm/yy

 

[Sharid]

Don't worry I have fixed the problem

ActiveCell.Value = Format(strDate, "dd/mm/yy")