Solved

saving records to diskette...

Posted on 2001-09-07
9
224 Views
Last Modified: 2010-04-06
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.
0
Comment
Question by:cacandz
9 Comments
 
LVL 7

Accepted Solution

by:
Motaz earned 50 total points
ID: 6466331
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
 

Author Comment

by:cacandz
ID: 6466386
thanks Motaz... i'll try this code tonight and i'll let you know.
0
 
LVL 7

Expert Comment

by:Motaz
ID: 6466425
ok, take your time
0
 

Author Comment

by:cacandz
ID: 6473917
motaz, i really got confused with the code. is there a simpler code?

thanks again.

candz
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 7

Expert Comment

by:Motaz
ID: 6474156
Sorry, only I have this code
0
 

Author Comment

by:cacandz
ID: 6475835
thanks anyway...

:)

candz
0
 
LVL 1

Expert Comment

by:mpoots
ID: 6477429
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
 

Author Comment

by:cacandz
ID: 6481430
I agree with you marcel. im really impressed with Motaz's code. it's just that im still new at Delphi programming.

Candz
0
 
LVL 17

Expert Comment

by:geobul
ID: 9295776
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

Featured Post

Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

Join & Write a Comment

Suggested Solutions

This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
Illustrator's Shape Builder tool will let you combine shapes visually and interactively. This video shows the Mac version, but the tool works the same way in Windows. To follow along with this video, you can draw your own shapes or download the file…
This video demonstrates how to create an example email signature rule for a department in a company using CodeTwo Exchange Rules. The signature will be inserted beneath users' latest emails in conversations and will be displayed in users' Sent Items…

705 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now