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
Mostrar Temas
