XProfan

================================================================================
================================================================================/
Daten packen/entpacken sin Dll, sólo mittels API.
© 2008 Franco Abbing, http://frabbing.de
Def RtlCompressBuffer(8) !"ntdll.dll", "RtlCompressBuffer"
Def RtlDecompressBuffer(6) !"ntdll.dll", "RtlDecompressBuffer"
Def RtlGetCompressionWorkSpaceSize(3) !"ntdll.dll", "RtlGetCompressionWorkSpaceSize"
Def RtlMoveMemory(3) !"kernel32.dll", "RtlMoveMemory"
Speicherbereich packen. Parámetro: (Speicherbereich, Anzahl Bytes en el Speicherbereich)

Proc CompressBuffer

    Parámetros bbereich#, cbx&
    Declarar cstatus&, bworkspacesize&, fworkspacesize&, cbereich#, workspace#
    cstatus&=0

    Caso negativo RtlGetCompressionWorkSpaceSize(2, Addr(bworkspacesize&), Addr(fworkspacesize&))

        Dim workspace#,bworkspacesize&
        Dim cbereich#,cbx&+400

        Caso negativo RtlCompressBuffer(2,bbereich#,cbx&,cbereich#,cbx&+400,0,Addr(bworkspacesize&),workspace#)

            Claro bbereich#
            Largo bbereich#,0=cbx&
            RtlMoveMemory(bbereich#+4,cbereich#,bworkspacesize&)
            cstatus&=bworkspacesize&+4

        EndIf

        Disponer workspace#
        Disponer cbereich#

    Endif

    Volver cstatus&
    Rückgabe: Anzahl el gepackten Bytes. El gepackten Daten fueron en el übergebenen Speicherbereich kopiert.

ENDPROC

Originale Speichergrösse ermitteln. Parámetro: (gepackter Speicherbereich#)

Proc GetDecompressSize

    Parámetros bbereich#
    Volver Largo(bbereich#,0)

ENDPROC

Speicherbereich entpacken. Parámetro: (gepackter Speicherbereich, Anzahl Bytes en el gepackten Speicherbereich, freier Speicherbereich)

Proc DecompressBuffer

    Parámetros bbereich#, cbx&, cbereich#
    Declarar bworkspacesize&

    Caso negativo RtlDecompressBuffer(2,cbereich#,Largo(bbereich#,0),bbereich#+4,cbx&-4,Addr(bworkspacesize&))

        Volver bworkspacesize&

    EndIf

    Volver 0
    Rückgabe: Anzahl el entgepackten Bytes.

ENDPROC

================================================================================
================================================================================/
====> HAUPTPROGRAMM
Declarar bereich#, bereich2#, texto$, x&, xcopy&, newbytes&
Cls

Mientras que 1

    texto$=LoadFile$("Datei para Packen aussuchen","")

    If texto$<>""

        Packen testen
        x&=FileSize(texto$)
        xcopy&=x&

        If x&

            Dim bereich#, x&+400
            BlockRead(texto$, bereich#, 0, x&)
            newbytes&=CompressBuffer(bereich#, x&)

            If newbytes&

                Conjunto("Decimals",2)
                Imprimir "Dateiname: "+texto$
                Imprimir "Originalgrösse liegt en "+Str$(x&)+" Bytes, comprimiert en "+Str$(newbytes&)+" Bytes."
                Imprimir "Packrate liegt en "+Str$(100-(newbytes&*100/x&))+" Prozent."
                texto$=texto$+".pck"
                BlockWrite texto$, bereich#, 0, newbytes&
                Disponer bereich#
                Entpacken testen
                x&=FileSize(texto$)

                If x&

                    Dim bereich#, x&
                    BlockRead(texto$, bereich#, 0, x&)
                    newbytes&=GetDecompressSize(bereich#)
                    Dim bereich2#,newbytes&
                    x&=DecompressBuffer(bereich#, x&, bereich2#)

                    If x&

                        texto$=texto$+".org"
                        BlockWrite texto$, bereich2#, 0, x&
                        Imprimir "Dateiname: "+texto$
                        Imprimir "Decomprimierte Originalgrösse beträgt "+Str$(x&)+" Bytes."
                        Imprimir

                    Más

                        Imprimir texto$+" podría no entpackt voluntad."
                        Imprimir

                    EndIf

                    Disponer bereich2#
                    Disponer bereich#

                EndIf

            Más

                Disponer bereich#
                Imprimir texto$+" podría no se envasarán."

            EndIf

        EndIf

    Más

        BREAK

    EndIf

EndWhile

WaitInput
End