在VBA的文本框中格式化MM/DD/YYYY日期

Question

我正在寻找一种方法来自动将VBA文本框中的日期格式化为MM/DD/YYYY格式,我希望它在用户输入时格式化.例如,一旦用户键入第二个数字,程序将自动输入"/".现在,我使用以下代码完成了这项工作(以及第二个破折号):

Private Sub txtBoxBDayHim_Change()
    If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
    txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
End Sub

现在,这在打字时效果很好.但是,当尝试删除时,它仍然以破折号输入,因此用户无法删除其中一个短划线(删除破折号会导致长度为2或5,然后再次运行该子,添加另一个破折号).有关更好的方法的任何建议吗？

Answer 1

我从不建议使用文本框或输入框来接受日期.很多事情都可能出错.我甚至不建议使用日历控件或日期选择器,因为您需要注册mscal.ocx或mscomct2.ocx,这是非常痛苦的,因为它们不是可自由分发的文件.

这是我推荐的.您可以使用此自定义日历接受来自用户的日期

PROS:

1. 您不必担心用户输入错误信息
2. 您不必担心用户在文本框中粘贴
3. 您不必担心编写任何主要代码
4. 吸引人的GUI
5. 可以轻松地整合到您的应用程序中
6. 不使用任何需要引用mscal.ocx或mscomct2.ocx等库的控件

缺点:

嗯...嗯......想不出任何......

如何使用它

1. 下载Userform1.frm并Userform1.frx从这里.
2. 在您的VBA中,只需导入Userform1.frm,如下图所示.

导入表单

跑步

您可以在任何程序中调用它.例如

Sub Sample()
    UserForm1.Show
End Sub

屏幕拍摄动作

注意:您可能还希望将" 将日历"设置为新级别

Answer 2

这与Siddharth Rout的答案相同.但是我想要一个可以完全定制的日期选择器,以便可以根据其使用的任何项目定制外观和感觉.

您可以单击此链接下载我想出的自定义日期选择器.以下是该表格的一些截图.

要使用日期选择器,只需将CalendarForm.frm文件导入VBA项目即可.上面的每个日历都可以通过一个函数调用获得.结果只取决于您使用的参数(所有参数都是可选的),因此您可以根据需要自定义它.

例如,左侧最基本的日历可以通过以下代码行获得:

MyDateVariable = CalendarForm.GetDate

这里的所有都是它的.从那里,您只需包含您想要获得所需日历的任何参数.下面的函数调用将生成右侧的绿色日历:

MyDateVariable = CalendarForm.GetDate( _
    SelectedDate:=Date, _
    DateFontSize:=11, _
    TodayButton:=True, _
    BackgroundColor:=RGB(242, 248, 238), _
    HeaderColor:=RGB(84, 130, 53), _
    HeaderFontColor:=RGB(255, 255, 255), _
    SubHeaderColor:=RGB(226, 239, 218), _
    SubHeaderFontColor:=RGB(55, 86, 35), _
    DateColor:=RGB(242, 248, 238), _
    DateFontColor:=RGB(55, 86, 35), _
    SaturdayFontColor:=RGB(55, 86, 35), _
    SundayFontColor:=RGB(55, 86, 35), _
    TrailingMonthFontColor:=RGB(106, 163, 67), _
    DateHoverColor:=RGB(198, 224, 180), _
    DateSelectedColor:=RGB(169, 208, 142), _
    TodayFontColor:=RGB(255, 0, 0), _
    DateSpecialEffect:=fmSpecialEffectRaised)

这是它包含的一些功能的一小部分.所有选项都在userform模块中完整记录:

• 便于使用.userform是完全独立的,可以导入到任何VBA项目中,并且如果有任何其他编码,则不需要太多使用.
• 简洁,迷人的设计.
• 完全可定制的功能,大小和配色方案
• 将用户选择限制在特定日期范围内
• 选择一周中第一天的任何一天
• 包括周数,并支持ISO标准
• 单击标题中的月份或年份标签可显示可选择的组合框
• 鼠标悬停在日期后,日期会改变颜色

Answer 3

添加一些内容以跟踪长度,并允许您"检查"用户是添加还是减去文本.这是目前未经测试的,但类似的东西应该工作(特别是如果你有一个用户形式).

'add this to your userform or make it a static variable if it is not part of a userform
private oldLength as integer

Private Sub txtBoxBDayHim_Change()
    if ( oldlength > txboxbdayhim.textlength ) then
        oldlength =txtBoxBDayHim.textlength
        exit sub
    end if

    If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
    txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
    end if
    oldlength =txtBoxBDayHim.textlength
End Sub

Answer 4

我也以一种或多种方式偶然发现了同样的困境，为什么Excel VBA根本没有Date Picker。感谢Sid，他为我们所有人创造了一件很棒的工作。

但是，我到达了需要创建自己的位置的地步。我将其发布在这里，因为我敢肯定很多人都会喜欢此职位并从中受益。

除了不使用临时工作表之外，我所做的工作与Sid一样非常简单。我认为计算非常简单直接，因此无需将其转储到其他位置。这是日历的最终输出：

设置方法：

• 创建42个Label控件并按顺序命名，并从左到右，从上到下排列（此标签包含从灰色25到5上方的灰色）。将Label控件的名称更改为Label_01，Label_02等。将所有42个标签Tag属性设置为dts。
• Label为标题创建其他7个控件（其中将包含Su，Mo，Tu ...）
• 再创建2个Label控件，其中一个用于水平线（高度设置为1），另一个用于“ 月”和“年”显示。命名Label用于显示月份和年份的Label_MthYr
• 插入2个Image控件，其中一个包含左图标以滚动上个月，一个包含下个月滚动（我更喜欢简单的左右箭头图标）。命名Image_Left并Image_Right

布局应该大致像这样（我将创造力留给使用它的任何人）。

声明：
我们需要在最顶部声明​​一个变量来保存所选的当前月份。

Option Explicit
Private curMonth As Date

私人程序和功能：

Private Function FirstCalSun(ref_date As Date) As Date
    '/* returns the first Calendar sunday */
    FirstCalSun = DateSerial(Year(ref_date), _
                  Month(ref_date), 1) - (Weekday(ref_date) - 1)
End Function

Private Sub Build_Calendar(first_sunday As Date)
    '/* This builds the calendar and adds formatting to it */
    Dim lDate As MSForms.Label
    Dim i As Integer, a_date As Date

    For i = 1 To 42
        a_date = first_sunday + (i - 1)
        Set lDate = Me.Controls("Label_" & Format(i, "00"))
        lDate.Caption = Day(a_date)
        If Month(a_date) <> Month(curMonth) Then
            lDate.ForeColor = &H80000011
        Else
            If Weekday(a_date) = 1 Then
                lDate.ForeColor = &HC0&
            Else
                lDate.ForeColor = &H80000012
            End If
        End If
    Next
End Sub

Private Sub select_label(msForm_C As MSForms.Control)
    '/* Capture the selected date */
    Dim i As Integer, sel_date As Date
    i = Split(msForm_C.Name, "_")(1) - 1
    sel_date = FirstCalSun(curMonth) + i

    '/* Transfer the date where you want it to go */
    MsgBox sel_date

End Sub

图片事件：

Private Sub Image_Left_Click()

    If Month(curMonth) = 1 Then
        curMonth = DateSerial(Year(curMonth) - 1, 12, 1)
    Else
        curMonth = DateSerial(Year(curMonth), Month(curMonth) - 1, 1)
    End If

    With Me
        .Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With

End Sub

Private Sub Image_Right_Click()

    If Month(curMonth) = 12 Then
        curMonth = DateSerial(Year(curMonth) + 1, 1, 1)
    Else
        curMonth = DateSerial(Year(curMonth), Month(curMonth) + 1, 1)
    End If

    With Me
        .Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With

End Sub

我添加了它，使它看起来像用户单击标签，也应该在Image_Right控件上完成。

Private Sub Image_Left_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                                 ByVal X As Single, ByVal Y As Single)
    Me.Image_Left.BorderStyle = fmBorderStyleSingle
End Sub

Private Sub Image_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Image_Left.BorderStyle = fmBorderStyleNone
End Sub

标签事件：
应该对所有42个标签（Label_01to Lable_42）完成所有这些操作。
提示：构建前10 个标签，仅使用find和replace替换其余标签。

Private Sub Label_01_Click()
    select_label Me.Label_01
End Sub

这是用于将鼠标悬停在日期和点击效果上。

Private Sub Label_01_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BorderStyle = fmBorderStyleSingle
End Sub

Private Sub Label_01_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BackColor = &H8000000B
End Sub

Private Sub Label_01_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                             ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BorderStyle = fmBorderStyleNone
End Sub

UserForm事件：

Private Sub UserForm_Initialize()
    '/* This is to initialize everything */
    With Me
        curMonth = DateSerial(Year(Date), Month(Date), 1)
        .Label_MthYr = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With

End Sub

同样，只是为了将鼠标悬停在日期上。

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)

    With Me
        Dim ctl As MSForms.Control, lb As MSForms.Label

        For Each ctl In .Controls
            If ctl.Tag = "dts" Then
                Set lb = ctl: lb.BackColor = &H80000005
            End If
        Next
    End With

End Sub

就是这样。这是原始的，您可以添加自己的扭曲方式。
我已经使用了一段时间了，没有任何问题（性能和功能方面）。
没有Error Handling还，但可以很容易地管理我猜。
实际上，没有效果，代码太短。
您可以管理select_label程序中日期的位置。HTH。