Функция подсчёта количества строк в файле на VB6 (для всех кодировок файлов)

Option Explicit
Private Declare Function IsFileAPI Lib "shlwapi" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function StrStrA Lib "shlwapi" (ByVal pszFirst As Long, ByVal pszSrch As Long) As Long
Private Declare Function StrStrW Lib "shlwapi" (ByVal pszFirst As Long, ByVal pszSrch As Long) As Long
 
' Подсчитать количество строк в файле, в кодировке ANSI или UTF8
Public Function CountStrsFromFileA(FileName As String) As Long
    Dim FileNo As Integer
    Dim str() As Byte
    Dim fLen As Long
    Dim NewLine As Long
    Dim FirstSearch As Long
    Dim SearchFromTheSymbol As Long
    Dim cnt As Long
    
    If IsFileAPI(FileName) = 0 Then Exit Function ' Файл не существует, с вероятностью 99%
    fLen = FileLen(FileName)
    If fLen = 0 Then Exit Function
    
    ' Инициализировать счётчик
    FileNo = FreeFile
    
    ' Открыть файл
    Open FileName For Binary As FileNo
        ReDim str(fLen - 1)
        Get #FileNo, , str
    Close FileNo
    
    cnt = 1
    SearchFromTheSymbol = VarPtr(str(0))
    NewLine = StrPtr(vbNewLine)
    
    Do
        FirstSearch = StrStrA(SearchFromTheSymbol, NewLine) ' Искать нужную нам строку
        If FirstSearch > 0 Then
            cnt = cnt + 1
            SearchFromTheSymbol = FirstSearch + 2 ' + vbcrlf
        End If
    Loop While FirstSearch > 0 ' Выполнять цикл до тех пор, пока будет найдена искомая подстрока
    
    CountStrsFromFileA = cnt
End Function
 
' Подсчитать количество строк в файле, в кодировке UTF16LE или UTF16BE (работает даже без BOM)
Public Function CountStrsFromFileW(FileName As String) As Long
    Dim FileNo As Integer
    Dim str() As Byte
    Dim fLen As Long
    Dim NewLine As Long
    Dim FirstSearch As Long
    Dim SearchFromTheSymbol As Long
    Dim cnt As Long
    Dim i As Long
    
    If IsFileAPI(FileName) = 0 Then Exit Function ' Файл не существует, с вероятностью 99%
    fLen = FileLen(FileName)
    If fLen = 0 Then Exit Function ' Если в файле 0 байт значит в файле 0 строк
    
    ' Инициализировать счётчик
    FileNo = FreeFile
    
    ' Открыть файл
    Open FileName For Binary As FileNo
        ReDim str(fLen - 1)
        Get #FileNo, , str
    Close FileNo
    
    ' Если файл это файл размером один байт
    If UBound(str) < 1 Then
        If str(0) = 13 Then cnt = 2
        
        CountStrsFromFileW = cnt
        Exit Function
    End If
    
    If str(0) = 254 And str(1) = 255 Then ' UTF16BE
        SearchFromTheSymbol = VarPtr(str(1)) ' Изменим адресацию поиска +1 байт
        NewLine = StrPtr(Chr(13) & Chr(0) & Chr(10))
    Else ' UTF16LE обычное
        SearchFromTheSymbol = VarPtr(str(0))
        NewLine = StrPtr(vbNewLine)
    End If
    
    cnt = 1 ' Будем предполагать, что в файле всегда есть хотя бы одна строка, если в файле не 0 байт конечно...
    
    Do
        FirstSearch = StrStrW(SearchFromTheSymbol, NewLine) ' Искать нужную нам строку
        If FirstSearch > 0 Then
            cnt = cnt + 1
            SearchFromTheSymbol = FirstSearch + 4 ' + vbcrlf
        End If
    Loop While FirstSearch > 0 ' Выполнять цикл до тех пор, пока будет найдена искомая подстрока
    
    If cnt = 1 Then ' Если ничего не найдено, попытаться поискать снова (на случай если в файле UTF16BE была утрачена запись BOM)
        SearchFromTheSymbol = VarPtr(str(1)) ' Изменим адресацию поиска +1 байт
        NewLine = StrPtr(Chr(13) & Chr(0) & Chr(10))
    
        Do
            FirstSearch = StrStrW(SearchFromTheSymbol, NewLine) ' Искать нужную нам строку
            If FirstSearch > 0 Then
                cnt = cnt + 1
                SearchFromTheSymbol = FirstSearch + 4 ' + vbcrlf
            End If
        Loop While FirstSearch > 0 ' Выполнять цикл до тех пор, пока будет найдена искомая подстрока
    End If
    
    CountStrsFromFileW = cnt
End Function

Option Explicit
Option Base 0
 
Private Const INVALID_HANDLE_VALUE    As Long = -1
Private Const FILE_MAP_READ           As Long = &H4
Private Const PAGE_READONLY           As Long = 2&
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 MapViewOfFile Lib "kernel32" ( _
                         ByVal hFileMappingObject As OLE_HANDLE, _
                         ByVal dwDesiredAccess As Long, _
                         ByVal dwFileOffsetHigh As Long, _
                         ByVal dwFileOffsetLow As Long, _
                         ByVal dwNumberOfBytesToMap As Long) As Long
Private Declare Function UnmapViewOfFile Lib "kernel32" ( _
                         ByVal lpBaseAddress As Long) As Long
Private Declare Function OpenFileMapping Lib "kernel32" _
                         Alias "OpenFileMappingW" ( _
                         ByVal dwDesiredAccess As Long, _
                         ByVal bInheritHandle As Long, _
                         ByVal lpName As Long) As Long
Private Declare Function CreateFileMapping Lib "kernel32" _
                         Alias "CreateFileMappingW" ( _
                         ByVal hFile As OLE_HANDLE, _
                         ByRef lpFileMappingAttributes As Any, _
                         ByVal flProtect As Long, _
                         ByVal dwMaximumSizeHigh As Long, _
                         ByVal dwMaximumSizeLow As Long, _
                         ByVal lpName 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 memchr CDecl Lib "ntdll" ( _
                         ByRef pDst As Any, _
                         ByVal c As Long, _
                         ByVal lCount As Long) As Long
                         
Sub Main()
    Dim lCount  As Long
    Dim f As Single
    
    f = Timer
    
    CountLinesAnsi "C:\temp\test_big.txt", lCount
    
    MsgBox Format$(Timer - f, "0.000") & "sec" & vbNewLine & "Lines: " & lCount
    
End Sub
 
Public Function CountLinesAnsi( _
                ByRef sFileName As String, _
                ByRef lRet As Long) As Long
    Dim hFile       As OLE_HANDLE
    Dim hMap        As OLE_HANDLE
    Dim tSize       As LARGE_INTEGER
    Dim tArrDesc    As SAFEARRAY1D
    Dim lText()     As Long
    Dim hr          As Long
    Dim lIndex      As Long
    Dim lCount      As Long
    Dim lBits       As Long
    Dim lTest       As Long
    Dim pData       As Long
    Dim pData2      As Long
    Dim bIsInIDE    As Boolean
    
    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
        lRet = 0
        GoTo CleanUp
    End If
        
    hMap = CreateFileMapping(hFile, ByVal 0&, PAGE_READONLY, 0, 0, 0)
    If hMap = 0 Then
        hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
        GoTo CleanUp
    End If
    
    With tArrDesc
        
        .pvData = MapViewOfFile(hMap, FILE_MAP_READ, 0, 0, 0)
        
        If .pvData = 0 Then
            hr = &H80070000 Or (Err.LastDllError And &HFFFF&)
            GoTo CleanUp
        End If
        
        .cDims = 1
        .cbElements = 4
        .tBounds.cElements = (tSize.lowpart + 3) \ 4
        
    End With
    
    PutMem4 ByVal ArrPtr(lText), VarPtr(tArrDesc)
    
    Debug.Assert MakeTrue(bIsInIDE)
    
    If bIsInIDE Then
    
        pData = VarPtr(lText(0)) - 1
        
        Do
        
            pData2 = memchr(ByVal pData + 1, &HA, tSize.lowpart)
        
            If pData2 Then
                lCount = lCount + 1
                tSize.lowpart = tSize.lowpart - (pData2 - pData)
            End If
            
            pData = pData2
            
         Loop While pData
         
    Else
    
        For lIndex = 0 To UBound(lText)
 
            lBits = lText(lIndex) Xor &HA0A0A0A
            lTest = ((lBits + &H7EFEFEFF) Xor (Not lBits)) And &H81010100
            
            If lTest Then
                
                If lTest And &H100 Then
                    lCount = lCount + 1
                End If
                If lTest And &H10000 Then
                    lCount = lCount + 1
                End If
                If lTest And &H1000000 Then
                    lCount = lCount + 1
                End If
                If (lBits And &HFF000000) = 0 Then
                    lCount = lCount + 1
                End If
                
            End If
 
        Next
    
    End If
    
    lCount = lCount + 1
 
    lRet = lCount
    
CleanUp:
    
    PutMem4 ByVal ArrPtr(lText), ByVal 0&
    
    If tArrDesc.pvData Then
        UnmapViewOfFile tArrDesc.pvData
    End If
    
    If hMap Then
        CloseHandle hMap
    End If
    
    If hFile Then
        CloseHandle hFile
    End If
    
    CountLinesAnsi = hr
    
End Function
 
Private Function MakeTrue( _
                 ByRef bValue As Boolean) As Boolean
    MakeTrue = True
    bValue = True
End Function

Option Explicit
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
 
Dim QF As Currency
Dim OldQC As Currency
Dim MinCur As Currency
Dim MaxCur As Currency
Dim QTimeVal As Double
 
Public Sub QTimeReset(ByVal Time As Double)
  MaxCur = CCur("922337203685477") + CCur(0.5807)
  MinCur = -MaxCur - CCur(0.0001)
  QueryPerformanceCounter OldQC
  QueryPerformanceFrequency QF
  QTimeVal = Time
End Sub
 
Public Function QTime() As Double
  Dim QC As Currency
 
  QueryPerformanceCounter QC
  If QC >= OldQC Then
    QTimeVal = QTimeVal + (QC - OldQC) / QF
  Else
    QTimeVal = QTimeVal + ((MaxCur - OldQC) + (QC - MinCur)) / QF
  End If
  OldQC = QC
  QTime = QTimeVal
End Function
 
Private Sub Form_Load()
    Dim lCount  As Long
    Dim f As Single
    
    f = Timer
    
    QTimeReset 0
    
    CountLinesAnsi "f:\Проекты Test\Чтение странного TXT\40 BE.txt", lCount
    
    MsgBox Format$(Timer - f, "0.000") & "sec" & vbNewLine & "Lines: " & lCount & vbNewLine & QTime
End Sub