Tipy a triky v Delphi, díl 98.

Dnes budeme provádět kompresi a dekompresi dat. Prostřednictvím paměťového streamu zkomprimujeme obsah komponenty RichEdit a uložíme do souboru na disk. A samozřejmě si ukážeme i dekomprimaci.
Téma je jasné, takže se hned bez dalších řečí pusťme do práce. Pro náš příklad si vytvoříme dvě funkce. První bude paměťový blok komprimovat, druhá naopak. Budou vlastně tvořit pouze jakési rozhraní a o samotnou kompresi se postará knihovna ZLib.

Těchto dvou funkcí pak využijeme k našemu příkladu. Na formulář přidáme dvě tlačítka (jedno na kompresi, druhé pro dekompresi) a komponentu RichEdit. Tu naplníme nějakým textem. Samozřejmě nestačí napsat dvě tři slova, protože abychom dobře viděli výsledný efekt, je potřeba použít delší text, kde bude komprese dobře patrná. Zkomprimovaný obsah RichEditu pak bude uložen do souboru na disk a vypočítáme si i výsledný kompresní poměr.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ZLib, StdCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    RichEdit1: TRichEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure CompressStream(inpStream, outStream: TStream);
var
  InpBuf, OutBuf: Pointer;
  InpBytes, OutBytes: Integer;
begin
  InpBuf := nil;
  OutBuf := nil;
  try
    GetMem(InpBuf, inpStream.Size);
    inpStream.Position := 0;
    InpBytes := inpStream.Read(InpBuf^, inpStream.Size);
    CompressBuf(InpBuf, InpBytes, OutBuf, OutBytes);
    outStream.Write(OutBuf^, OutBytes);
  finally
    if InpBuf <> nil then FreeMem(InpBuf);
    if OutBuf <> nil then FreeMem(OutBuf);
  end;
end;

procedure DecompressStream(inpStream, outStream: TStream);
var
  InpBuf, OutBuf: Pointer;
  OutBytes, sz: Integer;
begin
  InpBuf := nil;
  OutBuf := nil;
  sz := inpStream.Size - inpStream.Position;
  if sz > 0 then
    try
      GetMem(InpBuf, sz);
      inpStream.Read(InpBuf^, sz);
      DecompressBuf(InpBuf, sz, 0, OutBuf, OutBytes);
      outStream.Write(OutBuf^, OutBytes);
    finally
      if InpBuf <> nil then FreeMem(InpBuf);
      if OutBuf <> nil then FreeMem(OutBuf);
    end;
  outStream.Position := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ms1, ms2: TMemoryStream;
begin
  ms1 := TMemoryStream.Create;
  try
    ms2 := TMemoryStream.Create;
    try
      RichEdit1.Lines.SaveToStream(ms1);
      CompressStream(ms1, ms2);
      ShowMessage(Format(`Kompresni pomer: %d %%`, [round(100 / ms1.Size * ms2.Size)]));
      ms2.SaveToFile(`C:\test.dat`);
    finally
      ms1.Free;
    end;
  finally
    ms2.Free;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  ms1, ms2: TMemoryStream;
begin
  ms1 := TMemoryStream.Create;
  try
    ms2 := TMemoryStream.Create;
    try
      ms1.LoadFromFile(`C:\test.dat`);
      DecompressStream(ms1, ms2);
      RichEdit1.Lines.LoadFromStream(ms2);
    finally
      ms1.Free;
    end;
  finally
    ms2.Free;
  end;
end;

end.

Nezapomeňte si také upravit cestu k výstupnímu souboru. Jak vidíte, samotný postup je velmi jednoduchý a při ukládání rozličných dat je velmi dobře použitelný (příklad s RichEdit je jen na ukázku).

Diskuze (7) Další článek: Další problémy pro Epson

Témata článku: Software, Windows, Programování, Díl, Trik, Pointer


Určitě si přečtěte

Modelářský zázrak: Maketa raketoplánu Columbia, která létá jako skutečná raketa

Modelářský zázrak: Maketa raketoplánu Columbia, která létá jako skutečná raketa

** Model raketoplánu Columbia od českého konstruktéra umí i létat ** Obdivuhodný model si vzal 1600 hodin práce ** Podívejte se na fotografie ze stavby a prvního letu

Karel Jeřábek | 20

Portál občana už funguje. Na státní web vypadá až překvapivě použitelně

Portál občana už funguje. Na státní web vypadá až překvapivě použitelně

** Portál občana už funguje, vyřídíte na něm první požadavky ** Funkce se budou postupně rozšiřovat ** Web je docela moderní a přehledný

David Polesný | 66

Loopwheels znovu vymyslelo kolo. Místo drátů má v ráfcích kompozitové pružiny, které vylepší komfort jízdy

Loopwheels znovu vymyslelo kolo. Místo drátů má v ráfcích kompozitové pružiny, které vylepší komfort jízdy

** Proč vymýšlet kolo? Protože ho lze vymyslet lépe! ** Kola Loopwheels nabízejí integrované odpružení ** Cílem je poskytnout pohodlnější a klidnější jízdu

Karel Kilián | 14

Tohle tak jednou zažít: Nová vzducholoď Airlander 10 s prosklenou podlahou

Tohle tak jednou zažít: Nová vzducholoď Airlander 10 s prosklenou podlahou

** Airlander 10 nabídne plavby vzduchem v interiéru s prosklenou podlahou ** Luxusní vzducholoď byla původně vyvíjena pro vojenské účely ** Počítá se s třídenními „kochacími“ výlety za poznáním

Karel Kilián | 7


Aktuální číslo časopisu Computer

Jak vytvořit a spravovat vlastní web

Velký test herních klávesnic a DVB-T2 tunerů

Vše o formátu RAW

Vybíráme nejlepší základní desku