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 Val1OArgs(), Val1OIndex As Integer
Function S_Val1(ByVal text) As Variant
On Error Resume Next
KillTimer 0&, gTimerID: gTimerID = 0
S_Val1 = ""
Dim K As Integer
K = UBound(Val1OArgs)
ReDim Preserve Val1OArgs(1 To K + 1)
Val1OArgs(K + 1) = VBA.Array(text, Application.Caller)
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Val1_callback)
End Function
Private Sub S_Val1_callback()
On Error Resume Next
Call KillTimer(0&, gTimerID): gTimerID = 0
Call KillTimer(0&, gTimerID2): gTimerID2 = 0
Dim UA As Integer
UA = UBound(Val1OArgs)
On Error GoTo 0
If UA > 0 Then
Val1OIndex = Val1OIndex + 1
Val1OArgs(Val1OIndex)(1).Formula = "=" & S_Val3(Val1OArgs(Val1OIndex)(0))
If Val1OIndex >= UA Then
Erase Val1OArgs: Val1OIndex = 0
Else
gTimerID2 = SetTimer(0&, 0&, 1, AddressOf S_Val1_callback2)
End If
End If
End Sub
Private Sub S_Val1_callback2()
S_Val1_callback
End Sub
Private Sub S_Val_test()
S_Val2 ("TL = 1.013.030*20/78/5,34*1+1.013.030*33/78/4,34*1 = 147.396 d")
End Sub
Function S_Val2(text)
S_Val2 = S_ValE("\= ((?:[\u0000-\u003C\u003E-\uFFFF])+) .{1,3}$", text)
S_Val2 = CDec(Replace(S_Val2, ".", ""))
End Function
Function S_Val3(text)
S_Val3 = S_ValE("(?:TL *= *)*(?:TL *= *)(.*?) *\=", text)
If Application.International(xlDecimalSeparator) = "." Then
S_Val3 = Replace(S_Val3, ".", "")
S_Val3 = Replace(S_Val3, ",", ".")
End If
End Function
Function S_ValE(ByVal pattern$, _
ByVal text$, _
Optional ByVal FrontText As String = "", _
Optional ByVal BehindText As String = "", _
Optional ByVal InSubMatches As Integer = -1, _
Optional ByVal InMatchs As Integer = -1, _
Optional ByVal bEvaluate As Boolean = False, _
Optional ByVal bGlobal As Boolean = True, _
Optional ByVal IgnoreCase As Boolean = True, _
Optional ByVal bMulLine As Boolean = True, _
Optional ByVal Delimiter As String = "")
With VBA.CreateObject("VBScript.RegExp")
.Global = bGlobal: .IgnoreCase = IgnoreCase: .MultiLine = bMulLine: .pattern = pattern
Dim M, M2, N, N2, i%, j%, s$
Set M = .Execute(text)
If M.Count Then
If InMatchs >= 0 Then
If InMatchs < M.Count Then i = InMatchs: GoSub SubMatches
Else
For i = 0 To M.Count - 1: GoSub SubMatches: Next
End If
If s <> "" Then
s = FrontText & s & BehindText
If bEvaluate Then
S_ValE = Application.Evaluate(s)
Else
S_ValE = s
End If
End If
End If
End With
Exit Function:
SubMatches:
Set N = M(i).SubMatches
If N.Count Then
If InSubMatches >= 0 Then
If InSubMatches < N.Count Then
s = s & IIf(s = "", "", Delimiter) & N(InSubMatches)
End If
Else
For j = 0 To N.Count - 1
s = s & IIf(s = "", "", Delimiter) & N(j)
Next
End If
Else
s = s & IIf(s = "", "", Delimiter) & M(i)
End If
Return
End Function
Function S_ValR(ByVal pattern$, _
ByVal sReplace$, _
ByVal text$, _
Optional ByVal FrontText As String = "", _
Optional ByVal BehindText As String = "", _
Optional ByVal bEvaluate As Boolean = False, _
Optional ByVal bGlobal As Boolean = True, _
Optional ByVal IgnoreCase As Boolean = True, _
Optional ByVal bMulLine As Boolean = True)
With VBA.CreateObject("VBScript.RegExp")
.Global = bGlobal: .IgnoreCase = IgnoreCase: .MultiLine = bMulLine: .pattern = pattern
Dim s$
If .test(text) Then
s = FrontText & .Replace(text, sReplace) & BehindText
If bEvaluate Then
S_ValR = Application.Evaluate(s)
Else
S_ValR = s
End If
End If
End With
End Function
