Самый быстрый поиск строки в файле ANSI

@HackerVlad · Регистрация: 10.09.2021

Студворк — интернет-сервис помощи студентам

Я давно уже ищу способ самого быстрого поиска строки в обычном текстовом файле ANSI. Вообще эта процедура быстрая, но если искать ключевую фразу, без учёта регистра, то это уже будет намного дольше по времени... Итак мне нужно найти фразу, все вхождения этой фразы, внутри файла TXT. Просто получить список найденных строк внутри файла. В листбокс например. Всё равно найденного будет не так много. Строк 10 например. ListBox я рассматриваю только для примера поиска конечно же.

Я очень долго искал способ наибыстрейшего поиска. Чтобы искало так же быстро как и в Total Commander'е например. Но скорости такой как в Total Commander, пока не смог достичь... Но всё равно я значит продвинулся в этом вопросе вдруг узнав о том, что если файл загружать не весь полностью сразу, а частями, тогда скорость будет в 2 раза больше...

Итак вот мой код (с преобразованием регистров):

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
Option Explicit
Private Declare Function CharLowerBuff Lib "user32" Alias "CharLowerBuffA" (ByVal lpsz As Long, ByVal cchLength As Long) As Long
 
' Ещё предстоит поработать с делением буфера на разные части не всегда будет находить то что надо...
    ' Если поисковая фраза вдруг случайно разобьётся на две разные части буфера...
    ' Поэтому сейчас не 100% гарантировано нахождение искомой строки в файле...
    Const BUFSIZE As Long = 132768
    Dim FileNo As Integer
    Dim fLen As Long
    Dim dTime As Long
    Dim z As Long
    Dim strLCaseANSI As String
    Dim SearchStringANSI As String
    Dim TwoSearch As Long
    Dim TwoSearchRev As Long
    Dim TwoSearchRev2 As Long
    Dim SearchFromTheSymbol As Long
    Dim i As Integer
    Dim NewLine As String
    Dim Buffer() As Byte
    Dim BytesLeft As Long
    Dim BufPos As Long
    Dim strBuffer As String
    
    If List1.ListCount > 0 Then List1.Clear
    
    dTime = GetTickCount
    Screen.MousePointer = 13
    
    fLen = FileLen(App.Path + "\h.txt")
    BytesLeft = fLen
    
    SearchStringANSI = "smoKing" ' Задать поисковую фразу
    SearchStringANSI = LCase$(SearchStringANSI)
    SearchStringANSI = StrConv(SearchStringANSI, vbFromUnicode) ' Конвертировать в ANSI
    NewLine = vbCrLf
    NewLine = StrConv(NewLine, vbFromUnicode) ' Конвертировать vbCrLf в ANSI
    
    ' Инициализировать счётчик
    FileNo = FreeFile
    
    Open App.Path + "\h.txt" For Binary Access Read As FileNo
        ReDim Buffer(BUFSIZE - 1)
        
        Do Until BytesLeft = 0
            If BufPos = 0 Then
                If BytesLeft < BUFSIZE Then ReDim Buffer(BytesLeft - 1)
                
                Get #FileNo, , Buffer
                strBuffer = Buffer
                strLCaseANSI = strBuffer
                CharLowerBuff StrPtr(strLCaseANSI), LenB(strLCaseANSI)
                
                BytesLeft = BytesLeft - LenB(strBuffer)
                BufPos = 1
            End If
            
            SearchFromTheSymbol = 1
            
            Do
                BufPos = InStrB(SearchFromTheSymbol, strLCaseANSI, SearchStringANSI) ' Искать нужную нам строку
                If BufPos > 0 Then
                    TwoSearch = InStrB(BufPos, strLCaseANSI, NewLine) ' Искать следующий vbCrLf (в последней строке его нет)
            
                    ' Искать предыдущий vbCrLf (в первой строке его нет)
                    i = 260: TwoSearchRev2 = 0 ' На 260 символов назад по максимальной длинне строки MAX_PATH ну это в моём случае, а вообще лучше всего InStrRev которого нет для байтового режима, нет функции InStrRevB...
                    Do While i > 0 ' Перебирать от последней строки к первой
                        If BufPos - i > 0 Then
                            TwoSearchRev2 = InStrB(BufPos - i, strLCaseANSI, NewLine)
            
                            If TwoSearchRev2 > 0 And TwoSearchRev2 < BufPos Then
                                TwoSearchRev = TwoSearchRev2
                            End If
                        End If
            
                        i = i - 2 ' Шаг 2 символа
                    Loop
            
                    If TwoSearchRev > 0 Then
                        If TwoSearch > 0 Then
                            List1.AddItem StrConv(MidB(strBuffer, TwoSearchRev + 2, (TwoSearch - TwoSearchRev) - 2), vbUnicode) ' Строка не первая и не последняя
                        Else
                            List1.AddItem StrConv(MidB(strBuffer, TwoSearchRev + 2), vbUnicode) ' Строка последняя
                        End If
                    Else
                        List1.AddItem StrConv(MidB(strBuffer, 1, IIf(TwoSearch, TwoSearch - 1, Len(strBuffer))), vbUnicode) ' Первая строка (она может быть и последней одновременно)
                    End If
                End If
            
                If TwoSearch > 0 Then
                    SearchFromTheSymbol = TwoSearch + 2 ' + vbCrLf
                Else
                    Exit Do
                End If
            Loop While BufPos > 0 ' Выполнять цикл до тех пор, пока будет найдена искомая подстрока
        Loop
    Close FileNo
    
    z = GetTickCount - dTime
    Label1.Caption = "Скорость: " & z & " млск." ' 450 ml на 70 Мб у меня
    Screen.MousePointer = 0

Для тестирования этого кода, на форме надо создать Label1 и List1.
Функция не дописана до конца. С буферными кусочками ещё работать надо бы. Длина поисковой строки тоже ограничена 260 символами, а это тоже не очень хорошо. Дело в том что в VB нет функции InStrRevB. Которая в этом коде мне так нужна...

Дело в том, что я работаю всё время только лишь с ANSI строкой. И поиск ищу тоже внутри ANSI строки, чтобы экономить время на преобразованиях кодировок. Для 70 Мб файла у меня 550 млск в среде VB6 ищет и 450 млск в EXE, со всеми галочками оптимизации. Это супер быстрая скорость. Но я думаю, можно ещё быстрее, если знать как...

Преобразование регистров осуществляется функцией CharLowerBuff потому что встроенная VB6 функция LCase$ не преобразовывает как надо регистры если строка ANSI. А у меня строка именно в ANSI кодировке получается. Хотя LCase скорее всего будет быстрее чуть-чуть. Можно конечно попробовать написать эту функцию и работать со строка понятными для VB6 в кодировке UTF16 но на преобразование ушло бы значительное время, когда файлы 50-100 Мб. В которых всё происходит и идёт поиск... VB6 хранит строки по умолчанию в кодировке UTF16 LE только без нуль-символа на конце? Наверное... Так в моём коде идёт работа исключительно с ANSI строками. Поэтому этот код только для файлов ANSI.

Добавлено через 1 час 11 минут
Сейчас ещё по быстрому написал функцию, но только для обработки строк в уникоде. Ну то есть файл конечно загружается ANSI но в уникодную строку VB. Так как строка уже уникодная, то работа уже идёт с родными функциями VB это с помощью функций LCase, InStrRev... Как я и ожидал, для 70 Мб это заняло ажно на 100 млск больше, чем при работе с анси строками. То есть 515 млск. А в моём первом варианте 420 млск где-то.

Вот собственно код (он недоработан был написан по быстрому чисто для проверки):

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Const BUFSIZE As Long = 132768
    Dim FileNo As Integer
    Dim fLen As Long
    Dim dTime As Double
    Dim z As Double
    Dim i As Long
    Dim strOriginal As String
    Dim strLCase As String
    Dim SearchString As String
    Dim FirstSearch As Double
    Dim TwoSearch As Double
    Dim TwoSearchRev As Double
    Dim SearchFromTheSymbol As Double
    
    If List1.ListCount > 0 Then List1.Clear
    
    dTime = GetTickCount
    Screen.MousePointer = 13
    
    ' Инициализировать счётчик
    FileNo = FreeFile
    
    Open App.Path + "\h.txt" For Binary As FileNo
        fLen = LOF(FileNo)
        
        For i = 0 To fLen Step BUFSIZE
            If fLen >= BUFSIZE Then
                PutMem4 VarPtr(strOriginal), SysAllocStringLen(0&, BUFSIZE) ' Выделить память для строки
            Else
                PutMem4 VarPtr(strOriginal), SysAllocStringLen(0&, fLen) ' Выделить память для строки
            End If
            
            Get FileNo, i + 1, strOriginal
            
            strLCase = LCase$(strOriginal)
            
            SearchString = "smoKing"
            SearchString = LCase$(SearchString)
            
            SearchFromTheSymbol = 1
            
            Do
                FirstSearch = InStr(SearchFromTheSymbol, strLCase, SearchString) ' Искать нужную нам строку
                If FirstSearch > 0 Then
                    TwoSearch = InStr(FirstSearch, strLCase, vbCrLf) ' Искать следующий vbCrLf (в последней строке его нет)
                    TwoSearchRev = InStrRev(strLCase, vbCrLf, FirstSearch) ' Искать предыдущий vbCrLf (в первой строке его нет)
            
                    If TwoSearchRev > 0 Then
                        If TwoSearch > 0 Then
                            List1.AddItem Mid(strOriginal, TwoSearchRev + 2, (TwoSearch - TwoSearchRev) - 2) ' Строка не первая и не последняя
                        Else
                            List1.AddItem Mid(strOriginal, TwoSearchRev + 2) ' Строка последняя
                        End If
                    Else
                        List1.AddItem Mid(strOriginal, 1, IIf(TwoSearch, TwoSearch - 1, Len(strOriginal))) ' Первая строка (она может быть и последней одновременно)
                    End If
                End If
            
                If TwoSearch > 0 Then
                    SearchFromTheSymbol = TwoSearch + 2 ' + vbCrLf
                Else
                    Exit Do
                End If
            Loop While FirstSearch > 0 ' Выполнять цикл до тех пор, пока будет найдена искомая подстрока
        Next
    Close FileNo
    
    z = GetTickCount - dTime
    Label1.Caption = "Скорость: " & z & " млск."
   
    Screen.MousePointer = 0

Добавлено через 11 минут
Как вы видите, такие варианты, как с загрузкой и поиском через массив, например, я вообще даже не рассматриваю - это слишком долго по времени было бы, поэтому я ищу поисковую фразу, а потом сам вычленяю нужную строку из файла, искав следующий и предыдущий vbcrlf от найденной фразы.

Добавлено через 48 минут
Думал немного убыстрить с помощью поиска по vbTextCompare но это, как оказалось, работает только в уникодных строках с помощью InStr обычного, а с помощью InStrB сравнение vbTextCompare уже не сработало в ансишной строке.

Но немного изменив уникодную функцию поставив сравнение в InStr vbTextCompare я смог там чуть-чуть увеличить скорость до 499 млск.

А вообще самое медленное это Option Compare Text я помню раньше всегда его любил вставлять во все формы и во все модули своих всех проектов. Был идиотом. Пока однажды вдруг не узнал, что это ни только просто медленно но ещё и способно полностью подвесить всю систему даже если оперировать строками по 100Мб например.

Помню, только одна фраза Option Compare Text заставила полностью зависнуть одновременно все работающие программы, которые написаны на VB6. Хотя теоретически такого быть не должно. Но у меня было это реально. С тех пор я ненавижу Option Compare Text и отказался от его использования абсолютно везде.

Добавлено через 2 часа 4 минуты
Ещё из моих наблюдений сейчас: функции StrStr и StrStrI работают медленнее, чем обычный InStr или InStr с сравнением vbTextCompare. А в больших циклах - гораздо медленнее.

@HackerVlad · 10.03.2023, 19:20 **[ТС]**

Если бы регулярка Like выдавала бы индекс вхождения вместо True и False было бы куда проще с поисками

Добавлено через 2 минуты

Сообщение от The trick

Твой код использует StrChrA

Она кстати ещё довольно быстро работает 250 млск на 70Мб, в отличии от функции регулярки StrCSpnA которая вообще по 2 секунды времени висит... а я всего лишь хотел найти либо большой либо маленький один символ

Добавлено через 9 минут

Сообщение от The trick

Твой код использует StrChrA которая вообще не имеет понятия о регистре

Не дай Бог я бы использовал функцию StrChrIA так вообще нахрен всё зависло бы, в цикле по миллиону раз оно бы тогда пыталось преобразовать регистры всего огромного файла. У них же так работает код сравнения строк. Медленно очень.

Добавлено через 10 минут
Кстати функцию StrChrIA можно самому написать получается, которая будет работать в 100 раз быстрее чем майкрософтовская.

Добавлено через 5 часов 8 минут
Написал сегодня вот новую технологию, на основе поиска первого символа и просмотра маленьких участков памяти.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
Const BUFSIZE As Long = 100000
    Dim FileNo As Integer
    Dim fLen As Long
    Dim dTime As Long
    Dim z As Long
    Dim SearchStringANSI As String
    Dim pSearchStringANSI As Long
    Dim i As Long
    Dim buffer() As Byte
    Dim BytesLeft As Long
    Dim cnt As Long
    Dim byteSearchLCase As Byte
    Dim byteSearchUCase As Byte
    Dim LenBytesSearchString As Long
    Dim UBoundBuffer As Long
    Dim BufferGap As Long
    Dim strs As String
    Dim StrPtrstrs As Long
    Dim IndexCr As Long
    Dim ResultSearch As String
    Dim BufferStartAddress As Long
    
    If List1.ListCount > 0 Then List1.Clear
    
    dTime = GetTickCount
    Screen.MousePointer = 13
    
    fLen = FileLen(App.Path + "\h.txt")
    BytesLeft = fLen
    
    SearchStringANSI = "SmoKing" ' Задать поисковую фразу
    byteSearchLCase = Asc(LCase$(Left$(SearchStringANSI, 1)))
    byteSearchUCase = Asc(UCase$(Left$(SearchStringANSI, 1)))
    LenBytesSearchString = Len(SearchStringANSI)
    SearchStringANSI = StrConv(LCase$(SearchStringANSI), vbFromUnicode) ' Конвертировать в ANSI
    pSearchStringANSI = StrPtr(SearchStringANSI)
    
    PutMem4 VarPtr(strs), SysAllocStringByteLen(0&, LenBytesSearchString) ' Выделить память для строки
    StrPtrstrs = StrPtr(strs)
    
    ' Инициализировать счётчик
    FileNo = FreeFile
    
    Open App.Path + "\h.txt" For Binary Access Read As FileNo
        ReDim buffer(BUFSIZE - 1)
        
        Do Until BytesLeft = 0
            If BytesLeft < BUFSIZE Then ReDim buffer(BytesLeft - 1)
            
            Get #FileNo, , buffer
            
            If (BytesLeft - BUFSIZE) > 0 Then
                BytesLeft = BytesLeft - BUFSIZE
                UBoundBuffer = BUFSIZE - 1
            Else
                BytesLeft = BytesLeft - (UBound(buffer) + 1)
                UBoundBuffer = UBound(buffer)
            End If
            
            BufferStartAddress = VarPtr(buffer(0))
            
            For i = 0 To UBoundBuffer
                If buffer(i) = byteSearchLCase Or buffer(i) = byteSearchUCase Then ' Если байт является символом в большом или маленьком регистре
                    If LenBytesSearchString <> 8 Then
                        CopyMemory StrPtrstrs, VarPtr(buffer(i)), LenBytesSearchString
                    Else
                        GetMem8 VarPtr(buffer(i)), StrPtrstrs
                    End If
                    
                    If StrCmpICA(StrPtrstrs, pSearchStringANSI) = 0 Then ' Найдена искомая подстрока
                        cnt = cnt + 1
                        If (i + LenBytesSearchString) <= UBoundBuffer Then i = i + LenBytesSearchString - 1
                        
                        IndexCr = StrChrA(VarPtr(buffer(i)), 13)
                        
                        ResultSearch = Space$((IndexCr - BufferStartAddress) - (IndexCr - (IndexCr - i)) + LenBytesSearchString)
                        ResultSearch = StrConv(ResultSearch, vbFromUnicode)
                        CopyMemory StrPtr(ResultSearch), VarPtr(buffer(i - LenBytesSearchString)), LenB(ResultSearch)
                        
                        List1.AddItem StrConv(ResultSearch, vbUnicode)
                    Else
                        If (i + LenBytesSearchString) <= UBoundBuffer Then
                            i = i + 1
                        Else
                            BufferGap = BufferGap + 1 ' Зафиксирован буферный разрыв
                        End If
                    End If
                End If
            Next
        Loop
    Close FileNo
    
    z = GetTickCount - dTime
    Label1.Caption = "Скорость: " & z & " млск." ' 359 ml на 70 Мб у меня
    Screen.MousePointer = 0
    Me.Caption = cnt
    Print BufferGap

350 миллисекунд вышло, вместо 500 мл по технологии The trick

@The trick · 10.03.2023, 20:31

Сообщение от HackerVlad

Если бы регулярка Like выдавала бы индекс вхождения вместо True и False было бы куда проще с поисками

Регулярки еще медленнее чем простой поиск.

Сообщение от HackerVlad

Она кстати ещё довольно быстро работает 250 млск на 70Мб, в отличии от функции регулярки StrCSpnA которая вообще по 2 секунды времени висит... а я всего лишь хотел найти либо большой либо маленький один символ

Они совершенно разные. StrChrA тоже может быть медленной на многобайтных кодировках. Быстрее StrChrA будет memchr. Но эта функция не различает регистр, так что смысла в ней тут нет.

Сообщение от HackerVlad

Не дай Бог я бы использовал функцию StrChrIA так вообще нахрен всё зависло бы, в цикле по миллиону раз оно бы тогда пыталось преобразовать регистры всего огромного файла. У них же так работает код сравнения строк. Медленно очень.

Ну так тогда никакого поиска без учета регистра.

Сообщение от HackerVlad

Кстати функцию StrChrIA можно самому написать получается, которая будет работать в 100 раз быстрее чем майкрософтовская.

Нет. Их функция StrChrIA работает со всеми кодировками и написана довольно эффективно. Если тебе нужна функция работающая только с определенной кодировкой (к примеру 1251) то можно эффективнее гораздо сделать, но не универсальную как StrChrIA.

Добавлено через 33 минуты

Сообщение от HackerVlad

350 миллисекунд вышло, вместо 500 мл по технологии The trick

Так твой код не ищет строки, он находит просто слово до конца строки. А где поиск начала?

Добавлено через 12 минут
Вот еще мой вариант:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
Option Explicit
Option Base 0
 
Private Const INVALID_HANDLE_VALUE    As Long = -1
Private Const GENERIC_READ            As Long = &H80000000
Private Const OPEN_EXISTING           As Long = 3
Private Const FILE_ATTRIBUTE_NORMAL   As Long = &H80
 
Private Type SAFEARRAYBOUND
    cElements   As Long
    lLBound     As Long
End Type
 
Private Type SAFEARRAY1D
    cDims       As Integer
    fFeatures   As Integer
    cbElements  As Long
    cLocks      As Long
    pvData      As Long
    tBounds     As SAFEARRAYBOUND
End Type
 
Private Type LARGE_INTEGER
    lowpart     As Long
    highpart    As Long
End Type
 
Private Declare Function CreateFile Lib "kernel32" _
                         Alias "CreateFileW" ( _
                         ByVal lpFileName As Long, _
                         ByVal dwDesiredAccess As Long, _
                         ByVal dwShareMode As Long, _
                         ByRef lpSecurityAttributes As Any, _
                         ByVal dwCreationDisposition As Long, _
                         ByVal dwFlagsAndAttributes As Long, _
                         ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
                         ByVal hObject As OLE_HANDLE) As Long
Private Declare Function GetFileSizeEx Lib "kernel32" ( _
                         ByVal hFile As Long, _
                         ByRef lpFileSize As LARGE_INTEGER) As Long
Private Declare Function ArrPtr Lib "msvbvm60" _
                         Alias "VarPtr" ( _
                         ByRef pArr() As Any) As Long
Private Declare Function PutMem4 Lib "msvbvm60" ( _
                         ByRef pDst As Any, _
                         ByVal lValue As Any) As Long
Private Declare Function ReadFile Lib "kernel32" ( _
                         ByVal hFile As OLE_HANDLE, _
                         ByRef lpBuffer As Any, _
                         ByVal nNumberOfBytesToRead As Long, _
                         ByRef lpNumberOfBytesRead As Long, _
                         ByRef lpOverlapped As Any) As Long
Private Declare Function CharLowerBuff Lib "user32" _
                         Alias "CharLowerBuffA" ( _
                         ByRef lpsz As Any, _
                         ByVal cchLength As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" ( _
                         ByVal CodePage As Long, _
                         ByVal dwFlags As Long, _
                         ByRef lpMultiByteStr As Any, _
                         ByVal cchMultiByte As Long, _
                         ByRef lpWideCharStr As Any, _
                         ByVal cchWideChar As Long) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" ( _
                         ByRef psz As Any, _
                         ByVal llen As Long) As Long
Private Declare Function SysAllocStringLen Lib "oleaut32" ( _
                         ByRef psz As Any, _
                         ByVal llen As Long) As Long
                         
Sub Main()
    Dim sLines()    As String
    Dim o As Single
    
    o = Timer
    GetLinesWithTextA "C:\temp\40 ANSI.txt", "SmoKing", sLines
    MsgBox Format$(Timer - o, "0.000") & vbNewLine & UBound(sLines) + 1
    
End Sub
 
Public Function GetLinesWithTextA( _
                ByRef sFileName As String, _
                ByRef sText As String, _
                ByRef sRet() As String) As Long
    Dim hFile       As OLE_HANDLE
    Dim tSize       As LARGE_INTEGER
    Dim sContent    As String
    Dim hr          As Long
    
    Erase sRet
    
    If Len(sText) = 0 Then
        Exit Function
    End If
 
    hFile = CreateFile(StrPtr(sFileName), GENERIC_READ, 0, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    If hFile = INVALID_HANDLE_VALUE Then
        hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
        GoTo CleanUp
    End If
    
    If GetFileSizeEx(hFile, tSize) = 0 Then
        hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
        GoTo CleanUp
    End If
    
    If tSize.highpart <> 0 Or tSize.lowpart < 0 Or tSize.lowpart > &H40000000 Then
        hr = &H8000FFFF
        GoTo CleanUp
    ElseIf tSize.lowpart = 0 Then
        Erase sRet
        GoTo CleanUp
    End If
 
    PutMem4 ByVal VarPtr(sContent), ByVal SysAllocStringByteLen(ByVal 0&, tSize.lowpart)
 
    If StrPtr(sContent) = 0 Then
        hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
        GoTo CleanUp
    End If
 
    If ReadFile(hFile, ByVal StrPtr(sContent), tSize.lowpart, 0, ByVal 0&) = 0 Then
        hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
        GoTo CleanUp
    End If
    
    LowerBufSB sContent
 
    hr = GetLinesA(sContent, sText, sRet)
 
CleanUp:
 
    If hFile Then
        CloseHandle hFile
    End If
    
    GetLinesWithTextA = hr
 
End Function
 
Private Sub LowerBufSB( _
            ByRef sText As String)
    Dim tBDesc  As SAFEARRAY1D
    Dim bTbl()  As Byte
    Dim bData() As Byte
    Dim lIndex  As Long
    
    With tBDesc
        .cbElements = 1
        .cDims = 1
        .fFeatures = 1
        .pvData = StrPtr(sText)
        .tBounds.cElements = LenB(sText)
        PutMem4 ByVal ArrPtr(bData), VarPtr(tBDesc)
    End With
    
    ReDim bTbl(255)
    
    For lIndex = 0 To 255
        bTbl(lIndex) = lIndex
    Next
    
    CharLowerBuff bTbl(1), 254
    
    For lIndex = 0 To LenB(sText) - 1
        bData(lIndex) = bTbl(bData(lIndex))
    Next
    
End Sub
 
Private Function GetLinesA( _
                 ByRef sContent As String, _
                 ByRef sText As String, _
                 ByRef sRet() As String) As Long
    Dim lTxtPos As Long
    Dim lCurPos As Long
    Dim lLfPos  As Long
    Dim lCrPos  As Long
    Dim lLenTxt As Long
    Dim pText   As Long
    Dim sTextA  As String
    Dim lCount  As Long
    Dim sCrA    As String
    Dim bData() As Byte
    Dim lData() As Long
    Dim tBDesc  As SAFEARRAY1D
    Dim tLDesc  As SAFEARRAY1D
    Dim lIndex  As Long
    Dim lBits   As Long
    Dim lTest   As Long
    Dim lSize   As Long
    Dim lLenW   As Long
    Dim lConLen As Long
    Dim bIsIDE  As Boolean
    Dim pDst    As Long
    Dim pNewStr As Long
    
    Debug.Assert MakeTrue(bIsIDE)
    
    sTextA = StrConv(LCase(sText), vbFromUnicode)
    lLenTxt = LenB(sTextA)
    
    Erase sRet
    
    If lLenTxt = 0 Then
        Exit Function
    End If
    
    lCurPos = 0
    pText = StrPtr(sContent)
    sCrA = StrConv(vbCr, vbFromUnicode)
    lConLen = LenB(sContent)
    
    With tBDesc
        .cbElements = 1
        .cDims = 1
        .fFeatures = 1
        .pvData = pText
        .tBounds.cElements = lConLen
        PutMem4 ByVal ArrPtr(bData), VarPtr(tBDesc)
    End With
    
    With tLDesc
        .cbElements = 4
        .cDims = 1
        .fFeatures = 1
        .pvData = pText
        .tBounds.cElements = lConLen \ 4
        PutMem4 ByVal ArrPtr(lData), VarPtr(tLDesc)
    End With
    
    Do Until lCurPos + lLenTxt > lConLen
        
        lTxtPos = InStrB(lCurPos + 1, sContent, sTextA, vbBinaryCompare) - 1
        
        If lTxtPos = -1 Then
            Exit Do
        End If
        
        lLfPos = InStrB(lTxtPos + lLenTxt + 1, sContent, sCrA, vbBinaryCompare) - 1
        
        If lLfPos = -1 Then
            lLfPos = lConLen
        End If
        
        If lTxtPos Then
            
            lIndex = lTxtPos - 1
            lCrPos = -1
 
            Do Until (lIndex And 3) = 3
            
                If bData(lIndex) = &HA Then
                    lCrPos = lIndex
                    GoTo cr_found
                End If
                
                lIndex = lIndex - 1
                
            Loop
            
            lIndex = lIndex \ 4
            
            For lIndex = lIndex To 0 Step -1
                
                If bIsIDE Then
                
                    lBits = lData(lIndex) Xor &HA0A0A0A
                    
                    If (lBits And &HFF000000) = 0 Then
                        lCrPos = lIndex * 4 + 3
                        Exit For
                    ElseIf (lBits And &HFF0000) = 0 Then
                        lCrPos = lIndex * 4 + 2
                        Exit For
                    ElseIf (lBits And &HFF00&) = 0 Then
                        lCrPos = lIndex * 4 + 1
                        Exit For
                    ElseIf (lBits And &HFF) = 0 Then
                        lCrPos = lIndex * 4
                        Exit For
                    End If
                
                Else
                    
                    lBits = lData(lIndex) Xor &HA0A0A0A
                    lTest = ((lBits + &H7EFEFEFF) Xor (Not lBits)) And &H81010100
                    
                    If lTest Then
                    
                        If (lBits And &HFF000000) = 0 Then
                            lCrPos = lIndex * 4 + 3
                        ElseIf lTest And &H1000000 Then
                            lCrPos = lIndex * 4 + 2
                        ElseIf lTest And &H10000 Then
                            lCrPos = lIndex * 4 + 1
                        Else
                            lCrPos = lIndex * 4
                        End If
                        
                        Exit For
                        
                    End If
                
                End If
                
            Next
        
        Else
            lCrPos = -1
        End If
        
cr_found:
                
        If lCount Then
            If lCount > UBound(sRet) Then
                ReDim Preserve sRet(lCount * 2 - 1)
                pDst = VarPtr(sRet(0))
            End If
        Else
            ReDim sRet(999)
            pDst = VarPtr(sRet(0))
        End If
        
        lSize = lLfPos - (lCrPos + 1)
        
        If lSize > 0 Then
 
            lLenW = MultiByteToWideChar(0, 0, ByVal pText + lCrPos + 1, lSize, ByVal 0&, 0)
            
            If lLenW Then
                
                pNewStr = SysAllocStringLen(ByVal 0&, lLenW)
                PutMem4 ByVal pDst + lCount * 4, ByVal pNewStr
                MultiByteToWideChar 0, 0, ByVal pText + lCrPos + 1, lSize, ByVal pNewStr, lLenW
                
            End If
            
        End If
 
        lCount = lCount + 1
        lCurPos = lLfPos + 2
        
    Loop
    
    If lCount Then
        ReDim Preserve sRet(lCount - 1)
    Else
        Erase sRet
    End If
    
End Function
 
Private Function MakeTrue( _
                 ByRef bValue As Boolean) As Boolean
    bValue = True
    MakeTrue = True
End Function

Сообщение от HackerVlad

Написал сегодня вот новую технологию, на основе поиска первого символа и просмотра маленьких участков памяти.

Вылетает при поиске фразы Documents.

@The trick · 10.03.2023, 21:36

Как и обещал вариант без преобразования регистра:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
Option Explicit
Option Base 0
 
Private Const INVALID_HANDLE_VALUE    As Long = -1
Private Const GENERIC_READ            As Long = &H80000000
Private Const OPEN_EXISTING           As Long = 3
Private Const FILE_ATTRIBUTE_NORMAL   As Long = &H80
 
Private Type SAFEARRAYBOUND
    cElements   As Long
    lLBound     As Long
End Type
 
Private Type SAFEARRAY1D
    cDims       As Integer
    fFeatures   As Integer
    cbElements  As Long
    cLocks      As Long
    pvData      As Long
    tBounds     As SAFEARRAYBOUND
End Type
 
Private Type LARGE_INTEGER
    lowpart     As Long
    highpart    As Long
End Type
 
Private Declare Function CreateFile Lib "kernel32" _
                         Alias "CreateFileW" ( _
                         ByVal lpFileName As Long, _
                         ByVal dwDesiredAccess As Long, _
                         ByVal dwShareMode As Long, _
                         ByRef lpSecurityAttributes As Any, _
                         ByVal dwCreationDisposition As Long, _
                         ByVal dwFlagsAndAttributes As Long, _
                         ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
                         ByVal hObject As OLE_HANDLE) As Long
Private Declare Function GetFileSizeEx Lib "kernel32" ( _
                         ByVal hFile As Long, _
                         ByRef lpFileSize As LARGE_INTEGER) As Long
Private Declare Function ArrPtr Lib "msvbvm60" _
                         Alias "VarPtr" ( _
                         ByRef pArr() As Any) As Long
Private Declare Function PutMem4 Lib "msvbvm60" ( _
                         ByRef pDst As Any, _
                         ByVal lValue As Any) As Long
Private Declare Function ReadFile Lib "kernel32" ( _
                         ByVal hFile As OLE_HANDLE, _
                         ByRef lpBuffer As Any, _
                         ByVal nNumberOfBytesToRead As Long, _
                         ByRef lpNumberOfBytesRead As Long, _
                         ByRef lpOverlapped As Any) As Long
Private Declare Function CharLowerBuff Lib "user32" _
                         Alias "CharLowerBuffA" ( _
                         ByRef lpsz As Any, _
                         ByVal cchLength As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" ( _
                         ByVal CodePage As Long, _
                         ByVal dwFlags As Long, _
                         ByRef lpMultiByteStr As Any, _
                         ByVal cchMultiByte As Long, _
                         ByRef lpWideCharStr As Any, _
                         ByVal cchWideChar As Long) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" ( _
                         ByRef psz As Any, _
                         ByVal llen As Long) As Long
Private Declare Function SysAllocStringLen Lib "oleaut32" ( _
                         ByRef psz As Any, _
                         ByVal llen As Long) As Long
Private Declare Function memchr CDecl Lib "ntdll" ( _
                         ByRef psz As Any, _
                         ByVal lC As Long, _
                         ByVal llen As Long) As Long
Private Declare Function CharLower Lib "user32" _
                         Alias "CharLowerA" ( _
                         ByRef lpsz As Any) As Long
Private Declare Function CharUpper Lib "user32" _
                         Alias "CharUpperA" ( _
                         ByRef lpsz As Any) As Long
Private Declare Sub GetMem1 Lib "msvbvm60" ( _
                    ByRef Addr As Any, _
                    ByRef RetVal As Any)
 
Sub Main()
    Dim sLines()    As String
    Dim o           As Single
 
    o = Timer
    GetLinesWithTextA "C:\temp\40 ANSI.txt", "SmOkIng", sLines
    MsgBox Format$(Timer - o, "0.000") & vbNewLine & UBound(sLines) + 1
 
End Sub
 
Public Function GetLinesWithTextA( _
                ByRef sFileName As String, _
                ByRef sText As String, _
                ByRef sRet() As String) As Long
    Dim hFile       As OLE_HANDLE
    Dim tSize       As LARGE_INTEGER
    Dim sContent    As String
    Dim hr          As Long
    
    Erase sRet
    
    If Len(sText) = 0 Then
        Exit Function
    End If
 
    hFile = CreateFile(StrPtr(sFileName), GENERIC_READ, 0, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    If hFile = INVALID_HANDLE_VALUE Then
        hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
        GoTo CleanUp
    End If
    
    If GetFileSizeEx(hFile, tSize) = 0 Then
        hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
        GoTo CleanUp
    End If
    
    If tSize.highpart <> 0 Or tSize.lowpart < 0 Or tSize.lowpart > &H40000000 Then
        hr = &H8000FFFF
        GoTo CleanUp
    ElseIf tSize.lowpart = 0 Then
        Erase sRet
        GoTo CleanUp
    End If
 
    PutMem4 ByVal VarPtr(sContent), ByVal SysAllocStringByteLen(ByVal 0&, tSize.lowpart)
 
    If StrPtr(sContent) = 0 Then
        hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
        GoTo CleanUp
    End If
 
    If ReadFile(hFile, ByVal StrPtr(sContent), tSize.lowpart, 0, ByVal 0&) = 0 Then
        hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
        GoTo CleanUp
    End If
 
    hr = GetLinesA(sContent, sText, sRet)
 
CleanUp:
 
    If hFile Then
        CloseHandle hFile
    End If
    
    GetLinesWithTextA = hr
 
End Function
 
Private Function GetLinesA( _
                 ByRef sContent As String, _
                 ByRef sText As String, _
                 ByRef sRet() As String) As Long
    Dim lTxtPos As Long
    Dim lCurPos As Long
    Dim lLfPos  As Long
    Dim lCrPos  As Long
    Dim lLenTxt As Long
    Dim pText   As Long
    Dim sTextA  As String
    Dim lCount  As Long
    Dim sCrA    As String
    Dim bData() As Byte
    Dim lData() As Long
    Dim bText() As Byte
    Dim tBDesc  As SAFEARRAY1D
    Dim tLDesc  As SAFEARRAY1D
    Dim tTDesc  As SAFEARRAY1D
    Dim lIndex  As Long
    Dim lBits   As Long
    Dim lTest   As Long
    Dim lSize   As Long
    Dim lLenW   As Long
    Dim lConLen As Long
    Dim bIsIDE  As Boolean
    Dim pDst    As Long
    Dim pNewStr As Long
    Dim lUCase  As Long
    Dim lLCase  As Long
    Dim lUCaseD As Long
    Dim lLCaseD As Long
    Dim lDword  As Long
    Dim bTbl()  As Byte
    Dim pFind   As Long
    Dim lIndex2 As Long
    Dim lChar   As Long
    
    Debug.Assert MakeTrue(bIsIDE)
    
    sTextA = StrConv(sText, vbFromUnicode)
    lLenTxt = LenB(sTextA)
 
    Erase sRet
    
    If lLenTxt = 0 Then
        Exit Function
    End If
    
    pFind = StrPtr(sTextA)
    GetMem1 ByVal pFind, lChar
    
    lUCase = CharLower(ByVal lChar)
    lLCase = CharUpper(ByVal lChar)
    
    ReDim bTbl(255)
    
    For lIndex = 0 To 255
        bTbl(lIndex) = lIndex
    Next
    
    CharLowerBuff bTbl(1), 254
    
    If bIsIDE Then
    
        lUCaseD = lUCase * &H10101
        
        If lUCase And &H80 Then
            lUCaseD = lUCaseD Or ((lUCase And &H7F) * &H1000000) Or &H80000000
        Else
            lUCaseD = lUCaseD Or (lUCase * &H1000000)
        End If
        
        lLCaseD = lLCase * &H10101
        
        If lLCase And &H80 Then
            lLCaseD = lLCaseD Or ((lLCase And &H7F) * &H1000000) Or &H80000000
        Else
            lLCaseD = lLCaseD Or (lLCase * &H1000000)
        End If
        
    Else
        
        lUCaseD = lUCase * &H1010101
        lLCaseD = lLCase * &H1010101
        
    End If
 
    lCurPos = 0
    pText = StrPtr(sContent)
    sCrA = StrConv(vbCr, vbFromUnicode)
    lConLen = LenB(sContent)
    
    With tBDesc
        .cbElements = 1
        .cDims = 1
        .fFeatures = 1
        .pvData = pText
        .tBounds.cElements = lConLen
        PutMem4 ByVal ArrPtr(bData), VarPtr(tBDesc)
    End With
    
    With tLDesc
        .cbElements = 4
        .cDims = 1
        .fFeatures = 1
        .pvData = pText
        .tBounds.cElements = lConLen \ 4
        PutMem4 ByVal ArrPtr(lData), VarPtr(tLDesc)
    End With
    
    With tTDesc
        .cbElements = 1
        .cDims = 1
        .fFeatures = 1
        .pvData = pFind
        .tBounds.cElements = lLenTxt
        PutMem4 ByVal ArrPtr(bText), VarPtr(tTDesc)
    End With
    
    Do Until lCurPos + lLenTxt > lConLen
        
        lIndex = lCurPos
        
        Do While lIndex And 3
        
            If bData(lIndex) = lUCase Or bData(lIndex) = lLCase Then
                lTxtPos = lIndex
                GoTo first_found
            End If
            
            lIndex = lIndex + 1
            
        Loop
        
        lIndex = lIndex \ 4
        
        For lIndex = lIndex To tLDesc.tBounds.cElements - 1
            
            lDword = lData(lIndex)
            
            If bIsIDE Then
            
                lBits = lDword Xor lUCaseD
                
                If (lBits And &HFF000000) = 0 Then
                    lTxtPos = lIndex * 4 + 3
                    GoTo first_found
                ElseIf (lBits And &HFF0000) = 0 Then
                    lTxtPos = lIndex * 4 + 2
                    GoTo first_found
                ElseIf (lBits And &HFF00&) = 0 Then
                    lTxtPos = lIndex * 4 + 1
                    GoTo first_found
                ElseIf (lBits And &HFF) = 0 Then
                    lTxtPos = lIndex * 4
                    GoTo first_found
                End If
                
                lBits = lDword Xor lLCaseD
                
                If (lBits And &HFF000000) = 0 Then
                    lTxtPos = lIndex * 4 + 3
                    GoTo first_found
                ElseIf (lBits And &HFF0000) = 0 Then
                    lTxtPos = lIndex * 4 + 2
                    GoTo first_found
                ElseIf (lBits And &HFF00&) = 0 Then
                    lTxtPos = lIndex * 4 + 1
                    GoTo first_found
                ElseIf (lBits And &HFF) = 0 Then
                    lTxtPos = lIndex * 4
                    GoTo first_found
                End If
                
            Else
                
                lBits = lDword Xor lUCaseD
                lTest = ((lBits + &H7EFEFEFF) Xor (Not lBits)) And &H81010100
                
                If lTest Then
                
                    If (lBits And &HFF000000) = 0 Then
                        lTxtPos = lIndex * 4 + 3
                    ElseIf lTest And &H1000000 Then
                        lTxtPos = lIndex * 4 + 2
                    ElseIf lTest And &H10000 Then
                        lTxtPos = lIndex * 4 + 1
                    Else
                        lTxtPos = lIndex * 4
                    End If
                    
                    GoTo first_found
                    
                End If
                
                lBits = lDword Xor lLCaseD
                lTest = ((lBits + &H7EFEFEFF) Xor (Not lBits)) And &H81010100
                
                If lTest Then
                
                    If (lBits And &HFF000000) = 0 Then
                        lTxtPos = lIndex * 4 + 3
                    ElseIf lTest And &H1000000 Then
                        lTxtPos = lIndex * 4 + 2
                    ElseIf lTest And &H10000 Then
                        lTxtPos = lIndex * 4 + 1
                    Else
                        lTxtPos = lIndex * 4
                    End If
                    
                    GoTo first_found
                    
                End If
                
            End If
            
        Next
            
        Exit Do
        
first_found:
        
        If lTxtPos + lLenTxt > lConLen Then
            Exit Do
        End If
 
        lIndex2 = 1
        
        For lIndex = lTxtPos + 1 To lTxtPos + lLenTxt - 1
        
            If bTbl(bData(lIndex)) <> bTbl(bText(lIndex2)) Then
                lCurPos = lTxtPos + 1
                GoTo continue
            End If
            
            lIndex2 = lIndex2 + 1
            
        Next
 
        lLfPos = InStrB(lTxtPos + lLenTxt + 1, sContent, sCrA, vbBinaryCompare) - 1
        
        If lLfPos = -1 Then
            lLfPos = lConLen
        End If
        
        If lTxtPos Then
            
            lIndex = lTxtPos - 1
            lCrPos = -1
 
            Do Until (lIndex And 3) = 3
            
                If bData(lIndex) = &HA Then
                    lCrPos = lIndex
                    GoTo cr_found
                End If
                
                lIndex = lIndex - 1
                
            Loop
            
            lIndex = lIndex \ 4
            
            For lIndex = lIndex To 0 Step -1
                
                If bIsIDE Then
                
                    lBits = lData(lIndex) Xor &HA0A0A0A
                    
                    If (lBits And &HFF000000) = 0 Then
                        lCrPos = lIndex * 4 + 3
                        Exit For
                    ElseIf (lBits And &HFF0000) = 0 Then
                        lCrPos = lIndex * 4 + 2
                        Exit For
                    ElseIf (lBits And &HFF00&) = 0 Then
                        lCrPos = lIndex * 4 + 1
                        Exit For
                    ElseIf (lBits And &HFF) = 0 Then
                        lCrPos = lIndex * 4
                        Exit For
                    End If
                
                Else
                    
                    lBits = lData(lIndex) Xor &HA0A0A0A
                    lTest = ((lBits + &H7EFEFEFF) Xor (Not lBits)) And &H81010100
                    
                    If lTest Then
                    
                        If (lBits And &HFF000000) = 0 Then
                            lCrPos = lIndex * 4 + 3
                        ElseIf lTest And &H1000000 Then
                            lCrPos = lIndex * 4 + 2
                        ElseIf lTest And &H10000 Then
                            lCrPos = lIndex * 4 + 1
                        Else
                            lCrPos = lIndex * 4
                        End If
                        
                        Exit For
                        
                    End If
                
                End If
                
            Next
        
        Else
            lCrPos = -1
        End If
        
cr_found:
                
        If lCount Then
            If lCount > UBound(sRet) Then
                ReDim Preserve sRet(lCount * 2 - 1)
                pDst = VarPtr(sRet(0))
            End If
        Else
            ReDim sRet(999)
            pDst = VarPtr(sRet(0))
        End If
        
        lSize = lLfPos - (lCrPos + 1)
        
        If lSize > 0 Then
 
            lLenW = MultiByteToWideChar(0, 0, ByVal pText + lCrPos + 1, lSize, ByVal 0&, 0)
            
            If lLenW Then
                
                pNewStr = SysAllocStringLen(ByVal 0&, lLenW)
                PutMem4 ByVal pDst + lCount * 4, ByVal pNewStr
                MultiByteToWideChar 0, 0, ByVal pText + lCrPos + 1, lSize, ByVal pNewStr, lLenW
                
            End If
            
        End If
 
        lCount = lCount + 1
        lCurPos = lLfPos + 2
        
continue:
        
    Loop
    
    If lCount Then
        ReDim Preserve sRet(lCount - 1)
    Else
        Erase sRet
    End If
    
End Function
 
Private Function MakeTrue( _
                 ByRef bValue As Boolean) As Boolean
    bValue = True
    MakeTrue = True
End Function

@HackerVlad · 10.03.2023, 22:27 **[ТС]**

Сообщение от The trick

Так твой код не ищет строки, он находит просто слово до конца строки. А где поиск начала?

Так я знаю, что я до конца не дописал эту функцию, она ещё сырая. Мне важно было только проверить скорость. А так смысл всё допиливать до конца если меня не устроит что-то в этой функции потом.

Там чтобы найти начало строки нужно бы использовать InStrRevB, функцию которой не существует, поэтому её пришлось бы писать самому через RightB$

Добавлено через 4 минуты

Сообщение от The trick

Вылетает при поиске фразы Documents

Спасибо, что сказал, я там перемудрил с формулой конечно... Вылетает в этой строке... (IndexCr - BufferStartAddress) - (IndexCr - (IndexCr - i)) + LenBytesSearchString
Ну я там сильно не проверял... Писал на скорую руку...

Добавлено через 1 минуту
Ну формулу я перепишу и всё будет правильно работать конечно эту ошибку легко будет исправить, суть не в этом, а суть в том стоит ли мне допиливать всю эту функцию...

Добавлено через 32 секунды
У меня был просто спортивный интерес а смогу я сделать быстрее. Смог.

@The trick · 10.03.2023, 22:33

Сообщение от Catstail

- не совсем понятно... В файле ищем контекст. Что меняется?

Поиск необходимо производить без учета регистра. Чтобы задействовать сверх-быстрый InStrB нужно обеспечить единство регистра + тип переменной должен быть BSTR. С файл-маппингом такой трюк не пройдет, т.к. BSTR хранить длину по смещению -4.

@HackerVlad · 10.03.2023, 22:42 **[ТС]**

Сообщение от The trick

Нет. Их функция StrChrIA работает со всеми кодировками и написана довольно эффективно. Если тебе нужна функция работающая только с определенной кодировкой (к примеру 1251) то можно эффективнее гораздо сделать, но не универсальную как StrChrIA.

Так я ведь уже написал эту функцию в 100 раз быстрее чем майкрософтовскую. Ну и подумаешь что я не смотрю на все кодировки, локали и так далее. Сама по себе функция LCase$ уже должна работать во всех локалях.

Добавлено через 2 минуты

Сообщение от The trick

Вот еще мой вариант:

Уже лучше. Уже 300 млск, вместо 500

@The trick · 10.03.2023, 22:46

Сообщение от HackerVlad

Сама по себе функция LCase$ уже должна работать во всех локалях.

Она работает с юникодом и использует CharLowerBuffW.

@HackerVlad · 10.03.2023, 23:18 **[ТС]**

Сообщение от The trick

Как и обещал вариант без преобразования регистра:

0,172 уже, просто фантастика!

Добавлено через 5 минут
Ты ведь понимаешь почему моя функция StrChrIA работает быстрее чем майкрософтовская.
Потому что я один раз ищу в огромном массиве и проверяю, является ли байт, большой или маленькой буквой.

А как работает код майкрософта? Я и без дизассемблера скажу что их код преобразовывает в другой регистр всю полностью огромную строку, и лишь потом сравнивает в цикле. Я не произвожу преобразование регистров, для огромной строки. Поэтому у меня в сто раз быстрее.

Добавлено через 4 минуты
Спасибо большое, The trick, видишь ты написал функцию гораздо быстрее и лучше чем у меня. Именно поэтому я свою до конца и не дописывал, потому что знал что может от неё откажусь и буду пользоваться твоей новой функцией))))
Единственный минус - очень медленно в VB.

Добавлено через 1 минуту
Знаешь, я даже думал прогнать два раза memchr будет быстрее. Для большого и для маленького символа. Хоть весь файл и два раза прогонять придётся. Всё равно быстрее будет.

Добавлено через 2 минуты
Ты свою сверхбыструю функцию написал же по этой технологии? Поиск первого символа большого или маленького? Я просто сильно не вникал...

Добавлено через 17 минут
Посмотрел я твой код. Очень интересный. Понравилась фича GoTo continue. Классно придумал, а я давно думал почему в VB циклах нет continue, очень не хватает иногда, в отличии от других языков, где мы привыкли к continue. Удобно переходить к следующей интерации конечно.

@The trick · 10.03.2023, 23:19

Сообщение от HackerVlad

Ты ведь понимаешь почему моя функция StrChrIA работает быстрее чем майкрософтовская.
Потому что я один раз ищу в огромном массиве и проверяю, является ли байт, большой или маленькой буквой.
А как работает код майкрософта? Я и без дизассемблера скажу что их код преобразовывает в другой регистр всю полностью огромную строку, и лишь потом сравнивает в цикле. Я не произвожу преобразование регистров, для огромной строки. Поэтому у меня в сто раз быстрее.

Строго говоря так неверно искать. Символ в многобайтовой кодировке может занимать несколько байт и правильно использовать функции CharNext/CharPrev для перехода между символами. StrChrIA просто создает строку с 1-м символом и использует функцию lstrcmpiA. lstrcmpiA делает конверсию из ANSI в UNICODE и сравнивает уже через CompareStringW. Самый оптимальный и правильный вариант - вообще не работать с ANSI строками. Преобразовывать в юникод и только с юникодом работать всегда.

Сообщение от HackerVlad

Знаешь, я даже думал прогнать два раза memchr будет быстрее. Для большого и для маленького символа. Хоть весь файл и два раза прогонять придётся. Всё равно быстрее будет.
Ты свою сверхбыструю функцию написал же по этой технологии? Поиск первого символа большого или маленького? Я просто сильно не вникал...

У меня комбинация memchr (c двумя символами правда) + сравнение однобайтовых символов без учета регистра.

@HackerVlad · 10.03.2023, 23:25 **[ТС]**

Сообщение от The trick

У меня комбинация memchr (c двумя символами правда)

Неужели? Я же проверил у тебя не используется эта функция. В последнем варианте объявлена в модуле, но по факту нигде не используется. А лучше бы использовать для VB IDE конечно...

Добавлено через 1 минуту

Сообщение от The trick

+ сравнение однобайтовых символов без учета регистра

Ты сам написал сравнение? Для русских букв тоже описал? Ну для нашей CP1251 короче?

@The trick · 10.03.2023, 23:27

Сообщение от HackerVlad

Неужели? Я же проверил у тебя не используется эта функция. В последнем варианте объявлена в модуле, но по факту нигде не используется. А лучше бы использовать для VB IDE конечно...

Так у меня именно реализация на вб этой функции, иначе пришлось бы 2 раза пробегать.

Добавлено через 1 минуту

Сообщение от HackerVlad

Ты сам написал сравнение? Для русских букв тоже описал? Ну для нашей CP1251 короче?

Для однобайтовых это делается тривиально, создается таблица с соответствием символов одного регистра к фиксированному.

@HackerVlad · 10.03.2023, 23:30 **[ТС]**

Сообщение от The trick

Так у меня именно реализация на вб этой функции, иначе пришлось бы 2 раза пробегать

А ты выложил код, который ещё и для VB IDE или забыл, я так и не понял, у меня в ВБ очень медленно 3-4 сек.

@The trick · 10.03.2023, 23:34

Сообщение от HackerVlad

А ты выложил код, который ещё и для VB IDE или забыл, я так и не понял, у меня в ВБ очень медленно 3-4 сек.

Для IDE мне не важен результат. По 40 МБ текста в IDE не так часто используется, в крайнем случае это можно скомпилировать в ActiveX DLL и все будет летать. Производительность нужно проверять в скомпилированном варианте со всеми опциями оптимизации.

@HackerVlad · 10.03.2023, 23:46 **[ТС]**

Сообщение от The trick

Так у меня именно реализация на вб этой функции, иначе пришлось бы 2 раза пробегать.

Я тебя понял. Не сразу просто догадался, что ты имеешь ввиду. То есть ты вручную циклами ищешь байт и смотришь большой он или маленький. А если написать для IDE то придётся 2 раза memchr. Так? Но всё равно же быстрее будет...

Добавлено через 1 минуту
Ну да, я согласен, что нам не сильно важно для IDE. Просто помню, как ты написал функцию подсчёта строк, там было разделение на для EXE и для VB. Мне это хорошо запомнилось) Особенно когда выдало разный результат в EXE и VB. Думал и тут будет так же просто)))

Добавлено через 2 минуты

Сообщение от The trick

в крайнем случае это можно скомпилировать в ActiveX DLL и все будет летать

Я тоже думал написать библиотеку. Но в VB6 нельзя писать натив API DLL. Можно в PowerBasic'е или в дельфи или Си.

Добавлено через 46 секунд

Сообщение от HackerVlad

ActiveX DLL

а ActiveX DLL это ведь что-то другое я думал только про DLL API Nativ stdcall

Добавлено через 3 минуты
DLL натив API, честно, я писал только на дельфи, ибо в VB6 нельзя. Хочешь прикол расскажу. Когда писал DLL перепробовал все версии дельфи, и только одна старая версия выдавала самый быстрый результат по скорости. Новая версия точно медленная. Старая версия одна хорошо по скоростям, Четвёртая что ли по моему, уже точно не помню.

Добавлено через 57 секунд
А какую я функцию писал? Да эту же самую. Тогда потому что не умел быстро на VB достичь быстрого результат. А там же у них класс TString и так далее. Там у них много классных фишек.

Добавлено через 1 минуту
У меня уже написана библиотека DLL на дельфи то есть. Но там всё равно медленее конечно скорость чем твой супер идеальный код этот новый))))))

Добавлено через 1 минуту
И на С++ я тоже писал эту функцию. Тоже нихрена не получилось по скорости. На дельфи более ни менее быстро вышло.

Новые блоги и статьи Все статьи Все блоги /
Был праздник вчера, а я и не знал. kumehtar 28.07.2026 27. 07. 2026г. Intel Core 2 Duo исполнилось 20 лет Новости компьютерного мира и их обсуждение (4) Салют, шампанское, овации! :drink:	Нейтральные знания, чистый код - бла-бла-бла-бла, на самом деле кликбейт и самореклама, плагиат, и вот почему Hrethgir 27.07.2026 То-есть отклонение такой публикации говорит само за себя, и пусть только возьмут на вооружение после отклонения публикации - это будет чистейшим актом плагиата. Отклонял Хабр. Дословно, отклонённая. . .	тв 16 бой ии anaschu 27.07.2026 Великий Перелом ИИ: Как уравнения ОДУ Radau дожали цензурные фильтры Алисы Фиксируем в мемофонде Теории Всего беспрецедентный факт в истории ИИ-зондирования. В затяжном многораундовом. . .	мв 15. непроверенное, возможно, глюк anaschu 27.07.2026 НАУЧНО-АНАЛИТИЧЕСКИЙ ОТЧЕТ. РАЗДЕЛ 1. 1: «НАУКА» (РАСШИРЕННАЯ СТЕХИОМЕТРИЧЕСКАЯ И ГЕНЕТИЧЕСКАЯ ВЕРСИЯ)Тема: Теоретическое обоснование инвариантности 19-мерного тензорного ядра непрерывных ОДУ и. . .
Очистка реквизитов и табличных частей документа при копировании (вариант 2) Maks 26.07.2026 Алгоритм из решения ниже разработан на примере нетипового документа "ЗаявкаНаРаботу", разработанного в КА2. Задача: Заменить алгоритм запрета копирования документов для сотрудников с ролью "Стажер",. . .	Доктрина интенционального знания - Доктрина для портала "Срез". Hrethgir 25.07.2026 Может найдётся кто захочет оценить доктрину. . . Написания правил участия для меня роскошь, требующая лимита времени, поэтому все сообщения не прошедшие модерацию будут видны только участникам портала,. . .	сукцессия 44. Решил подать на припринт в межународные сервисы препринтов. Но нужно одобрение от ученых anaschu 25.07.2026 Английский вариант. Пока кто то не одобрит мою личность, мне не получиться это опубликовать на препринте. Но заявку на публикацию статьи я сегодня подам.	сукцессия 43. Вторая научная статья за месяц- прайминг и гатгил anaschu 25.07.2026 две стороны одной монеты

Самый быстрый поиск строки в файле ANSI

Решение