Shareware Overload/ShartewareOverload.cdr/windows/wincrd.zip/WINCRD.PAS

Pascal/Delphi Source File | 1986-08-27 | 15KB | 465 lines

      program wincrd;

(*
      This program converts a Microsoft Windows card file
      file to or from an ASCII file format. The ASCII file
      generated or read from consists of one card per line
      with the fields delimited by a tab. The first field is
      the card index line, with the remaining field being
      lines on the card (a field in the ascii line will be
      a series of characters ending in CR/LF on the card, it
      may be more than one text line).

      The variable fielddelimiter set in the procedure init
      is used as the field delimiter, and may be changed to
      anything desired. A tab was chosen because windows
      cardfile does not use it.

      This program only supports text cards, graphics is
      not supported in any form.

      No checking is done on the length of anything input, so
      when converting from ASCII to cardfile, the user must
      insure that the first field (card index line) is less
      than 39 characters long.
*)

      type
          filebytetype = string[1];

      var
         Cardfile : file;
         Asciifile : text;
         cardfilename, asciifilename : string[64];
         keyhit : string[1];
         charactersin : array[1..1024] of char;
         numberofcharacters : integer;
         blockimage, blockimageblank : string[128];
         currentblockindex : integer;
         currentfilesize : integer;
         i, j, k, l : integer;
         numcards : integer;
         xnumcards : real;
         iop : integer;
         indexchar, datachar : string[1];
         indexblock, indexbyte : integer;
         datablock, databyte : integer;
         datalen : integer;
         fielddelimiter : string [1];
         indexout : boolean;

      procedure openfilecardtoascii; forward;

      function filebyte(blocknum,bytenum:integer):filebytetype;
      var
         block, byten : integer;
      begin
           block := blocknum * 2;
           if bytenum > 127 then
           begin
           byten := bytenum-128;
           block := block+1;
           end
           else
           byten := bytenum;
           if block = currentblockindex then
           begin
                filebyte:=blockimage[byten];
           end
           else
           begin
                seek(cardfile,block);
                blockread(cardfile,blockimage,1);
                currentblockindex := block;
                filebyte:=blockimage[byten];
           end;
      end;

      procedure waitforkey;
      var
         waitforkeybyte : string[1];
      begin
           read(kbd,waitforkeybyte);
      end;

      function getnumcards:integer;
      begin
           getnumcards := ord(filebyte(0,3)) + ord(filebyte(0,4)) * 256;
      end;

      procedure incrementindex(increment:integer);
      begin
           indexbyte := indexbyte + increment;
           if indexbyte > 255 then
           begin
                indexbyte := indexbyte - 256;
                indexblock := indexblock + 1;
           end;
      end;

      procedure incrementdata(increment:integer);
      begin
           databyte := databyte + increment;
           if databyte > 255 then
           begin
                databyte := databyte - 256;
                datablock := datablock + 1;
           end;
      end;
      procedure outputdata;
      var
         i : integer;
      begin
           incrementdata(2);
           datalen := ord(filebyte(datablock,databyte));
           incrementdata(1);
           datalen := datalen + ord(filebyte(datablock,databyte)) * 256;
           i := 1;
           while i <= datalen do
           begin
                incrementdata(1);
                datachar := filebyte(datablock,databyte);
                if datachar = #13 then
                begin
                     write(asciifile,fielddelimiter);
                     incrementdata(1);
                     i := i + 2;
                end
                else
                begin
                     write(asciifile,datachar);
                     i := i + 1;
                end;
            end;
       end;

       procedure usermessage(icard:integer);
       begin
            gotoxy(29,3);
            write(icard);
       end;

      procedure cardtoascii;
      var
         i, j : integer;
      begin
           openfilecardtoascii;
           numcards := getnumcards;
           clrscr;
           writeln('Number of cards in file is ',numcards);
           gotoxy(5,3);
           write('Processing card number');
           indexblock := 0;
           indexbyte := 11;
           for i := 1 to numcards do
           begin
                databyte := ord(filebyte(indexblock,indexbyte));
                incrementindex(1);
                j := ord(filebyte(indexblock,indexbyte));
                incrementindex(1);
                j := j + ord(filebyte(indexblock,indexbyte)) * 256;
                datablock := j;
                incrementindex(2);
                indexout := true;
                for j := 1 to 46 do
                begin
                     incrementindex(1);
                     indexchar := filebyte(indexblock,indexbyte);
                     if indexout and (ord(indexchar) = 0) then
                     begin
                          indexout := false;
                          write(asciifile,fielddelimiter);
                     end;
                     if indexout then
                     begin
                          write(asciifile,indexchar);
                     end;
                 end;
                 incrementindex(2);
                 outputdata;
           write(asciifile,#13,#10);
           usermessage(i);
           end;
           close(asciifile);
           close(cardfile);
      end;

      procedure openfilecardtoascii;
      begin
           clrscr;
           writeln('Enter name of Cardfile file');
           readln(cardfilename);
           clrscr;
           writeln('Enter name of Ascii file');
           readln(asciifilename);
           clrscr;
           assign(cardfile,cardfilename);
           assign(asciifile,asciifilename);
           reset(cardfile);
           rewrite(asciifile);
           currentblockindex := -1;
      end;

      procedure openfileasciitocard;
      begin
           clrscr;
           writeln('Enter name of Ascii file');
           readln(asciifilename);
           clrscr;
           writeln('Enter name of Cardfile file');
           readln(cardfilename);
           clrscr;
           assign(cardfile,cardfilename);
           assign(asciifile,asciifilename);
           rewrite(cardfile);
           reset(asciifile);
           currentblockindex := 0;
           for I := 0 to 127 do
           begin
                blockimage[i] := chr(0);
           end;
           blockimage[0] := chr($4d);
           blockimage[1] := chr($47);
           blockimage[2] := chr($43);
           seek(cardfile,currentblockindex);
           blockwrite(cardfile,blockimage,1);
           currentfilesize := filesize(cardfile);
      end;

      procedure closefileasciitocard;
      begin
           seek(cardfile,currentblockindex);
           blockwrite(cardfile,blockimage,1);
           close(cardfile);
           close(asciifile);
      end;

      procedure checkfilesize(block:integer);
      var
         i : integer;
      begin
           if block >= currentfilesize then
           begin
                for i := currentfilesize to block do
                begin
                     seek(cardfile,i);
                     blockwrite(cardfile,blockimageblank,1);
                end;
                currentfilesize := filesize(cardfile);
           end;
      end;

      procedure outfilebyte(blocknum,bytenum:integer;outbyte:filebytetype);
      var
         block, byten : integer;
      begin
           block := blocknum * 2;
           if bytenum > 127 then
           begin
                byten := bytenum - 128;
                block := block + 1;
           end
           else
                byten := bytenum;
           if block = currentblockindex then
           begin
                blockimage[byten] := outbyte;
           end
           else
           begin
                seek(cardfile,currentblockindex);
                blockwrite(cardfile,blockimage,1);
                checkfilesize(block);
                seek(cardfile,block);
                blockread(cardfile,blockimage,1);
                currentblockindex := block;
                blockimage[byten] := outbyte;
           end;
      end;

      function asciifilelength:integer;
      var
         i : integer;
      begin
           reset(asciifile);
           i := 0;
           while not eof(asciifile) do
           begin
                readln(asciifile,datachar);
                i := i + 1;
           end;
           asciifilelength := i;
      end;

      procedure setstartofdata;
      var
         i : integer;
      begin
           xnumcards := numcards * 52.0 + 5.0;
           xnumcards := xnumcards / 256.0 + 0.0001;
           datablock := trunc(int(xnumcards));
           databyte := trunc(frac(xnumcards) * 256.0);
           indexblock := 0;
           indexbyte := 3;
           datachar := chr(numcards mod 256);
           outfilebyte(indexblock,indexbyte,datachar);
           indexbyte := 4;
           datachar := chr(numcards div 256);
           outfilebyte(indexblock,indexbyte,datachar);
           indexbyte := 5;
      end;

      procedure outputindex;
      var
         i : integer;
      begin
           datachar := chr(0);
           for i := 1 to 5 do
           begin
                outfilebyte(indexblock,indexbyte,datachar);
                incrementindex(1);
           end;
           datachar := chr(256);
           outfilebyte(indexblock,indexbyte,datachar);
           incrementindex(1);
           datachar := chr(databyte);
           outfilebyte(indexblock,indexbyte,datachar);
           incrementindex(1);
           datachar := chr(datablock mod 256);
           outfilebyte(indexblock,indexbyte,datachar);
           incrementindex(1);
           datachar := chr(datablock div 256);
           outfilebyte(indexblock,indexbyte,datachar);
           incrementindex(1);
           datachar := chr(0);
           for i := 1 to 2 do
           begin
                outfilebyte(indexblock,indexbyte,datachar);
                incrementindex(1);
           end;
           indexout := true;
           for i := 1 to 41 do
           begin
                if indexout then
                begin
                     read(asciifile,datachar);
                     if datachar = chr(9) then
                     begin
                          indexout := false;
                          datachar := chr(0);
                     end;
                end;
                outfilebyte(indexblock,indexbyte,datachar);
                incrementindex(1);
           end;
      end;

      procedure outputasciidata;
      var
         i : integer;
      begin
           numberofcharacters := 0;
           datachar := chr(0);
           while not eoln(asciifile) do
           begin
                read(asciifile,datachar);
                if datachar = chr(9) then
                begin
                     numberofcharacters := numberofcharacters + 1;
                     charactersin[numberofcharacters] := chr(13);
                     numberofcharacters := numberofcharacters + 1;
                     charactersin[numberofcharacters] := chr(10);
                end
                else
                begin
                     numberofcharacters := numberofcharacters + 1;
                     charactersin[numberofcharacters] := datachar;
                end;
           end;
           readln(asciifile);
           datachar := chr(0);
           outfilebyte(datablock,databyte,datachar);
           incrementdata(1);
           outfilebyte(datablock,databyte,datachar);
           incrementdata(1);
           datachar := chr(numberofcharacters mod 256);
           outfilebyte(datablock,databyte,datachar);
           incrementdata(1);
           datachar := chr(numberofcharacters div 256);
           outfilebyte(datablock,databyte,datachar);
           incrementdata(1);
           for i := 1 to numberofcharacters do
           begin
                datachar := charactersin[i];
                outfilebyte(datablock,databyte,datachar);
                incrementdata(1);
           end;
      end;

      procedure asciitocard;
      begin
           openfileasciitocard;
           numcards := asciifilelength;
           clrscr;
           writeln('Number of cards in ASCII file ',numcards);
           gotoxy(5,3);
           write('Processing card number');
           reset(asciifile);
           setstartofdata;
           for i := 1 to numcards do
           begin
                usermessage(i);
                outputindex;
                outputasciidata;
           end;
           closefileasciitocard;
      end;

      procedure initialize;
      begin
           fielddelimiter := #9;
           for i := 0 to 128 do
           begin
                blockimageblank[i] := chr(0);
           end;
      end;

      procedure finish;
      begin
           textcolor(14);
           textbackground(0);
           clrscr;
      end;

      procedure menu;
      begin
        iop := 1;
        while iop <> 0 do
        begin
           clrscr;
           writeln('Enter option');
           writeln(' ');
           writeln('    0)    Exit program');
           writeln(' ');
           writeln('    1)    Convert Cardfile to ASCII');
           writeln('    2)    Convert ASCII to Cardfile');
           read(kbd,keyhit);
           iop := ord(keyhit) - 48;
           case iop of
                0: ;
                1: cardtoascii;
                2: asciitocard;
           else
                sound(600);
                delay(180);
                nosound;
           end;
        end;
        clrscr;
      end;

      begin
           initialize;
           menu;
           finish;
      end.