Option Explicit
Declare Sub GetMem2 Lib "msvbvm60" (Src As Any, Dst As Any)
Declare Sub RtlMoveMemory Lib "kernel32" (Dst As Any, Src As Any, ByVal Bytes As Long)
Const EXMPL = "1A136902RN010 1A101402OT010 1A158802GEM20 115788DW5 115788GH5 1157SD5"
Const N& = 100000
Sub test()
Dim d$(), t!, i&, j&, s$
d = Split(EXMPL)
'прогрев и сравнение результатов
For j = 0 To UBound(d)
s = insertSpacesS(d(j))
If s <> a(d(j)) Or s <> a1(d(j)) Or s <> a2(d(j)) Or s <> a3(d(j)) Then Stop
If s <> insertSpaces2(d(j)) Or s <> a5(d(j)) Or s <> a6(d(j)) Or s <> a7(d(j)) Then Stop
Next
'забег
DoEvents: t = Timer
For i = 1 To N \ 50
For j = 0 To UBound(d)
insertSpaces d(j)
Next
Next
Debug.Print "insertSpaces", (Timer - t) * 50, "экстраполировано"
DoEvents: t = Timer
For i = 1 To N
For j = 0 To UBound(d)
insertSpacesS d(j)
Next
Next
Debug.Print "insertSpacesS", Timer - t
DoEvents: t = Timer
For i = 1 To N
For j = 0 To UBound(d)
insertSpaces2 d(j)
Next
Next
Debug.Print "insertSpaces2", Timer - t
DoEvents: t = Timer
For i = 1 To N
For j = 0 To UBound(d)
a d(j)
Next
Next
Debug.Print "a", Timer - t
DoEvents: t = Timer
For i = 1 To N
For j = 0 To UBound(d)
a1 d(j)
Next
Next
Debug.Print "a1", Timer - t
DoEvents: t = Timer
For i = 1 To N
For j = 0 To UBound(d)
a2 d(j)
Next
Next
Debug.Print "a2", Timer - t
DoEvents: t = Timer
For i = 1 To N
For j = 0 To UBound(d)
a3 d(j)
Next
Next
Debug.Print "a3", Timer - t
DoEvents: t = Timer
For i = 1 To N
For j = 0 To UBound(d)
a5 d(j)
Next
Next
Debug.Print "a5", Timer - t
DoEvents: t = Timer
For i = 1 To N
For j = 0 To UBound(d)
a6 d(j)
Next
Next
Debug.Print "a6", Timer - t
DoEvents: t = Timer
For i = 1 To N
For j = 0 To UBound(d)
a7 d(j)
Next
Next
Debug.Print "a7", Timer - t
End Sub
Public Function insertSpaces(ByVal intoText As String) As String
Dim pReg As Object
Set pReg = CreateObject("VBScript.RegExp")
pReg.Global = True: pReg.Pattern = "(\d(?=\D)|\D(?=\d))"
insertSpaces = pReg.Replace(intoText, "$1 ")
End Function
Public Function insertSpacesS(intoText As String) As String
Static pReg As Object
On Error GoTo 1
insertSpacesS = pReg.Replace(intoText, "$1 ")
Exit Function
1 Set pReg = CreateObject("VBScript.RegExp")
pReg.Global = True: pReg.Pattern = "(\d(?=\D)|\D(?=\d))"
Resume
End Function
Function a$(x$)
Dim i&, f$
f = String(Len(x), "@")
For i = 1 To Len(x) - 1
If IsNumeric(Mid$(x, i, 1)) Xor IsNumeric(Mid$(x, i + 1, 1)) Then Mid(f, i) = "#"
Next
a = Format(x, Replace(f, "#", "@ "))
End Function
Function a1$(x$)
Dim i&, f$, b As Boolean
f = String$(Len(x), "@")
b = IsNumeric(Left$(x, 1))
For i = 2 To Len(x)
If b Xor IsNumeric(Mid$(x, i, 1)) Then Mid$(f, i, 1) = "#": b = Not b
Next
a1 = Format$(x, Replace(f, "#", " @"))
End Function
Function a2$(x$)
Dim i&, f$, b As Boolean, p&, k%
f = String$(Len(x), "@")
i = StrPtr(x)
GetMem2 ByVal i, k
b = k > 47 And k < 58
p = 1
For i = i + 2 To i + LenB(x) - 2 Step 2
GetMem2 ByVal i, k
p = p + 1
If b Xor k > 47 And k < 58 Then Mid$(f, p, 1) = "#": b = Not b
' If b Xor Abs(k * 2 - 105) < 10 Then Mid$(f, p, 1) = "#": b = Not b
Next
a2 = Format$(x, Replace(f, "#", " @"))
End Function
Function a3$(x$)
Dim i&, f$, b As Boolean, g&, k%
f = String$(Len(x), "@")
i = StrPtr(x)
g = StrPtr(f) - i
GetMem2 ByVal i, k
b = k > 47 And k < 58
For i = i + 2 To i + LenB(x) - 2 Step 2
GetMem2 ByVal i, k
If b Xor k > 47 And k < 58 Then GetMem2 35, ByVal g + i: b = Not b 'asc("#")=35
Next
a3 = Format$(x, Replace(f, "#", " @"))
End Function
Function a6$(x$)
Dim px&, b As Boolean, pa&, k%, i&
If Len(x) = 0 Then Exit Function
a6 = Space$(LenB(x))
pa = StrPtr(a6)
px = StrPtr(x)
GetMem2 ByVal px, k
b = k > 47 And k < 58
For i = px + 2 To px + LenB(x) - 2 Step 2
GetMem2 ByVal i, k
If b Xor k > 47 And k < 58 Then
b = Not b
RtlMoveMemory ByVal pa, ByVal px, i - px
pa = pa - px + i + 2
px = i
End If
Next
RtlMoveMemory ByVal pa, ByVal px, i - px
' a6 = LeftB$(a6, pa - px + i - StrPtr(a6))
a6 = RTrim$(a6)
End Function
Function a5$(x$)
Dim px&, b As Boolean, pa&, k%, i&
If Len(x) = 0 Then Exit Function
a5 = Space$(LenB(x))
pa = StrPtr(a5)
px = StrPtr(x)
GetMem2 ByVal px, k
GetMem2 ByVal px, ByVal pa
b = k > 47 And k < 58
For i = px + 2 To px + LenB(x) - 2 Step 2
GetMem2 ByVal i, k
If b Xor k > 47 And k < 58 Then b = Not b: pa = pa + 4 Else pa = pa + 2
GetMem2 ByVal i, ByVal pa
Next
a5 = RTrim$(a5)
End Function
Public Function insertSpaces2(intoText As String) As String
Dim bArr() As Byte, i As Long
Dim bOut() As Byte, vOff As Long
bArr = intoText
bOut = String(CLng(2 * Len(intoText)), " ")
vOff = 0
bOut(0) = bArr(0): bOut(1) = bArr(1)
For i = 2 To UBound(bArr) Step 2
If bArr(i - 2) > 47 And bArr(i - 2) < 58 And bArr(i - 1) = 0 And (bArr(i) < 48 Or bArr(i) > 57 Or bArr(i + 1) <> 0) _
Or bArr(i) > 47 And bArr(i) < 58 And bArr(i + 1) = 0 And (bArr(i - 2) < 48 Or bArr(i - 2) > 57 Or bArr(i - 1) <> 0) Then
vOff = vOff + 2
End If
bOut(i + vOff) = bArr(i): bOut(i + vOff + 1) = bArr(i + 1)
Next
insertSpaces2 = RTrim$(bOut)
End Function
Function a7$(x$)
Dim q() As Byte, i&, b As Boolean
q = x
b = q(0) > 47 And q(0) < 58
For i = 2 To UBound(q) Step 2
If b Xor q(i) > 47 And q(i) < 58 Then b = Not b: q(i - 1) = 32 Else q(i - 1) = 168 '"Ё"
Next
q(i - 1) = 168
a7 = Replace(StrConv(q, vbUnicode), "Ё", vbNullString)
End Function
|
