Файловые операции

Option Explicit
DefLng F, H-I, L, N, U: DefDbl D, M: DefStr J, S: DefBool B: DefObj O: DefVar V
'
'                   Модуль для работы с файлами и сохранением списков
'                   ©JoraVoenyjHaker
'
'--------------------------[Константы]
Private Const MaxSpace = 256
Public Enum F_ReCod
    [Без изменений] = 0
    [Windows To DOS] = 1
    [DOS To Windows] = 2
    [Binary To Unicode] = 4
    [Unicode To Binary] = 8
    [Без нулей справа] = 16
    [Без нулей слева] = 32
End Enum
'--------------------------[Переменные модуля]
Dim FxSpace As String * MaxSpace, Byt() As Byte
Dim f, n, n1, Dln, AnyString$, i, Dln1&
'--------------------------[Api Функции]
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
 
Public Function LoadList(Path$) As String()
    'Загрузка списка
    Dim f, f1, ul, n, n1, i, j(), text$
    text = ReadBytes(Path, [Binary To Unicode])
 
    For f = 1 To 3
        n = n * 256 + Asc(Mid$(text, f, 1))
    Next
    ul = Fix(n) / 3: n = n Mod 3
    ReDim j(ul)
    On Error GoTo 10
 
    For f = 4 To ul * (n + 1) + 4 Step n + 1
        n1 = 0
 
        For f1 = f To f + n
            n1 = n1 * 256 + Asc(Mid$(text, f1, 1))
        Next
        j(i) = n1: i = i + 1
    Next
 
    For f1 = 0 To ul
        n = j(f1)
        j(f1) = Mid$(text, f, n)
        f = f + n
    Next
10
    LoadList = j
End Function
 
Public Sub SaveList(Path$, List$())
    'Сохранение списка
    Dim f, f1, ul, n, j()
    ul = UBound(List)
    '-------------
    ReDim Preserve j(ul + 1)
 
    For f = 1 To ul + 1
        n = Len(List(f - 1))
        j(f) = Space(3)
 
        For f1 = 3 To 1 Step -1
            Mid$(j(f), f1, 1) = Chr(n Mod 256)
            n = Fix(n / 256)
        Next
    Next
    '----------------------- Сжать индексы
    For f = 2 To 0 Step -1
 
        For f1 = 1 To ul + 1
            If Mid$(j(f1), 1, 1) <> vbNullChar Then GoTo 10
        Next
 
        For f1 = 1 To ul + 1
            j(f1) = Mid$(j(f1), 2)
        Next
    Next
10
    '------------------ Первая ячейка
    n = ul * 3 + Abs(f)
    j(0) = Space(3)
 
    For f = 3 To 1 Step -1
        Mid$(j(0), f, 1) = Chr(n Mod 256)
        n = Fix(n / 256)
    Next
    Call WriteBytes(Path, Join(j, "") & Join(List, ""), [Unicode To Binary], 1, True)
End Sub
 
Public Function WriteBytes&(Path$, Bytes As Variant, Optional ByVal Flag As F_ReCod, Optional ByVal Start& = 1, Optional Overwrite As Boolean)
    'Запись байт в файл
    'Арг: Путь // Массив байт (Или текст) // Флаг кодировки // Старт // Флаг перезаписи
    'Возврат: Следующая позиция записи (при успешном выполнении)
    On Error GoTo 1
    If Overwrite Then Call Kill(Path)
1
    Open Path For Binary As #1
    Byt = Bytes
    If Start Then Else Start = 1
    Put #1, Start, ReCod(Byt, Flag)
    WriteBytes = Start + UBound(Byt) + 1
    Close #1
End Function
 
Public Function ReadBytes(Path$, Optional ByVal Flag As F_ReCod, Optional ByVal Start&, Optional ByVal Dln&) As Byte()
    'Чтение байт из файла
    'Арг: Путь // Флаг кодировки // Старт // Длина
    'Возврат: Массив байт
    Open Path For Binary As #1
    On Error Resume Next
    If Start Then Else Start = 1
    Dln1 = LOF(1) - Start + 1
    If Dln = 0 Or Dln > Dln1 Then Dln = Dln1
    ReDim Preserve ReadBytes(Dln - 1)
    Get #1, Start, ReadBytes
    ReadBytes = ReCod(ReadBytes, Flag)
    Close #1
End Function
 
Public Function ReCod(Bytes As Variant, Optional ByVal Flag As F_ReCod) As Byte()
    'Перекодирование текста стандартами Windows
    'Bytes: Массив байт (Или текст)
    'Flag: Комбинируемые команды: [DOS to Windows] + [Binary to Unicode] ...
    ReCod = Bytes
 
    While Flag > 0
 
        Select Case Flag
        Case Is >= [Без нулей слева]
            Flag = Flag - [Без нулей слева]
            n = MaxSpace
            f = 1
 
            Do While n > 0
 
                For f = f To UBound(ReCod) + 1 Step n
                    If Mid$(ReCod, f, n) <> Mid$(FxSpace, 1, n) Then Exit For
                Next
                n = n / 2
            Loop
            ReCod = Mid$(ReCod, f)
        Case Is >= [Без нулей справа]
            '-------------------------
            ReCod = StrReverse(ReCod)
            Flag = Flag - [Без нулей справа]
            n = MaxSpace
            f = 1
 
            Do While n > 0
 
                For f = f To UBound(ReCod) + 1 Step n
                    If Mid$(ReCod, f, n) <> Mid$(FxSpace, 1, n) Then Exit For
                Next
                n = n / 2
            Loop
            ReCod = StrReverse(Mid$(ReCod, f))
            '-----------------------------------------------
        Case Is >= [Unicode To Binary]
            Flag = Flag - [Unicode To Binary]
            ReCod = StrConv(ReCod, vbFromUnicode)
        Case Is >= [Binary To Unicode]
            Flag = Flag - [Binary To Unicode]
            ReCod = StrConv(ReCod, vbUnicode)
        Case Is >= [DOS To Windows]
            Flag = Flag - [DOS To Windows]
            AnyString = ReCod
            Call OemToChar(ReCod, AnyString)
            ReCod = AnyString
        Case Is >= [Windows To DOS]
            Flag = Flag - [Windows To DOS]
            AnyString = ReCod
            Call CharToOem(ReCod, AnyString)
            ReCod = AnyString
        End Select
    Wend
End Function