Private Sub fld_date_Change()
    Dim DatBox As Object
    Set DatBox = Me.ActiveControl
    If Len(DatBox) = 2 And Right$(DatBox, 1) = "." Then DatBox = "0" & DatBox
    If Len(DatBox) = 5 And Right$(DatBox, 1) = "." Then _
       DatBox = Left$(DatBox, 3) & "0" & Right$(DatBox, 2)
    If (Len(DatBox) = 3 Or Len(DatBox) = 6) And Right$(DatBox, 1) <> "." Then
        DatBox = Left$(DatBox, Len(DatBox) - 1) & "." & Right$(DatBox, 1)
    End If
    Set DatBox = Nothing
End Sub

Private Sub fld_date_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
        fld_date.MaxLength = 10
        KeyAscii = DatBox_KeyPress(KeyAscii)
End Sub
Function DatBox_KeyPress(ByVal KeyAsci As Integer)
    Select Case KeyAsci
    Case 48 To 57: DatBox_KeyPress = KeyAsci
    Case 44 To 47, 58: DatBox_KeyPress = 46
    Case Else: DatBox_KeyPress = 0
    End Select
End Function

Private Sub fld_date_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Dim Cancl As Boolean, datText$
    Dim fUsFr As Object: Set fUsFr = Me
    Dim DatBox As Object: Set DatBox = Me.ActiveControl
    If Len(DatBox) Then Else GoTo Cancel_
    datText = Left$(DatBox.Text, 5)
    If Len(datText) = 4 Then datText = Left$(datText, 3) & "0" & Right$(datText, 1)
    If Len(DatBox) = 6 Then DatBox = datText
    If IsDate(DatBox) Then
        If datText <> Format(DatBox, "DD.MM") Then GoTo err_
        DatBox = Format(DatBox, "DD.MM.YYYY"): GoTo Cancel_
    End If
err_:
    MsgBox "Ошибка ввода даты!", vbExclamation, "ПРОВЕРКА ДАТЫ"
    With fUsFr.Controls(DatBox.Name)
        .SelStart = 0: .SelLength = Len(DatBox.Text)
    End With
    Cancl = True
Cancel_:
    Set DatBox = Nothing: Set fUsFr = Nothing

    Cancel = Cancl
End Sub