XProfan

================================================================================
================================================================================/
données saisir/entpacken sans Dll, seulement 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 saisir. paramètre: (Speicherbereich, Anzahl Bytes im Speicherbereich)

Proc CompressBuffer

    Paramètres bbereich#, cbx&
    Déclarer cstatus&, bworkspacesize&, fworkspacesize&, cbereich#, workspace#
    cstatus&=0

    Si non RtlGetCompressionWorkSpaceSize(2, Addr(bworkspacesize&), Addr(fworkspacesize&))

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

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

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

        EndIf

        Dispose workspace#
        Dispose cbereich#

    Endif

    Retour cstatus&
    Rückgabe: Anzahl qui gepackten Bytes. qui gepackten données wurden dans den übergebenen Speicherbereich kopiert.

ENDPROC

Originale Speichergrösse ermitteln. paramètre: (gepackter Speicherbereich#)

Proc GetDecompressSize

    Paramètres bbereich#
    Retour Long(bbereich#,0)

ENDPROC

Speicherbereich entpacken. paramètre: (gepackter Speicherbereich, Anzahl Bytes im gepackten Speicherbereich, freier Speicherbereich)

Proc DecompressBuffer

    Paramètres bbereich#, cbx&, cbereich#
    Déclarer bworkspacesize&

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

        Retour bworkspacesize&

    EndIf

    Retour 0
    Rückgabe: Anzahl qui entgepackten Bytes.

ENDPROC

================================================================================
================================================================================/
====> HAUPTPROGRAMM
Déclarer bereich#, bereich2#, text$, x&, xcopy&, newbytes&
Cls

Tandis que 1

    text$=LoadFile$("Datei zum saisir aussuchen",»)

    Si text$<>»

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

        Si x&

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

            Si newbytes&

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

                Si x&

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

                    Si x&

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

                    D'autre

                        Imprimer text$+" konnte pas entpackt volonté."
                        Imprimer

                    EndIf

                    Dispose bereich2#
                    Dispose bereich#

                EndIf

            D'autre

                Dispose bereich#
                Imprimer text$+" konnte pas être emballés."

            EndIf

        EndIf

    D'autre

        BREAK

    EndIf

Endwhile

WaitInput
Fin