Advertisement
Guest User

Untitled

a guest
Oct 20th, 2018
200
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "DateInputWrapper"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = False
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Explicit
  11.  
  12. Public Enum DateOrder
  13.     MDY
  14.     DMY
  15.     YMD
  16. End Enum
  17.  
  18. Private Type DateInputWrapperMembers
  19.     Delimiter As String
  20.     TwoDigitYear As Boolean
  21.     Order As DateOrder
  22.     NumericDate As String
  23. End Type
  24.  
  25. Private Const DELETE_KEY As Integer = 46
  26. Private Const BACKSPACE_KEY As Integer = 8
  27.  
  28. Private this As DateInputWrapperMembers
  29. Private WithEvents wrapped As MSForms.TextBox
  30. Attribute wrapped.VB_VarHelpID = -1
  31. Private formatting As Boolean
  32.  
  33. Private Sub Class_Initialize()
  34.     this.Delimiter = "-"
  35.     this.Order = DateOrder.YMD
  36. End Sub
  37.  
  38. Public Property Set Wrapping(ByVal rhs As MSForms.TextBox)
  39.     Set wrapped = rhs
  40. End Property
  41.  
  42. Public Property Get Wrapping() As MSForms.TextBox
  43.     Set Wrapping = wrapped
  44. End Property
  45.  
  46. Public Property Let Delimiter(ByVal rhs As String)
  47.     If Len(rhs) > 1 Then
  48.         Err.Raise 5 'invalid argument
  49.    End If
  50.     this.Delimiter = rhs
  51. End Property
  52.  
  53. Public Property Get Delimiter() As String
  54.     Delimiter = this.Delimiter
  55. End Property
  56.  
  57. Public Property Let Order(ByVal rhs As DateOrder)
  58.     this.Order = rhs
  59. End Property
  60.  
  61. Public Property Get Order() As DateOrder
  62.     Order = this.Order
  63. End Property
  64.  
  65. Public Property Let TwoDigitYear(ByVal rhs As Boolean)
  66.     this.TwoDigitYear = rhs
  67. End Property
  68.  
  69. Public Property Get TwoDigitYear() As Boolean
  70.     TwoDigitYear = this.TwoDigitYear
  71. End Property
  72.  
  73. Public Property Let DateValue(ByVal Value As Variant)
  74.     Dim valueType As VbVarType
  75.     valueType = VarType(Value)
  76.     Select Case True
  77.         Case valueType = vbDate, IsNumeric(Value)
  78.             LoadFromDate CDate(Value)
  79.             SetTextFromInternal
  80.         Case valueType = vbString
  81.             wrapped.Text = CStr(Value)
  82.         Case Else
  83.             Err.Raise 5 'invalid argument
  84.    End Select
  85. End Property
  86.  
  87. 'Output value, returns Empty if invalid.
  88. Public Property Get DateValue() As Variant
  89.     If Not IsValidDate Then Exit Property
  90.     DateValue = DateSerial(CInt(YearValue), CInt(MonthValue), CInt(DayValue))
  91. End Property
  92.  
  93. 'Returns a string suitable for passing to Format$ that matches the TextBox setup.
  94. Public Property Get DateFormat() As String
  95.     Dim yearFormat As String
  96.     yearFormat = String$(IIf(TwoDigitYear, 2, 4), "y")
  97.     Select Case Order
  98.         Case DateOrder.MDY
  99.             DateFormat = "mm" & Delimiter & "dd" & Delimiter & yearFormat
  100.         Case DateOrder.DMY
  101.             DateFormat = "dd" & Delimiter & "mm" & Delimiter & yearFormat
  102.         Case DateOrder.YMD
  103.             DateFormat = yearFormat & Delimiter & "mm" & Delimiter & "dd"
  104.     End Select
  105. End Property
  106.  
  107. Public Property Get FormattedDate() As String
  108.     ReDim elements(2) As String
  109.  
  110.     Select Case Order
  111.         Case DateOrder.MDY
  112.             elements(0) = MonthValue
  113.             elements(1) = DayValue
  114.             elements(2) = YearValue
  115.         Case DateOrder.DMY
  116.             elements(0) = DayValue
  117.             elements(1) = MonthValue
  118.             elements(2) = YearValue
  119.         Case DateOrder.YMD
  120.             elements(0) = YearValue
  121.             elements(1) = MonthValue
  122.             elements(2) = DayValue
  123.     End Select
  124.  
  125.     If elements(0) = vbNullString Then Exit Property
  126.    
  127.     Dim idx As Long
  128.     For idx = 1 To 2
  129.         If elements(idx) = vbNullString Then
  130.             ReDim Preserve elements(idx - 1)
  131.             Exit For
  132.         End If
  133.     Next
  134.     FormattedDate = Join(elements, this.Delimiter)
  135. End Property
  136.  
  137. Public Property Get IsValidDate() As Boolean
  138.     Select Case False
  139.         Case Len(YearValue) <> IIf(this.TwoDigitYear, 2, 4)
  140.         Case Len(DayValue) <> 2
  141.         Case Len(MonthValue) <> 2
  142.         Case Else
  143.             Exit Property
  144.     End Select
  145.  
  146.     Dim dayOfMonth As Long, valueOfYear As Long
  147.     dayOfMonth = CLng(DayValue)
  148.     valueOfYear = CLng(YearValue)
  149.    
  150.     If this.TwoDigitYear Then
  151.         'Note: This will break in the year 2100.
  152.        valueOfYear = valueOfYear + IIf(valueOfYear < CLng(Year(Date)) Mod 100, 2000, 1900)
  153.     ElseIf valueOfYear < 100 Then
  154.         Exit Property
  155.     End If
  156.    
  157.     Select Case CLng(MonthValue)
  158.         Case 2
  159.             If IsLeapYear(valueOfYear) Then
  160.                 IsValidDate = dayOfMonth > 0 And dayOfMonth <= 29
  161.             Else
  162.                 IsValidDate = dayOfMonth > 0 And dayOfMonth <= 28
  163.             End If
  164.         Case 4, 6, 9, 11
  165.             IsValidDate = dayOfMonth > 0 And dayOfMonth <= 30
  166.         Case 1, 3, 5, 7, 8, 10, 12
  167.             IsValidDate = dayOfMonth > 0 And dayOfMonth <= 31
  168.     End Select
  169. End Property
  170.  
  171. Private Property Get YearValue() As String
  172.     If Order = DateOrder.YMD Then
  173.         YearValue = Left$(this.NumericDate, IIf(this.TwoDigitYear, 2, 4))
  174.     Else
  175.         Dim characters As Long
  176.         characters = Len(this.NumericDate)
  177.         If characters <= 4 Then Exit Property
  178.         YearValue = Right$(this.NumericDate, characters - 4)
  179.     End If
  180. End Property
  181.  
  182. Private Property Get MonthValue() As String
  183.     Select Case Order
  184.         Case DateOrder.DMY
  185.             MonthValue = Mid$(this.NumericDate, 3, 2)
  186.         Case DateOrder.MDY
  187.             MonthValue = Left$(this.NumericDate, 2)
  188.         Case DateOrder.YMD
  189.             MonthValue = Mid$(this.NumericDate, IIf(this.TwoDigitYear, 3, 5), 2)
  190.     End Select
  191. End Property
  192.  
  193. Private Property Get DayValue() As String
  194.     Select Case Order
  195.         Case DateOrder.MDY
  196.             DayValue = Mid$(this.NumericDate, 3, 2)
  197.         Case DateOrder.DMY
  198.             DayValue = Left$(this.NumericDate, 2)
  199.         Case DateOrder.YMD
  200.             Dim characters As Long
  201.             characters = Len(this.NumericDate) - 2 - IIf(this.TwoDigitYear, 2, 4)
  202.             If characters <= 0 Then Exit Property
  203.             DayValue = Right$(this.NumericDate, characters)
  204.     End Select
  205. End Property
  206.  
  207. Private Sub LoadFromDate(ByVal Value As Date)
  208.     Dim formattedYear As String
  209.     formattedYear = Right$(CStr(Year(Value)), IIf(this.TwoDigitYear, 2, 4))
  210.    
  211.     Select Case Order
  212.         Case DateOrder.MDY
  213.             this.NumericDate = Format$(Month(Value), "00") & Format$(Day(Value), "00") & formattedYear
  214.         Case DateOrder.DMY
  215.             this.NumericDate = Format$(Day(Value), "00") & Format$(Month(Value), "00") & formattedYear
  216.         Case DateOrder.YMD
  217.             this.NumericDate = formattedYear & Format$(Month(Value), "00") & Format$(Day(Value), "00")
  218.     End Select
  219. End Sub
  220.  
  221. Private Sub wrapped_Change()
  222.     'Prevent re-entry from SetTextFromInternal
  223.    If formatting Then Exit Sub
  224.  
  225.     With Wrapping
  226.         'Handle pasting and drag-drop, and any other random input methods.
  227.        If .Text Like "*[!0-9" & Delimiter & "]*" Then
  228.             SetTextFromInternal
  229.             Exit Sub
  230.         End If
  231.         'Handle keyboard input.
  232.        this.NumericDate = Left$(Replace$(.Text, Delimiter, vbNullString), IIf(this.TwoDigitYear, 6, 8))
  233.         SetTextFromInternal
  234.     End With
  235. End Sub
  236.  
  237. 'Accept only numbers, and limit digits.
  238. Private Sub wrapped_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
  239.     If Not Chr$(KeyAscii) Like "[0-9]" Or Len(this.NumericDate) = IIf(this.TwoDigitYear, 6, 8) Then
  240.         KeyAscii.Value = 0
  241.     End If
  242. End Sub
  243.  
  244. 'Delete and backspace are handled on key-down to keep the internal version in sync.
  245. Private Sub wrapped_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  246.     With wrapped
  247.         Dim caret As Long, characters As Long
  248.         caret = .SelStart
  249.         characters = .SelLength
  250.        
  251.         If KeyCode <> BACKSPACE_KEY And KeyCode <> DELETE_KEY Then
  252.             If .SelLength > 0 Then
  253.                 'Over-typing selection.
  254.                HandleSelectionDelete .SelStart, characters
  255.             End If
  256.             Exit Sub
  257.         End If
  258.  
  259.         Dim newCaret As Long
  260.         If KeyCode = BACKSPACE_KEY And characters = 0 Then
  261.             newCaret = HandleBackspace(caret, characters)
  262.         ElseIf characters = 0 Then
  263.             newCaret = HandleDelete(caret)
  264.         Else
  265.             newCaret = HandleSelectionDelete(.SelStart, characters)
  266.         End If
  267.     End With
  268.    
  269.     SetTextFromInternal newCaret
  270.     KeyCode.Value = 0
  271. End Sub
  272.  
  273. Private Sub SetTextFromInternal(Optional ByVal caret As Variant)
  274.     'Going to change the .Text, so set the re-entry flag.
  275.    formatting = True
  276.     With wrapped
  277.         .Text = FormattedDate
  278.         If Not IsMissing(caret) Then
  279.             .SelStart = caret
  280.         End If
  281.     End With
  282.     formatting = False
  283. End Sub
  284.  
  285. Private Function HandleBackspace(ByVal caret As Long, ByVal characters As Long) As Long
  286.     With wrapped
  287.         If caret = 0 Then Exit Function
  288.         If caret = characters Then
  289.             this.NumericDate = Left$(this.NumericDate, Len(this.NumericDate) - 1)
  290.         Else
  291.             Dim adjustedCaret As Long
  292.             adjustedCaret = caret - SpannedDelimiters(Left$(.Text, caret))
  293.             this.NumericDate = Left$(this.NumericDate, adjustedCaret - 1) & _
  294.                 Right$(this.NumericDate, Len(this.NumericDate) - adjustedCaret)
  295.         End If
  296.         HandleBackspace = caret - 1
  297.     End With
  298. End Function
  299.  
  300. Private Function HandleDelete(ByVal caret As Long) As Long
  301.     With wrapped
  302.         Dim adjustedCaret As Long
  303.         adjustedCaret = caret - SpannedDelimiters(Left$(.Text, caret))
  304.         Dim characters As Long
  305.         characters = Len(this.NumericDate)
  306.        
  307.         If adjustedCaret = characters Then
  308.             HandleDelete = caret
  309.             Exit Function
  310.         End If
  311.            
  312.         If caret = 0 Then
  313.             this.NumericDate = Right$(this.NumericDate, characters - 1)
  314.         Else
  315.             this.NumericDate = Left$(this.NumericDate, adjustedCaret) & _
  316.                 Right$(this.NumericDate, characters - adjustedCaret - 1)
  317.             HandleDelete = caret + SpannedDelimiters(.SelText)
  318.         End If
  319.     End With
  320. End Function
  321.  
  322. Private Function HandleSelectionDelete(ByVal caret As Long, ByVal selected As Long) As Long
  323.     With wrapped
  324.         Dim characters As Long
  325.         characters = .TextLength
  326.        
  327.         If characters = selected Then
  328.             this.NumericDate = vbNullString
  329.         ElseIf caret = 0 Then
  330.             this.NumericDate = Right$(.Text, characters - selected)
  331.         ElseIf caret + selected = characters Then
  332.             this.NumericDate = Left$(.Text, caret)
  333.         Else
  334.             this.NumericDate = Left$(.Text, caret) & Right$(.Text, characters - selected - caret)
  335.         End If
  336.         this.NumericDate = Replace$(this.NumericDate, Delimiter, vbNullString)
  337.     End With
  338.     HandleSelectionDelete = caret
  339. End Function
  340.  
  341. Private Function SpannedDelimiters(ByVal testing As String) As Long
  342.     If testing = vbNullString Then
  343.         Exit Function
  344.     End If
  345.     SpannedDelimiters = UBound(Split(testing, Delimiter))
  346. End Function
  347.  
  348. Private Function IsLeapYear(ByVal test As Long) As Boolean
  349.     Select Case True
  350.         Case test Mod 400
  351.             IsLeapYear = True
  352.         Case test Mod 100
  353.         Case test Mod 4
  354.             IsLeapYear = True
  355.     End Select
  356. End Function
Advertisement
Advertisement
Advertisement
RAW Paste Data Copied
Advertisement