XProfan

================================================================================
================================================================================/
Daten packen/entpacken ohne Dll, nur mittels 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 packen. Parameter: (Speicherbereich, Anzahl Bytes im 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&
    Rückgabe: Anzahl der gepackten Bytes. Die gepackten Daten wurden in den übergebenen Speicherbereich kopiert.

EndProc

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

Proc GetDecompressSize

    Parameters bbereich#
    Return Long(bbereich#,0)

EndProc

Speicherbereich entpacken. Parameter: (gepackter Speicherbereich, Anzahl Bytes im gepackten Speicherbereich, freier 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
    Rückgabe: Anzahl der entgepackten Bytes.

EndProc

================================================================================
================================================================================/
====> HAUPTPROGRAMM
Declare bereich#, bereich2#, text$, x&, xcopy&, newbytes&
Cls

While 1

    text$=LoadFile$("Datei zum Packen aussuchen","")

    If text$<>""

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

        If x&

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

            If newbytes&

                Set("Decimals",2)
                Print "Dateiname: "+text$
                Print "Originalgrösse liegt bei "+Str$(x&)+" Bytes, comprimiert bei "+Str$(newbytes&)+" Bytes."
                Print "Packrate liegt bei "+Str$(100-(newbytes&*100/x&))+" Prozent."
                text$=text$+".pck"
                BlockWrite text$, bereich#, 0, newbytes&
                Dispose bereich#
                Entpacken testen
                x&=FileSize(text$)

                If x&

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

                    If x&

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

                    Else

                        Print text$+" konnte nicht entpackt werden."
                        Print

                    EndIf

                    Dispose bereich2#
                    Dispose bereich#

                EndIf

            Else

                Dispose bereich#
                Print text$+" konnte nicht gepackt werden."

            EndIf

        EndIf

    Else

        BREAK

    EndIf

EndWhile

WaitInput
End

Zeile 27: Dim cbereich#,cbx&+399
Zeile 29: IfNot RtlCompressBuffer(2,bbereich#,cbx&,cbereich#,cbx&+399,0,Addr(bworkspacesize&),workspace#)
Zeile 106: Dim bereich#, x&+399