Как создать вход календаря в VBA Excel?

Постановка задачи

В VBA можно использовать три основных типа элементов управления датой и временем при условии, что определенные oxx были зарегистрированы с использованием прав администратора. Это элементы управления VB6, которые не являются родными для среды VBA. Чтобы установить Montview Control и Datetime Picker, нам нужно установить ссылку на Microsoft MonthView Control 6.0 (SP4), доступ к которой возможен только при повышенной регистрации mscomct2.ocx. Аналогично для mscal.ocx и mscomctl.ocx. Сказав это, устаревший mscal.ocx может работать, а может и не работать в Windows 10.

В зависимости от вашей версии Windows и Office (32-битной или 64-битной), может быть очень больно регистрировать эти ocxs.

Элемент управления Monthview, Datetime Picker и устаревший элемент управления Calendar выглядят следующим образом.

Так с какой проблемой я могу столкнуться, если я включу это в свое выражение?

Если вы включите их в свой проект и передадите их своим друзьям, соседям, клиентам и т.д., Приложение может работать, а может и не работать, в зависимости от того, установлены ли у них эти ocx.

И поэтому настоятельно рекомендуется НЕ использовать их в своем проекте

Какие альтернативы у меня есть?

Этот календарь, использующий пользовательскую форму и рабочий лист, был предложен ранее и является невероятно простым.

Когда я увидел календарь Windows 10, который появился, когда я щелкнул по дате и времени в системном трее, я не мог не задаться вопросом, можем ли мы повторить это в VBA.

Этот пост о том, как создать виджет календаря, который не зависит от ocx или 32bit/64bit и может свободно распространяться вместе с вашим проектом.

Вот как выглядит календарь в Windows 10:

и вот как вы взаимодействуете с ним:

Ответ 1

Образец файла (добавленный в конце публикации) содержит пользовательскую форму, модуль и модуль класса. Чтобы включить это в ваш проект, просто экспортируйте пользовательскую форму, модуль и модуль класса из файла примера и импортируйте его в свой проект.

Код модуля класса

В модуле класса (пусть назовем его CalendarClass) вставьте этот код

Public WithEvents CommandButtonEvents As MSForms.CommandButton

'~~> Unload the form when the user presses Escape
Private Sub CommandButtonEvents_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If Not f Is Nothing Then If KeyAscii = 27 Then Unload f
End Sub

'~~> This section delas with showing/displaying controls
'~~> and updating different labels
Private Sub CommandButtonEvents_Click()
    f.Label6.Caption = CommandButtonEvents.Tag

    If Left(CommandButtonEvents.Name, 1) = "Y" Then
        If Len(Trim(CommandButtonEvents.Caption)) <> 0 Then
            CurYear = Val(CommandButtonEvents.Caption)                
            With f
                .HideAllControls
                .ShowMonthControls

                .Label4.Caption = CurYear
                .Label5.Caption = 2

                .CommandButton1.Visible = False
                .CommandButton2.Visible = False
            End With
        End If
    ElseIf Left(CommandButtonEvents.Name, 1) = "M" Then
        Select Case UCase(CommandButtonEvents.Caption)
            Case "JAN": CurMonth = 1
            Case "FEB": CurMonth = 2
            Case "MAR": CurMonth = 3
            Case "APR": CurMonth = 4
            Case "MAY": CurMonth = 5
            Case "JUN": CurMonth = 6
            Case "JUL": CurMonth = 7
            Case "AUG": CurMonth = 8
            Case "SEP": CurMonth = 9
            Case "OCT": CurMonth = 10
            Case "NOV": CurMonth = 11
            Case "DEC": CurMonth = 12
        End Select

        f.HideAllControls
        f.ShowSpecificMonth
    End If
End Sub

Код модуля

В модуле (пусть назовем его CalendarModule) вставьте этот код

Option Explicit

Public Const GWL_STYLE = -16
Public Const WS_CAPTION = &HC00000

#If VBA7 Then
    #If Win64 Then
        Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _
        "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr

        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias _
        "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _
        "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr

        Private Declare Function SetWindowLongPtr Lib "user32" Alias _
        "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr
    #End If

    Public Declare PtrSafe Function DrawMenuBar Lib "user32" _
    (ByVal hwnd As LongPtr) As LongPtr

    Private Declare PtrSafe Function FindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As LongPtr

    Private Declare PtrSafe Function SetTimer Lib "user32" _
    (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
    ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr

    Public Declare PtrSafe Function KillTimer Lib "user32" _
    (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr

    Public TimerID As LongPtr

    Dim lngWindow As LongPtr, lFrmHdl As LongPtr
#Else

    Public Declare Function GetWindowLong _
    Lib "user32" Alias "GetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex As Long) As Long

    Public Declare Function SetWindowLong _
    Lib "user32" Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

    Public Declare Function DrawMenuBar _
    Lib "user32" (ByVal hwnd As Long) As Long

    Public Declare Function FindWindowA _
    Lib "user32" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long

    Public Declare Function SetTimer Lib "user32" ( _
    ByVal hwnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

    Public Declare Function KillTimer Lib "user32" ( _
    ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

    Public TimerID As Long
    Dim lngWindow As Long, lFrmHdl As Long
#End If

Public TimerSeconds As Single, tim As Boolean
Public CurMonth As Integer, CurYear As Integer
Public frmYr As Integer, ToYr As Integer

Public f As frmCalendar

Enum CalendarThemes
    Venom = 0
    MartianRed = 1
    ArcticBlue = 2
    Greyscale = 3
End Enum

Sub Launch()
    Set f = frmCalendar

    With f
        .Caltheme = Greyscale
        .LongDateFormat = "dddd dd. mmmm yyyy" '"dddd mmmm dd, yyyy" etc
        .ShortDateFormat = "dd/mm/yyyy"  '"mm/dd/yyyy" or "d/m/y" etc
        .Show
    End With
End Sub

'~~> Hide the title bar of the userform
Sub HideTitleBar(frm As Object)
    #If VBA7 Then
        Dim lngWindow As LongPtr, lFrmHdl As LongPtr
        lFrmHdl = FindWindow(vbNullString, frm.Caption)
        lngWindow = GetWindowLongPtr(lFrmHdl, GWL_STYLE)
        lngWindow = lngWindow And (Not WS_CAPTION)
        Call SetWindowLongPtr(lFrmHdl, GWL_STYLE, lngWindow)
        Call DrawMenuBar(lFrmHdl)
    #Else
        Dim lngWindow As Long, lFrmHdl As Long
        lFrmHdl = FindWindow(vbNullString, frm.Caption)
        lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)
        lngWindow = lngWindow And (Not WS_CAPTION)
        Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)
        Call DrawMenuBar(lFrmHdl)
    #End If
End Sub

'~~> Start Timer
Sub StartTimer()
    '~~ Set the timer for 1 second
    TimerSeconds = 1
    TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc)
End Sub

'~~> End Timer
Sub EndTimer()
    On Error Resume Next
    KillTimer 0&, TimerID
End Sub

'~~> Update Time
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows  ' Use LongLong and LongPtr
    Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As LongLong, _
    ByVal nIDEvent As LongPtr, ByVal dwTimer As LongLong)
        frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
        frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
    End Sub
#ElseIf VBA7 Then ' 64 bit Excel in all environments
    Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
    ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)
        frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
        frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
    End Sub
#Else ' 32 bit Excel
    Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
    ByVal nIDEvent As Long, ByVal dwTimer As Long)
        frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
        frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
    End Sub
#End If

'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(1) Get weekday name
Function wday(ByVal wd&, ByVal lang As String) As String
    ' Purpose: get weekday in "DDD" format
    wday = Application.Text(DateSerial(6, 1, wd), cPattern(lang) & "ddd")    ' the first day in year 1906 starts with a Sunday
End Function

'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(2) Get month name
Function mon(ByVal mo&, ByVal lang As String) As String
    ' Example call: mon(12, "1031") or mon(12, "de")
    mon = Application.Text(DateSerial(6, mo, 1), cPattern(lang) & "mmm")
End Function

'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(3) International patterns
Function cPattern(ByVal ctry As String) As String
    ' Purpose: return country code pattern for above functions mon() and wday()
    ' Codes: see https://msdn.microsoft.com/en-us/library/dd318693(VS.85).aspx
    ctry = LCase(Trim(ctry))
    Select Case ctry
        Case "1033", "en-us": cPattern = "[$-409]" ' English (US)
        Case "1031", "de": cPattern = "[$-C07]" ' German
        Case "1034", "es": cPattern = "[$-C0A]" ' Spanish
        Case "1036", "fr": cPattern = "[$-80C]" ' French
        Case "1040", "it": cPattern = "[$-410]" ' Italian
        ' more ...
    End Select
End Function

Код пользовательской формы

Код Userform (пусть назовем его frmCalendar) слишком велик для размещения здесь. Пожалуйста, обратитесь к образцу файла.

Скриншот

Темы

Особенности

Нет необходимости регистрировать любые DLL/OCX.
Легко распространяется. Это свободно.
Никаких прав администратора не требуется, чтобы использовать это.
Вы можете выбрать скин для виджета календаря. Можно выбрать одну из 4 тем: Venom, MartianRed, ArticBlue и GreyScale.
Выберите язык, чтобы увидеть название месяца/дня. Поддержка 4 языков.
Укажите длинные и короткие форматы даты

Образец файла

Образец файла

Благодарности @Pᴇʜ, @chrisneilsen и @TM за предложения по улучшению.

Что нового:

Исправлены ошибки, сообщаемые @RobinAipperspach и @Jose

Ответ 2

Получить международные названия дня и месяца

Этот ответ призван помочь подходу Сид в отношении интернационализации; поэтому он не повторяет другие части кода, которые я считаю достаточно понятными при создании пользовательской формы. Если хотите, я могу удалить его после включения в Vers. 4.0.

В дополнение к действительному решению Sid я демонстрирую упрощенный код для получения международных названий дней недели и месяцев - ср. Динамическое отображение названий дней недели на родном языке Excel

Модифицированная процедура ChangeLanguage в модуле формы frmCalendar

Sub ChangeLanguage(ByVal LCID As Long)
    Dim i&
    '~~> Week Day Name
     For i = 1 To 7
         Me.Controls("WD" & i).Caption = Left(wday(i, LCID), 2)
     Next i
    '~~> Month Name
     For i = 1 To 12
         Me.Controls("M" & i).Caption = Left(mon(i, LCID), 3)
     Next i
End Sub

Вызываемые функции в CalendarModule

Эти три функции могут заменить функцию LanguageTranslations(). Преимущество: короткий код, меньше памяти, простота обслуживания, правильные имена

'(1) Get weekday name
Function wday(ByVal wd&, ByVal lang As String) As String
' Purpose: get weekday in "DDD" format
  wday = Application.Text(DateSerial(6, 1, wd), cPattern(lang) & "ddd")    ' the first day in year 1906 starts with a Sunday
End Function

'(2) Get month name
Function mon(ByVal mo&, ByVal lang As String) As String
' Example call: mon(12, "1031") or mon(12, "de")
  mon = Application.Text(DateSerial(6, mo, 1), cPattern(lang) & "mmm")
End Function

'(3) International patterns
Function cPattern(ByVal ctry As String) As String
' Purpose: return country code pattern for above functions mon() and wday()
' Codes: see https://msdn.microsoft.com/en-us/library/dd318693(VS.85).aspx
ctry = lcase(trim(ctry))
Select Case ctry
  Case "1033", "en-us"
    cPattern = "[$-409]" ' English (US)
  Case "1031", "de"
    cPattern = "[$-C07]" ' German
  Case "1034", "es"
    cPattern = "[$-C0A]" ' Spanish
  Case "1036", "fr"
    cPattern = "[$-80C]" ' French
  Case "1040", "it"
    cPattern = "[$-410]" ' Italian
' more ...
End Select
End Function

Ответ 3

Я отвечаю как гость. Я извиняюсь, если это не правильно. Мне нравится этот календарь, но я нахожу четыре вещи неправильно. Я не программист, поэтому я могу ошибаться. В порядке информации, я нахожу эти проблемы в двух разных версиях Windows, но обе они работают на 64 битах. Первая проблема: календарная дата кажется на один день раньше дня недели. На этой веб-странице видно из изображений, которые отображают созданные календари, что они показывают 12 февраля в среду для 2019 года, но я вижу, что это на самом деле во вторник. Календари кажутся "выключенными" в этот день каждый месяц, каждый год. Календарные даты "выключены" по будням. Вторая проблема: при первом отображении я могу щелкнуть любую дату, и эта дата будет отображена в элементе управления Label6 внизу. Однако при первом отображении, если я нажимаю на первый день месяца, ничего не происходит, вместо этого элемент управления Label6 становится невидимым. Если я переместлю календарный месяц вперед или назад, а затем щелкну первый день какого-либо другого месяца или текущего месяца, элемент управления Label6 будет заполнен, но он отобразит неправильную дату. Третья проблема: текущая календарная дата может иметь дифференциальное форматирование. Опять же, это похоже на все даты текущего месяца, кроме первого дня месяца. Первый день не получит никакого другого форматирования. Четвертая проблема: если я включу некоторый код, такой как "ActiveCell.Value = CommandButtonEvents.Tag", он будет выполняться и работать, если нажата какая-либо командная кнопка, но не в течение первого дня команды месяца. Эта кнопка просто неактивна, код не будет выполнен. Если я переместлю календарный месяц вперед или назад, а затем щелкну первый день какого-либо другого месяца или текущего месяца, строка кода будет выполняться и работать, но так же, как элемент управления Label6 отобразит неправильную дату, строка кода также получит неправильный результат.

В помощь я могу предложить эту маленькую вещь. Я не знаю, правильно это или неправильно, но, похоже, работает. В пользовательской форме frmCalendar я нахожу некоторый код Case в подпрограмме "PopulateCalendar (d As Date)" в разделе "Выберите Case Weekday Day (dtOne, 0)". Шкафы имеют линейную форму 7,1,2,3,4,5,6. Я обнаружил, что если я поменяю номера дел и сделаю их 1,2,3,4,5,6,7 (оставив весь остальной код "неотредактированным"), это решит первую проблему: (одного дневная разница). Похоже, что календарные даты соответствуют дням недели.

Я не знаю, что делать с последними тремя проблемами. Я не программист. Я думаю, что если второе и третье решены, четвертое автоматически разрешится, но я не уверен. Эти последние проблемы могут быть связаны с некоторым кодом в подпрограмме, упомянутой выше. Я нахожу строку кода "Для я = 2 до LastDay", прямо под случаями, которые я упомянул. Этот бит кода полностью пропускает "первую" командную кнопку в текущем месяце? Это вызывает все проблемы?

Я надеюсь, что мистер Сиддхарт Роут или некоторые из вас, хорошие люди, попытаются решить эти проблемы, и этот прекрасный календарь будет работать на все 100%. Спасибо.

Ответ 4

Я думаю, что ваш образец календаря очень полезен. Я хочу использовать ваш календарь в MS Access, но я новичок в программе VBA и программе доступа. Я пытался использовать его в доступе, но не удалось.
поэтому, вы можете дать метод (шаг за шагом) для использования вашего календаря в доступе?