Question

问题陈述

在VBA中，只要已使用administrator rights注册了某些ocx，就可以使用三种主要的日期时间控件。这些是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位）的不同，注册这些ocx可能非常痛苦。

Monthview控件， Datetime Picker 和不推荐使用的日历控件如下所示。

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

如果将它们包含在项目中并分发给您的朋友，邻居，客户等，则该应用程序可能会或可能不会运行，这取决于他们是否安装了ocx。

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

我有什么选择？

此calendar, using Userform and Worksheet是较早提出的，非常基础。

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

这篇文章是关于如何创建日历 widget 的，该日历不依赖任何ocx或32bit / 64bit，并且可以随项目自由分发。

这是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）代码太大，无法在此处发布。请参考示例文件。

屏幕截图

主题

要点

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

示例文件

Sample File

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

Answer 2

获取国际日期和月份名称

此答案旨在帮助Sid处理国际化的方法；因此它不会重复我认为足够清楚地构建UserForm的其他代码部分。如果需要，可以在合并到Vers中后将其删除。 4.0

除了Sid的有效解决方案外，我还演示了简化的代码来获取国际工作日和月份名称 -c.f. 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 Color Codes

代码更改

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

每个主题的屏幕截图：

下载代码链接：

Win10ExcelCal.xlsm

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

3 个答案: