Advertisement
FacundoCruz

Global

Oct 16th, 2020
190
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Pascal 3.84 KB | None | 0 0
  1. unit u_Global;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, Dialogs, Math, utiles;
  9.  
  10. const
  11.   PATH_FICHEROS    = 'ficheros/';
  12.   FICHERO_PRODUCTOS = PATH_FICHEROS + 'productos.dat';
  13.   FICHERO_AUXILIAR_PRODUCTOS = PATH_FICHEROS +'auxiliar.dat';
  14.   NO_ENCONTRADO = -1;
  15.  
  16.  
  17. type
  18.   Cadena70 = String[70]; // Tipo Cadena de 70 caracteres
  19.   Cadena20 = String[20]; // Tipo Cadena de 20 caracteres
  20.   TProducto = record  // Tipo Registro de producto
  21.      codigo : integer;
  22.      descripcion : Cadena20;
  23.      precio : real;
  24.      stock : integer;
  25.   end;
  26.  
  27.   TFicheroProductos = file of TProducto;     // Tipo fichero de productos
  28.  
  29. var
  30.   P: TProducto; //Registro de un producto
  31.   f: TFicheroProductos;  //Fichero de productos
  32.   n: Integer;   //Cantidad inicial de productos
  33.  
  34. procedure altaProducto(var f:TFicheroProductos; producto:TProducto);
  35. procedure crearFichero(var f:TFicheroProductos);
  36. function buscarProducto(var f:TFicheroProductos;codigo:longInt):longInt;
  37. procedure modificarProducto(var f:TFicheroProductos;producto:TProducto;posicion:longInt);
  38. procedure bajaProducto(var f:TFicheroProductos; K:String);
  39.  
  40. implementation
  41.  
  42. function buscarProducto(var f:TFicheroProductos;codigo:longInt):longInt;
  43. var
  44.   i,posicion : longInt;
  45.   producto : TProducto;
  46. begin
  47.  try
  48.    reset(f);
  49.    posicion := NO_ENCONTRADO;  //NO_ENCONTRADO es una constante = -1
  50.    i := 0;
  51.  
  52.    while not eof(f) and (posicion = NO_ENCONTRADO) do
  53.        begin
  54.          read(f, producto);
  55.          if codigo = producto.codigo then
  56.              posicion:= i
  57.          else
  58.             i := i + 1;
  59.        end;
  60.     closeFile(f);
  61.  finally
  62.    buscarProducto:=posicion;
  63.  end;
  64. end;
  65.  
  66. procedure leerFichero(var f:TFicheroProductos);
  67. var
  68.   producto : TProducto;
  69. begin
  70.  try
  71.    reset(f);
  72.  
  73.    while not eof(f) do
  74.        begin
  75.          read(f, producto);
  76.          //procear producto: por ejemplo cargar en un StringGrid
  77.        end;
  78.     closeFile(f);
  79.  except
  80.    on E: EInOutError do
  81.    ShowMessage('NO se pudo abrir el fichero: '+E.ClassName+'/'+E.Message);
  82.  end;
  83. end;
  84.  
  85.  
  86. procedure modificarProducto(var f:TFicheroProductos;producto:TProducto;posicion:longInt);
  87. begin
  88.  try
  89.    reset(f);
  90.    seek(f,posicion);
  91.    write(f,producto);
  92.  finally
  93.    closeFile(f);
  94.  end;
  95. end;
  96.  
  97. procedure altaProducto(var f:TFicheroProductos; producto:TProducto);
  98. begin
  99.  try
  100.    reset(f);
  101.    seek(f,fileSize(f));
  102.    write(f,producto);
  103.  finally
  104.    closeFile(f)
  105.  end;
  106. end;
  107.  
  108. procedure bajaProducto(var f:TFicheroProductos; K:String);
  109. var
  110.   R: TProducto;
  111.   existe: boolean;
  112.   ok,codigo: integer;
  113.   aux: TFicheroProductos;
  114. begin
  115.   assignFile(aux,FICHERO_AUXILIAR_PRODUCTOS);
  116.   try
  117.     reset(f);
  118.     rewrite(aux);
  119.     val(K, codigo, ok);
  120.     existe := false;
  121.     while not eof(f) do
  122.      begin
  123.       read(f, R);
  124.       if(R.Codigo = codigo) then
  125.         existe := true
  126.       else
  127.         write(aux, R);
  128.      end;
  129.     closeFile(f);
  130.     closeFile(aux);
  131.      if(existe) then
  132.        begin
  133.          erase(f);
  134.          rename(aux, FICHERO_PRODUCTOS);
  135.        end
  136.      else
  137.        begin
  138.          ShowMessage('El codigo No existe...');
  139.          erase(aux);
  140.        end;
  141.   except
  142.     on E: EInOutError do
  143.       ShowMessage('File handling error occurred. Details: '+E.ClassName+'/'+E.Message);
  144.   end;
  145. end;
  146.  
  147. procedure crearFichero(var f:TFicheroProductos);
  148. var
  149.   P : TProducto;
  150.   i : integer;
  151. begin
  152.   assignFile(f,FICHERO_PRODUCTOS);
  153.   try
  154.     reset(f);
  155.   except
  156.     rewrite(f);
  157.     randomize;
  158.     for i := 1 to n do
  159.       begin
  160.         P.codigo := i;
  161.         P.descripcion := 'Producto ' + inttostr(i);
  162.         P.precio := random*1000;
  163.         P.stock := randomRange(100,999);
  164.         write(f,P);
  165.       end;
  166.   end;
  167.     closeFile(f);
  168. end;
  169.  
  170. initialization
  171.   n := 10;   //Cantidad de productos inicial
  172. end.
  173.                                                                
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement