Daten/Dateien packen/entpacken ohne Dll

[Frabbing]

Dateien packen/entpacken mittels API:

' ================================================================================\
' ================================================================================/
'
' Daten packen/entpacken ohne Dll, nur mittels API.
' © http://frabbing.bplaced.net
'
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

[Jac de Lad]

Wie groß sind denn die Packraten?

[Sascha Oliver Haak]

@Frabbing
Tolle Routine hab sie gleich mal ausprobiert klappt gut.

@Jac de Lad
Ist natürlich unterschiedlich: Meine Beispiele 2% (eine PDF)
über 40% (bei verschiedenen Dateien) bis zu 62% bei Tabellen (XLS).

Gruß
Sascha

[Frabbing]

Genau, einfach ausprobieren. Wenn ich es richtig in Erinnerung habe, lagen die Packraten etwas unter ZIP.

[Jac de Lad]

Gar nicht mal so übel!