RESPUESTA A LA PREGUNTA 9773 - PASCAL/TURBO PASCAL


Writeln(lst,Chr(27)+Chr(78)+Chr(6))

Cesar Berrio 
Palmira, Valle del Cauca
Colombia SA

te doy un regalo espero que te guste

{$O+,F+}
UNIT ImprimeU;

INTERFACE
Uses TiposU;

    Function printOk:Boolean;
    Procedure ImprimirP(Var ArchX:Archivo1;Nombre:String;Sec:byte);
    Procedure ImprimirE(Var ArchX:Archivo1;Nombre:String;Sec:byte);


IMPLEMENTATION

Uses Dos,Screen,Crt,Printer,Error;

Const
  pagina=#12;

{------------------------------------------------}
Function printOk:Boolean;
var
  T:Char;
  E:Integer;
Begin
  Repeat
    Fondo(0,15);
    Cuadro1(7,11,69,15,7,1,0,15);
    LiniaF(8,12,68,1,1,1,15);
    LiniaF(8,13,68,1,1,1,15);
    LiniaF(8,14,68,1,1,1,15);
    Gotoxy(8,12);
    Write(' Aliste la Impresora y Presione una Tecla Para Continuar..[ ]');
    Gotoxy(8,13);
    Write('  ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ    ');
    Gotoxy(8,14);
    Write('        Para Cancelar Esta Operaci¢n Digite ESC.             ');
    GotoXY(67,12);
    t:=Readkey;
    If t=#27 Then Printok:=False
    Else
      Begin
        {$i-}Writeln(lst);{$i+}
         E:=IOResult;
         If E=0 then Printok:=True
         Else
           begin
             Fondo(0,15);
             Cuadro1(7,11,69,15,7,1,0,15);
             LiniaF(8,12,68,1,1,1,15);
             LiniaF(8,13,68,1,1,1,15);
             LiniaF(8,14,68,1,1,1,15);
             Gotoxy(8,12);
             Write('   No Se Puede Imprimir!     Anular / Reintentar A/R ?   :[ ]');
             Gotoxy(8,13);
             Write('  ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ    ');
             Gotoxy(8,14);
             Write('   Existe Un Error..  Presione la tecla segun el caso        ');
             Repeat
               GotoXY(67,12);
               t:=Readkey;
             Until UpCase(t) in ['A','R'];
             If UpCase(t)='A' Then
               begin
                 Printok:=False;
                 t:=#27;
               end;
           end;
      End;
  Until ((E=0) Or (t=#27));
  Esperar;
End;
{------------------------------------------------}
Function Porcentaje(Sec:byte):Real;
var t:Char;
    Por:Real;
begin
  Fondo(0,15);
  Cuadro1(10,7,70,10,7,1,0,15);
  LiniaF(11,8,69,1,1,1,15);
  LiniaF(11,9,69,1,1,1,15);
  Gotoxy(12,8);Writeln('Porcentaje del precio Dos(2) en secci¢n: ',sec);
  TextColor(15);
  Gotoxy(12,9);Write('Ingrese el porcentaje: ');
  GotoXY(35,9);LReal(por,1,14,1,15);
  gotoxy(1,25);
  Porcentaje:=por;
End; {MensajeImp}

Function Mil(x:Real):String;
Var S,c:String[12];
    Nc,n:Integer;
Begin
  c:=',';
  Str(x:5:2,s);
  Nc:=Length(s);
  If Nc=7 Then Insert(c,S,2)Else
  If Nc=8 Then Insert(c,S,3)Else
  If Nc=9 Then Insert(c,S,4)Else
  If Nc=10 Then Begin
                Insert(c,S,2);
                Insert(c,S,6);
                End;
  Mil:=S;
End;

{Impresion Lista de Precios----------------------}
Procedure ImprimirP(Var ArchX:Archivo1;Nombre:String;Sec:byte);
Var
  k,pag      :Integer;
  dd,mm,aa,xx:Word;
  RegT       :CamposE;
  pos        :Integer;{Posici¢n}
  An         :Integer;{campo anterior}
  Por        :Real;   {porcentaje del precio dos}
  P2         :Real;   {precio 2}
  E          :Integer;{Codigo de Error}

  Function PCad(cad:string;tm,pos:byte):Integer;
  var l:Integer;
  Begin l:=tm-length(cad);PCad:=pos-l;End;

  Function Ant(Cad:string;tm:integer):Integer;
  begin Ant:=tm-length(cad); end;

Begin
  Assign(ArchX,Nombre);
  (*$i-*)Reset(ArchX);(*$i+*)
  If IOResult<>0 Then Exit;
  {Sistema de clasificacion ---------------------}
  {ClasificacionArt(ArchX);......................}
  {----------------------------------------------}
  por:=Porcentaje(Sec);
  Esperar;
(*$i-*)
  Seek(ArchX,0);pag:=0;
  GetDate(aa,mm,dd,xx);
  While Not Eof(ArchX) Do
  Begin
    pag:=pag+1;k:=0;
    Writeln(lst,' ');
    Writeln(lst,' ');
    Writeln(lst,' ');
    Write(lst,Chr(27)+Chr(18));
    Write(lst,Chr(27)+Chr(52));
    Write(lst,Chr(27)+Chr(77));
    Write(lst,'  ','   O N L Y    C O M P A C T .                ');
    Writeln(lst,'  ','         Fecha: ',dd,'/',mm,'/',aa);
    Writeln(lst,'  ','   Listado de Precios: ',seccion[sec]);
    Write(lst,Chr(27)+Chr(80));
    Write(lst,Chr(27)+Chr(53));
    Writeln(lst,' ');
    Write(lst,Chr(27)+Chr(18));
    Writeln(lst,'  ','   - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Pag:',pag:2);
    Writeln(lst,'CODIGO':11,'DETALLE':10,'PRECIO':30,'PRECIO DOS':20);
    Writeln(lst,'  ','   -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -');
    While (k<48) And (Not Eof(ArchX)) Do
    Begin
      Read(ArchX,RegT);
      If RegT.cod<>0 Then
      Begin
        k:=k+1;
        Write(lst,RegT.cod:9);
        Pos:=PCad(RegT.Art,25,30);
        Write(lst,RegT.Art:pos);
        An:=Ant(RegT.Art,25);
        P2:=((RegT.vta*por)/100)+RegT.vta;
        Write(lst,Mil(RegT.vta):12+an);
        Writeln(lst,Mil(p2):15+an);
      End;
    End;{While}
    Writeln(lst,'     ==================================================================');
    Writeln(lst,'     Cab');
    If k=48 Then Writeln(lst,Chr(27)+Chr(78)+Chr(6))
    Else
     If k<48 Then
      Begin
        Write(lst,Chr(27)+Chr(12));
        Write(lst,Chr(27)+Chr(79));
        Write(lst,Chr(27)+Chr(18));
      End;
    End;{While}
  Writeln(lst,pagina);
(*$i+*)
  E:=IOResult;
  If E<>0 then Err(E);
  Close(Archx);Exit;
End;
{------------------------------------------------}

{Impresion: De Existencias ----------------------}
Procedure ImprimirE(Var ArchX:Archivo1;Nombre:String;Sec:byte);
Var
  k,pag      :Integer;
  dd,mm,aa,xx:Word;
  RegT       :CamposE;
  Art        :String;
  pos        :Integer;{Posicion}
  An         :Integer;{Campo Anterior}
  E          :Integer;{Codigo de Error}

  Function PCad(cad:string;tm,pos:byte):Integer;
  var l:Integer;
  Begin l:=tm-length(cad);PCad:=pos-l;End;

  Function Ant(Cad:string;tm:integer):Integer;
  begin Ant:=tm-length(cad); end;

Begin
  {----------------------------------------------}
  Assign(ArchX,Nombre);
  (*$i-*)Reset(ArchX);(*$i+*)
  If IOResult<>0 Then Exit;
  {----------------------------------------------}
  {Sistema de clasificacion ---------------------}
  {ClasificacionArt(ArchX);......................}
  {----------------------------------------------}
  pag:=0;Seek(ArchX,0);
(*$i-*)
  GetDate(aa,mm,dd,xx);
  While Not Eof(ArchX) Do
  Begin
    pag:=pag+1;k:=0;
    Writeln(lst,' ');
    Writeln(lst,' ');
    Writeln(lst,' ');
    Write(lst,Chr(27)+Chr(18));
    Write(lst,Chr(27)+Chr(52));
    Write(lst,Chr(27)+Chr(77));
    Write(lst,'  ','    O N L Y   C O M P A C T .                       ');
    Writeln(lst,'  ','          Fecha: ',dd,'/',mm,'/',aa);
    Writeln(lst,'  ','    Listado de Existencias: ',Seccion[sec]);
    Write(lst,Chr(27)+Chr(80));
    Write(lst,Chr(27)+Chr(53));
    Writeln(lst,' ');
    Write(lst,Chr(27)+Chr(18));
    Writeln(lst,'  ','   ___________________________________________________________ Pag:',pag:2);
    Writeln(lst,'CODIGO':11,'DETALLE':10,'PROVEEDOR':22,'CANT':12,' COSTO':16);
    Writeln(lst,'  ','   ------------------------------------------------------------------');
    While (k<48) And (Not Eof(ArchX)) Do
    Begin
      Read(ArchX,RegT);
      If RegT.cod<>0 Then
      Begin
        k:=k+1;
        Write(Lst, RegT.cod:9);
        Pos:=PCad(RegT.Art,25,30);
        Write(Lst,RegT.Art:pos);
        An:=Ant(RegT.Art,25);
        Pos:=PCad(RegT.pro,25,20);
        Write(Lst,RegT.pro:pos+an);
        An:=Ant(RegT.pro,20);
        Write(Lst,RegT.can:an);
        Writeln(Lst,Mil(RegT.cos):17);
      End;
    End;{While}
    Writeln(lst,'     ==================================================================');
    Writeln(lst,'     Cab');
    If k=48 Then Writeln(lst,Chr(27)+Chr(78)+Chr(6))
    Else
     If k<48 Then
      Begin
        Write(lst,Chr(27)+Chr(12));
        Write(lst,Chr(27)+Chr(79));
        Write(lst,Chr(27)+Chr(18));
      End;
  End;{While}
  Writeln(lst,pagina);
(*$i+*)
  E:=IOResult;
  If E<>0 then Err(E);
  Close(Archx);Exit;
End;
{------------------------------------------------}
END.{IMPLEMENTATION}


Cesar Augusto Berrio Martinez
cberriom@acuaviva.com.co