Indetectables

Bueno, aquí os traigo mi primer algoritmo de compresión. Básicamente, comprime las sucesiones de ceros, en cadenas de 4 bytes (2 para la firma, 2 para la cantidad). Es un algoritmo muy simple, por lo que el porcentaje de compresión no es muy alto. Además, he intentado hacer el mínimo de operaciones posibles, para hacerlo más eficiente.

Este algoritmo está pensado sobre todo para comprimir ejecutables, ya que el 0 suele ser el número que más se repite en este tipo de archivos.

Código: Seleccionar todo

'Simple compresión de ceros
'
'Autor:     Slek
'
'Versión:   1
'
'Fecha:     17/12/2011
'
'Indetectables.net
'
'Ej:
'   Call ComprimirCeros(ArrIn(), ArrOut())
'   Call DescomprimirCeros(ArrIn(), ArrOut())

Option Explicit

Public Function ComprimirCeros(ByRef b() As Byte, ByRef Result() As Byte)

    Dim i       As Long
    Dim lSize   As Long
    Dim lRes    As Long
    Dim cRes    As Long
    Dim Bound   As Long
    
    Bound = UBound(b)
    
    ReDim Result(Bound)
    
    For i = 0 To Bound
        If b(i) = 0 Then
        
            lSize = CerosConsecutivos(i, b())
            
            If lSize > 4 Then
                
                cRes = i - lRes
                
                Result(cRes) = &HBB
                Result(cRes + 1) = &HBE
                Result(cRes + 2) = lSize And &HFF
                Result(cRes + 3) = (lSize And &HFF00&) \ &H100
                
                lRes = lRes + (lSize - 4)
                
                i = i + lSize - 1
            End If
        Else
            Result(i - lRes) = b(i)
        End If
    Next
    
    ReDim Preserve Result(Bound - lRes + 4)
    
    Call PutLong(Bound - lRes + 1, Bound, Result())

End Function

Private Function CerosConsecutivos(ByVal nStart As Long, ByRef b() As Byte) As Integer
    
    Dim i       As Long
    Dim lMax    As Long
    
    lMax = UBound(b) + 1
    
    i = nStart
    
    Do
        i = i + 1
        If i = lMax Then Exit Do
    Loop While b(i) = 0
    
    CerosConsecutivos = i - nStart
End Function

Private Sub PutLong(ByVal nStart As Long, ByVal DWord As Long, ByRef b() As Byte)

    Dim iWord   As Integer
    
    iWord = IIf(DWord And &H8000&, DWord Or &HFFFF0000, DWord And &HFFFF&)
    
    b(nStart) = iWord And &HFF
    b(nStart + 1) = (iWord And &HFF00&) \ &H100
    
    iWord = (DWord And &HFFFF0000) \ &H10000
    
    b(nStart + 2) = iWord And &HFF
    b(nStart + 3) = (iWord And &HFF00&) \ &H100
    
End Sub

Public Sub DescomprimirCeros(ByRef b() As Byte, ByRef Result() As Byte)

    Dim i       As Long
    Dim lSize   As Long
    Dim lRes    As Long
    Dim Bound   As Long
    
    Bound = UBound(b) - 4
    
    ReDim Result(GetLong(b))
    
    For i = 0 To Bound
        If b(i) = &HBB Then
            If b(i + 1) = &HBE Then
                lSize = b(i + 3) * &H100 + b(i + 2)
                
                Call AñadirCeros(lSize, i + lRes, Result())
                
                lRes = lRes + (lSize - 4)
                
                i = i + 3
            Else
                Result(i + lRes) = b(i)
            End If
        Else
            Result(i + lRes) = b(i)
        End If
    Next
    
End Sub

Private Sub AñadirCeros(ByVal nCeros As Long, ByVal nStart As Long, ByRef b() As Byte)

    Dim i       As Long
    Dim nStop   As Long
    
    nStop = nStart + nCeros - 1
    
    For i = nStart To nStop
        b(i) = 0
    Next
    
End Sub

Private Function GetLong(ByRef b() As Byte) As Long

    Dim Bound   As Long
    
    Bound = UBound(b)
    
    GetLong = b(Bound) * &H1000000 + b(Bound - 1) * &H10000 + b(Bound - 2) * &H100 + b(Bound - 3)
    
End Function

Nota: Puede dar algún error si en el archivo a comprimir se encuentra la firma &HBBBE
Nota2: si se modifica y se le añade una encriptación Xor o ROT, es un algoritmo bastante bueno para usar en crypters etc...

Ejemplo para comprimir:

Código: Seleccionar todo

Private Sub Command1_Click()
    Dim Arr() As Byte
    Dim Out() As Byte
    
    Open "C:\1.exe" For Binary Access Read As #1
        ReDim Arr(LOF(1) - 1)
        Get #1, , Arr()
    Close #1
    
    Call ComprimirCeros(Arr(), Out())
    
    Open "C:\1.bin" For Binary Access Write As #1
        Put #1, , Out()
    Close #1
    
    MsgBox "Fin"
End Sub

Ejemplo para descomprimir:

Código: Seleccionar todo

Private Sub Command1_Click()
    Dim Arr() As Byte
    Dim Out() As Byte
    
    Open "C:\1.bin" For Binary Access Read As #1
        ReDim Arr(LOF(1) - 1)
        Get #1, , Arr()
    Close #1
    
    Call DescomprimirCeros(Arr(), Out())
    
    Open "C:\2.exe" For Binary Access Write As #1
        Put #1, , Out()
    Close #1
    
    MsgBox "Fin"
End Sub

P.D: cómo se nota que me aburro no? xDD

Saludos!!

Slek eres una máquina programando.
Gracias por compartirlo!

vaya caca de modulo... Asi lo digo. Na hombre, impecable como siempre.
Me dejo un archivo de 12kb a 3,68kb :P

Muy buen algoritmo, bro te felicito!

Estás a tope tio, que grande. Buen trabajo!

un saludo!

Felicidades hermano como siempre, pules la zona y ones a todos al 100% !!

Muchas Gracias a todos ^^

Saludos y Felices Fiestas!!

he muy buena SLEK, si eso lo haces cuando te aburres ,entonces que haras cuando no te aburras

saludos y feliz navidad

De lujo, como siempre, Slek

Indetectables

[VB6] ZCompression by Slek

[VB6] ZCompression by Slek

Re: [VB6] ZCompression by Slek

Re: [VB6] ZCompression by Slek

Re: [VB6] ZCompression by Slek

Re: [VB6] ZCompression by Slek

Re: [VB6] ZCompression by Slek

Re: [VB6] ZCompression by Slek

Re: [VB6] ZCompression by Slek

Re: [VB6] ZCompression by Slek