Newsgroup: it.comp.lang.visual-basic
Titolo: Compressione con lz32.dll

Salve a tutti,
dovendo comprimere dei dati, posso usare la lz32.dll ?
ho trovato le Api solo per la decompressione.
In altenativa, c'è qualcos'altro che comprime, possibilmente non
un ocx?
Grazie.

Ciao,
ti allego un sorgente che utilizza l'algoritmo LZ78 che io uso e che ha una
buona compressione.
Grazie a Gaetano Caivano per il buon lavoro! (;-))
P.S.  devi fare delle piccole modifiche, così da passare i parametri
relativi al file da comprimere
e decomprimere.
'***************************************************************************
******'
'* Tradotto dal C da Gaetano Caivano
*'
'* Modulo di dimostrazione che implementa l'algoritmo LZ78 (a tabella
variabile) *'
'* 06 Marzo 1999
*'
'*
*'
'*
*'
'* Questa è una traduzione abbastanza fedele di un programma realizzato in C
da  *'
'* Mark Nelson. Mia intenzione è quella di realizzare in Visual Basic del
codice *'
'* che permette di compattare file. Forse è un po' lento (almeno sembra)
però se *'
'* qualcuno volesse adoperarsi per farlo diventare più veloce ben venga
(ovvia-  *'
'* mente può sempre informarmi della cosa o almeno mensionarmi nei
ringraziamen- *'
'* ti....). A tutti voi il lavoro eseguito (lieto di conoscere eventuali
bug).   *'
'*
*'
'***************************************************************************
******'
Const BITS = 12
Const HASHING_SHIFT = BITS - 8
Const MAX_VALUE = (1 * 2 ^ BITS) - 1
Const MAX_CODE = MAX_VALUE - 1
Const TABLE_SIZE = 5021
Dim code_value@ (0 To TABLE_SIZE - 1)
Dim prefix_code@ (0 To TABLE_SIZE - 1)
Dim append_character$(0 To TABLE_SIZE - 1)
Dim decode_stack$
Dim buffers() As Byte
Dim intro() As Byte
Dim putto&, GETTO&
Dim conto&
'---------
Sub main()
'---------
Dim inp_file%
Dim outp_file%
Dim lzw_file%
ReDim Preserve buffers(0 To 1000000) As Byte
putto = 0
' Apre il file di input per la compattazione
inp_file% = FreeFile
Form1.cd1.ShowOpen
Open Form1.cd1.FileName For Binary As inp_file%
' Apre il file di output per la compattazione
lzw_file% = FreeFile
Form1.cd1.ShowOpen
On Error Resume Next
Kill Form1.cd1.FileName
On Error GoTo 0
Open Form1.cd1.FileName For Binary As lzw_file%
' Comprime il file
orig = LOF(inp_file)
lung& = CLng(LOF(inp_file%))
Put lzw_file, , lung&
towrite& = compress(inp_file, lzw_file, lung&)
ReDim Preserve buffers(0 To towrite& - 1) As Byte
Put lzw_file, , buffers
Close inp_file
Close lzw_file
'---------------------------------------------------------------'
MsgBox ("Ratio: " & Int((towrite& + 4) / orig * 1000) / 10 & "%")
'---------------------------------------------------------------'
ReDim Preserve buffers(0 To 1000000) As Byte
putto = 0
' Ora apre il file per la decompressione
Open Form1.cd1.FileName For Binary As lzw_file%
' Ed il file di output
On Error Resume Next
Kill "d:\prova\output.txt"
On Error GoTo 0
outp_file% = FreeFile
Open "d:\prova\output.txt" For Binary As outp_file%
Get lzw_file, , lung&
' Decomprime il file
towrite& = expand(lzw_file, outp_file, lung&)
ReDim Preserve buffers(0 To putto - 1) As Byte
If towrite& > lung& Then
    Put outp_file%, , intro
Else
    Put outp_file%, , buffers
End If
Close lzw_file
Close outp_file
'------------------------------'
MsgBox ("Operazione completata")
'------------------------------'
End Sub
'------------------------
Public Function getc&(a%)
'------------------------
Dim s As Byte
If GETTO < LOF(a%) Then
    Get a%, , s
    getc = s
    GETTO = GETTO + 1
Else
    getc = -1
End If
End Function
'-------------------------------------
Public Sub putc(buff As Byte)
'-------------------------------------
buffers(putto) = buff
putto = putto + 1
End Sub
'Questa è la routine di compressione
'-----------------------------
Function compress(inp%, outp%, lung&)
'-----------------------------
Dim next_code@
Dim character@
Dim stringa_code@
Dim index@
Dim i%
ReDim Preserve intro(0 To LOF(inp) - 1) As Byte
Get inp%, , intro                               ' Ridimensiona e legge il
buffer
conto = 0
next_code = 256                                 ' Next code è il prossimo
codice a disposizione
For i = 0 To TABLE_SIZE - 1                     ' Annulla la tabella stringa
    code_value(i) = -1
Next
i = 0
stringa_code = intro(conto)                     ' Legge il primo codice
conto = conto + 1
' Questa è il loop dove succede tutto. Viene reiterato finche il buffer
' viene controllato. Si ferma ad aggiungere codici alla tabella dopo
' che tutti i codici possibili sono stati definiti
character = intro(conto)                        ' Legge il secondo codice
conto = conto + 1
Do While character <> -1
    index = find_match(stringa_code, character) ' Controlla character è
nella
    If (code_value(index) <> -1) Then           ' tabella. Se c'è
    stringa_code = code_value(index)            ' prende code_value
Else                                            ' altrimenti
    If (next_code <= MAX_CODE) Then             ' prova ad aggiungerla.
        code_value(index) = next_code
        next_code = next_code + 1
        prefix_code(index) = stringa_code
        append_character(index) = character
    End If
    outp_code outp, stringa_code                ' Quando una stringa non
presente
    stringa_code = character                    ' nella tabella viene
trovata
End If                                          ' viene stampata l'ultima
stringa
If conto = UBound(intro) + 1 Then Exit Do
character = intro(conto)
conto = conto + 1
Loop                                            ' Dopo aver aggiunto la
stringa.
' Fine del ciclo principale
outp_code outp, stringa_code                    ' Output dell'ultimo codice
outp_code outp, MAX_VALUE                       ' Output della fine del
buffer
outp_code outp, 0
compress = putto                                'Restituisce la lunghezza
reale del buffer di output
End Function
' Questa funzione cerca di trovare la stringa prefisso+carattere nella
tabella
' delle stringhe. Se la trova restituisce l'indice altrimenti il primo
indice
' utilizzabile viene restituito
'-------------------------------------------------
Function find_match(hash_prefix@, hash_character@)
'-------------------------------------------------
Dim index&
Dim offset&
index = ((hash_character Mod (256 ^ 3)) * 2 ^ HASHING_SHIFT) Xor hash_prefix
If (index = 0) Then
    offset = 1
Else
    offset = TABLE_SIZE - index
End If
Do While (1)
    If (code_value(index) = -1) Then
        find_match = index
        Exit Function
    End If
    If (prefix_code(index) = hash_prefix And append_character(index) =
hash_character) Then
        find_match = index
        Exit Function
    End If
    index = index - offset
    If (index < 0) Then index = index + TABLE_SIZE
Loop
End Function
Function expand(inp%, outp%, lung&)
Dim next_code@
Dim new_code@
Dim old_code@
Dim character%
Dim counter%
Dim stringa As String
ReDim intro(0 To LOF(inp) - 1) As Byte          ' Ridimensiona e legge il
Get inp%, , intro                               ' buffer di input
Dim stri&, deco&
stri = 1
deco& = 1
next_code = 256             ' Primo codice utilizzabile
old_code = inp_code(inp)    ' Legge il primo codice,
character = old_code        ' inizializza character e
putc CByte(old_code)        ' stampa il primo codice
new_code = inp_code(inp)
' Questo è il ciclo principale dove tutto avviene.
' Leggi i caratteri fino a quando trova MAX_VALUE.
While new_code <> MAX_VALUE
    ' Questo codice controlla il caso speciale
STRINGA+CHARACTER+STRINGA+CHARACTER+STRINGA
    ' che genera un codice indefinito. Lo maneggia decodificando l'ultimo
codice ed
    ' aggiungendo un singolo carattere alla fine della stringa
    If (new_code >= next_code) Then
        decode_stack = Chr(character)
        stri = decode_string(stringa, decode_stack, deco& + 1, old_code)
    Else ' Altrimenti effettua una decodifica normale
        stri = decode_string(stringa, decode_stack, deco&, new_code)
    End If
    character = Asc(Mid(stringa, stri, 1))
    ' Stampa della stringa decodificata in ordine inverso
    While (stri >= deco)
        putc Asc(Mid(stringa, stri, 1))
        stri = stri - 1
    Wend
    stringa = ""
    decode_stack = ""
    'Infine è possibile aggiungere un nuovo codice alla tabella delle
stringhe
    If (next_code <= MAX_CODE) Then
        prefix_code(next_code) = old_code
        append_character(next_code) = character
    next_code = next_code + 1
End If
old_code = new_code
new_code = inp_code(inp)
Wend
End Function
' Questa routine decodifica una stringa dalla tabella mettendola in un
buffer
Function decode_string(stringh$, ByVal buffer$, ByVal ii, ByVal code@)
Dim i%
i = 0
While (code > 255)
    buffer = buffer & Chr(append_character(code))
    code = prefix_code(code)
    If (i >= 4094) Then
        MsgBox ("Errore fatale durante l'espansione.")
    End
End If
i = i + 1
ii = ii + 1
Wend
buffer = buffer & Chr(code)
stringh$ = buffer$
decode_string = ii
End Function
'-----------------------
Function inp_code@(inp%)
'-----------------------
Dim return_value@
Static inp_bit_count%
Static inp_bit_buffer@
Static count&
Dim chip@
If count > UBound(intro) Then
    inp_code = -1
    Exit Function
End If
While (inp_bit_count <= 24)
    If count > UBound(intro) Then
        inp_code = -1
        Exit Function
    End If
    pap = intro(count)
    inp_bit_buffer = inp_bit_buffer Or mood(pap * 2 ^ (24 - inp_bit_count))
    inp_bit_count = inp_bit_count + 8
    count = count + 1
Wend
chip = Int((inp_bit_buffer - CInt(inp_bit_buffer < 0) * 4294967296@) / 2 ^
(32 - BITS))
return_value = chip
inp_bit_buffer = mood(((inp_bit_buffer - CInt(inp_bit_buffer < 0) *
4294967296@) - (chip * 2 ^ (32 - BITS))) * 2 ^ BITS)
inp_bit_count = inp_bit_count - BITS
inp_code@ = return_value
End Function
'--------------------------
Sub outp_code(outp%, code@)
'--------------------------
Static outp_bit_count%
Static outp_bit_buffer#
Dim chip As Byte
gaet# = CDbl(code * 2 ^ (32 - BITS - outp_bit_count))
outp_bit_buffer = (outp_bit_buffer# Or mood(gaet#))
outp_bit_count = outp_bit_count + BITS
While (outp_bit_count >= 8)
    chip = Int((outp_bit_buffer - CInt(outp_bit_buffer < 0) * 4294967296@) /
2 ^ 24)
    putc chip
    outp_bit_buffer = mood((((outp_bit_buffer - CInt(outp_bit_buffer < 0) *
4294967296@)) - (chip * 2 ^ 24)) * 2 ^ 8)
    outp_bit_count = outp_bit_count - 8
Wend
End Sub
' Un po' di compatibilità con il linguaggio C ci vorrebbe.....
' Non esistendo in Visual Basic il tipo unsigned long (cioè un
' long che parte da &H0 (0) e arriva a &HFFFFFFFF (4294967295)
'--------------------------
Public Function mood(gaet#)
'--------------------------
While gaet# > 4294967295@
    gaet# = gaet# - 4294967295@
Wend
asf% = (gaet# > &H7FFFFFFF)
If asf% Then
    mood = gaet# - 4294967296@
Else
    mood = gaet#
End If
End Function
'--------------------------------------------
"StefanoniM" <so...@fatti.miei> ha scritto nel messaggio
news:lgc18.33406$aD.12...@twister2.libero.it...
