Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/READWKS.ZIP/READWKS.PAS

Pascal/Delphi Source File | 1986-10-01 | 6.3 KB | 215 lines

 program readwks;   {Program to print data in a LOTUS Worksheet file. From P.C.
                                      Tech Journal October 1984 J.P. Holtman
                                      [phone]}

    const   {1 => floating, 2 => formula, 4 => header}
       debug = 0;

    var
       wks_name : string[20];
       infile : file of byte;

    type
       hex_string = string[4];

    function hexprt(a : integer) : hex_string;   {binary -> HEX conversion}

       const
          hexit : array[0..15] of char = '0123456789ABCDEF';

       var
          strout : hex_string;
          i : integer;

       begin
          strout := '    ';
          for i := 4 downto 1 do begin
             strout[i] := hexit[a and $F];
             a := a shr 4;
             end;
          hexprt := strout;
          end;

    function read_byte : byte;

       var
          i : byte;

       begin
          read(infile,i);
          read_byte := i;
          end;

    function read_word : integer;

       var
          hibyte,lobyte : byte;

       begin
          read(infile,lobyte);
          read(infile,hibyte);
          read_word := hibyte shl 8 or lobyte;
          end;


    function process_record : boolean;

       var
          rec_type, i, fld_value, rec_len, word1 : integer;
          rec_format, junk : byte;
          column, row, fromcol, fromrow, tocol, torow : integer;
          isna : boolean;
          byt : array[1..8] of byte;
          double : real;
          char_string : string[255];

       procedure get_format;

          begin
             rec_format := read_byte;
             column := read_word;
             row := read_word;
             end;

       procedure get_double;   {convert to REAL number}

          var
             sign, exponent,i : integer;
             byt2left, byt2right : integer;
             sum, signicand : real;

          begin
             if (debug and 1) <> 0 then begin
                write('bytes=');
                for i := 1 to 8 do write(' ',copy(hexprt(byt[i]),3,2));
                end;
             if (byt[1] = 255) and (byt[2] = 240) then isna := true
             else begin
                isna := false;
                if (byt[1] = 0) and (byt[2] = 0) then double := 0.0
                else begin
                   if (byt[1] and $80) > 0 then sign := -1
                   else sign := 1;
                   byt[1] := byt[1] and $7F;
                   byt2left := (byt[2] and $F0) shr 4;
                   byt2right := byt[2] and $0F;
                   exponent := byt[1] shl 4 + byt2left - 1023;
                   sum := 0;
                   for i := 8 downto 3 do sum := (sum + byt[i]) / 256.0;
                   signicand := 1+(byt2right/16.0)+sum/16.0;
                   double := sign*(signicand*exp(ln(2.0)*exponent));
                   end   end;
             end;

       procedure print_loc;   {print row/column with proper spacing}

          var
             char1,char2 : integer;
             alpha : string[2];
             val_str : string[10];

          begin
             char1 := column div 26;
             char2 := column mod 26;
             if char1 = 0 then alpha := ' '
             else alpha := chr(64+char1);
             alpha := alpha + chr(65+char2);
             str(row+1,val_str);
             write(copy(alpha+val_str+'         ',1,9));
             end;

       begin
          process_record := true;
          rec_type := read_word;
          rec_len := read_word;
          if (debug and 4) <> 0 then writeln('type=',rec_type,'  len=',rec_len);
          case rec_type of   {header}
             0: begin
                word1 := read_word;
                if (rec_len <> 2) or (word1 <> $404) then begin
                   writeln(#7'Not valid worksheet'#7);
                   halt;
                   end;
                end;

{range}
             6: begin
                fromcol := read_word;
                fromrow := read_word;
                tocol := read_word;
                torow := read_word;
                row := torow-fromrow;
                column := tocol-fromcol;
                write('Lower Right Corner: ');
                print_loc;
                writeln;
                end;

{integer value}
             13: begin
                get_format;
                print_loc;
                fld_value := read_word;
                writeln(fld_value);
                end;

{double precision}
             14: begin
                get_format;
                print_loc;
                for i := 1 to 8 do byt[9-i] := read_byte;
                get_double;
                if isna then writeln('NA')
                else writeln(double);
                end;

{character string}
             15: begin
                get_format;
                print_loc;
                char_string := '';
                for i := 1 to rec_len-5 do char_string := char_string + chr(
                     read_byte);
                writeln(char_string);
                end;

{formula and value}
             16: begin
                get_format;
                print_loc;
                for i := 1 to 8 do byt[9-i] := read_byte;
                get_double;
                if isna then writeln('NA')
                else writeln(double);
                for i := 1 to rec_len-13 do begin   {read rest of formula and
                                      discard}
                   junk := read_byte;
                   if (debug and 2) <> 0 then write(copy(hexprt(junk),3,2),' ');
                   end;
                if (debug and 2) <> 0 then writeln;
                end;

{end of worksheet}
             1: begin
                writeln('End of Worksheet');
                process_record := false;
                end;

             else
                begin   {ignore the record type}
                   for i := 1 to rec_len do junk := read_byte;
                   end;

             end;
          end;

    begin
       write('Worksheet name: ');
       readln(wks_name);
       assign(infile,wks_name+'.wks');
       reset(infile);
       repeat
          until process_record = false;
       end.