XProfan

================================================================================
================================================================================/
data pack/entpacken without Dll, only through API.
© 2008 Frank 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 pack. Parameter: (Speicherbereich, amount Bytes in the Speicherbereich)

Proc CompressBuffer

    Parameters bbereich#, cbx&
    Declare cstatus&, bworkspacesize&, fworkspacesize&, cbereich#, workspace#
    cstatus&=0

    Ifnot RtlGetCompressionWorkSpaceSize(2, Addr(bworkspacesize&), Addr(fworkspacesize&))

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

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

            Clear bbereich#
            Long bbereich#,0=cbx&
            RtlMoveMemory(bbereich#+4,cbereich#,bworkspacesize&)
            cstatus&=bworkspacesize&+4

        EndIf

        Dispose workspace#
        Dispose cbereich#

    Endif

    Return cstatus&
    Return: amount the gepackten Bytes. The gepackten data get in whom übergebenen Speicherbereich copies.

ENDPROC

Originale Speichergrösse detect. Parameter: (gepackter Speicherbereich#)

Proc GetDecompressSize

    Parameters bbereich#
    Return Long(bbereich#,0)

ENDPROC

Speicherbereich entpacken. Parameter: (gepackter Speicherbereich, amount Bytes in the gepackten Speicherbereich, suitor Speicherbereich)

Proc DecompressBuffer

    Parameters bbereich#, cbx&, cbereich#
    Declare bworkspacesize&

    Ifnot RtlDecompressBuffer(2,cbereich#,Long(bbereich#,0),bbereich#+4,cbx&-4,Addr(bworkspacesize&))

        Return bworkspacesize&

    EndIf

    Return 0
    Return: amount the entgepackten Bytes.

ENDPROC

================================================================================
================================================================================/
====> HAUPTPROGRAMM
Declare area#, area2#, Text$, x&, xcopy&, newbytes&
Cls

While 1

    Text$=LoadFile $("Datei to that pack aussuchen","")

    If Text$<>""

        pack testing
        x&=FileSize(text $)
        xcopy&=x&

        If x&

            Dim area#, x&+400
            BlockRead(Text$, area#, 0, x&)
            newbytes&=CompressBuffer(area#, x&)

            If newbytes&

                Set("Decimals",2)
                Print "Dateiname: "+Text$
                Print "Originalgrösse lying with "+Str $(x&)+" Bytes, comprimiert with "+Str $(newbytes&)+" Bytes."
                Print "Packrate lying with "+Str $(100-(newbytes&*100/x&))+" percent."
                Text$=text $+".pck"
                BlockWrite Text$, area#, 0, newbytes&
                Dispose area#
                Entpacken testing
                x&=FileSize(text $)

                If x&

                    Dim area#, x&
                    BlockRead(Text$, area#, 0, x&)
                    newbytes&=GetDecompressSize(area #)
                    Dim area2#,newbytes&
                    x&=DecompressBuffer(area#, x&, area2#)

                    If x&

                        Text$=text $+".org"
                        BlockWrite Text$, area2#, 0, x&
                        Print "Dateiname: "+Text$
                        Print "Decomprimierte Originalgrösse totals "+Str $(x&)+" Bytes."
                        Print

                    Else

                        Print Text$+" couldn't entpackt go."
                        Print

                    EndIf

                    Dispose area2#
                    Dispose area#

                EndIf

            Else

                Dispose area#
                Print Text$+" couldn't gepackt go."

            EndIf

        EndIf

    Else

        BREAK

    EndIf

EndWhile

WaitInput
End