saving records to diskette...

i want to save my yearly records in a floppy diskette in a compressed (sort of like WinZip) form.
how do i do this? and how do i retrieve the records in my application?

i hope you can show me the code....

THANK YOU.
cacandzAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
MotazConnect With a Mentor Commented:
This is a unit I was written three years ago:


(***************************************)
(*      Compress unit                  *)
(*-------------------------------------*)
(* Written by Motaz Abel Azim          *)
(* Written on  : Sun, 16-Aug-1998      *)
(* Last update : Sun, 23-May-1999      *)
(***************************************)

Unit Compress;

interface

Uses SysUtils, Dialogs;

type
  TRec = Record
             Frequency: Longint;
             ch: char;
             Bits: string[8];
  end;

 function CompressFile(SourceName, DestName: String): integer;
 function DecompressFile(SourceName, DestName: String): integer;

implementation

 var
   SortedTable: Array [0..255] of char;
   Freq: array [0..255] of TRec;
   SourceF, DestF: file;
   SourceBuf, DestBuf: Array [1..1024] of byte;
   NumRead, BytesRead, BytesWritten: integer;
   BitsCount, TempBits, Duplication: byte;
   Eod: boolean;

 (*********************  Decimal to binary  ***********************)

Function DecToBin(Dec, Len: byte): String;
var
   Temp: string;
   i: byte;
begin
  Temp:= '';
  for i:= 1 to Len do
  begin
    Temp:= Char((Dec mod 2)+48)+Temp;
    Dec:= Dec shr 1;
  end;
  DecToBin:= Temp;

end;

 (*********************  Binary to decimal  ***********************)

Function BinToDec(Bin: String): byte;
var
   Temp: byte;
   i, Len: byte;
begin

  Temp:= 0;
  Len:= Length(Bin);

  for i:= 1 to Len do
    Inc(Temp,(byte(Bin[i])-48)*(1 shl (Len-i)));

  BinToDec:= Temp;

end;

 (*********************  Sort by frequency  ***********************)

Procedure SortByFrequency;
var
   Done: boolean;
   i: byte;
   Temp: TRec;
begin
  repeat     (*** Sort ***)

   Done:= true;
    for i:= 0 to 254 do
     if Freq[i].Frequency < Freq[i+1].Frequency then
     begin
       Done:= False;
       Temp:= Freq[i];
       Freq[i]:= Freq[i+1];
       Freq[i+1]:= Temp;
     end;
  until done;
end;

 (***************  Assign short values ('0101') *****************)

procedure AssignShortValues;
var
   i,
   j,
   Width,
   Counter,
   TempCounter: Byte;

begin
  Width:= 1;
  Counter:= 0;
  for i:= 0 to 255 do
    begin
     if Freq[i].Frequency = 0 then
       break;
     if i in [2 , 6, 14, 30, 62, 126, 254] then (*** New bit ***)
       begin
         Inc(Width);
         Counter:= 0;
       end;
      With Freq[i] do
        begin
          Bits[0]:= Char(Width);
          TempCounter:= Counter;
          for j:= 1 to Width do
          begin
            Bits[Width-j+1]:= Char((TempCounter mod 2)+48);
            TempCounter:= TempCounter shr 1;
          end;
        end;
        Inc(Counter);

    end;
end;

 (***********************  Get frequency table  *************************)

Function GetTable(FileName: String): Integer;
var
   f: file;
   k: byte;
   i: integer;
   Done: Boolean;
   Temp: TRec;
   TableSize: byte;
   NumRead: integer;
   Buf: array[1..2048] of byte;
begin
  for i:= 0 to 255 do
   begin
    Freq[i].Ch:= char(i);
    Freq[i].Frequency:= 0;
    Freq[i].Bits:= '';
   end;
  AssignFile(f, FileName);
  FileMode:= 0;
  reset(f, 1);
  repeat
    BlockRead(f, Buf, Sizeof(Buf), NumRead);
    for i:= 1 to NumRead do
      Inc(Freq[Buf[i]].Frequency);
  until eof(f);

  (*** Sort by frequency ***)

  SortByFrequency;

  for i:= 0 to 255 do   (*** Get Sorted table ***)
  begin
    k:= i;
    if Freq[i].Frequency = 0 then
    begin
      Dec(k);
      break
    end
    else
      SortedTable[i]:=Freq[i].ch;
  end; // for i

  TableSize:= k;
  GetTable:= TableSize+1;

  (***  Assign short value  ***)

  AssignShortValues;

  Duplication:= Round((Freq[0].Frequency+Freq[1].Frequency+
  Freq[2].Frequency+Freq[3].Frequency+
  Freq[4].Frequency+Freq[5].Frequency)/(FileSize(F)+1)*100);
  CloseFile(f);

  repeat     (*** Sort : final sort ***)

   Done:= True;
    for i:= 0 to 254 do
     if Freq[i].ch > Freq[i+1].ch then
     begin
       Done:= False;
       Temp:= Freq[i];
       Freq[i]:= Freq[i+1];
       Freq[i+1]:= Temp;
     end; // if Freq[i]
  until Done;

end;

  (**************** Read byte from file ***************)

Function GetByte:Byte;
begin
  if BytesRead = NumRead then
  begin
    BytesRead:= 0;
    BlockRead(SourceF, SourceBuf, SizeOf(SourceBuf), NumRead);
  end;
  Inc(BytesRead);
  Result:= SourceBuf[BytesRead];
  Eod:= (NumRead = 0);
end;

   (********************  Look for a byte  ********************)

function Look(Offset: integer): byte;
begin
  Look:= SourceBuf[BytesRead+Offset];
end;

   (********************  Flush Buffer   ********************)

Procedure FlushBuffer;
begin
  (*** Write compressed data ***)
  BlockWrite(DestF, DestBuf, BytesWritten);
  BytesWritten:= 0;
end;

  (**************** Put bits into file ***************)

Procedure PutBits(Bits: string; Last: boolean);
var
    i: byte;
begin
 for i:= 1 to Length(Bits) do
 begin
   TempBits:= TempBits shl 1;
   Inc(BitsCount);
   if Bits[i] = '1' then
     Inc(TempBits);

   if BitsCount = 8 then   (*** New byte  ***)
   begin
     BitsCount:=0;
     Inc(BytesWritten);
     DestBuf[BytesWritten]:= TempBits;

     if BytesWritten = SizeOf(DestBuf) then  (*** Buffer is full ***)
      FlushBuffer;
   end; (*** Bits... ***)
 end; (*** end for i:=1... ***)

 if Last then         (*** Last byte to be written ***)
 begin
 if BitsCount > 0 then
   begin
     TempBits:= TempBits shl (8-BitsCount);
     Inc(BytesWritten);
     DestBuf[BytesWritten]:= TempBits;
   end; (* if BitsCount *)
   FlushBuffer;
 end; (* if Last *)

end;

  (*******************    Dont compress  ********************)

function DontCompress(SourceName, DestName: String): integer;
var
   SourceF, DestF: file;
   Buf: array [0..1023] of byte;
   NumRead, Handle, Age: integer;
begin
  try
    AssignFile(SourceF, SourceName);
    AssignFile(DestF, DestName);
    FileMode:= 0;
    Reset(SourceF, 1);
    Rewrite(DestF, 1);
    Buf[0]:= 0;
    BlockWrite(DestF, Buf, 1);

    while not Eof(SourceF) do
    begin
      BlockRead(SourceF, Buf, SizeOf(Buf), NumRead);
      BlockWrite(DestF, Buf, NumRead);
    end; // while

    CloseFile(SourceF);
    CloseFile(DestF);

    (*** Copy file date and time ***)
    Age:= FileAge(SourceName);
    Handle:= FileOpen(DestName, fmOpenWrite);
    FileSetDate(Handle, Age);
    FileClose(Handle);

  except
  on E: EInOutError do
  begin
    MessageDlg(E.Message,
    mtError, [mbOk], 0);
    Result:= E.ErrorCode;
    exit;
  end; // on E: EInOutError..
  end; // try

  Result:=0;  (*** Successed ***)

end;

  (*******************    Compress file   ********************)

function CompressFile(SourceName, DestName: String): integer;
var
    Data, Len, CType: byte;
    DupCounter: integer;
    TableSize: integer;
    Age, Handle: integer;
    TempStr: string;
begin
  Result:= 0;

 try

  TableSize:= GetTable(SourceName);

  (*** Select the best compression acording to the ***)
  (*** Duplication ratio                           ***)

  if Duplication < 12 then   (*** No compression ***)
  begin
    result:= DontCompress(SourceName, DestName);
    exit;
  end
  else
  if Duplication > 70 then
    CType:= 1
  else
    CType:= 2;

  BitsCount:= 0;
  TempBits:= 0;
  NumRead:= 0;
  BytesRead:= 0;
  AssignFile(SourceF, SourceName);
  AssignFile(DestF, DestName);
  FileMode:= 0;
  Reset(SourceF, 1);
  Rewrite(DestF, 1);

  BlockWrite(DestF, CType, 1); (*** Write Compression type ***)
  Data:= TableSize-1;

  BlockWrite(DestF, Data, 1); (*** Write table length ***)
  BlockWrite(DestF, SortedTable, TableSize); (*** Write table into file ***)
  Eod:= False;

  while not Eod do    (*** While not end of data ***)
  begin
    Data:= GetByte; (*** Read byte from source file ***)
    if Eod then break;

    (*** Check for duplication ***)
    if (BytesRead+3 < NumRead) and (Look(1) = Data) and (Look(2) = Data)
    then
    begin
      DupCounter:= 1;
      while (Look(DupCounter) = Data) and (BytesRead+DupCounter < NumRead)
      and (DupCounter<265) do
         Inc(DupCounter);
       Dec(DupCounter);
       Inc(BytesRead, DupCounter);
       Dec(DupCounter);
       if CType = 1 then TempStr:= '000'
       else TempStr:= '00';

       PutBits(TempStr, false);  (*** Duplication signature ***)
       if DupCounter > 6 then
       begin
         if DupCounter = 7 then PutBits('1110', false)
         else PutBits('1111'+DecToBin(DupCounter-8, 8), false);
       end
       else
         PutBits(DecToBin(DupCounter, 3), false);

        (*** Put indivedual element length ***)
        Len:= Length(Freq[Data].Bits);
        PutBits(DecToBin(Len, 4), False);

       PutBits(Freq[Data].Bits, false); (*** Write duplicated byte ***)

    end (*** if (BytesRead+3... ***)
    else
    begin (*** Non duplicated ***)
    (** Put bits length **)
    Len:= Length(Freq[Data].Bits);
    if Ctype = 1 then      (*** 3 bits length compression ***)
    begin
      if Len > 6 then
      begin
        if Len = 7 then
          PutBits('1110', False)  (*** 7 bits length ***)
        else
          PutBits('1111', False); (*** 8 bits length ***)
      end // if Len > 6
      else
        PutBits(DecToBin(Len, 3), False); (*** Less than 7 bits ***)
      end (*** if CType = 1...***)
      else
      begin               (*** 2 bits length compression ***)
        if Len > 2 then
        begin
          if Len = 3 then
            PutBits('110', False)    (*** 3 bits length ***)
          else
          begin
            PutBits('111', False); (*** More than 3 bits ***)
            if Len > 6 then
            begin
              if Len = 7 then
                PutBits('110', False)
              else
                PutBits('111', False);
            end // if Len > 6
            else   (*** Less or equal to 6 ***)
              PutBits(DecToBin(Len-4, 2), False);

          end; (*** else if Len = 3.. ***)
        end  (*** if Len > 2.. ***)
        else
          PutBits(DecToBin(Len, 2), False); (*** Less than 3 bits ***)
    end; (*** else if CType = 1...***)

         (*** Put bits ***)
         PutBits(Freq[Data].Bits, False);
  end; (*** end else ***)

  end; (*** while not eof.. ***)

  PutBits('000000',True); (*** End of data signature ***)

  FlushBuffer;
  CloseFile(SourceF);
  CloseFile(DestF);

  (*** Copy file date and time ***)
  Age:= FileAge(SourceName);
  Handle:= FileOpen(DestName, fmOpenWrite);
  FileSetDate(Handle, Age);
  FileClose(Handle);

  except
   on E: EInoutError do
    begin
      MessageDlg(E.Message,
      mtError, [mbOk], 0);
      Result:= E.ErrorCode;
      exit;
    end;
  end;  (*** try ***)

end;

  (*******************    GetBits    ********************)

Function GetBits(Len: byte): String;

Procedure ReadBuffer;  (*** Read buffer ***)
begin
  BlockRead(SourceF, SourceBuf, SizeOf(SourceBuf), NumRead);
  BitsCount:= 0;
  BytesRead:= 1;
  TempBits:= SourceBuf[BytesRead];
end;

var
   TempStr: string;
   i: byte;
begin
 TempStr:= '';
 if NumRead = 0
   then ReadBuffer;
 for i:= 1 to Len do
 begin
   TempStr:= TempStr+Char(((TempBits shr 7) and 1)+48);
   TempBits:= TempBits shl 1;
   Inc(BitsCount);

   if BitsCount = 8 then   (*** New byte  ***)
   begin
     if BytesRead = NumRead then  (*** Buffer is empty ***)
       ReadBuffer
      else
      begin
        Inc(BytesRead);
        TempBits:= SourceBuf[BytesRead];
        BitsCount:= 0;
      end; // else if BytesRead..
   end; // if BitsCount...
 end; // for i:= 1..

 if TempStr = '' then
   TempStr:= '0';
 GetBits:= TempStr;
end;

  (*******************    Write byte to buffer    ********************)

procedure WriteBuffer(ch: char);
begin
  Inc(BytesWritten);
  DestBuf[BytesWritten]:= byte(ch);
  if BytesWritten = SizeOf(DestBuf) then
    FlushBuffer;
end;

  (*******************    Dont decompress  ********************)

function DontDecompress(SourceName, DestName: String): integer;
var
   SourceF, DestF: file;
   Buf: array [0..1023] of byte;
   NumRead, Handle, Age: integer;
begin
  try
    AssignFile(SourceF, SourceName);
    AssignFile(DestF, DestName);
    FileMode:= 0;
    Reset(SourceF, 1);
    Rewrite(DestF, 1);
    BlockRead(SourceF, Buf, 1);

    (*** Coping ***)
    while not Eof(SourceF) do
    begin
      BlockRead(SourceF, Buf, SizeOf(Buf), NumRead);
      BlockWrite(DestF, Buf, NumRead);
    end; // while not Eof

    CloseFile(SourceF);
    CloseFile(DestF);

    (*** Copy file date and time ***)
    Age:= FileAge(SourceName);
    Handle:= FileOpen(DestName, fmOpenWrite);
    FileSetDate(Handle, Age);
    FileClose(Handle);

  except
  on E: EInOutError do
  begin
    MessageDlg(E.Message,
    mtError, [mbOk], 0);
    result:= E.ErrorCode;
    exit;
  end; // on E: EInOutError..

  end; // try

  Result:= 0; (*** Successed ***)

end;

  (*******************    Decompress file   ********************)

function DecompressFile(SourceName,DestName:String):integer;
var
    R,i,Data,CType:byte;
    j,TableSize,Len:integer;
    Age,Handle:integer;
    CompressedData:string;
    LenStr:String;
begin
  Result:=0;
  BitsCount:=0;
  TempBits:=0;
  NumRead:=0;
  BytesRead:=0;
  BytesWritten:=0;
 try
  FileSetAttr(DestName, 32);
  Assign(SourceF, SourceName);
  Assign(DestF, DestName);
  FileMode:=0;
  Reset(SourceF, 1);
  Rewrite(DestF, 1);

  BlockRead(SourceF, CType, 1);(*** Read Compression type ***)

  if CType=0 then    (*** Uncompressed file ***)
  begin
    CloseFile(SourceF);
    CloseFile(DestF);
    result:=DontDecompress(SourceName,DestName);
    exit;
  end;
 
  BlockRead(SourceF,Data,1); (*** Read table length ***)

  TableSize:=Data+1;
  BlockRead(SourceF,SortedTable,TableSize); (*** Read table from file ***)

  for i:=0 to 255 do
  begin
    Freq[i].ch:=char(i);
    Freq[i].Frequency:=0;
  end;

  for i:=0 to TableSize-1 do    (*** Assume this frequency ***)
    Freq[Byte(SortedTable[i])].Frequency:=TableSize-i;

  SortByFrequency;

  AssignShortValues;

  Eod:=false;

  while true do   (*** While not end of data ***)
  begin

    LenStr:=GetBits(4-CType); (*** Read byte from source file ***)

    if LenStr='11' then   (*** More than 2 bits length ***)
     begin
     LenStr:=GetBits(1);
     if LenStr='0' then  (*** 3 bits length ***)
       LenStr:='11'
       else    (*** more than 3 bits length ***)
       begin
         LenStr:=GetBits(2);
         if LenStr='11' then  (*** More than 6 bits length ***)
          begin
            LenStr:=GetBits(1);
            if LenStr='0' then  (*** 7 bits length ***)
             LenStr:='111'
             else               (*** 8 bits length ***)
              LenStr:='1000';
          end (*** end if LenStr='11'.. ***)

          else (*** Less than or equal 6 bits length ***)

           LenStr:=DecToBin(BinToDec(LenStr)+4,3);

       end; (*** end else if LenStr='0'.. ***)

     end (*** end if LenStr='11' ***)
     else
    if LenStr='111' then   (*** More than 6 bits length ***)
     begin
     LenStr:=GetBits(1);
     if LenStr='0' then
       LenStr:='111'     (*** Seven bits length ***)
       else
       LenStr:='1000';   (*** Eight bits length ***)
     end (*** end if LenStr='111' ***)
     else
     if (LenStr='000') or (LenStr='00') then  (*** Duplication ***)
     begin
       LenStr:=GetBits(3); (*** Read number of duplication ***)
       if LenStr='000' then break;
       if LenStr='111' then (*** More than 6 length ***)
       begin
        LenStr:=GetBits(1);
        if LenStr='0' then Len:=7
        else
        begin
          LenStr:=GetBits(8);
          Len:=BinToDec(LenStr)+8;
        end;
       end  (*** end if LenStr='111'... ***)
       else    (*** Less that 7 duplication ***)
       Len:=BinToDec(LenStr);
       Inc(Len,2);
       CompressedData:=GetBits(BinToDec(GetBits(4)));

       (*** Extract duplicated data ***)
       for j:=1 to Len do
        begin
          R:=0;
           for i:=2 to Length(CompressedData) do
             Inc(R,1 shl (i-1));
             WriteBuffer(SortedTable[BinToDec(CompressedData)+R]);
        end;

        Continue; (*** While True ***)

     end (*** end if LenStr='000'... ***)
     else       (*** Check for end signature ***)
    if (BinToDec(LenStr)=0) and
    (BytesRead+1>=NumRead) and
    (Eof(SourceF)) then
      Break;

    (*** Extract non duplicated data ***)
    CompressedData:=GetBits(BinToDec(LenStr));
     R:=0;
     for i:=2 to Length(CompressedData) do
       Inc(R,1 shl (i-1));
       WriteBuffer(SortedTable[BinToDec(CompressedData)+R]);

  end; (*** end while not eof.. ***)

  FlushBuffer;

  CloseFile(SourceF);
  CloseFile(DestF);

  (*** Copy file date and time ***)
  Age:=FileAge(SourceName);
  Handle:=FileOpen(DestName,fmOpenWrite);
  FileSetDate(Handle,Age);
  FileClose(Handle);

  except
   on e: EInOutError do
     begin
       MessageDlg(E.Message,
       mtError, [mbOk], 0);
       Result:=E.ErrorCode;
       Exit;
     end;
  end;  (*** end try ***)

end;

end.

Use:

CompressFile('Source.txt', 'Target.cmp');

DecompressFile('Target.cmp', 'Decompressed.txt');

Motaz
0
 
cacandzAuthor Commented:
thanks Motaz... i'll try this code tonight and i'll let you know.
0
 
MotazCommented:
ok, take your time
0
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

 
cacandzAuthor Commented:
motaz, i really got confused with the code. is there a simpler code?

thanks again.

candz
0
 
MotazCommented:
Sorry, only I have this code
0
 
cacandzAuthor Commented:
thanks anyway...

:)

candz
0
 
mpootsCommented:
I just want to complement Motaz on this code. Excellent. Building a sequence table first and asign the character that is used most frequent the lowest bit.. Some kind of huffman encoding right? I wish I could write stuff like that.

Marcel
0
 
cacandzAuthor Commented:
I agree with you marcel. im really impressed with Motaz's code. it's just that im still new at Delphi programming.

Candz
0
 
geobulCommented:
No comment has been added lately, so it's time to clean up this TA.
I will leave a recommendation in the Cleanup topic area that this question is:

accept Motaz's comment as answer

Please leave any comments here within the next seven days.

PLEASE DO NOT ACCEPT THIS COMMENT AS AN ANSWER!

Thanks,

geobul
EE Cleanup Volunteer
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.