在 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，這非常痛苦，因為它們不是可自由分發的文件。

這是我推薦的。 您可以使用此自定義日歷來接受用戶的日期

優點：

1. 您不必擔心用戶輸入錯誤的信息
2. 您不必擔心用戶在文本框中粘貼
3. 您不必擔心編寫任何主要代碼
4. 有吸引力的圖形用戶界面
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)

這是它包含的一些功能的一小部分。 所有選項都完整記錄在用戶表單模塊中：

• 便於使用。 用戶窗體是完全獨立的，可以導入到任何 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 。
• 為標題創建另外 7 個Label控件（這將包含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_01到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

用戶窗體事件：

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過程中管理日期的位置。 哈。

Answer 5

只是為了好玩，我采納了 Siddharth 關於單獨文本框的建議並做了組合框。 如果有人感興趣，可以添加一個包含三個名為 cboDay、cboMonth 和 cboYear 的組合框的用戶表單，並將它們從左到右排列。 然后將下面的代碼粘貼到用戶窗體的代碼模塊中。 所需的組合框屬性在 UserFormInitialization 中設置，因此不需要額外的准備。

棘手的部分是更改由於年份或月份的變化而無效的日期。 此代碼只是在發生這種情況時將其重置為 01 並突出顯示 cboDay。

我已經有一段時間沒有編寫這樣的代碼了。 希望有一天它會引起某人的興趣。 如果不是，那很有趣！

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

Answer 6

為了快速解決，我通常會這樣做。

這種方法將允許用戶以他們喜歡的任何格式在文本框中輸入日期，並在完成編輯后最終以 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

然而，我認為 Sid 開發的是一種更好的方法 - 一個成熟的日期選擇器控件。

Answer 7

您也可以在文本框上使用輸入掩碼。 如果您將掩碼設置為##/##/#### ，它將始終在您鍵入時進行格式化，除了檢查輸入的內容是否為真實日期外，您無需進行任何編碼。

這只是幾行簡單的

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

Answer 8

雖然我同意下面答案中提到的內容，但建議這對於用戶表單來說是一個非常糟糕的設計，除非包含大量錯誤檢查......

為了完成您需要做的事情，對您的代碼進行最少的更改，有兩種方法。

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 ' ie 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

而他打字的結果顯示為

    12/07/2003

但是“/”字符僅在輸入 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

Answer 9

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

這對我有用。 :)

你的代碼對我幫助很大。 謝謝！

我是巴西人，我的英語很差，如有任何錯誤，請見諒。