Autor
|
Tema: [Módulos] - 5 métodos para comprimir archivos en VB (Leído 2,584 veces)
|
_Sergi_
Desconectado
Mensajes: 842
|
Bueno aqui les dejo cinco módulos completos y listos para usar para comprimir archivos desde VB. Como es lógico tambien sirven para cifrar datos, pero esa no es su función principal. Método 1: Base64Option Explicit
'This coder makes all the numbers <64 'it does this by stripping bit 0+1 of every byte and store those bits 'into a new byte 'so every 3 bytes will get an additional byte of 6 bits because 'we want this byte also to be <64 'The decoder reads the additional byte and substract the 6 bits 'from it and place them back into the original bytes
Public Sub FlattenTo64(ByteArray() As Byte) Dim codeBuf() As Byte Dim DecreaseBuf() As Byte Dim CodeTel As Long Dim DecrCode As Byte Dim Waarde As Integer Dim BitPos(7) As Byte Dim TelBits As Integer Dim FileLang As Long Dim X As Long Dim Y As Integer For X = 0 To 7 BitPos(X) = 2 ^ X Next FileLang = UBound(ByteArray) ReDim DecreaseBuf(FileLang) ReDim codeBuf(FileLang / 3 + 3) DecrCode = 0 CodeTel = -1 TelBits = 0 For X = 0 To FileLang Waarde = ByteArray(X) For Y = 1 To 2 If (Waarde And 1) = 1 Then DecrCode = DecrCode Or BitPos(TelBits) End If Waarde = Int(Waarde / 2) TelBits = TelBits + 1 Next DecreaseBuf(X) = Waarde If TelBits = 6 Then CodeTel = CodeTel + 1 codeBuf(CodeTel) = DecrCode DecrCode = 0 TelBits = 0 End If Next If TelBits > 0 Then CodeTel = CodeTel + 1 codeBuf(CodeTel) = DecrCode End If ReDim ByteArray(4 + CodeTel + FileLang) ByteArray(0) = Int(FileLang / &H1000000) And &HFF ByteArray(1) = Int(FileLang / &H10000) And &HFF ByteArray(2) = Int(FileLang / &H100) And &HFF ByteArray(3) = FileLang And &HFF Call CopyMem(ByteArray(4), codeBuf(0), CodeTel) Call CopyMem(ByteArray(CodeTel + 4), DecreaseBuf(0), FileLang + 1) End Sub
Public Sub DeFlattenTo64(ByteArray() As Byte) Dim OutStream() As Byte Dim OutPos As Long Dim CodeTel As Long Dim Code As Byte Dim DecrCode As Byte Dim Waarde As Integer Dim BitPos(7) As Byte Dim TelBits As Integer Dim FileLang As Long Dim X As Long Dim Y As Integer Dim InpCodeByte As Long Dim InpOrgByte As Long For X = 0 To 7 BitPos(X) = 2 ^ X Next For X = 0 To 3 FileLang = FileLang * 256 + ByteArray(X) Next InpCodeByte = 4 InpOrgByte = UBound(ByteArray) - FileLang If Int(InpOrgByte - Int((FileLang / 3))) <> InpCodeByte Then MsgBox "there was a problem in de Deflatter routine" End If ReDim OutStream(FileLang) OutPos = 0 Code = ByteArray(InpCodeByte) InpCodeByte = InpCodeByte + 1 TelBits = 2 For X = InpOrgByte To UBound(ByteArray) Waarde = ByteArray(X) For Y = 1 To 2 Waarde = Waarde * 2 + (-1 * ((Code And BitPos(TelBits - Y)) > 0)) Next TelBits = TelBits + 2 If TelBits = 8 Then TelBits = 2 Code = ByteArray(InpCodeByte) InpCodeByte = InpCodeByte + 1 End If OutStream(OutPos) = Waarde OutPos = OutPos + 1 Next ReDim ByteArray(OutPos - 1) Call CopyMem(ByteArray(0), OutStream(0), OutPos) End Sub
Método 2: EliasDeltaOption Explicit
'This is a 1 run method
'This compressor makes use of the Elias Delta codes 'How This codes are build up you can see in the init section
Private LeadingZero(9) As Integer Private DeltaCode(9) As Integer Private BitsToFollow(9) As Integer Private ValToAdd(9) As Integer Private OutPos As Long Private OutByteBuf As Byte Private OutBitCount As Integer Private InpPos As Long Private ReadBitPos As Integer
Public Sub Compress_Elias_Delta(ByteArray() As Byte) Dim OutStream() As Byte Dim X As Long Call Init_Elias_Delta ReDim OutStream(UBound(ByteArray)) For X = 0 To UBound(ByteArray) Call AddEliasToArray(OutStream, CLng(ByteArray(X))) Next Call AddEliasToArray(OutStream, 256) If OutBitCount > 0 Then Call AddBitsToArray(OutStream, 0, 8 - OutBitCount) End If ReDim ByteArray(OutPos) Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1) End Sub
Public Sub DeCompress_Elias_Delta(ByteArray() As Byte) Dim OutStream() As Byte Dim Char As Integer Dim X As Long Call Init_Elias_Delta ReDim OutStream(UBound(ByteArray)) Char = ReadEliasCode(ByteArray) Do While Char <> 256 Call AddCharToArray(OutStream, Char) Char = ReadEliasCode(ByteArray) Loop OutPos = OutPos - 1 ReDim ByteArray(OutPos) Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1) End Sub
Private Sub Init_Elias_Delta() OutPos = 0 OutByteBuf = 0 OutBitCount = 0 InpPos = 0 ReadBitPos = 0 LeadingZero(0) = 0: DeltaCode(0) = 1: BitsToFollow(0) = 0 '1 =1 -7 LeadingZero(1) = 1: DeltaCode(1) = 2: BitsToFollow(1) = 1 '010x =2-3 -4 LeadingZero(2) = 1: DeltaCode(2) = 3: BitsToFollow(2) = 2 '011xx =4-7 -3 LeadingZero(3) = 2: DeltaCode(3) = 4: BitsToFollow(3) = 3 '00100xxx =8-15 0 LeadingZero(4) = 2: DeltaCode(4) = 5: BitsToFollow(4) = 4 '00101xxxx =16-31 +1 LeadingZero(5) = 2: DeltaCode(5) = 6: BitsToFollow(5) = 5 '00110xxxxx =32-63 +2 LeadingZero(6) = 2: DeltaCode(6) = 7: BitsToFollow(6) = 6 '00111xxxxxx =64-127 +3 LeadingZero(7) = 3: DeltaCode(7) = 1: BitsToFollow(7) = 7 '0001xxxxxxx =128-255 +3 LeadingZero(8) = 4: DeltaCode(8) = 1: BitsToFollow(8) = 0 '00001 =256 -3 LeadingZero(9) = 4: DeltaCode(9) = 0: BitsToFollow(9) = 0 '00000 =257 +5 EOF ValToAdd(0) = 1 ValToAdd(1) = 2 ValToAdd(2) = 4 ValToAdd(3) = 8 ValToAdd(4) = 16 ValToAdd(5) = 32 ValToAdd(6) = 64 ValToAdd(7) = 128 ValToAdd(8) = 0 ValToAdd(9) = 0 End Sub
Private Function Get_Elias_Code(Number As Long) As Integer Select Case Number Case 1 Get_Elias_Code = 0 Case Is < 4 Get_Elias_Code = 1 Case Is < 8 Get_Elias_Code = 2 Case Is < 16 Get_Elias_Code = 3 Case Is < 32 Get_Elias_Code = 4 Case Is < 64 Get_Elias_Code = 5 Case Is < 128 Get_Elias_Code = 6 Case Is < 256 Get_Elias_Code = 7 Case Is = 256 Get_Elias_Code = 8 Case Else Get_Elias_Code = 9 End Select End Function
Private Sub AddEliasToArray(Toarray() As Byte, Char As Long) Dim Code As Integer Dim X As Integer Dim BitSize As Integer Char = Char + 1 Code = Get_Elias_Code(Char) Call AddBitsToArray(Toarray, 0, LeadingZero(Code)) Select Case DeltaCode(Code) Case Is < 2 BitSize = 1 Case Is < 4 BitSize = 2 Case Is < 8 BitSize = 3 Case Else BitSize = 1 End Select Call AddBitsToArray(Toarray, CLng(DeltaCode(Code)), BitSize) Call AddBitsToArray(Toarray, Char, BitsToFollow(Code)) End Sub
Private Function ReadEliasCode(FromArray() As Byte) As Integer Dim X As Integer Dim Temp As Integer Dim DeltaCode As Integer Dim bitcount As Integer Do While ReadBitsFromArray(FromArray, InpPos, 1) = 0 And bitcount < 5 bitcount = bitcount + 1 Loop If bitcount = 5 Then ReadEliasCode = 256: Exit Function If bitcount = 4 Then ReadEliasCode = 255: Exit Function If bitcount = 3 Then DeltaCode = 7 Else DeltaCode = 2 ^ bitcount + ReadBitsFromArray(FromArray, InpPos, bitcount) - 1 End If Temp = ValToAdd(DeltaCode) + ReadBitsFromArray(FromArray, InpPos, BitsToFollow(DeltaCode)) ReadEliasCode = Temp - 1 End Function
'this sub will add an amount of bits into the outputstream Private Sub AddBitsToArray(Toarray() As Byte, Number As Long, Numbits As Integer) Dim X As Long For X = Numbits - 1 To 0 Step -1 OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0)) OutBitCount = OutBitCount + 1 If OutBitCount = 8 Then Toarray(OutPos) = OutByteBuf OutBitCount = 0 OutByteBuf = 0 OutPos = OutPos + 1 If OutPos > UBound(Toarray) Then ReDim Preserve Toarray(OutPos + 500) End If End If Next End Sub
Private Sub AddCharToArray(Toarray() As Byte, Char As Integer) If OutPos > UBound(Toarray) Then ReDim Preserve Toarray(OutPos + 100) End If Toarray(OutPos) = Char OutPos = OutPos + 1 End Sub
Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As Long Dim X As Integer Dim Temp As Long For X = 1 To Numbits Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0)) ReadBitPos = ReadBitPos + 1 If ReadBitPos = 8 Then If FromPos + 1 > UBound(FromArray) Then Do While X < Numbits Temp = Temp * 2 X = X + 1 Loop FromPos = FromPos + 1 Exit For End If FromPos = FromPos + 1 ReadBitPos = 0 End If Next ReadBitsFromArray = Temp End Function
|
|
|
En línea
|
Proyecto de Ingeniero
|
|
|
_Sergi_
Desconectado
Mensajes: 842
|
Método 3: FibonacciOption Explicit
'This is a 1 run method
'This compressor makes use of the Fibonacci codes 'How This codes are build up you can see in the init section
Private Type Fibonacci_Code LeadingZero As Integer Value As Long End Type
Private BitNumVal(11) As Integer Private Fibonacci(257) As Fibonacci_Code Private OutPos As Long Private OutByteBuf As Byte Private OutBitCount As Integer Private InpPos As Long Private ReadBitPos As Integer
Private Sub Init_Fibonacci_code() ' 1 2 3 5 8 13 21 34 55 89 144 233 ' -------------------------------------------- ' 1 (1) =1 ' 0 1 (1) =2 ' 0 0 1 (1) =3 ' 1 0 1 (1) =4 ' 0 0 0 1 (1) =5 ' 1 0 0 1 0 0 1 (1) =27 ' 0 0 1 0 1 0 1 (1) =32 ' = 3 + 8 + 21 = =32 BitNumVal(0) = 1 BitNumVal(1) = 2 BitNumVal(2) = 3 BitNumVal(3) = 5 BitNumVal(4) = 8 BitNumVal(5) = 13 BitNumVal(6) = 21 BitNumVal(7) = 34 BitNumVal(8) = 55 BitNumVal(9) = 89 BitNumVal(10) = 144 BitNumVal(11) = 233 OutPos = 0 OutByteBuf = 0 OutBitCount = 0 InpPos = 0 ReadBitPos = 0 End Sub
Private Sub Create_Fibonacci_Codes() Dim Temp As String Dim X As Integer Dim Y As Integer Dim Value As Integer Dim bitcount As Integer Call Init_Fibonacci_code For Y = 1 To 257 Value = Y Fibonacci(Y).LeadingZero = 0 Fibonacci(Y).Value = 1 bitcount = 0 For X = 11 To 0 Step -1 If Value - BitNumVal(X) < 0 Then If Fibonacci(Y).Value > 1 Then Fibonacci(Y).LeadingZero = Fibonacci(Y).LeadingZero + 1 End If Else bitcount = bitcount + 1 Fibonacci(Y).Value = Fibonacci(Y).Value + 2 ^ bitcount Fibonacci(Y).LeadingZero = -1 * (X > 0) Value = Value - BitNumVal(X) X = X - 1 End If If bitcount > 0 Then bitcount = bitcount + 1 End If Next Next End Sub
Public Sub Compress_Fibonacci(ByteArray() As Byte) Dim OutStream() As Byte Dim X As Long Call Create_Fibonacci_Codes ReDim OutStream(UBound(ByteArray)) For X = 0 To UBound(ByteArray) Call AddFibonacciToArray(OutStream, CLng(ByteArray(X))) Next Call AddFibonacciToArray(OutStream, 256) If OutBitCount > 0 Then Call AddBitsToArray(OutStream, 0, 8 - OutBitCount) End If ReDim ByteArray(OutPos) Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1) End Sub
Public Sub DeCompress_Fibonacci(ByteArray() As Byte) Dim OutStream() As Byte Dim Char As Integer Dim X As Long Call Init_Fibonacci_code ReDim OutStream(UBound(ByteArray)) Char = ReadFibonacciCode(ByteArray) Do While Char <> 256 Call AddCharToArray(OutStream, Char) Char = ReadFibonacciCode(ByteArray) Loop OutPos = OutPos - 1 ReDim ByteArray(OutPos) Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1) End Sub
Private Sub AddFibonacciToArray(Toarray() As Byte, Char As Long) Dim X As Integer Dim bitcount As Integer Char = Char + 1 For bitcount = 0 To 14 If Fibonacci(Char).Value < 2 ^ bitcount Then Exit For End If Next Call AddBitsToArray(Toarray, 0, Fibonacci(Char).LeadingZero) Call AddBitsToArray(Toarray, Fibonacci(Char).Value, bitcount) End Sub
Private Function ReadFibonacciCode(FromArray() As Byte) As Integer Dim bitcount As Integer Dim Temp As Integer Dim BitVal As Integer Dim LastCode As Boolean LastCode = False Do BitVal = ReadBitsFromArray(FromArray, InpPos, 1) If BitVal = 1 Then If LastCode = True Then Exit Do Else LastCode = True End If Temp = Temp + BitNumVal(bitcount) Else LastCode = False End If bitcount = bitcount + 1 Loop ReadFibonacciCode = Temp - 1 End Function
'this sub will add an amount of bits into the outputstream Private Sub AddBitsToArray(Toarray() As Byte, Number As Long, Numbits As Integer) Dim X As Long For X = Numbits - 1 To 0 Step -1 OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0)) OutBitCount = OutBitCount + 1 If OutBitCount = 8 Then Toarray(OutPos) = OutByteBuf OutBitCount = 0 OutByteBuf = 0 OutPos = OutPos + 1 If OutPos > UBound(Toarray) Then ReDim Preserve Toarray(OutPos + 500) End If End If Next End Sub
Private Sub AddCharToArray(Toarray() As Byte, Char As Integer) If OutPos > UBound(Toarray) Then ReDim Preserve Toarray(OutPos + 100) End If Toarray(OutPos) = Char OutPos = OutPos + 1 End Sub
Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As Long Dim X As Integer Dim Temp As Long For X = 1 To Numbits Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0)) ReadBitPos = ReadBitPos + 1 If ReadBitPos = 8 Then If FromPos + 1 > UBound(FromArray) Then Do While X < Numbits Temp = Temp * 2 X = X + 1 Loop FromPos = FromPos + 1 Exit For End If FromPos = FromPos + 1 ReadBitPos = 0 End If Next ReadBitsFromArray = Temp End Function
Método 4: GroupSmartOption Explicit
'This is a 1 run method
'This method is the smartgrouping method 'it will search for follower bytes within a curtain range wich 'will fit into a curtain bitlenght 'It will search as long as needed to find the best compression 'if it finds followers of 12*0 and 4*1 = 16 bytes it will be compressed 'because 0 - 0 and 1 - 0 will both fit into 1 bit, it will fit 'in 16*1 bit wich will lead to to the following 'in 17 headerbits and 16 codebits = 33 bits = 4 bytes and 1 bit 'if it finds followers of 12*0 and 4*173 = 16 bytes it will be compressed 'because 0 - 0 will fit in 1 bit and 173 - 173 will fit into 1 bit it will fit 'in 12*1 bit and 4*1 bit wich will lead to to the following 'in 17 headerbits and 12 codebits = 29 bits = 3 bytes and 5 bits 'in 17 headerbits and 4 codebits = 21 bits = 2 bytes and 3 bits 'wich get a total of 6 bytes
Private OutPos As Long 'invoeg positie voor de output array Private OutBitCount As Integer Private OutByteBuf As Byte Private ReadBitPos As Integer Private NumExtBits(7) As Byte
Private Type Grouping LowValue As Long HighValue As Long NumInGroup As Long End Type Private Sub Init_Grouping() OutPos = 0 'Next position in the output stream OutBitCount = 0 'Number of bits stored in the output buffer OutByteBuf = 0 'byte wich will be stores in outputstream if it is filled with 8 bits ReadBitPos = 0 'next position wich will be read 'This array is used to determen the amount of bits used to store a number NumExtBits(0) = 3 '<8 NumExtBits(1) = 3 '<16 NumExtBits(2) = 4 '<32 NumExtBits(3) = 5 '<64 NumExtBits(4) = 6 '<128 NumExtBits(5) = 7 '<256 NumExtBits(6) = 8 '<512 NumExtBits(7) = 16 'the rest End Sub
Public Sub Compress_SmartGrouping(ByteArray() As Byte) Dim OutStream() As Byte 'The output array Dim BeginGroup As Long 'Start for the next bytes wich will be compressed Dim BestGroup As Integer 'Best grouping method to get the best result Dim NewBest As Integer 'used to check if there is maybe a better method Dim BitsDeep As Integer 'This is used as a dummy Dim X As Long Dim TotFileLen As Long 'total file len Dim Group(1 To 8) As Grouping TotFileLen = UBound(ByteArray) ReDim OutStream(TotFileLen + (TotFileLen / 7)) 'Worst case scenario BeginGroup = 0 'whe start by setting the beginvalues Call Init_Grouping 'lets check if we have done the whole file Do While BeginGroup < TotFileLen Group(8).LowValue = 0 Group(8).HighValue = 255 Group(8).NumInGroup = TotFileLen - BeginGroup + 1 'If where not ready yet whe assume the best method of compression is no compression 'That is indeed the best method cause nocompression needs 9 additional bits and compression uses 17 BestGroup = 8 'lets check if there is maybe a better way NewBest = CheckForBetterWithin(ByteArray, Group, BestGroup, BeginGroup) Do While BestGroup <> NewBest 'yes there is, lets check again to be shure BestGroup = NewBest NewBest = CheckForBetterWithin(ByteArray, Group, BestGroup, BeginGroup) Loop 'whe have found the best method If BestGroup = 8 Then BitsDeep = 0 'No compression Else BitsDeep = BestGroup End If 'here we will store the header in into the outputstream Call AddGroupCodeToStream(OutStream, Group(BestGroup).NumInGroup, BitsDeep) 'If we have found compression then we must store also the lowest value of the group 'opslaan minimum waarde van de groep If BestGroup <> 8 Then Call AddBitsToStream(OutStream, CLng(Group(BestGroup).LowValue), 8) End If 'here we will read the bytes from the inputstream, convert them, and store them 'into the output stream For X = BeginGroup To BeginGroup + Group(BestGroup).NumInGroup - 1 Call AddBitsToStream(OutStream, CLng(ByteArray(X) - Group(BestGroup).LowValue), BestGroup) Next BeginGroup = BeginGroup + Group(BestGroup).NumInGroup Loop 'if the grouping part is complete we have to store the EOF-marker = 0 '0 = no compression ,marker for less than 8 bytes, and 0 bytes to store Call AddGroupCodeToStream(OutStream, 0, 0) 'maybe we have some bits leftover so lets store them If OutBitCount < 8 Then Do While OutBitCount < 8 OutByteBuf = OutByteBuf * 2 OutBitCount = OutBitCount + 1 Loop OutStream(OutPos) = OutByteBuf: OutPos = OutPos + 1 End If OutPos = OutPos - 1 ReDim ByteArray(OutPos) 'lets copy the outputstream into the inputstream so that we can return the compressed file 'to the caller Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1) End Sub
'This part is used to select the extra bits used to store a value Private Function GetExtraBitsNum(Number As Long) Select Case Number Case Is < 8 GetExtraBitsNum = 0 Case Is < 16 GetExtraBitsNum = 1 Case Is < 32 GetExtraBitsNum = 2 Case Is < 64 GetExtraBitsNum = 3 Case Is < 128 GetExtraBitsNum = 4 Case Is < 256 GetExtraBitsNum = 5 Case Is < 512 GetExtraBitsNum = 6 Case Else GetExtraBitsNum = 7 End Select End Function
Private Sub AddGroupCodeToStream(ToStream() As Byte, Number As Long, GroupNum As Integer) Dim NumVal As Byte Dim X As Long 'Store 3 bits to say what grouping method is used Call AddBitsToStream(ToStream, CLng(GroupNum), 3) NumVal = GetExtraBitsNum(Number) 'store 3 bits to with will tell the amount of bits to be read to get the groupsize Call AddBitsToStream(ToStream, CLng(NumVal), 3) 'store 3 to 16 bits to put in the groepsize Call AddBitsToStream(ToStream, Number, CInt(NumExtBits(NumVal))) End Sub
'this sub will add an amount of bits into the outputstream Private Sub AddBitsToStream(ToStream() As Byte, Number As Long, Numbits As Integer) Dim X As Long For X = Numbits - 1 To 0 Step -1 OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0)) OutBitCount = OutBitCount + 1 If OutBitCount = 8 Then: ToStream(OutPos) = OutByteBuf: OutBitCount = 0: OutByteBuf = 0: OutPos = OutPos + 1 Next End Sub
'This is Smart part of the grouping method 'it will look for the way to get the best compression Private Function CheckForBetterWithin(InArray() As Byte, Group() As Grouping, MaxGroup As Integer, StartPositie As Long) Dim LowInGroup As Integer 'lowest value found Dim HighInGroup As Integer 'highest value found Dim GroupSize As Integer 'size of the group 1-7 Dim NumInGroup As Long 'total numbers in group Dim RealBegin As Long Dim BestGroep As Integer 'the best group found Dim NewBestGroep As Integer 'check for bestgroup Dim StartGroep As Integer 'startgroup to hold the group wich will be checked for better comp. Dim BestCompression As Long 'maximum compression (for now) Dim WheHaveCompression As Boolean 'whe have found a better method Dim Char As Integer 'character found in input stream Dim BitsNoComp As Long 'bits used if no comp. Dim BitsComp As Long 'bits used if comp. Dim CheckLen As Long 'maximum bytes to check Dim StartPos As Long 'startposition where the check will start StartPos = StartPositie RealBegin = StartPos StartGroep = MaxGroup CheckForBetterWithin = MaxGroup BestCompression = 0 If MaxGroup = 1 Then Exit Function 'better than the use of 1 bit ???? Do While StartPos + NumInGroup <= RealBegin + Group(StartGroep).NumInGroup - 1 CheckLen = RealBegin - StartPos + Group(StartGroep).NumInGroup - 1 'if ther are less then 3 bytes to check we exit If CheckLen < 3 Then Exit Function WheHaveCompression = False GroupSize = 1 'Lets start with the minimal groupsize Group(GroupSize).LowValue = InArray(StartPos + NumInGroup) Group(GroupSize).HighValue = InArray(StartPos + NumInGroup) 'check if we don't check the group we started with Do While (GroupSize < StartGroep) And (NumInGroup < 65535) NumInGroup = NumInGroup + 1 Group(GroupSize).NumInGroup = NumInGroup 'if we are at the end of the group we exit If StartPos + NumInGroup > RealBegin + Group(StartGroep).NumInGroup - 1 Then GoSub Calc_Compression: Exit Do Char = InArray(StartPos + NumInGroup) If Char < Group(GroupSize).LowValue Then If Group(GroupSize).HighValue - Char >= 2 ^ GroupSize Then GoSub Calc_Compression 'we have have found the maximum numer in the group If GroupSize < StartGroep - 1 Then 'why start over again for the next group 'if the number 15 will fit in 4 bits it shure will fit in 5 Group(GroupSize + 1).LowValue = Group(GroupSize).LowValue Group(GroupSize + 1).HighValue = Group(GroupSize).HighValue End If GroupSize = GroupSize + 1 Else Group(GroupSize).LowValue = Char End If ElseIf Char > Group(GroupSize).HighValue Then If Char - Group(GroupSize).LowValue >= 2 ^ GroupSize Then GoSub Calc_Compression If GroupSize < StartGroep - 1 Then Group(GroupSize + 1).LowValue = Group(GroupSize).LowValue Group(GroupSize + 1).HighValue = Group(GroupSize).HighValue End If GroupSize = GroupSize + 1 Else Group(GroupSize).HighValue = Char End If End If Loop If WheHaveCompression = True Then If RealBegin = StartPos Then 'if the beginning of the group is the same we startted with we have found a best group and leave CheckForBetterWithin = BestGroep Exit Function Else 'if not, then we have to check if there is maybe a compression possible in the part between 'the start of the file and the start of the new found bestgroep (again we start with no compression) Group(8).NumInGroup = StartPos - RealBegin BestGroep = 8 NewBestGroep = CheckForBetterWithin(InArray, Group, 8, RealBegin) Do While BestGroep <> NewBestGroep BestGroep = NewBestGroep NewBestGroep = CheckForBetterWithin(InArray, Group, BestGroep, RealBegin) Loop CheckForBetterWithin = BestGroep Exit Function End If Else 'if we didn't find compression then maybe there is a part further up in the file that achieves 'even better compression StartPos = StartPos + 1 NumInGroup = 0 End If Loop Exit Function Calc_Compression: 'bits needed if we dont do compression or maybe did already '3 for the compression method '3 for the number with will tell the amount of next bits to read '? numbers of bits needed to store the number of groupsize 'if whe already would do it with compression we need 8 bits for the lowvalue 'plus ofcourse the numbers of bits needed to store the group If CheckLen > 65535 Then CheckLen = 65535 BitsNoComp = 3 + 3 + NumExtBits(GetExtraBitsNum(Group(GroupSize).NumInGroup)) + (8 * Abs(MaxGroup < 8)) + (Group(GroupSize).NumInGroup * 8) - (Group(GroupSize).NumInGroup * (8 - MaxGroup)) 'bits needed to store compression '3 for method,3 for bits needed,the groupsize,8 bits for lowest value and the group itself BitsComp = 3 + 3 + NumExtBits(GetExtraBitsNum(Group(GroupSize).NumInGroup)) + (8 * Abs(GroupSize < 8)) + (Group(GroupSize).NumInGroup * 8) - (Group(GroupSize).NumInGroup * (8 - GroupSize)) 'if the new groep falls within the range of the old one whe also need to store the header the old group again If Group(GroupSize).NumInGroup <= Group(MaxGroup).NumInGroup Then BitsComp = BitsComp + 3 + 3 + NumExtBits(GetExtraBitsNum(CheckLen - StartPos - Group(GroupSize).NumInGroup)) + (8 * Abs(MaxGroup < 8)) 'if the start position of the new group is different whe also need the store a new header for that group If StartPos <> RealBegin Then BitsComp = BitsComp + 3 + 3 + NumExtBits(GetExtraBitsNum(RealBegin - StartPos)) ' + (8 * Abs(MaxGroup < 8)) NumInGroup = NumInGroup - 1 'if it is still better than the old method then whe have found a new group If BitsComp < BitsNoComp Then If BestCompression < BitsNoComp - BitsComp Then BestCompression = BitsNoComp - BitsComp WheHaveCompression = True BestGroep = GroupSize End If End If Return End Function
'this peace of code is very strait forward Public Sub DeCompress_SmartGrouping(ByteArray() As Byte) Dim AddFileLen As Long Dim OutStream() As Byte 'de output array Dim InpPos As Long Dim NewPos As Long Dim MaxPos As Long Dim PackedOrNot As Integer Dim NumBytes As Long Dim LowInGroup As Integer 'Laagste waarde in de groep Dim NumVal As Byte Dim X As Long AddFileLen = UBound(ByteArray) / 4 ReDim OutStream(UBound(ByteArray) + AddFileLen) MaxPos = UBound(OutStream) InpPos = 0 NewPos = 0 Call Init_Grouping Do 'loop until done 'read 3 bits to get grouping method (0 = not grouped) PackedOrNot = ReadBitsFromArray(ByteArray, InpPos, 3) 'read 3 bits to get the bits needed for the groupsize NumVal = ReadBitsFromArray(ByteArray, InpPos, 3) 'read the amount of data needed for the group NumBytes = ReadBitsFromArray(ByteArray, InpPos, CInt(NumExtBits(NumVal))) 'add an extra bit if needed (number 15 fits in 3 bits) If NumVal > 0 And NumVal < 7 Then NumBytes = NumBytes Or 2 ^ (NumVal + 2) End If If NumBytes = 0 Then Exit Do 'whe are done If PackedOrNot = 0 Then 'if not grouped, read the amount of nongrouped data (8 bits) For X = 1 To NumBytes 'de bytes zijn niet geGrouped If NewPos > MaxPos Then GoSub Increase_Outstream OutStream(NewPos) = ReadBitsFromArray(ByteArray, InpPos, 8) NewPos = NewPos + 1 Next Else 'if grouped, read the lowest value in the group LowInGroup = ReadBitsFromArray(ByteArray, InpPos, 8) 'and get the amount of data for that group For X = 1 To NumBytes 'de bytes zijn geGrouped If NewPos > MaxPos Then GoSub Increase_Outstream OutStream(NewPos) = ReadBitsFromArray(ByteArray, InpPos, PackedOrNot) + LowInGroup NewPos = NewPos + 1 Next End If Loop NewPos = NewPos - 1 ReDim ByteArray(NewPos) 'copy the temporary outputstream into the input stream to return it to the caller Call CopyMem(ByteArray(0), OutStream(0), NewPos + 1) Exit Sub Increase_Outstream: 'this is used if the reserved amount of store space wasn't sufficient ReDim Preserve OutStream(NewPos + AddFileLen) MaxPos = UBound(OutStream) Return End Sub
'this function will return a value out of the amaunt of bits you asked for Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As Long Dim X As Integer Dim Temp As Long For X = 1 To Numbits Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0)) ReadBitPos = ReadBitPos + 1 If ReadBitPos = 8 Then If FromPos + 1 > UBound(FromArray) Then Do While X < Numbits Temp = Temp * 2 X = X + 1 Loop FromPos = FromPos + 1 Exit For End If FromPos = FromPos + 1 ReadBitPos = 0 End If Next ReadBitsFromArray = Temp End Function
|
|
|
En línea
|
Proyecto de Ingeniero
|
|
|
_Sergi_
Desconectado
Mensajes: 842
|
Método 5: VBCOption Explicit
'This is a 2 run method
Private OutPos As Long Private OutByteBuf As Integer Private OutBitCount As Integer Private ReadBitPos As Integer Private ExtraBits(7) As Integer Private MinValToAdd(7) As Integer Private LastChar As Byte
Public Sub Compress_VBC(ByteArray() As Byte) Dim X As Long Dim OutStream() As Byte Dim CharCount(255) As Long Dim NewLen As Long Dim Char As Byte Dim ExtBits As Integer Call Init_VBC LastChar = 0 For X = 0 To UBound(ByteArray) CharCount(ByteArray(X)) = CharCount(ByteArray(X)) + 1 Next For X = 0 To 255 If CharCount(X) > 0 Then NewLen = NewLen + ((3 + getBitSize(CByte(X))) * CharCount(X)) End If Next NewLen = Int(NewLen / 8) + 1 ReDim OutStream(NewLen) 'worst case scenario For X = 0 To UBound(ByteArray) Char = ByteArray(X) ExtBits = getBitSize(Char) Call AddBitsToArray(OutStream, CLng(ExtBits), 3) If ExtBits <> 0 Then Call AddBitsToArray(OutStream, CLng(Char), ExtraBits(ExtBits)) End If LastChar = Char Next 'maybe we have some bits leftover so lets store them If OutBitCount < 8 Then Do While OutBitCount < 8 OutByteBuf = OutByteBuf * 2 OutBitCount = OutBitCount + 1 Loop OutStream(OutPos) = OutByteBuf: OutPos = OutPos + 1 End If OutPos = OutPos - 1 NewLen = UBound(ByteArray) ReDim ByteArray(OutPos + 4) ByteArray(0) = Int(NewLen / &H1000000) And &HFF ByteArray(1) = Int(NewLen / &H10000) And &HFF ByteArray(2) = Int(NewLen / &H100) And &HFF ByteArray(3) = NewLen And &HFF Call CopyMem(ByteArray(4), OutStream(0), OutPos + 1) End Sub
Public Sub DeCompress_VBC(ByteArray() As Byte) Dim X As Long Dim OutStream() As Byte Dim InpPos As Long Dim FileLang As Long Dim Char As Byte Dim ExtBits As Integer Call Init_VBC LastChar = 0 For X = 0 To 3 FileLang = FileLang * 256 + ByteArray(X) Next InpPos = 4 ReDim OutStream(FileLang) Do While OutPos < FileLang + 1 ExtBits = ReadBitsFromArray(ByteArray, InpPos, 3) If ExtBits = 0 Then Char = LastChar Else Char = ReadBitsFromArray(ByteArray, InpPos, ExtraBits(ExtBits)) + MinValToAdd(ExtBits) End If Call AddCharToArray(OutStream, OutPos, Char) LastChar = Char Loop OutPos = OutPos - 1 ReDim ByteArray(OutPos) Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1) End Sub
Private Sub Init_VBC() OutPos = 0 OutByteBuf = 0 OutBitCount = 0 ReadBitPos = 0 ExtraBits(0) = 0 'Last Character +5 MinValToAdd(0) = 0 ExtraBits(1) = 3 '0-7 +2 MinValToAdd(1) = 0 ExtraBits(2) = 3 '8-15 +2 MinValToAdd(2) = 8 ExtraBits(3) = 4 '16-31 +1 MinValToAdd(3) = 16 ExtraBits(4) = 4 '32-47 +1 MinValToAdd(4) = 32 ExtraBits(5) = 4 '48-64 +1 MinValToAdd(5) = 48 ExtraBits(6) = 6 '64-127 -1 MinValToAdd(6) = 64 ExtraBits(7) = 7 '128-255 -2 MinValToAdd(7) = 128 End Sub
Private Function getBitSize(Char As Byte) As Byte Select Case Char Case Is = LastChar getBitSize = 0 Case Is < 8 getBitSize = 1 Case Is < 16 getBitSize = 2 Case Is < 32 getBitSize = 3 Case Is < 48 getBitSize = 4 Case Is < 64 getBitSize = 5 Case Is < 128 getBitSize = 6 Case Else getBitSize = 7 End Select End Function
'this sub will add an amount of bits into the outputstream Private Sub AddBitsToArray(Toarray() As Byte, Number As Long, Numbits As Integer) Dim X As Long For X = Numbits - 1 To 0 Step -1 OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0)) OutBitCount = OutBitCount + 1 If OutBitCount = 8 Then Toarray(OutPos) = OutByteBuf OutBitCount = 0 OutByteBuf = 0 OutPos = OutPos + 1 If OutPos > UBound(Toarray) Then ReDim Preserve Toarray(OutPos + 500) End If End If Next 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 ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As Long Dim X As Integer Dim Temp As Long For X = 1 To Numbits Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0)) ReadBitPos = ReadBitPos + 1 If ReadBitPos = 8 Then If FromPos + 1 > UBound(FromArray) Then Do While X < Numbits Temp = Temp * 2 X = X + 1 Loop FromPos = FromPos + 1 Exit For End If FromPos = FromPos + 1 ReadBitPos = 0 End If Next ReadBitsFromArray = Temp End Function
Espero que les sean de utilidad, sobre la autoría de los mismos, los tenía en el disco duro y realmente no sé de que parte de internet los saqué ni quien es su autor, si lo encuentro lo añado. Un saludo Sergi
|
|
|
En línea
|
Proyecto de Ingeniero
|
|
|
ジ
Desconectado
Mensajes: 944
en la cuna !!
|
De mucha utilidad _Sergi_ , mira ver si puedes añadir más, salu2
|
|
|
En línea
|
el tiempo pondrá a cada uno en su lugar
|
|
|
Robokop
Desconectado
Mensajes: 1.660
|
Gracias Muy buenos y necesarios cuando se requiere trabajar con grandes cantidades de datos
|
|
|
En línea
|
|
|
|
Kizar
Desconectado
Mensajes: 1.325
kizar_net
|
Base 64 es muy conocido, por ejemplo se usa para codificar los archivos adjuntos k se envia por email. Me gustaria k explicases cual de los demas k as dicho reduce mas el tamaño de el archivo
|
|
|
En línea
|
|
|
|
|
Hans el Topo
Desconectado
Mensajes: 1.754
"Estoy cansado de no hacer nada"
|
yo no sabia que el de fibonacci servia pa eso... xD pensaba que era para cifrar y tal...
|
|
|
En línea
|
|
|
|
_Sergi_
Desconectado
Mensajes: 842
|
El que más me gusta es el método de Huffman, pero no lo he puesto porque creo que ya se ha hablado del tema.
Un saludo
|
|
|
En línea
|
Proyecto de Ingeniero
|
|
|
|
Mensajes similares |
|
Asunto |
Iniciado por |
Respuestas |
Vistas |
Último mensaje |
|
|
Comprimir Archivos de AVI
Multimedia
|
ignorantev1.1
|
9
|
10,668
|
7 Febrero 2011, 17:25 pm
por Songoku
|
|
|
[DUDA]Ocultar o comprimir archivos.
Criptografía
|
OneBlaack
|
3
|
4,028
|
12 Abril 2012, 14:41 pm
por APOKLIPTICO
|
|
|
Modulos para wifiway3.4
Wireless en Linux
|
El_Andaluz
|
2
|
3,802
|
14 Mayo 2012, 15:41 pm
por El_Andaluz
|
|
|
[c++]Script para comprimir varios archivos
Programación C/C++
|
MakotoAkira
|
1
|
3,450
|
6 Octubre 2012, 15:38 pm
por 0xDani
|
|
|
comprimir archivos
Multimedia
|
inma55
|
7
|
4,122
|
8 Diciembre 2019, 12:03 pm
por inma55
|
|