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

Question

问题陈述

在VBA中,如果使用管理员权限注册了某些ocx,则可以使用三种主要的日期时间控件.这些是VB6控件,并不是VBA环境的原生.要安装Montview控件和日期时间选择器,我们需要设置对Microsoft MonthView Control 6.0(SP4)的引用,该引用只能通过提升的mscomct2.ocx注册来访问.同样适用于mscal.ocx和mscomctl.ocx.话虽如此,不推荐使用的mscal.ocx可能适用于Windows 10,也可能不适用.

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

该MonthView控件,日期时间选择器和过时日历控件看起来像下面.

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

如果将它们包含在项目中并将它们分发给您的朋友,邻居,客户等,则应用程序可能会也可能不会起作用,具体取决于它们是否安装了这些ocx.

因此,最好不要在项目中使用它们

我有什么选择？

这个日历使用Userform和Worksheet,之前已经提出过,并且非常基本.

当我看到从系统托盘点击日期和时间时弹出的Windows 10日历时,我忍不住想知道我们是否可以在VBA中复制它.

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

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

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

Answer 1

示例文件(在帖子末尾添加)具有Userform,Module和Class Module.要将其合并到项目中,只需从示例文件中导出Userform,Module和Class Module,然后将其导入到项目中.

类模块代码

在类模块中(让我们称之为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)代码太大,无法在此处发布.请参阅示例文件.

截图

主题

强调

1. 无需注册任何dll/ocx.
2. 易于分发.这是免费的.
3. 没有管理员权利需要使用它.
4. 您可以为日历窗口小部件选择外观.人们可以选择4种主题Venom,MartianRed,ArticBlue和GreyScale.
5. 选择语言以查看月/日名称.支持4种语言.
6. 指定长日期和短日期格式

示例文件

示例文件

Acknowlegements @Pᴇʜ,@ chrisneilsen和@TM建议改进.

Answer 2

获取国际日期和月份名称

这个答案旨在帮助 Sid 关于国际化的方法；所以它不会重复我认为足够清晰的构建用户窗体的其他代码部分。如果需要，我可以在合并到 Vers 后将其删除。4.0.

除了 Sid 的有效解决方案之外，我还演示了一个简化的代码来获取国际工作日和月份名称 - cf Dynamically display weekday names in native Excel language

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

Answer 3

这是我在这里的第一篇文章。我觉得有必要分享一下，因为 Excel 中的日历丢失是一件大事，而 SiddhartRout 创建的这个日历令人难以置信。所以，非常感谢@SiddhartRout 整理了这个非常棒的日历。我对化妆品进行了更改，但它的大部分基础内容仍然是 Siddhart 的工作，只进行了一些小的更改以满足我的用例。

外观变化：

• 用无边框标签替换了所有按钮，使其看起来更像 Windows 10 日历
• 标签的边框将在鼠标进入/退出时出现/消失
• 我将不属于当月的天数灰显。“灰色”是一种不同的颜色，更适合每个主题。
• 根据我的喜好修改了主题颜色。添加了一个标签以单击以循环浏览主题。
• 将字体更改为 Calibri
• 将鼠标输入的颜色更改添加到月/年和箭头控件
• 使用本网站满足您所有的颜色代码需求 --> RGB 颜色代码

代码更改

• 优化了属性让 Caltheme 更容易设置和添加主题颜色或全新的主题
• 我无法让“ESC 退出”可靠地工作，因此我将其替换为“X”。它也停止了崩溃。
• 删除了本地化的东西，因为我永远不需要它
• 从按钮更改为标签需要在整个项目中根据需要修改一些对象变量
• 添加了用于存储 RGB 值的公共变量，允许在整个项目中使用主题颜色，从而更一致、更轻松地应用所选主题
• 用户选择的主题存储在隐藏的工作表中，因此它在运行之间保持不变
• 删除了复选标记按钮并在任何一天单击即可直接启动。

每个主题的截图：

代码下载链接：

• Win10ExcelCal.xlsm