Open graphic calendar on cell click

[craigwojo]

I'm looking for a way to open a graphic (GUI-Type) calendar to select the date. After the information is inserted the cell will show the date formatted as: Mar 14, 2012.

Thank you and God bless.
Craig

 

[Domenic]

Have a look at the following link...

Date Picker | xl-central.com

Displays a calendar, and prompts the user to select a date.

xl-central.com

You'll find a sample workbook that you can download at the bottom of that page. Also, you can search Google for other examples, using search terms such as VBA, calendar, and date picker.

Hope this helps!

 

[craigwojo]

Have a look at the following link...

Date Picker | xl-central.com

Displays a calendar, and prompts the user to select a date.

xl-central.com

You'll find a sample workbook that you can download at the bottom of that page. Also, you can search Google for other examples, using search terms such as VBA, calendar, and date picker.

Hope this helps!

Thank you. Now if I send my Excel worksheet to another worker, will they have to have the program (date picker) installed on their Excel?

 

[Domenic]

Actually, it's not an add-in, so there's nothing to install and enable. All of the necessary code is contained within the workbook modules.

 

[craigwojo]

Actually, it's not an add-in, so there's nothing to install and enable. All of the necessary code is contained within the workbook modules.

Sweet. Thank you very much.

 

[Domenic]

You're very welcome!

Cheers!

 

[craigwojo]

You're very welcome!

Cheers!

Hi Domenic, thank you again... it works great.
Is there a way to have the calendar open next to cell that I placed the icon in? Currently, it defaults to the center of the page.
I might have some other questions about certain tweaks with this date picker.
Thank you and God bless,
Craig

 

[Domenic]

Hi Craig,

Unfortunately, I don't have any code that would position the calendar relative to a cell. However, I searched online, and thought I found some code that would help. However, it doesn't seem to be working properly. I've asked other members here on the Board for some help. If I can get the code to work, or if I find some other code that would work, I'll post it here.

By the way, here's where I posted my question...

Position UserForm Relative to Cell

Hi everyone, I downloaded the sample workbook FormPositioner from Pearson's website. First I replaced each occurence of VBA6 with VBA7 in the code. Then I set the horizontal and vertical positions as follows... HO = cstFhpFormLeftCellRight ' set these to how you want the form positioned...

www.mrexcel.com

Cheers!

 

[Domenic]

Hi Craig,

@Akuini , who is a member here on the Board, provided me with a link to code available on StackOverflow.

I've tested it, and it seems to work just fine. It works even when the worksheet is zoomed in or out, and also when the worksheet is resized.

Here is my code, which has been amended to display the calendar to the right of the icon. However, sure that the icon is completely contained within the cell. Also, I've amended the code to allow the user to cancel and dismiss the calendar simply by hitting the esc key. And I've amended it to allow the user to click the left and right arrows in quick succession.

In module modCalendar...

Sub ShowCalendar()

    Dim userDate As Date
    userDate = frmCalendar.selectDate(Range("B2").Value)
    
    If userDate > 0 Then
        Range("B2").Value = userDate
    End If
    
End Sub

In a new and separate module (name it as you wish)...

Option Explicit

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90

Public Type pointcoordinatestype
    Left As Double
    Top As Double
    Right As Double
    Bottom As Double
End Type

Private pixelsperinchx As Long, pixelsperinchy As Long, pointsperinch As Long, zoomratio As Double

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
#Else
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#End If

Private Sub ConvertUnits()
  Dim hdc As LongPtr
    hdc = GetDC(0)
    pixelsperinchx = GetDeviceCaps(hdc, LOGPIXELSX) ' Usually 96
    pixelsperinchy = GetDeviceCaps(hdc, LOGPIXELSY) ' Usually 96
    ReleaseDC 0, hdc
    pointsperinch = Application.InchesToPoints(1)   ' Usually 72
    zoomratio = ActiveWindow.Zoom / 100
End Sub

Private Function PixelsToPointsX(ByVal pixels As Long) As Double
    PixelsToPointsX = pixels / pixelsperinchx * pointsperinch
End Function

Private Function PixelsToPointsY(ByVal pixels As Long) As Double
    PixelsToPointsY = pixels / pixelsperinchy * pointsperinch
End Function

Private Function PointsToPixelsX(ByVal points As Double) As Long
    PointsToPixelsX = points / pointsperinch * pixelsperinchx
End Function

Private Function PointsToPixelsY(ByVal points As Double) As Long
    PointsToPixelsY = points / pointsperinch * pixelsperinchy
End Function

Public Sub GetPointCoordinates(ByVal cellrange As Range, ByRef pointcoordinates As pointcoordinatestype)
    Dim i As Long
    ConvertUnits
    Set cellrange = cellrange.MergeArea
    For i = 1 To ActiveWindow.Panes.Count
        If Not Intersect(cellrange, ActiveWindow.Panes(i).VisibleRange) Is Nothing Then
            pointcoordinates.Left = PixelsToPointsX(ActiveWindow.Panes(i).PointsToScreenPixelsX(cellrange.Left))
            pointcoordinates.Top = PixelsToPointsY(ActiveWindow.Panes(i).PointsToScreenPixelsY(cellrange.Top))
            pointcoordinates.Right = pointcoordinates.Left + cellrange.Width * zoomratio
            pointcoordinates.Bottom = pointcoordinates.Top + cellrange.Height * zoomratio
            Exit Sub
        End If
    Next
End Sub

The module frmCalendar...

Option Explicit

Private m_minYear As Long
Private m_maxYear As Long
Private m_date As Date
Private m_userSelectedDate As Date
Private m_labelCollection As Collection
Private m_locked As Boolean

Private m_labelWithFocus As MSForms.label

Public Property Set LabelWithFocus(ByRef lbl As MSForms.label)
    Set m_labelWithFocus = lbl
End Property

Public Property Get LabelWithFocus() As MSForms.label
    Set LabelWithFocus = m_labelWithFocus
End Property

Public Function selectDate(Optional dt As Variant) As Date

    If IsMissing(dt) Then
        dt = Date
    End If
    
    If Not IsDate(dt) Then
        dt = Date
    End If
    
    m_date = dt
    
    m_locked = True
    Me.comboBoxMonth.Value = Format(dt, "mmmm")
    Me.comboboxYear = Year(dt)
    m_locked = False
    
    refreshCalendar
    
    Me.Show
    
    selectDate = m_userSelectedDate
    
End Function

Public Property Let userSelectedDate(v As Date)
    m_userSelectedDate = v
End Property

Private Sub comboBoxMonth_Change()
    If m_locked Then Exit Sub
    refreshCalendar
End Sub

Private Sub comboboxYear_Change()
    If m_locked Then Exit Sub
    refreshCalendar
End Sub

Private Sub commandButtonCancel_Click()
    Unload Me
End Sub

Private Sub labelLeftArrow_Click()

    Dim dt As Date
    dt = DateValue(Me.comboBoxMonth.Value & " " & Me.comboboxYear.Value)
    
    dt = dt - 1
    
    If Year(dt) < m_minYear Then
        'Beep
        Exit Sub
    End If
    
    m_locked = True
    Me.comboBoxMonth.Value = Format(dt, "mmmm")
    Me.comboboxYear.Value = Year(dt)
    m_locked = False
    
    refreshCalendar
    
End Sub

Private Sub labelLeftArrow_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    labelLeftArrow_Click
End Sub

Private Sub labellRightArrow_Click()

    Dim dt As Date
    dt = DateValue(Me.comboBoxMonth.Value & " " & Me.comboboxYear.Value)
    dt = DateSerial(Year(dt), Month(dt) + 1, 1)
    
    If Year(dt) > m_maxYear Then
        'Beep
        Exit Sub
    End If
    
    m_locked = True
    Me.comboBoxMonth.Value = Format(dt, "mmmm")
    Me.comboboxYear.Value = Year(dt)
    m_locked = False
    
    refreshCalendar
        
End Sub

Private Sub labellRightArrow_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    labellRightArrow_Click
End Sub

Private Sub labelMonth_Click()
    Me.comboBoxMonth.DropDown
End Sub

Private Sub labelToday_Click()

    m_date = Date

    m_locked = True
    Me.comboBoxMonth.Value = Format(Date, "mmmm")
    Me.comboboxYear.Value = Year(Date)
    m_locked = False
    
    refreshCalendar
    
End Sub

Private Sub labelYear_Click()
    Me.comboboxYear.DropDown
End Sub

Private Sub UserForm_Initialize()

    Dim targetCell As Range
    Set targetCell = ThisWorkbook.Worksheets("Calendar").Shapes("Graphic 7").TopLeftCell.Offset(, 1)

    Dim pointcoordinates As pointcoordinatestype
    Dim horizontaloffsetinpoints As Double
    Dim verticaloffsetinpoints As Double
    
    With Me
        horizontaloffsetinpoints = (.Width - .InsideWidth) / 2
        verticaloffsetinpoints = 1
        Call GetPointCoordinates(targetCell, pointcoordinates)
        .StartUpPosition = 0
        .Top = pointcoordinates.Top - verticaloffsetinpoints
        .Left = pointcoordinates.Left - horizontaloffsetinpoints
    End With
    
    Dim monthIndex As Long
    For monthIndex = 1 To 12
        Me.comboBoxMonth.AddItem Format(DateSerial(2022, monthIndex, 1), "mmmm")
    Next monthIndex
    
    m_minYear = Year(Date) - 100
    m_maxYear = Year(Date) + 100

    Dim yearIndex As Long
    For yearIndex = m_minYear To m_maxYear
        Me.comboboxYear.AddItem yearIndex
    Next yearIndex
    
    Set m_labelCollection = New Collection
    
    Dim currentLabel As clsLabel
    Dim i As Long
    For i = 1 To 42
        Set currentLabel = New clsLabel
        Set currentLabel.label = Me.Controls("label" & Format(i, "00"))
        m_labelCollection.Add currentLabel
    Next i
    
    Set m_labelWithFocus = Nothing

End Sub

Private Sub refreshCalendar()

    With Me.labelMonth
        .AutoSize = False
        .Width = Me.labelMonthAndYearFrame.Width
        .Caption = Me.comboBoxMonth.Value
        .AutoSize = True
    End With
    
    With Me.labelYear
        .AutoSize = False
        .Width = Me.labelMonthAndYearFrame.Width
        .Caption = Me.comboboxYear.Value
        .AutoSize = True
    End With
    
    Me.labelMonth.Left = Me.labelMonthAndYearFrame.Left + (Me.labelMonthAndYearFrame.Width - (Me.labelMonth.Width + 3 + Me.labelYear.Width)) / 2
    Me.labelYear.Left = Me.labelMonth.Left + Me.labelMonth.Width + 3
    
    With Me.comboBoxMonth
        .Left = Me.labelMonth.Left
        .Width = Me.labelMonth.Width
    End With
    
    With Me.comboboxYear
        .Left = Me.labelYear.Left
        .Width = Me.labelYear.Width
    End With
    
    Dim dt As Date
    dt = DateValue(Me.comboBoxMonth.Value & " " & Me.comboboxYear.Value)
    
    While Weekday(dt) <> vbSunday
        dt = dt - 1
    Wend
    
    Dim i As Long
    For i = 1 To 42
        With Me.Controls("label" & Format(i, "00"))
            .Caption = Day(dt)
            .Tag = dt
            If dt = m_date Then
                .BorderColor = "&H0000FF"
                .BorderStyle = fmBorderStyleSingle
            Else
                .BorderStyle = fmBorderStyleNone
            End If
            If Format(dt, "mmmm") = Me.comboBoxMonth.Value Then
                .ForeColor = "&H404040" 'dark grey
            Else
                .ForeColor = "&HC0C0C0" 'light grey
            End If
        End With
        dt = dt + 1
    Next i
    
End Sub


Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Not m_labelWithFocus Is Nothing Then
        m_labelWithFocus.BackColor = "&HFFFFFF"
        Set m_labelWithFocus = Nothing
    End If
End Sub

The module clsLabel remains unchanged.

I'd be interested in your feedback, good or bad.

Cheers!

 

[craigwojo]

Hi Craig,

Unfortunately, I don't have any code that would position the calendar relative to a cell. However, I searched online, and thought I found some code that would help. However, it doesn't seem to be working properly. I've asked other members here on the Board for some help. If I can get the code to work, or if I find some other code that would work, I'll post it here.

By the way, here's where I posted my question...

Position UserForm Relative to Cell

Hi everyone, I downloaded the sample workbook FormPositioner from Pearson's website. First I replaced each occurence of VBA6 with VBA7 in the code. Then I set the horizontal and vertical positions as follows... HO = cstFhpFormLeftCellRight ' set these to how you want the form positioned...

www.mrexcel.com

Cheers!

You're the best. God bless.