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í, Pointer, Díl, Trik


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

Alan Turing: Genius, který matematicky stvořil počítač

Alan Turing: Genius, který matematicky stvořil počítač

Řešením matematického problému se dostal k modelu teoretického stroje, který nese jeho jméno a je základem logiky univerzálních počítačů.

Pavel Tronner | 56

Jak dopadl velký den Applu s náloží novinek: Sledujte, co letos připravil

Jak dopadl velký den Applu s náloží novinek: Sledujte, co letos připravil

** Apple večer představil novinky ** Ukáže nové operační systémy, ale čekala se i nová zařízení ** Začíná vývojářská konference Applu WWDC 2018

Karel Javůrek | 87

Budoucnost elektroniky: čeští vědci stojí za revolučním čipem, který nemá ve světě obdoby

Budoucnost elektroniky: čeští vědci stojí za revolučním čipem, který nemá ve světě obdoby

** Čeští vědci pod vedením Tomáše Jungwirtha vyvíjí nový typ revolučního paměťového čipu ** Zatímco v současnosti elektronika pracuje s elektrony, v budoucnu to budou spiny elektronů ** Čipy budou moci být klidně i 1 000x rychlejší a úspornější

Karel Javůrek | 32

Rekordy počasí: V Česku to ještě jde, skutečné extrémy zažívají jinde

Rekordy počasí: V Česku to ještě jde, skutečné extrémy zažívají jinde

** Teplotní extrémy dokážou překvapit. Seznamte se s rekordy v Česku i ve světě ** Rekordní hodnoty jsou mnohdy až k neuvěření ** Zjistěte, kdy ke bylo největší horko, zima, déšť či vítr

Karel Kilián | 7

Nechcete platit za Total Commander? Těmito bezplatnými programy ho můžete nahradit

Nechcete platit za Total Commander? Těmito bezplatnými programy ho můžete nahradit

** Total Commander je na Windows takřka legendou ** Licence však stojí více než tisíc korun ** Našli jsme pro vás deset alternativ dostupných zdarma

Karel Kilián | 140

15 věcí, které umí Windows 10, ale možná o nich vůbec nevíte

15 věcí, které umí Windows 10, ale možná o nich vůbec nevíte

** Systém Windows 10 umí spoustu užitečných drobností ** O mnoha praktických funkcích pravděpodobně ani nevíte ** Poznejte užitečné tipy, které se vám mohou hodit každý den

Vladislav Kluska | 36

Nová zbraň Microsoftu proti iPadu: Levný tablet Surface Go bude stát jen deset tisíc

Nová zbraň Microsoftu proti iPadu: Levný tablet Surface Go bude stát jen deset tisíc

** Microsoft představil nový tablet Surface Go ** Nový model zaujme nízkou cenou, ale schopnostmi zařízení Surface ** Microsoft nepoužil čip ARM, ale klasický procesor od Intelu 

Karel Javůrek | 116


Aktuální číslo časopisu Computer

Velký test 18 bezdrátových sluchátek

Vše o přechodu na DVB-T2

Procesory AMD opět porážejí Intel

7 NVMe M.2 SSD v přímém souboji