Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
#If Win64 Then
Private gTimerID As LongPtr, gTimerID2 As LongPtr
#Else
Private gTimerID As Long, gTimerID2 As Long
#End If
Private Text2Date_OArgs(), Text2Date_OIndex As Integer
Function S_Text2Date(ByVal Target As Range, _
Optional ByVal fromFormat As String = "", _
Optional ByVal FormatCell As String = "dd/mm/yyyy", _
Optional ByVal ClearFormula As Boolean) As Variant
On Error Resume Next
KillTimer 0&, gTimerID: gTimerID = 0
S_Text2Date = ""
Dim K As Integer
K = UBound(Text2Date_OArgs)
ReDim Preserve Text2Date_OArgs(1 To K + 1)
Text2Date_OArgs(K + 1) = VBA.Array(Target, fromFormat, FormatCell, Application.Caller, ClearFormula)
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Text2Date_callback)
End Function
Private Sub S_Text2Date_callback()
On Error Resume Next
Call KillTimer(0&, gTimerID): gTimerID = 0
Call KillTimer(0&, gTimerID2): gTimerID2 = 0
Dim UA As Integer
UA = UBound(Text2Date_OArgs)
On Error GoTo 0
If UA > 0 Then
Text2Date_OIndex = Text2Date_OIndex + 1
Dim Args As Variant, R As Long, total(), UB As Long, LR As Long
Args = Text2Date_OArgs(Text2Date_OIndex)
Dim R1 As Range, A1 As Variant, FF As String, FC As String, tmp As String, tmp2 As String
Set R1 = Args(0): FF = Args(1): FC = Args(2):
UB = R1.Rows.Count: A1 = R1.Value2
ReDim total(1 To UB, 1 To 1)
LR = R1(UB + 2, 1).End(3).Row - R1.Row + 1
If LR > 0 Then
Dim y, d, m1, m2, h, s, i As Integer
For R = 1 To LR
A1(R, 1) = CStr(A1(R, 1))
If Len(A1(R, 1)) >= Len(FF) And Len(FF) > 6 Then
y = 0: d = 0: m1 = 0: m2 = 0: h = 0: s = 0
For i = 1 To Len(FF)
tmp = Mid(FF, i, 1)
tmp2 = Mid(A1(R, 1), i, 1)
Select Case True
Case tmp Like "[Yy]": y = y & tmp2
Case tmp Like "[Dd]": d = d & tmp2
Case tmp Like "[M]": m1 = m1 & tmp2
Case tmp Like "[hH]": d = d & tmp2
Case tmp Like "[sS]": s = s & tmp2
Case tmp Like "[m]": m2 = m2 & tmp2
End Select
Next
total(R, 1) = DateSerial(y, m1, d) + TimeSerial(h, m2, s)
End If
Next
R1.value = total
R1.NumberFormat = FC
End If
If Args(4) Then Args(3).value = ""
If Text2Date_OIndex >= UA Then
Erase Text2Date_OArgs: Text2Date_OIndex = 0
Else
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Text2Date_callback2)
End If
End If
End Sub
Private Sub S_Text2Date_callback2()
S_Text2Date_callback
End Sub
