Pascal/Turbo Pascal - Ayuda para realizar un programa en Pascal para registrar ventas de un producto

{A ver si esto ayuda}

 program acomercio;

 uses

    crt;

  type

    regbentas = record

            codigo : word;

            ventas : real;

            precio : real;

          end;

   const

       max = (60000 div sizeof(regbentas));

       archivo = 'ventas.dat';

 datit : array[0..99,1..3] of real = (

(117,5,10.5),(124,7,12),(318,4,16),(322,2,18.5),(455,6,19),

(172,7,14),(221,8,13.2),(217,9,11),(422,1,14.5),(101,4,21),

(117,5,10.5),(124,7,12),(172,7,14),(221,8,13.2),(217,9,11),

(422,1,14.5),(101,4,21),(117,5,10.5),(124,8,12),(318,4,16),

(322,2,18.5),(455,3,19),(172,7,14),(221,8,13.2),(217,9,11),

(422,2,14.5),(101,3,21),(117,5,10.5),(124,7,12),(318,4,16),

(322,5,18.5),(455,6,19),(172,7,14),(117,6,10.5),(124,8,12),

(318,5,16),(322,3,18.5),(455,7,19),(172,7,14),(221,9,13.2),

(217,10,11),(422,2,14.5),(101,5,21),(221,8,13.2),(217,9,11),

(422,1,14.5),(101,4,21),(117,6,10.5),(124,6,12),(318,3,16),

(322,1,18.5),(455,5,19),(172,8,14),(221,7,13.2),(217,8,11),

(422,2,14.5),(101,4,21),(117,6,10.5),(124,8,12),(318,5,16),

(322,3,18.5),(455,7,19),(172,8,14),(221,9,13.2),(217,8,11),

(422,5,14.5),(101,2,21),(117,5,10.5),(124,7,12),(318,4,16),

(322,2,18.5),(455,6,19),(172,7,14),(221,8,13.2),(217,9,11),

(422,1,14.5),(101,4,21),(117,5,10.5),(124,7,12),(318,4,16),

(322,2,18.5),(455,6,19),(117,4,10.5),(124,6,12),(318,5,16),

(322,2,18.5),(455,5,19),(172,3,14),(221,7,13.2),(217,8,11),

(422,5,14.5),(101,3,21),(322,2,18.5),(455,6,19),(172,7,14),

(221,8,13.2),(217,9,11),(422,1,14.5),(101,4,21),(117,6,10.5));

   var

    bentas : array[1..max] of regbentas;

    dis, cont : word;

    f : file of regbentas;

    ini : char;

  procedure entradatos;

  var

    sal : boolean;

    se, gu, rt : longint;

    tec : char;

  begin

     clrscr;

     sal := false;

     writeln('***** Entrada De Datos *****');

     writeln;

     rt := 1;

   repeat

       write(' Codigo        : ');

       readln(bentas[rt].codigo);

       write(' Unidades      : ');

       readln(bentas[rt].ventas);

       write(' Precio Unidad : ');

       readln(bentas[rt].precio);

       writeln;

       writeln(' Desea Entrar Mas [S/N]');

       repeat

           tec := upcase(readkey);

       until tec in['S','N'];

       if tec = 'S' then

       rt := rt + 1;

       if tec = 'N' then

       sal := true;

   until (sal = true) or (rt > max);

    assign(f, archivo);

    {$I-} reset(f); {$I+}

    if ioresult <> 0 then

    begin

       rewrite(f);

       for gu := 0 to rt do

       begin

       seek(f,gu);

       write(f,bentas[gu]);

       end;

       close(f);

    end

  else

     begin

        gu := filesize(f) - 1;

        for se := 1 to rt do

        begin

           seek(f,gu + se);

           write(f,bentas[se]);

        end;

        close(f);

     end;

   end;

   procedure genera_archivo;

   begin

       assign(f, archivo);

    {$I-} reset(f); {$I+}

    if ioresult <> 0 then

    begin

       rewrite(f);

       for dis := 0 to 99 do

       begin

         bentas[dis].codigo := round(datit[dis,1]);

         bentas[dis].ventas := datit[dis,2];

         bentas[dis].precio := datit[dis,3];

         seek(f,dis);

         write(f,bentas[dis]);

        end;

        close(f);

      end

   else

      close(f);

      clrscr;

   end;

   procedure presentadatos;

   var

     tom : word;

     q, t, k : longint;

     vent : real;

     totalp, totalv : real;

   begin

       clrscr;

       writeln('**** Muesta Contenido Archivo [ ',archivo,' ] ****');

       writeln;

       writeln(' Codigo      Unidades     Total Productos');

       assign(f, archivo);

    {$I-} reset(f); {$I+}

    if ioresult <> 0 then

    begin

        writeln;

        writeln('   El Archivo ',archivo,' No Encontrado Pulse Una Tecla');

        exit;

    end

  else

      begin

         k := 0;

         vent := 0;

         totalp := 0;

         totalv := 0;

       repeat

          seek(f,k);

          read(f,bentas[k + 1]);

          k := k + 1;

       until (k > filesize(f) - 1) or (k > max);

        close(f);

        for t := 1 to k - 1 do

        if bentas[t].codigo > 0 then

        begin

            tom := bentas[t].codigo;

            vent := vent + bentas[t].ventas;

            totalp := totalp + (bentas[t].precio * bentas[t].ventas);

            bentas[t].codigo := 0;

             for q := 1 to k - 1 do

             begin

                if bentas[q].codigo = tom then

                begin

                   vent := vent + bentas[q].ventas;

                   totalp := totalp + (bentas[q].precio * bentas[q].ventas);

                   bentas[q].codigo := 0;

                end;

             end;

              writeln('  ',tom,'        ',vent:0:2,'         ',totalp:0:2);

              totalv := totalv + totalp;

              vent := 0;

              totalp := 0;

              tom := 0;

           end;

           writeln;

           writeln('  Total Ventas Realizadas = ',totalv:0:2);

        end;

      end;

  procedure buscapresenta;

  var

    codig : word;

    kk : longint;

    mues : regbentas;

  begin

     writeln('**** Ver Ventas De Codigo ****');

     writeln;

     write('  Entre Codigo A Buscar : ');

     readln(codig);

     assign(f, archivo);

    {$I-} reset(f); {$I+}

    if ioresult = 0 then

    begin

       writeln(' Codigo      Unidades     Total Productos');

       for kk := 0 to filesize(f) - 1 do

       begin

          seek(f,kk);

          read(f,mues);

          if mues.codigo = codig then

 writeln('  ',mues.codigo,'         ',mues.ventas:0:2,

                                     '           ',mues.precio:0:2);

       end;

       writeln;

       writeln('    Punse Una Tecla');

       close(f);

    end

  else

     begin

        writeln('  El Archivo [ ',archivo,' ] No Esta Creado');

        writeln('  Pulse Una Tecla');

        readkey;

     end;

  end;

  procedure anulacion;

  begin

     assign(f, archivo);

    {$I-} reset(f); {$I+}

    if ioresult = 0 then

    begin

       close(f);

       erase(f);

    end;

  end;

  procedure menu;

  var

    fin : boolean;

    pul : char;

  begin

     fin := false;

   repeat

      clrscr;

      writeln('    ***** Menu General *****');

      writeln;

      writeln('    1 = Entrada De Datos');

      writeln('    2 = Busca Codigo y Presenta');

      writeln('    3 = Visualizar Resultados');

      writeln('    4 = Anula Archivo ventas.dat');

      writeln('    5 = Salir');

      writeln;

      writeln('   >>>>>> Elija Opcion <<<<<<<');

      repeat

          pul := readkey;

      until pul in[#49..#53];

  case pul of

 #49 : begin

       clrscr;

       entradatos;

       end;

 #50 : begin

       clrscr;

       buscapresenta;

       readkey;

       end;

 #51 : begin

       clrscr;

       presentadatos;

       writeln;

       writeln('>>>> Pulse Una Tecla <<<<');

       readkey;

       end;

 #52 : begin

          clrscr;

          anulacion;

          writeln('***** Archivo [ ',archivo,' ] Anulado Pulse Una Tecla *****');

          readkey;

       end;

 #53 : fin := true;

   end;

   until fin = true;

  end;

  begin

     clrscr;

     writeln('¨¨¨¨ Desea Crear El Archivo Para Ver Ejemplo [S/N] ????');

     repeat

     ini := upcase(readkey);

     until ini in['S','N'];

     if ini = 'S' then

     genera_archivo;

     menu;

  end.

{Fíjate que creo un archivo con tus datos como prueba si quieres y sino entra los a mano.}

{A ver si.esto te da una mas clara}

Program ventas;

Uses crt;

Type

  productos = Record

    cod: byte;

    cv: byte;

    pr: real;

  End;

Const ubar = 'C:/ventas.dat';

Var

  prod: productos;

  arch: file Of productos;

  tec: char;

Procedure ingresoproducto;

Var tecla: char;

Begin

  assign(arch,ubar);

     {$I-}

  reset(arch);{$I+}

  If ioResult<>0 Then

    Begin

      rewrite(arch);

    End;

  Repeat

    Begin

      clrscr;

      write('Ingrese codigo: ');

      readln(prod.cod);

      write('Ingrese cantidad vendida: ');

      readln(prod.cv);

      write('Ingrese precio unitario: ');

      readln(prod.pr);

      seek(arch,filesize(arch));

      write(arch,prod);

      writeln;

      write('Ingresar otro Producto? [S/N]');

      tecla := readkey;

    End;

  Until (tecla='N') Or (tecla='n');

  close(arch);

End;

Procedure leeregistro;

Begin

  assign(arch,ubar);

  reset(arch);

  While Not eof(arch) Do

    Begin

      read(arch,prod);

      writeln('Codigo: ',prod.cod);

      writeln('Unidades Vendidas: ',prod.cv);

      writeln('Precio Unitario: ',prod.pr:0:2);

      writeln;

    End;

  close(arch);

  readkey;

End;

Procedure buscaproducto;

Var codigo,cantv: byte;

  precio,unitario: real;

Begin

  write('Ingrese Codigo a Buscar: ');

  readln(codigo);

  assign(arch,ubar);

  reset(arch);

  cantv := 0;

  While Not (eof(arch)) Do

  begin

      read(arch,prod);

      If (codigo=prod.cod) Then

      begin

        cantv := cantv+prod.cv;

      precio := prod.pr*cantv;

      unitario:=prod.pr;

      end;

      end;

  writeln;

  writeln('Codigo: ',codigo);

  writeln('Cantidad Vendidas: ',cantv);

  writeln('Precio Unitario: ',unitario:0:2);

  writeln('Precio Total de Ventas: ',precio:0:2);

  close(arch);

  readkey;

End;

Procedure borraregistro;

Begin

  assign(arch,ubar);

  rewrite(arch);

  close(arch);

  clrscr;

  writeln;

  write('Archivo [VENTAS] ha sido borrado Correctamente!');

  readkey;

End;

Procedure menu;

Begin

  clrscr;

  writeln('|----------Menu----------|');

  writeln;

  writeln;

  writeln('1: Ingreso Nueva Venta!.');

  writeln('2: Ver Lista Ventas!.');

  writeln('3: Ver Producto por Codigo!.');

  writeln('4: Borrar Archivo VENTAS!.');

  writeln;

  write('Ingrese N° de Opcion: ');

  tec := readkey;

  Case tec Of

    '1':

         Begin

           clrscr;

           ingresoproducto;

           menu;

         End;

    '2':

         Begin

           clrscr;

           leeregistro;

           menu;

         End;

    '3':

         Begin

           clrscr;

           buscaproducto;

           menu;

         End;

    '4':

         Begin

           clrscr;

           borraregistro;

           menu;

         End;

  End;

End;

Begin

  menu;

End.