VBCoding Библиотека кодов Visual Basic 6 Файловая система Сжатие файла алгоритмом Rlevar

Visual Basic 6
Сжатие файла алгоритмом Rlevar
Чтобы запаковать файл используйте функцию Compress, распаковать его обратно - DeCompress.

'КОД МОДУЛЯ
Attribute VB_Name = "Comp_RLE_Var"
Option Explicit
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, ByVal Length As Long)
Private OutStream() As Byte
Private ContStream() As Byte
Private LengthStream() As Byte
Private ReadBitPos As Integer
Private CntPos As Long
Private OutPos As Long
Private JustLoaded As Boolean
Private WorkArray() As Byte
Private OriginalArray() As Byte
Private OriginalSize As Long
'this is a routine wich can be used recurserfly

Public Sub Compress_RLE_Var_Loop(ByteArray() As Byte)
    Dim NuSize As Long
    Dim TimesRLE As Integer
    Dim FileNr As Integer
    Dim IsCompressed As Boolean
    Do
        NuSize = UBound(ByteArray)
        Call Compress_RLE_Var(ByteArray, IsCompressed)
        TimesRLE = TimesRLE + 1
    Loop While IsCompressed = True
    ReDim Preserve ByteArray(UBound(ByteArray) + 1)
    ByteArray(UBound(ByteArray)) = TimesRLE
End Sub

Public Sub DeCompress_RLE_Var_Loop(ByteArray() As Byte)
    Dim X As Integer
    Dim TimesRLE As Integer
    TimesRLE = ByteArray(UBound(ByteArray))
    ReDim Preserve ByteArray(UBound(ByteArray) - 1)
    For X = 1 To TimesRLE
        Call DeCompress_RLE_Var(ByteArray)
    Next
End Sub

'This is a 1 run method but we have to keep the whole contents
'in memory until some variables are saved wich are needed bij the decompressor

Public Sub Compress_RLE_Var(ByteArray() As Byte, IsCompressed As Boolean)
    Dim X As Long
    Dim Y As Long
    Dim ByteCount As Long
    Dim LastAsc As Integer
    Dim TelSame As Long
    Dim Times255 As Integer
    Dim Same255 As Integer
    Dim IsRun As Boolean
    Dim ZeroCount As Integer
    Dim LengthPos As Long
    Dim NoLength As Boolean
    ReDim ContStream(200)
    ReDim LengthStream(200)
    ReDim OutStream(500)
    IsCompressed = False
    ByteCount = 0
    LastAsc = 0
    CntPos = 1
    OutPos = 0
    LengthPos = 0
    TelSame = 0
    ZeroCount = 0
    For X = 0 To UBound(ByteArray)
        DoEvents
        If LastAsc = ByteArray(X) And X <> 0 Then IsRun = True Else IsRun = False
        If IsRun = False Then
            If TelSame = 1 Then
                TelSame = 0
                Call AddCharToArray(OutStream, OutPos, CByte(LastAsc))
                ByteCount = ByteCount + 1
            ElseIf TelSame > 1 Then
                For Y = 1 To Int(ByteCount / 255)
                    Call AddCharToArray(ContStream, CntPos, 255)
                Next
                ByteCount = ByteCount Mod 255
                If ByteCount = 0 Then ZeroCount = ZeroCount + 1
                Call AddCharToArray(ContStream, CntPos, CByte(ByteCount))
                ByteCount = 0
                For Y = 1 To Int(TelSame / 255)
                    Call AddCharToArray(LengthStream, LengthPos, 255)
                Next
                TelSame = TelSame Mod 255
                Call AddCharToArray(LengthStream, LengthPos, CByte(TelSame))
                TelSame = 0
            End If
            Call AddCharToArray(OutStream, OutPos, ByteArray(X))
            ByteCount = ByteCount + 1
        Else
            TelSame = TelSame + 1
        End If
        LastAsc = ByteArray(X)
    Next
    If IsRun = True Then
        If TelSame < 2 Then
            Call AddCharToArray(OutStream, OutPos, CByte(LastAsc))
        Else
            For Y = 1 To Int(ByteCount / 255)
                Call AddCharToArray(ContStream, CntPos, 255)
            Next
            ByteCount = ByteCount Mod 255
            Call AddCharToArray(ContStream, CntPos, CByte(ByteCount))
            For Y = 1 To Int(TelSame / 255)
                Call AddCharToArray(LengthStream, LengthPos, 255)
            Next
            TelSame = TelSame Mod 255
            Call AddCharToArray(LengthStream, LengthPos, CByte(TelSame))
        End If
    End If
    ContStream(0) = CByte(ZeroCount)
    If CntPos > 1 Then IsCompressed = True
    Call AddCharToArray(ContStream, CntPos, 0)  'No Run Till EOF
    ReDim Preserve ContStream(CntPos - 1)
    If LengthPos > 0 Then
        ReDim Preserve LengthStream(LengthPos - 1)
        NoLength = False
    Else
        NoLength = True
    End If
    ReDim Preserve OutStream(OutPos - 1)
    CntPos = UBound(ContStream) + 1
    LengthPos = 0
    If NoLength = False Then LengthPos = UBound(LengthStream) + 1
    OutPos = UBound(OutStream) + 1
    ReDim ByteArray(CntPos + LengthPos + OutPos - 1)
    Call CopyMem(ByteArray(0), ContStream(0), CntPos)
    If LengthPos > 0 Then
        Call CopyMem(ByteArray(CntPos), LengthStream(0), LengthPos)
    End If
    Call CopyMem(ByteArray(CntPos + LengthPos), OutStream(0), OutPos)
End Sub

Public Sub DeCompress_RLE_Var(ByteArray() As Byte)
    Dim X As Long
    Dim CntCount As Long
    Dim LastChar As Byte
    Dim ByteCount As Long
    Dim InpPos As Long
    Dim ZeroCount As Integer
    Dim LengthPos As Long
    ZeroCount = 0
    For X = 1 To UBound(ByteArray)
        If ByteArray(X) = 0 Then
            If ZeroCount = ByteArray(0) Then Exit For
            ZeroCount = ZeroCount + 1
        End If
        If ByteArray(X) <> 255 Then
            CntCount = CntCount + 1
        End If
    Next
    OutPos = 0
    CntPos = 1
'    LengthPos = 0
    LengthPos = X + 1
    InpPos = LengthPos
    Do While CntCount > 0
        If ByteArray(InpPos) <> 255 Then
            CntCount = CntCount - 1
        End If
        InpPos = InpPos + 1
    Loop
    ReDim OutStream(UBound(ByteArray) - InpPos + 1)
    ByteCount = ReadCharFromArray(ByteArray, CntPos)
    CntCount = ReadCharFromArray(ByteArray, LengthPos)
    Do
    DoEvents
        If ByteCount = 0 Then
            For X = 1 To UBound(ByteArray) - InpPos + 1
                LastChar = ReadCharFromArray(ByteArray, InpPos)
                Call AddCharToArray(OutStream, OutPos, LastChar)
            Next
        Else
            For X = 1 To ByteCount
                LastChar = ReadCharFromArray(ByteArray, InpPos)
                Call AddCharToArray(OutStream, OutPos, LastChar)
            Next
            If ByteCount = 255 Then
                Do
                    ByteCount = ReadCharFromArray(ByteArray, CntPos)
                    For X = 1 To ByteCount
                        LastChar = ReadCharFromArray(ByteArray, InpPos)
                        Call AddCharToArray(OutStream, OutPos, LastChar)
                    Next
                Loop While ByteCount = 255
                ByteCount = ReadCharFromArray(ByteArray, CntPos)
            Else
                ByteCount = ReadCharFromArray(ByteArray, CntPos)
            End If
            For X = 1 To CntCount
                Call AddCharToArray(OutStream, OutPos, LastChar)
            Next
            If CntCount = 255 Then
                Do
                    CntCount = ReadCharFromArray(ByteArray, LengthPos)
                    For X = 1 To CntCount
                        Call AddCharToArray(OutStream, OutPos, LastChar)
                    Next
                Loop While CntCount = 255
                CntCount = ReadCharFromArray(ByteArray, LengthPos)
            Else
                CntCount = ReadCharFromArray(ByteArray, LengthPos)
            End If
        End If
    Loop While InpPos <= UBound(ByteArray)
    ReDim ByteArray(OutPos - 1)
    Call CopyMem(ByteArray(0), OutStream(0), OutPos)
End Sub

Private Sub AddCharToArray(Toarray() As Byte, ToPos As Long, Char As Byte)
    If ToPos > UBound(Toarray) Then
        ReDim Preserve Toarray(ToPos + 500)
    End If
    Toarray(ToPos) = Char
    ToPos = ToPos + 1
End Sub

Private Function ReadCharFromArray(FromArray() As Byte, FromPos As Long) As Byte
    ReadCharFromArray = FromArray(FromPos)
    FromPos = FromPos + 1
End Function

'this sub is used to load a chosen file
Public Sub load_File(ByVal FileName$)
    Dim FreeNum As Integer
    FreeNum = FreeFile
    Open FileName For Binary As #FreeNum
    ReDim OriginalArray(0 To LOF(FreeNum) - 1)
    Get #FreeNum, , OriginalArray()
    Close #FreeNum
    JustLoaded = True
    Call Split_Header_From_File(OriginalArray)
    OriginalSize = UBound(OriginalArray) + 1
End Sub

'this sub is used to see if the file just loaded is a file which is
'stored by this programm and is already coded/compressed
Private Sub Split_Header_From_File(ByteArray() As Byte)
    Dim HeadText As String
    Dim X As Integer
    Dim CodecsUsed As Integer
    Dim Version As String
    Dim InPos As Long
    If UBound(ByteArray) < 3 Then Exit Sub  'original file to small
    InPos = UBound(ByteArray)
    For X = 0 To 2
        HeadText = HeadText & Chr(ByteArray(InPos))
        InPos = InPos - 1
    Next
    If HeadText <> "UCF" Then Exit Sub  'this is an un-UCF'ed file
    Version = Chr(ByteArray(InPos))
    InPos = InPos - 1
    Select Case Version
        Case "0"
            CodecsUsed = ByteArray(InPos)
            InPos = InPos - 1
            ReDim UsedCodecs(CodecsUsed)
            For X = 1 To CodecsUsed
                UsedCodecs(X) = ByteArray(InPos)
                InPos = InPos - 1
            Next
            ReDim Preserve ByteArray(InPos)
    End Select
    ReDim WorkArray(0)
    JustLoaded = False
End Sub


Public Function Compress(ByVal FileName$) As Boolean
On Error GoTo 10
Dim Dummy As Boolean, s$, i
DoEvents
load_File FileName
ReDim WorkArray(UBound(OriginalArray))
Call CopyMem(WorkArray(0), OriginalArray(0), UBound(OriginalArray) + 1)
Compress_RLE_Var WorkArray, Dummy
If Dummy = False Then Exit Function
DoEvents
Kill FileName
DoEvents
i = FreeFile
Open FileName For Binary Shared As i
Put #1, 1, WorkArray
Compress = True
10 On Error Resume Next
Close #i
End Function


Public Function DeCompress(ByVal FileName$) As Boolean
On Error GoTo 10
Dim s$, i
DoEvents
load_File FileName
ReDim WorkArray(UBound(OriginalArray))
Call CopyMem(WorkArray(0), OriginalArray(0), UBound(OriginalArray) + 1)
DeCompress_RLE_Var WorkArray
If Dummy = False Then Exit Function
DoEvents
Kill FileName
DoEvents
i = FreeFile
Open FileName For Binary Shared As i
Put #1, 1, WorkArray
DeCompress = True
10 On Error Resume Next
Close #i
End Function
 

Добавить комментарий


Защитный код
Обновить

 
VBCoding Библиотека кодов Visual Basic 6 Файловая система Сжатие файла алгоритмом Rlevar  
Powered by Exponenta -