excel - 如何在 VBA Excel 中创建日历输入？

Question

问题陈述

在 VBA 中，如果已使用 administrator rights 注册了某些 ocx，则可以使用三种主要类型的日期时间控件。 。这些是 VB6 控件，并非 VBA 环境原生的。要安装Montview Control和日期时间选择器，我们需要设置对Microsoft MonthView Control 6.0 (SP4)的引用，该引用只能由mscomct2.ocx 的注册提升。对于 mscal.ocx 和 mscomctl.ocx 也是如此。话虽如此，已弃用的 mscal.ocx 可能会也可能不会在 Windows 10 上运行。

根据您的 Windows 和 Office 版本(32 位或 64 位)，注册这些 ocx 可能会非常痛苦。

月 View 控件、日期时间选取器和已弃用的日历控件如下所示。

如果我将这些包含在我的应用程序中，我会遇到什么问题？

如果您将它们包含在您的项目中并将其分发给您的 friend 、邻居、客户等，则应用程序可能会也可能不会工作，具体取决于他们是否安装了这些 ocx。

因此，强烈建议不要在您的项目中使用它们

我有什么选择？

这个calendar, using Userform and Worksheet ，是之前建议的，非常基础。

当我看到单击系统托盘中的日期和时间时弹出的 Windows 10 日历时，我不禁想知道我们是否可以在 VBA 中复制它。

这篇文章是关于如何创建一个日历小部件，它不依赖于任何 ocx 或 32 位/64 位，并且可以随您的项目自由分发。

这就是 Windows 10 中日历的样子:

这就是你与它交互的方式:

Answer 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

用户表单代码

用户表单(我们称之为frmCalendar)代码太大，无法在此处发布。请参阅示例文件。

屏幕截图

主题

亮点

1. 无需注册任何dll/ocx。
2. 易于分发。它是免费的。
3. 使用此功能无需管理员权限。
4. 您可以为日历小部件选择外观。您可以从 Venom、MartianRed、ArticBlue 和 GreyScale 4 个主题中进行选择。
5. 选择语言以查看月/日名称。支持 4 种语言。
6. 指定长日期和短日期格式

示例文件

Sample File

致谢 @Pᴇʜ、@chrisneilsen 和 @T.M.提出改进建议。

新增内容:

@RobinAipperspach 和 @Jose 报告的错误已修复