Fatal编程技术网
  • excel/
  • Excel 在VBA的文本框中格式化MM/DD/YYYY日期

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

excel vba user-interface

Excel 在VBA的文本框中格式化MM/DD/YYYY日期,excel,vba,user-interface,Excel,Vba,User Interface,我正在寻找一种将VBA文本框中的日期自动格式化为MM/DD/YYYY格式的方法，我希望在用户键入日期时对其进行格式化。例如，一旦用户键入第二个数字，程序将自动键入“/”。现在，我用以下代码实现了这一点（以及第二个破折号）： Private Sub txtBoxBDayHim_Change() If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then txtBoxBDayHim.Text = txtBo

我正在寻找一种将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，然后再次运行子，添加另一个破折号）。关于更好的方法有什么建议吗？

添加一些跟踪长度的内容，并允许您“检查”用户是添加还是删除文本。这目前还没有经过测试，但是类似的东西应该可以工作（特别是如果您有一个userform）

只是为了好玩，我采纳了Siddharth关于单独文本框的建议，并制作了组合框。如果有人感兴趣，可以添加一个userform，其中包含三个组合框cboDay、cboMonth和cboYear，并将它们从左到右排列。然后将下面的代码粘贴到UserForm的代码模块中。所需的组合框属性在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

Dim初始化为布尔值
私有子用户表单_初始化（）
我想我会坚持多久
作为MSForms.Control的Dim ctl
将cbo设置为MSForms.ComboBox
初始化=真
和我一起
和cboMonth先生在一起
“.附加项“月”
对于i=1到12
.AddItem格式（i，“00”）
接下来我
.Tag=“日期控制”
以
今天下午好吗
“.附加项“日”
对于i=1到31
.AddItem格式（i，“00”）
接下来我
.Tag=“日期控制”
以
和cboYear一起
“.补充“年”
i=年（现在（））到年（现在（））+12
A.AddItem i
接下来我
.Tag=“日期控制”
以
多芬特
对于Me.Controls中的每个ctl
如果ctl.Tag=“DateControl”，则
设置cbo=ctl
与国会预算办公室
.ListIndex=0
.MatchRequired=True
.MatchEntry=fmMatchEntryComplete
.Style=fmStyleDropDownList
以
如果结束
下一个ctl
以
初始化=错误
端接头
私人分包合同变更（）
如果没有初始化，那么
如果不是IsValidDate，那么
重置月份
如果结束
如果结束
端接头
私人分公司cboMonth_变更（）
如果没有初始化，那么
重置日列表
如果不是IsValidDate，那么
重置月份
如果结束
如果结束
端接头
私人分公司cboYear_变更（）
如果没有初始化，那么
重置日列表
如果不是IsValidDate，那么
重置月份
如果结束
如果结束
端接头
函数IsValidDate（）为布尔值
和我一起
IsValidDate=IsDate（.cboMonth&“/”&.cboDay&“/”&.cboYear）
以
端函数
子重置日列表（）
我想我会坚持多久
将开始日期设置为字符串
今天和我一起去
开始日期=.Text
对于i=31至29，步骤-1
出错时继续下一步
.RemoveItem i-1
错误转到0
接下来我
对于i=29到31
如果是IsDate（Me.cboMonth&“/”&i&“/”&Me.cboYear），那么
.AddItem格式（i，“0”）
如果结束
接下来我
出错时继续下一步
.Text=开始日期
如果错误号为0，则
.SetFocus
.ListIndex=0
如果结束
以
端接头
次月（）
Me.cboDay.ListIndex=0
端接头
我从不建议使用文本框或输入框来接受日期。很多事情都会出错。我甚至不能建议使用日历控件或日期选择器，因为您需要注册mscal.ocx或mscomct2.ocx，这非常痛苦，因为它们不是可自由分发的文件

以下是我的建议。您可以使用此自定义日历接受用户的日期

专业人士：

  • 你不必担心用户输入错误的信息
  • 您不必担心用户粘贴到文本框中
  • 您不必担心编写任何主要代码
  • 迷人的GUI
  • 可以轻松地合并到您的应用程序中
  • 不使用任何需要引用任何库（如mscal.ocx或mscomct2.ocx）的控件
    • 缺点：

    嗯…嗯。。。想不出任何

    如何使用它（我的dropbox中缺少文件。有关日历的升级版本，请参阅文章底部）

  • 从下载
    Userform1.frm
    和
    Userform1.frx
  • 在VBA中，只需导入
    Userform1.frm
    ，如下图所示
    • 导入表单

    运行它

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

    Sub Sample()
    UserForm1.Show
End Sub
    屏幕截图正在运行中

    注意：您可能还想查看

    以获得快速解决方案，我通常这样做

    这种方法将允许用户在文本框中以他们喜欢的任何格式输入日期，最后在编辑完成后以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

    Private子文本框1_退出（ByVal取消为MSForms.ReturnBoolean）
如果是TextBox1.Text“”，则
如果是IsDate（TextBox1.Text），则
TextBox1.Text=格式（TextBox1.Text，“mm/dd/yyyy”）
其他的
MsgBox“请输入有效日期！”
取消=真
如果结束
如果结束
端接头
    然而，我认为Sid开发的是一种更好的方法—一个成熟的日期选择器控件。

    您也可以在文本框上使用输入掩码。如果将掩码设置为
    #

    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

    

    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

    

    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

    

    12072003

    

        12/07/2003

    

        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

    

    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)

    

    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

    

    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

    

    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

    

    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