Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

saving records to diskette...

Posted on 2001-09-07
9
Medium Priority
?
234 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 200 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
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 

Author Comment

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

thanks again.

candz
0
 
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

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction The parallel port is a very commonly known port, it was widely used to connect a printer to the PC, if you look at the back of your computer, for those who don't have newer computers, there will be a port with 25 pins and a small print…
Hello everybody This Article will show you how to validate number with TEdit control, What's the TEdit control? TEdit is a standard Windows edit control on a form, it allows to user to write, read and copy/paste single line of text. Usua…
Want to learn how to record your desktop screen without having to use an outside camera. Click on this video and learn how to use the cool google extension called "Screencastify"! Step 1: Open a new google tab Step 2: Go to the left hand upper corn…
In a question here at Experts Exchange (https://www.experts-exchange.com/questions/29062564/Adobe-acrobat-reader-DC.html), a member asked how to create a signature in Adobe Acrobat Reader DC (the free Reader product, not the paid, full Acrobat produ…
Suggested Courses

963 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