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

Formatting MM/DD/YYYY dates in textbox in VBA

提问by nobillygreen

I'm looking for a way to automatically format the date in a VBA text box to a MM/DD/YYYY format, and I want it to format as the user is typing it in. For instance, once the user types in the second number, the program will automatically type in a "/". Now, I got this working (as well as the second dash) with the following code:

我正在寻找一种方法来自动将 VBA 文本框中的日期格式化为 MM/DD/YYYY 格式，并且我希望它在用户输入时进行格式化。例如，一旦用户输入第二个数字，程序将自动输入“/”。现在，我使用以下代码完成了这项工作（以及第二个破折号）：

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

Now, this works great when typing. However, when trying to delete, it still enters in the dashes, so its impossible for the user to delete past one of the dashes (deleting a dash results in a length of 2 or 5, and the sub is then run again, adding in another dash). Any suggestions on a better way to do this?

现在，这在打字时效果很好。然而，当试图删除时，它仍然进入破折号，因此用户不可能删除超过一个破折号（删除破折号的长度为 2 或 5，然后再次运行子，添加另一个破折号）。关于更好的方法的任何建议？

回答by Siddharth Rout

I never suggest using Textboxes or Inputboxes to accept dates. So many things can go wrong. I cannot even suggest using the Calendar Control or the Date Picker as for that you need to register the mscal.ocx or mscomct2.ocx and that is very painful as they are not freely distributable files.

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

Here is what I recommend. You can use this custom made calendar to accept dates from the user

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

PROS:

优点：

1. You don't have to worry about user inputting wrong info
2. You don't have to worry user pasting in the textbox
3. You don't have to worry about writing any major code
4. Attractive GUI
5. Can be easily incorporated in your application
6. Doesn't use any controls for which you need to reference any libraries like mscal.ocx or mscomct2.ocx

1. 您不必担心用户输入错误的信息
2. 您不必担心用户在文本框中粘贴
3. 您不必担心编写任何主要代码
4. 有吸引力的图形用户界面
5. 可以轻松集成到您的应用程序中
6. 不使用您需要引用任何库（如 mscal.ocx 或 mscomct2.ocx）的任何控件

CONS:

缺点：

Ummm...Ummm... Can't think of any...

嗯……嗯……想不到任何……

HOW TO USE IT (File missing from my dropbox. Please refer to the bottom of the post for an upgraded version of the calendar)

如何使用它（我的保管箱中缺少文件。日历的升级版本请参阅帖子底部）

1. Download the Userform1.frmand Userform1.frxfrom here.
2. In your VBA, simply import Userform1.frmas shown in the image below.

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

Importing the form

导入表单

RUNNING IT

运行它

You can call it in any procedure. For example

您可以在任何过程中调用它。例如

Sub Sample()
    UserForm1.Show
End Sub

SCREEN SHOTS IN ACTION

实际操作中的屏幕截图

NOTE: You may also want to see Taking Calendar to new level

注意：您可能还想查看将日历提升到新水平

回答by Trevor Eyre

This is the same concept as Siddharth Rout's answer. But I wanted a date picker which could be fully customized so that the look and feel could be tailored to whatever project it's being used in.

这与 Siddharth Rout 的回答的概念相同。但我想要一个可以完全定制的日期选择器，这样外观和感觉可以根据它正在使用的任何项目进行定制。

You can click this linkto download the custom date picker I came up with. Below are some screenshots of the form in action.

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

To use the date picker, simply import the CalendarForm.frm file into your VBA project. Each of the calendars above can be obtained with one single function call. The result just depends on the arguments you use (all of which are optional), so you can customize it as much or as little as you want.

要使用日期选择器，只需将 CalendarForm.frm 文件导入到您的 VBA 项目中。上述每个日历都可以通过一次函数调用获得。结果仅取决于您使用的参数（所有这些都是可选的），因此您可以根据需要尽可能多地或尽可能少地对其进行自定义。

For example, the most basic calendar on the left can be obtained by the following line of code:

比如左边最基础的日历可以通过下面这行代码获取：

MyDateVariable = CalendarForm.GetDate

That's all there is to it. From there, you just include whichever arguments you want to get the calendar you want. The function call below will generate the green calendar on the right:

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

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)

Here is a small taste of some of the features it includes. All options are fully documented in the userform module itself:

这是它包含的一些功能的一小部分。所有选项都完整记录在用户表单模块中：

• Ease of use. The userform is completely self-contained, and can be imported into any VBA project and used without much, if any additional coding.
• Simple, attractive design.
• Fully customizable functionality, size, and color scheme
• Limit user selection to a specific date range
• Choose any day for the first day of the week
• Include week numbers, and support for ISO standard
• Clicking the month or year label in the header reveals selectable comboboxes
• Dates change color when you mouse over them

• 便于使用。用户窗体是完全独立的，可以导入到任何 VBA 项目中，无需太多额外编码即可使用。
• 简单，有吸引力的设计。
• 完全可定制的功能、尺寸和配色方案
• 将用户选择限制在特定日期范围内
• 为一周的第一天选择任何一天
• 包括周数，并支持 ISO 标准
• 单击标题中的月份或年份标签会显示可选择的组合框
• 当您将鼠标悬停在日期上时，日期会改变颜色

回答by enderland

Add something to track the length and allow you to do "checks" on whether the user is adding or subtracting text. This is currently untested but something similar to this should work (especially if you have a userform).

添加一些内容来跟踪长度，并允许您“检查”用户是否正在添加或减去文本。这是目前未经测试的，但类似的东西应该可以工作（特别是如果你有一个用户表单）。

'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

回答by L42

I too, one way or another stumbled on the same dilemma, why the heck Excel VBA doesn't have a Date Picker. Thanks to Sid, who made an awesome job to create something for all of us.

我也以某种方式偶然发现了同样的困境，为什么 Excel VBA 没有Date Picker. 感谢 Sid，他出色地为我们所有人创造了一些东西。

Nonetheless, I came to a point where I need to create my own. And I am posting it here since a lot of people I'm sure lands on this post and benefit from it.

尽管如此，我还是到了需要创建自己的地步。我把它张贴在这里，因为我确信很多人都登陆了这篇文章并从中受益。

What I did was very simple as what Sid does except that I do not use a temporary worksheet. I thought the calculations are very simple and straight forward so there's no need to dump it somewhere else. Here's the final output of the calendar:

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

How to set it up:

如何设置：

• Create 42 Labelcontrols and name it sequentially and arranged left to right, top to bottom (This labels contains greyed 25up to greyed 5above). Change the name of the Labelcontrols to Label_01,Label_02and so on. Set all 42 labels Tagproperty to dts.
• Create 7 more Labelcontrols for the header (this will contain Su,Mo,Tu...)
• Create 2 more Labelcontrol, one for the horizontal line (height set to 1) and one for the Month and Yeardisplay. Name the Labelused for displaying month and year Label_MthYr
• Insert 2 Imagecontrols, one to contain the left icon to scroll previous months and one to scroll next month (I prefer simple left and right arrow head icon). Name it Image_Leftand Image_Right

• 创建 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

The layout should be more or less like this (I leave the creativity to anyone who'll use this).

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

Declaration:
We need one variable declared at the very top to hold the current month selected.

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

Option Explicit
Private curMonth As Date

Private Procedure and Functions:

私有过程和函数：

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

Image Events:

图像事件：

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

---

---

I added this to make it look like the user is clicking the label and should be done on the Image_Rightcontrol too.

我添加了这个，让它看起来像用户正在点击标签，也应该在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

Label Events:
All of this should be done for all 42 labels (Label_01to Lable_42)
Tip:Build the first 10 and just use find and replace for the remaining.

标签事件：
所有这一切都应该对所有 42 个标签 ( Label_01to Lable_42) 完成
提示：构建前 10 个，对其余的只使用查找和替换。

Private Sub Label_01_Click()
    select_label Me.Label_01
End Sub

---

---

This is for hovering over dates and clicking effect.

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

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 Events:

用户窗体事件：

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

---

---

Again, just for the hovering over dates effect.

同样，仅用于悬停日期效果。

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

And that's it. This is raw and you can add your own twist to it.
I've been using this for awhile and I have no issues (performance and functionality wise).
No Error Handlingyet but can be easily managed I guess.
Actually, without the effects, the code is too short.
You can manage where your dates go in the select_labelprocedure. HTH.

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

回答by Doug Glancy

Just for fun I took Siddharth's suggestion of separate textboxes and did comboboxes. If anybody's interested, add a userform with three comboboxes named cboDay, cboMonth and cboYear and arrange them left to right. Then paste the code below into the UserForm's code module. The required combobox properties are set in UserFormInitialization, so no additional prep should be required.

只是为了好玩，我采纳了 Siddharth 关于单独文本框的建议并做了组合框。如果有人感兴趣，可以添加一个包含三个名为 cboDay、cboMonth 和 cboYear 的组合框的用户表单，并将它们从左到右排列。然后将下面的代码粘贴到用户窗体的代码模块中。所需的组合框属性在 UserFormInitialization 中设置，因此不需要额外的准备。

The tricky part is changing the day when it becomes invalid because of a change in year or month. This code just resets it to 01 when that happens and highlights cboDay.

棘手的部分是更改由于年份或月份的变化而无效的日期。此代码只是在发生这种情况时将其重置为 01 并突出显示 cboDay。

I haven't coded anything like this in a while. Hopefully it will be of interest to somebody, someday. If not it was fun!

我已经有一段时间没有编写这样的代码了。希望有一天它会引起某人的兴趣。如果不是，那很有趣！

Dim Initializing As Boolean

Private Sub UserForm_Initialize()
Dim i As Long
Dim ctl As MSForms.Control
Dim cbo As MSForms.ComboBox

Initializing = True
With Me
    With .cboMonth
        '        .AddItem "month"
        For i = 1 To 12
            .AddItem Format(i, "00")
        Next i
        .Tag = "DateControl"
    End With
    With .cboDay
        '        .AddItem "day"
        For i = 1 To 31
            .AddItem Format(i, "00")
        Next i
        .Tag = "DateControl"
    End With
    With .cboYear
        '        .AddItem "year"
        For i = Year(Now()) To Year(Now()) + 12
            .AddItem i
        Next i
        .Tag = "DateControl"
    End With
    DoEvents
    For Each ctl In Me.Controls
        If ctl.Tag = "DateControl" Then
            Set cbo = ctl
            With cbo
                .ListIndex = 0
                .MatchRequired = True
                .MatchEntry = fmMatchEntryComplete
                .Style = fmStyleDropDownList
            End With
        End If
    Next ctl
End With
Initializing = False
End Sub

Private Sub cboDay_Change()
If Not Initializing Then
    If Not IsValidDate Then
        ResetMonth
    End If
End If
End Sub

Private Sub cboMonth_Change()
If Not Initializing Then
    ResetDayList
    If Not IsValidDate Then
        ResetMonth
    End If
End If
End Sub

Private Sub cboYear_Change()
If Not Initializing Then
    ResetDayList
    If Not IsValidDate Then
        ResetMonth
    End If
End If
End Sub

Function IsValidDate() As Boolean
With Me
    IsValidDate = IsDate(.cboMonth & "/" & .cboDay & "/" & .cboYear)
End With
End Function
Sub ResetDayList()
Dim i As Long
Dim StartDay As String

With Me.cboDay
    StartDay = .Text
    For i = 31 To 29 Step -1
        On Error Resume Next
        .RemoveItem i - 1
        On Error GoTo 0
    Next i
    For i = 29 To 31
        If IsDate(Me.cboMonth & "/" & i & "/" & Me.cboYear) Then
            .AddItem Format(i, "0")
        End If
    Next i
    On Error Resume Next
    .Text = StartDay
    If Err.Number <> 0 Then
        .SetFocus
        .ListIndex = 0
    End If
End With
End Sub

Sub ResetMonth()
Me.cboDay.ListIndex = 0
End Sub

回答by Pradeep Kumar

For a quick solution, I usually do like this.

为了快速解决，我通常会这样做。

This approach will allow the user to enter date in any format they like in the textbox, and finally format in mm/dd/yyyy format when he is done editing. So it is quite flexible:

这种方法将允许用户以他们喜欢的任何格式在文本框中输入日期，并在完成编辑后最终以 mm/dd/yyyy 格式输入日期。所以它非常灵活：

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If TextBox1.Text <> "" Then
        If IsDate(TextBox1.Text) Then
            TextBox1.Text = Format(TextBox1.Text, "mm/dd/yyyy")
        Else
            MsgBox "Please enter a valid date!"
            Cancel = True
        End If
    End If
End Sub

However, I think what Sid developed is a much better approach - a full fledged date picker control.

然而，我认为 Sid 开发的是一种更好的方法 - 一个成熟的日期选择器控件。

回答by Brad

You could use an input mask on the text box, too. If you set the mask to ##/##/####it will always be formatted as you type and you don't need to do any coding other than checking to see if what was entered was a true date.

您也可以在文本框上使用输入掩码。如果您将掩码设置为##/##/####它，它将始终在您键入时进行格式化，除了检查输入的内容是否为真实日期外，您无需进行任何编码。

Which just a few easy lines

这只是几行简单的

txtUserName.SetFocus
If IsDate(txtUserName.text) Then
    Debug.Print Format(CDate(txtUserName.text), "MM/DD/YYYY")
Else
    Debug.Print "Not a real date"
End If

回答by hnk

While I agree with what's mentioned in the answers below, suggesting that this is a very bad design for a Userform unless copious amounts of error checks are included...

虽然我同意下面答案中提到的内容，但建议这对于用户表单来说是一个非常糟糕的设计，除非包含大量错误检查......

to accomplish what you need to do, with minimal changesto your code, there are two approaches.

为了完成您需要做的事情，对您的代码进行最少的更改，有两种方法。

1. Use KeyUp()event instead of Change event for the textbox. Here is an example:

   Private Sub TextBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   
       Dim TextStr As String
       TextStr = TextBox2.Text
   
       If KeyCode <> 8 Then ' i.e. not a backspace
   
           If (Len(TextStr) = 2 Or Len(TextStr) = 5) Then
               TextStr = TextStr & "/"
           End If
   
       End If
       TextBox2.Text = TextStr
   End Sub
   

2. Alternately, if you need to use the Change()event, use the following code. This alters the behavior so the user keeps entering the numbers, as

   12072003
   

1. 对文本框使用KeyUp()事件而不是 Change 事件。下面是一个例子：

   Private Sub TextBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   
       Dim TextStr As String
       TextStr = TextBox2.Text
   
       If KeyCode <> 8 Then ' i.e. not a backspace
   
           If (Len(TextStr) = 2 Or Len(TextStr) = 5) Then
               TextStr = TextStr & "/"
           End If
   
       End If
       TextBox2.Text = TextStr
   End Sub
   

2. 或者，如果您需要使用Change()事件，请使用以下代码。这会改变行为，因此用户不断输入数字，如

   12072003
   

while the result as he's typing appears as

而他打字的结果显示为

    12/07/2003

But the '/' character appears only once the first character of the DD i.e. 0 of 07 is entered. Not ideal, but will still handle backspaces.

但是“/”字符仅在输入 DD 的第一个字符即 0 的 07 时出现。不理想，但仍会处理退格。

    Private Sub TextBox1_Change()
        Dim TextStr As String

        TextStr = TextBox1.Text

        If (Len(TextStr) = 3 And Mid(TextStr, 3, 1) <> "/") Then
            TextStr = Left(TextStr, 2) & "/" & Right(TextStr, 1)
        ElseIf (Len(TextStr) = 6 And Mid(TextStr, 6, 1) <> "/") Then
            TextStr = Left(TextStr, 5) & "/" & Right(TextStr, 1)
        End If

        TextBox1.Text = TextStr
    End Sub

回答by Lucas

Private Sub txtBoxBDayHim_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then 'only numbers and backspace
    If KeyAscii = 8 Then 'if backspace, ignores + "/"
    Else
        If txtBoxBDayHim.TextLength = 10 Then 'limit textbox to 10 characters
        KeyAscii = 0
        Else
            If txtBoxBDayHim.TextLength = 2 Or txtBoxBDayHim.TextLength = 5 Then 'adds / automatically
            txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
            End If
        End If
    End If
Else
KeyAscii = 0
End If
End Sub

This works for me. :)

这对我有用。:)

Your code helped me a lot. Thanks!

你的代码对我帮助很大。谢谢！

I'm brazilian and my english is poor, sorry for any mistake.

我是巴西人，我的英语很差，如有任何错误，请见谅。