Pascal/Turbo Pascal - programa completo

   
Vista:

programa completo

Publicado por Miguel (10 intervenciones) el 16/06/2011 20:51:19
Program gestcomercial;
uses crt,DOS;

TYPE
{===================== TIPO CLIENTE ================================}
cliente=record
NIF:string[10];
rsocial:string[40];
fpago:char;
estado:char;
fecha:string[12];
end;

pCliente=^nodocliente;

nodocliente=record
infoc:cliente;
sig:pCliente;
end;
{====================================================================}

{=================== TIPO PEDIDOS ==================================}

linea=record
nLinea:integer;
numpedido:integer;
cantidad:integer;
ppu:longint;
pt:longint;
end;
pLinea=^nodoLinea ;

nodoLinea=record
infoLinea:linea;
sig:plinea;
end;
{******************************}
pedido=record
npedido:integer;
cifCliente:string[10];
impPedido:longint;
fecha:string[10];
estado:char;
end;

pPedido=^nodoPedido;

nodoPedido=record
infoPedido:pedido;
lineas:pLinea;
sig:pPedido;
end;

{===================== TIPO FACTURAS =====================================}
LINEAF= record
nLineaF:integer;
nfactura:integer;
Cantidad:integer;
ipulF:longint;
itlF:longint;
end;

pLineaF=^nodolineaf;

nodolineaF=record
infolineaF:lineaF;
sig:pLineaf;
end;

{************************************************************************** }
factura=record
nfactura:integer;
cifCliente:string[10];
impFactura:longint; {calculado como suma de importe de lineas}
fecha:string[12];
end;

pFactura=^nodoFactura;

nodoFactura=record
infoFactura:factura;
sig:pFactura;
lineaF:pLineaF;
end;

{************************************************************************}
cuota=record
nfactura:integer;
norden:integer;
importe:longint;
{ vencimiento:fecha;}
end;

pCuota=^nodoCuota;

nodoCuota=record
infoCuota:cuota;
sig:pCuota;
end;

{========================================================================}

VAR

listacliente:pCliente;
c:cliente;
listaPedido:pPedido;
p:pedido;
listalinea:pLinea;
l:linea;
listafactura:pFactura;
f:factura;
listalineaF:plineaF;
lf:lineaF;
listacuota:pCuota;
ct:cuota;
s:string;
opc:integer;
opc2,opc3,opc4:char;

{************************************************************************}
{*======================= CLIENTES =====================================*}
{************************************************************************}


Procedure crealistavaciaC(VAR listacliente:pCliente);

begin
listacliente:=nil;
end;


Function listavaciaC(listacliente:pCliente):boolean;

Begin

listavaciaC:=listacliente=nil;

end;

function anterior(listacliente:pCliente; punttemp:pCliente):pCliente;

var i: pcliente;

begin
i:=listacliente;
if listavaciaC(listacliente) or (punttemp=listacliente)then
anterior:=listacliente
else
begin
while (i^.sig<>punttemp) and not listavaciaC(i^.sig) do
i:= i^.sig;
anterior:=i;

end;
end;

procedure busquedalineal(listacliente:pCliente; c:cliente;
VAR encontrado:boolean;
VAR puntanterior,puntactual:pCliente);
var finbusqueda:boolean;
begin
puntactual:=listacliente;
puntanterior:=nil;
encontrado:=false;
finbusqueda:=false;
While not finbusqueda and not listavaciaC(puntactual) do
if( puntactual^.infoc.nif <= c.nif) then
begin
finbusqueda:=true;
encontrado:=(puntactual^.infoc.nif= c.nif);
end
else
Begin
puntanterior:=puntactual;
puntactual:=puntactual^.sig;
end;

End;

procedure fecha(VAR c:cliente);

var
anio, mes, dia , hdia:word;
cad1,cad2,cad3:string;

begin
getdate(anio,mes,dia,hdia);
str(dia:2,cad1);
str(anio:3,cad3);
str(mes:2,cad2);
c.fecha:=cad3+'/'+cad2+'/'+cad1;
end;


Procedure mostrarlistaC(listacliente:pCliente);


var
op:char;

begin
clrscr;
Repeat

If listavaciaC(listacliente) then
begin
clrscr;
Writeln('No hay mas datos para mostrar');
end
else
While not listavaciaC(listacliente) do
begin
Writeln;
Writeln('NIF/CIF: ',listacliente^.infoc.nif);
Writeln('Razon Social: ',listacliente^.infoc.rsocial);
Writeln('Forma de Pago: ',listacliente^.infoc.fpago);
Writeln('Estado: ',listacliente^.infoc.estado);
Writeln('Fecha: ',listacliente^.infoc.fecha);
listacliente:=listacliente^.sig;
end;
Writeln('Desea continuar? [S/N]');
op:=readkey;
until (op='n');
end;

{**************************************************************************}
procedure insertarListaC(var listacliente:pCliente; c:cliente);

var punttemp,puntanterior:pCliente;
nodo: pCliente;

begin
punttemp:=listacliente;
new(nodo);
nodo^.infoc.nif:=c.nif;
nodo^.infoc.rsocial:=c.rsocial;
nodo^.infoc.fpago:=c.fpago;
nodo^.infoc.estado:=c.estado;
nodo^.infoc.fecha:=c.fecha;
if listavaciaC(listacliente) then
begin
nodo^.sig:=nil;
listacliente:=nodo;
end
else
begin
while (punttemp^.infoc.rsocial < c.rsocial) and (punttemp<>NIL) do
punttemp:=punttemp^.sig;
if punttemp=nil then
begin
puntanterior:=anterior(listacliente,punttemp);
puntanterior^.sig:=nodo;
nodo^.sig:=NIL;
end
else
begin
puntanterior:=anterior(listacliente,punttemp);
if punttemp=listacliente then
begin
nodo^.sig:=puntanterior;
listacliente:=nodo;
end
else
begin
nodo^.sig:=puntanterior^.sig;
puntanterior^.sig:=nodo;
end;
end;
end;
end;


Procedure CargarClientes(VAR listacliente:pCliente);

var
f:text;
c:cliente;
begin
assign(f,'clientes.txt');
{$I-}
reset(f);
{$I+}
if IOResult = 0 then
While not eof(f)do
begin
readln(f,c.NIF);
readln(f,c.Rsocial);
readln(f,c.fpago);
readln(f,c.estado);
readln(f,c.fecha);
insertarListaC(listacliente,c);
mostrarListaC(listacliente);
end
else
writeln('El archivo que trata de cargar no existe...');
End;

Procedure anadircliente(VAR listacliente:pCliente; VAR c:cliente);

VAR
encontrado:boolean;
puntanterior,puntactual:pCliente;
begin
busquedalineal(listacliente,c,encontrado,puntanterior,puntactual);
If not encontrado then
insertarlistac(listacliente,c)
else
begin
clrscr;
Writeln('Ya existe un registro para:');
Writeln('NIF: ',c.nif);
Writeln('Razon social: ',c.rsocial);
end;
End;



Function busquedabaja(listacliente:pCliente; c:cliente):boolean;

var
encontrado:boolean;

begin
encontrado:=false;
While(listacliente<>nil) and not encontrado do
begin
If listacliente^.infoc.nif=c.nif then
begin
encontrado:=true;
listacliente^.infoc.estado:='B';
end;
listacliente:=listacliente^.sig;
end;

busquedabaja:=encontrado;
end;

{*****************************************************************************}

procedure guardaclientes2(c:cliente);

var
f:text;

begin

assign(f,'clientes.txt');
{$I-}
append(f);
{$I+}
writeln(f,c.nif);
writeln(f,c.rsocial);
writeln(f,c.fpago);
writeln(f,c.estado);
writeln(f,c.fecha);
writeln;
close(f);
end;

Procedure BajasCliente(VAR listacliente:pCliente; VAR c:cliente);

begin
clrscr;
Writeln('============== BAJAS CLIENTES ================');
Writeln('Introduzca el numero de NIF que desee dar de baja: ');
if listavaciaC(listacliente) then
begin
Writeln('No hay Clientes dados de Alta');
end
else
begin
write('NIF/CIF: ');
readln(c.nif);
If busquedabaja(listacliente,c)then
mostrarlistaC(listacliente);
c.estado:='B';
guardaclientes2(c);
end;

end;


procedure guardaclientes(c:cliente);

var
f:text;

begin

assign(f,'clientes.txt');
{$I-}
rewrite(f);
{$I+}
close(f);
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Procedure Altascliente(VAR listacliente:pCliente; VAR c:cliente);
 
var
 op:char;
 
Begin
  Repeat
   clrscr;
   Writeln('_____________ ALTAS DE CLIENTES______________');
   Writeln('Introduzca los Datos Pedidos:');
   Write('NIF/CIF: ');
   readln(c.nif);
   Write('Razon Social: ');
 
   readln(c.rsocial);
   Write('Forma de Pago: ');
   readln(c.fpago);
   Write('Estado: ');
   c.estado:='A';
   Write('Fecha: ');
   fecha(c);
   Write(c.fecha);
   anadircliente(listacliente, c);
   guardaclientes2(c);
   Writeln('Desea continuar ? (S/N)');
 
   op:=readkey;
 until (op='n') or (op='N');
 
end;


esta es la primera parte del codigo( te lo mando en tres partes ya que es muy largo) si pudiese encontrar el fallo seria de muchisima ayuda ya que es un autentico quebradero de cabeza...

gracias
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder

programa completo

Publicado por Miguel (10 intervenciones) el 16/06/2011 20:53:28
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
{======================PEDIDOS============================================}
 
Procedure CrearListaVaciaP(VAR listaPedido:pPedido);
 
begin
 listaPedido:=nil;
 
end;
 
Function listavaciaP(listaPedido:pPedido):boolean;
 
Begin
 
 listavaciaP:=listaPedido=nil;
 
end;
 
Procedure CrearlistaVaciaL(VAR listaLinea:pLinea);
begin
 
 listalinea:=nil;
 
end;
 
 
Function listavaciaL(listalinea:pLinea):boolean;
 
begin
 
 listavaciaL:=listalinea=nil;
 
end;
 
 
Procedure fechas2(VAR p:pedido);
 
var
 anio, mes, dia , hdia:word;
 cad1,cad2,cad3:string;
 
begin
 getdate(anio,mes,dia,hdia);
 str(dia:2,cad1);
 str(anio:3,cad3);
 str(mes:2,cad2);
 p.fecha:=cad3+'/'+cad2+'/'+cad1;
end;
 
 
Procedure busquedalinealp(listaPedido:pPedido; p:Pedido;
                         VAR encontrado:boolean;
                         VAR puntanterior,puntactual:pPedido);
begin
 puntactual:=listaPedido;
 puntanterior:=nil;
 encontrado:=false;
 While not encontrado and (puntactual<>nil) do
  Begin
   if puntactual^.infoPedido.npedido=p.npedido then
    encontrado:=true
   else
    Begin
     puntanterior:=puntactual;
     puntactual:=puntactual^.sig;
    end;
  end;
end;
 
Procedure mostrarlistaP(listacliente:pCliente);
 
var
 op:char;
 
begin
 clrscr;
 Repeat
 If listavaciaC(listacliente) then
  begin
    clrscr;
    Writeln('No hay nada que mostrar');
  end
 else
  While not listavaciaC(listacliente) do
   begin
    Writeln;
    Writeln('NIF/CIF: ',listacliente^.infoc.nif);
    Writeln('Razon Social: ',listacliente^.infoc.rsocial);
    Writeln;
    listacliente:=listacliente^.sig;
   end;
   Writeln('Pulsa [S] para continuar');
   op:=readkey;
 until (op='s');
end;
 
 
Procedure buscarenlistaL(VAR listapedido:pPedido; VAR  listalinea:plinea);
 
var totalpedido:longint;
 
begin
 totalpedido:=0;
 While not listavaciaL(listalinea) do
  begin
    totalpedido:=totalpedido+(listalinea^.infolinea.pt);
    listalinea:=listalinea^.sig;
  end;
 listapedido^.infoPedido.impPedido:=totalpedido;
end;
 
 
Procedure mostrarPedido(listapedido:pPedido;listalinea:pLinea);
 
var
 op:char;
 
begin
 clrscr;
 Repeat
 If listavaciaP(listapedido) then
  Writeln('No hay Datos que mostrar')
 else
  While not listavaciaP(listapedido) do
   begin
    Writeln('Numero de Pedido: ',listapedido^.infoPedido.npedido);
    Writeln('NIF/CIF: ',listapedido^.infoPedido.cifCliente);
    buscarenlistaL(listapedido,listalinea);
    Writeln('Importe del Pedido: ',listapedido^.infoPedido.impPedido);
    Writeln('Fecha: ',listapedido^.infopedido.fecha);
    Writeln('Estado: ',listapedido^.infoPedido.estado);
    Writeln;
    listapedido:=listapedido^.sig;
   end;
   Writeln('Pulsa [S] para continuar');
   op:=readkey;
 until (op='s');
end;
 
Procedure insertarlistaP(VAR listaPedido:pPedido; p:Pedido);
 
var
 puntanterior,puntactual,punttemp:pPedido;
begin
   new(punttemp);
   punttemp^.infoPedido:=P;
   punttemp^.sig:=nil;
   puntanterior:=nil;
   puntactual:=listaPedido;
   While puntactual<> nil do
    begin
       puntanterior:=puntactual;
       puntactual:=puntactual^.sig;
    end;
    if puntanterior=nil then
      listaPedido:=punttemp
    else
      puntanterior^.sig:=punttemp;
 
end;
 
 
Procedure CargarPedidos(VAR listaPedidos:pPedido;
                        VAR lineaFact:string);
 
 
var
 f:text;
 p:pedido;
 
 
begin
 assign(f,s);
 reset(f);
 While not eof(f)do
  begin
    readln(f,p.npedido);
    readln(f,p.cifcliente);
    readln(f,p.impPedido);
    readln(f,p.fecha);
    readln(f,p.estado);
    insertarListaP(listapedido,p);
    mostrarPedido(listapedido,listalinea);
  end;
end;
 
Procedure AnularP(VAR listaPedido:pPedido; p:Pedido);
 
var
 
 puntanterior,puntsiguiente:pPedido;
 encontrado:boolean;
begin
 clrscr;
 Writeln('____________ANULACION DE PEDIDOS______________');
 Write('Introduzca los datos pedidos:');
 If listaVaciaP(listapedido)then
  begin
   Writeln('NO HAY DATOS');
  end
 else
   begin
      clrscr;
      Write('Numero de Pedido:  ');
      readln(p.npedido);
      busquedalinealP(listapedido,p,encontrado,puntanterior,puntsiguiente);
      If encontrado then
        begin
         listaPedido^.infoPedido.estado:='A';
         mostrarPedido(listaPedido,listalinea);
        end
      else
        begin
          clrscr;
          Writeln('NO EXISTE EL PEDIDO');
        end;
    end;
end;
 
Procedure anadirpedido(VAR listapedido:pPedido;  p:pedido);
 
var
 puntanterior,puntsiguiente:pPedido;
 encontrado:boolean;
 
begin
   busquedalinealP(listapedido,p,encontrado,puntanterior,puntsiguiente);
   If not encontrado then
      insertarlistap(listapedido,p)
   else
     begin
      Writeln('Ya existe un registro para: ', p.npedido);
     end;
end;
 
 
function numeropedido(VAR listapedido:pPedido):integer;
 
begin
 if listavaciap(listapedido) then
  numeropedido:=1
 else
 numeropedido:=1+numeropedido(listapedido^.sig);
end;
 
 
Function busquedabajaC(listacliente:pCliente; c:cliente):boolean;
 
var
 encontrado:boolean;
 
begin
 encontrado:=false;
 While(listacliente<>nil) and not encontrado do
  begin
   If (listacliente^.infoc.nif=c.nif)  then
    begin
    if (listacliente^.infoc.estado='B' ) then
    encontrado:=true;
 
    end;
    listacliente:=listacliente^.sig;
   end;
 
 busquedabajaC:=encontrado;
end;
 
procedure guardarpedidos(p:pedido);
 
var
  f:text;
begin
  assign(f,'pedidos.txt');
  {$I-}
  rewrite(f);
  {$I+}
  close(f);
end;
 
procedure guardarpedidos2(p:pedido);
 
var
 
  f: text;
 
begin
 
   assign(f,'pedidos.txt');
   {$I-}
   append(f);
   {$I+}
   writeln(f,p.npedido);
   writeln(f,p.cifcliente);
   writeln(f,p.fecha);
   writeln(f,p.estado);
   writeln;
   close(f);
end;
 
procedure muestrapedidos(ped:pedido);
 
begin
   writeln(ped.npedido);
   writeln(ped.cifcliente);
   writeln(ped.fecha);
   writeln(ped.estado);
end;
 
Procedure cargapedidos(var listapedido:ppedido);
 
  var
    f:text;
    ped:pedido;
  begin
    assign(f,'pedidos.txt');
    {$I-}
    reset(f);
    {$I+}
    while not eof(f) do
      begin
        readln(f,ped.npedido);
        readln(f,ped.cifcliente);
        readln(f,ped.fecha);
        readln(f,ped.estado);
        insertarlistaP(listapedido,ped);
        mostrarlistaP(listacliente);
        muestrapedidos(ped);
      end;
  end;
 
Procedure PedidosManualc(VAR listapedido:pPedido;listaCliente:pCliente;
                         VAR p:pedido);
VAR op:char;
 
BEGIN
      clrscr;
      mostrarlistaP(listacliente);
      Write('Introduzca NIF/CIF: ');
      readln(c.nif);
      clrscr;
      if not busquedabajac(listacliente,c)then
      begin
       Repeat
        begin
         Writeln('=============== PEDIDOS =================');
         Write('Numero de Pedido: ');
         p.npedido:=numeropedido(listapedido);
         Write(p.npedido);
         Write('CIF: ');
	 p.cifcliente:=c.nif;
         write(p.cifCliente);
         Write('Fecha: ');
         fechas2(p);
         Write(p.fecha);
         Write('Estado: ');
         p.estado:='P';
         Write(p.estado);
         guardarpedidos2(p);
         anadirPedido(listapedido,p);
         Writeln('Pulse [S] para continuar');
         readln(op);
        end;
      until (op='s');
   end
  else
    Writeln('El Cliente esta dado de Baja');
 
end;
 
Procedure ApuntarPL(VAR listapedido:pPedido;VAR listalinea:pLinea);
 
var punttemp:pPedido;
 
begin
 
  punttemp:=listapedido;
  punttemp^.lineas:=listalinea;
end;
 
{==================== LINEAS PEDIDOS ===================================}
 
Procedure busquedalinealL(listaLinea:pLinea; l:linea;
                         VAR encontrado:boolean;
                         VAR puntanterior,puntactual:pLinea);
begin
 puntactual:=listaLinea;
 puntanterior:=nil;
 encontrado:=false;
 While not encontrado and (puntactual<>nil) do
  Begin
   if puntactual^.infolinea.nlinea=l.nlinea then
    encontrado:=true
   else
    Begin
     puntanterior:=puntactual;
     puntactual:=puntactual^.sig;
    end;
  end;
end;
 
Procedure insertarlistal(VAR listaLinea:pLinea; l:Linea);
 
var
 puntanterior,puntactual,punttemp:pLinea;
 
begin
 
 new(punttemp);
 punttemp^.infoLinea:=L;
 punttemp^.sig:=nil;
 puntanterior:=nil;
 puntactual:=listaLinea;
 While puntactual<> nil do
  begin
   puntanterior:=puntactual;
   puntactual:=puntactual^.sig;
  end;
  if puntanterior=nil then
    listaLinea:=punttemp
  else
    puntanterior^.sig:=punttemp;
 
end;
{***************************************************************************}
Procedure mostrarlineasP(listaLinea:pLinea);
VAR
 op:char;
BEGIN
 clrscr;
 Repeat
 If listalinea=nil then
  begin
  Writeln('No hay nada que mostrar');
  end
 else
  While (listalinea<>nil) do
   begin
    Writeln;
    Writeln('Numero de Pedido: ',listalinea^.infolinea.numPedido);
    Writeln('Cantidad: ',listaLinea^.infoLinea.cantidad);
    Writeln('Precio por Unidad: ',listalinea^.infolinea.ppu);
    Writeln('Precio Total: ',listalinea^.infolinea.pt);
    Writeln;
    listaLinea:=listaLinea^.sig;
   end;
   Writeln('Pulsa [S] para continuar');
   op:=readkey;
 until (op='s');
end;
{***************************************************************************}
Procedure anhadirLinea(VAR listaLinea:pLinea;  l:Linea);
VAR
 pteroanterior,pterosiguiente:pLinea;
 encontrado:boolean;
BEGIN
 busquedalinealL(listalinea,l,encontrado,pteroanterior,pterosiguiente);
 If not encontrado then
  insertarlistaL(listaLinea,l)
 else
 
   Writeln('Ya existe un registro para: ',l.nlinea);
End;
{*************************************************************************}
Procedure pedidosManuall(p:pedido;VAR listalinea:pLinea;
                         VAR l:linea);
VAR
 op:char;
BEGIN
 
 Repeat
     clrscr;
     If listavaciaL(listalinea) then
       l.nlinea:=1
     else
       l.nlinea:=l.nlinea+1;
       Writeln('=================== LINEAS =============================');
       Writeln('Numero de Linea: ');
       writeln(l.nlinea);
       Writeln('Numero de Pedido: ');
       l.numpedido:=p.npedido;
       Writeln(l.numpedido);
       Write('Cantidad: ');
       readln(l.cantidad);
       Write('Importe de la Unidad: ');
       readln(l.ppu);
       Write('Importe total: ');
       l.pt:=(l.cantidad*l.ppu);
       writeln(l.pt:2);
     anhadirlinea(listalinea,l);
   Writeln('Desea continuar?[S/N]');
   readln(op);
 until (op='n');
END;
{*************************************************************************}
Procedure llamarPedido(VAR listacliente:pCliente;p:pedido;
                       VAR listaPedido:pPedido;l:linea;
                       VAR listaLinea:pLinea );
begin
          If not listavaciaC(listacliente) then
          begin
            pedidosmanualc(listapedido,listacliente,p);
            if not busquedabajaC(listacliente,c) then
              begin
                pedidosmanualL(p,listalinea,l);
                apuntarPL(listapedido,listalinea);
              end
          end
          else
            clrscr;
            Writeln('Introduzca primero Clientes');
End;
{*************************************************************************}
Procedure mostrarlistaP(listapedido:pPedido);
var
 op:char;
begin
 clrscr;
 Repeat
 If listapedido=nil then
   begin
     textcolor(yellow);
     Writeln('No hay nada que mostrar');
   end
 else
   While (listapedido<>nil) do
     begin
       Writeln;
       textcolor(black);
       Writeln('NIF/CIF: ',listapedido^.infopedido.cifcliente);
       Writeln('Numero de pedido: ',listapedido^.infopedido.npedido);
 
       Writeln;
       listapedido:=listapedido^.sig;
     end;
   textcolor(yellow);
   Writeln('Pulsa [S] para continuar');
   op:=readkey;
 until (op='s');
end;
 
{---------------------------------------CUOTAS------------------------------}
 
Procedure CrearListaVaciaCu(VAR listacuota:pCuota);
  begin
    listacuota:=nil;
  end;
 
Function listavaciaCuo(listacuota:pCuota):boolean;
  begin
    listavaciaCuo:=listacuota=nil;
  end;
 
Procedure insertarlistaCuo(VAR listaCuota:pcuota; Ct:Cuota);{al final de la lista}
 
var
  puntanterior,puntactual,punttemp:pCuota;
begin
  new(punttemp);
  punttemp^.infoCuota:=ct;
  punttemp^.sig:=nil;
  puntanterior:=nil;
  puntactual:=listaCuota;
 
  While puntactual<> nil do
    begin
      puntanterior:=puntactual;
      puntactual:=puntactual^.sig;
    end;
  If puntanterior=nil then
    listaCuota:=punttemp
  else
    puntanterior^.sig:=punttemp;
 
end;
 
Procedure crearcuotas(listacliente:pCliente;listaCuota:pCuota;listafactura:pFactura
                       ; ct:cuota);
var
  i:integer;
  encontrado:boolean;
  puntanterior,puntactual:pCliente;
begin
  ct.nfactura:=listaFactura^.infoFactura.nFactura;
  busquedalineal(listacliente,c,encontrado,puntanterior,puntactual);
 
  if (listacliente^.infoc.estado='c') then
    begin
      ct.importe:=listaFactura^.infoFactura.impfactura;
      insertarlistaCuo(listaCuota,Ct)
    end
  else
    if listacliente^.infoc.estado='t' then
      begin
        ct.importe:=listaFactura^.infoFactura.impfactura;
        insertarlistaCuo(listaCuota,Ct)
      end
    else
      if listacliente^.infoc.estado='s' then
        begin
          for i:=1 to 2 do
            begin
              ct.norden:=i;
              ct.importe:=((listafactura^.infofactura.impfactura * 50) div 100);
              insertarlistaCuo(listaCuota,Ct)
            end;
        end
      else
        if listacliente^.infoc.estado='n' then
          begin
            for i:=1 to 2 do
              begin
                ct.norden:=i;
                ct.importe:=((listafactura^.infofactura.impfactura*333) div 1000);
                insertarlistaCuo(listaCuota,Ct);
                listacuota:=listacuota^.sig;
              end;
          end;
end;


esta es la segunda parte (en la primera tuve un problemilla al poner

1
Reemplace este texto

sorry :)
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por Miguel (10 intervenciones) el 16/06/2011 20:56:31
[code]{-------------------------------FACTURAS---------------------------------}

Procedure CrearListaVaciaF(var listaFactura:pfactura);

begin
listaFactura:=nil;
end;

Function listavaciaF(listaFactura:pFactura):boolean;
begin
listavaciaF:=listaFactura=nil;
end;

Procedure CrearlistaVaciaLF(var listaLineaF:pLineaF);

begin
listalineaF:=nil;
end;

function listavaciaLF(listalineaF:pLineaF):boolean;

begin
listavaciaLF:=listalineaF=nil;
end;

Procedure fechaf(var f:factura);

var
year, month, day , wday:word;
cad1,cad2,cad3:string;

begin
getdate(year,month,day,wday);
str(day:2,cad1);
str(year:3,cad3);
str(month:2,cad2);
f.fecha:=cad3+'/'+cad2+'/'+cad1;
end;

Procedure busquedalinealF(listaFactura:pFactura; f:Factura;
var encontrado:boolean;
var puntanterior,puntactual:pFactura);
begin
puntactual:=listaFactura;
puntanterior:=nil;
encontrado:=false;
While not encontrado and (puntactual<>nil) do
begin
if puntactual^.infoFactura.nFactura=f.nFactura then
encontrado:=true
else
begin
puntanterior:=puntactual;
puntactual:=puntactual^.sig;
end;
end;
end;

Procedure mostrarFactura(listaFactura:pFactura;listalineaF:pLineaF);

var
op:char;
begin
clrscr;
Repeat
If listavaciaF(listafactura) then
Writeln('No hay nada que mostrar')
else
While not listavaciaF(listafactura) do
begin
clrscr;
Writeln;
Writeln('Numero de Factura: ',listaFactura^.infoFactura.nFactura);
Writeln('NIF/CIF: ',listaFactura^.infoFactura.cifCliente);
Writeln('Importe del Factura: ',listaFactura^.infoFactura.impFactura);
Write('Fecha: ',listafactura^.infoFactura.fecha);
Writeln;
listaFactura:=listafactura^.sig;
end;
Writeln('Presione [S] para continuar');
op:=readkey;
until (op='s');
end;

Procedure insertarlistaF(var listaFactura:pfactura; f:factura);

var
puntanterior,puntactual,punttemp:pfactura;
begin
new(punttemp);
punttemp^.infoFactura:=F;
punttemp^.sig:=nil;
puntanterior:=nil;
puntactual:=listaFactura;
While puntactual<> nil do
begin
puntanterior:=puntactual;
puntactual:=puntactual^.sig;
end;

If puntanterior=nil then
listaFactura:=punttemp
else
puntanterior^.sig:=punttemp;

end;

Procedure anhadirfactura(var listafactura:pfactura; f:factura);

var
puntanterior,puntsiguiente:pFactura;
encontrado:boolean;
begin
busquedalinealF(listafactura,f,encontrado,puntanterior,puntsiguiente);
If not encontrado then
insertarlistaf(listafactura,f)
else
begin
writeln('Ya existe un registro para: ', f.nfactura);
end;
end;

Function numerofactura(var listafactura:pFactura):integer;

begin
if listavaciaf(listafactura) then
numerofactura:=1
else numerofactura:= 1 + numerofactura(listafactura^.sig);
end;

Function busquedapendiente(listapedido:pPedido; var p:pedido):boolean;

var
encontrado:boolean;

begin
encontrado:=false;
While(listapedido<>nil) and not encontrado do
begin
If (listapedido^.infopedido.npedido=p.npedido) then
begin
if (listapedido^.infopedido.estado='P' ) then
begin
encontrado:=true;
listapedido^.infopedido.estado:='F';
end;
end;
listapedido:=listapedido^.sig;
end;
busquedapendiente:=encontrado;
end;

Procedure busquedaPedido(listapedido:pPedido;var p:Pedido;
var listafactura:pfactura);
begin
while not listavaciaP(listapedido) do
begin
If listapedido^.infopedido.npedido = p.npedido then
begin
listafactura^.infoFactura.cifcliente:=listapedido^.infopedido.cifcliente;
listaFactura^.infofactura.impfactura:=Listapedido^.infopedido.imppedido;
end;
listapedido:=listapedido^.sig;
end;
end;

Procedure FacturaManualC(var listafactura:pFactura;listaPedido:pPedido;
listacuota:pCuota;ct:cuota; var f:factura; p:pedido);
var
op:char;

begin
clrscr;
mostrarlistaP(listapedido);
clrscr;
writeln('Introduzca N§ de Pedido: ');
readln(p.npedido);
clrscr;
if busquedaPendiente(listapedido,p) then
begin
Repeat
begin
writeln('________________ Facturas _________________');
busquedapedido(listapedido,p,listafactura);
Writeln('Numero de Facturas: ');
f.nfactura:=numerofactura(listafactura);
Writeln(f.nfactura);
f.cifcliente:=listafactura^.infofactura.cifcliente;
writeln('CIF: ',listafactura^.infofactura.cifcliente);
writeln('Fecha: ');
fechaf(f);
write(f.fecha);
f.impfactura:=Listafactura^.infofactura.impfactura;
writeln('Importe total: ',Listafactura^.infofactura.impfactura);
anhadirFactura(listafactura,f);
listaPedido^.infoPedido.estado:='F';
writeln('Presione [S] para continuar');
readln(op);
end;
until (op='s');
end
else
Writeln('Pedido en estado de anulado o facturado');
crearcuotas(listacliente,listacuota,listafactura,ct);
end;

Procedure ApuntarFL(var listafactura:pfactura; var listalineaf:pLineaF);

var
punttemp:pfactura;

begin
punttemp:=listafactura;
punttemp^.lineaf:=listalineaf;
end;

{------------------LINEAS DE FACTURA----------------------}

Procedure busquedalinealLF(listaLineaF:pLineaF; lF:lineaF;
var encontrado:boolean;
var puntanterior,puntactual:pLineaF);
begin
puntactual:=listaLineaF;
puntanterior:=nil;
encontrado:=false;
While not encontrado and (puntactual<>nil) do
Begin
if puntactual^.infolineaF.nlineaF=lF.nlineaF then
encontrado:=true
else
begin
puntanterior:=puntactual;
puntactual:=puntactual^.sig;
end;
end;
end;

Procedure insertarlistalF(var listaLineaF:pLineaF; lF:LineaF);

var
puntanterior,puntactual,punttemp:pLineaF;

begin
new(punttemp);
punttemp^.infoLineaF:=LF;
punttemp^.sig:=nil;
puntanterior:=nil;
puntactual:=listaLineaF;
While puntactual<> nil do
begin
puntanterior:=puntactual;
puntactual:=puntactual^.sig;
end;
If puntanterior=nil then
listaLineaF:=punttemp
else
puntanterior^.sig:=punttemp;

end;

Procedure anhadirLineaF(var listaLineaF:pLineaF; lF:LineaF);

var
puntanterior,puntsiguiente:pLineaF;
encontrado:boolean;

begin
busquedalinealLF(listalineaF,lF,encontrado,puntanterior,puntsiguiente);
If not encontrado then
insertarlistaLF(listaLineaF,lF)
else
Writeln('Ya existe un registro para: ',lF.nlineaF);
end;

Procedure recorrerlistaLF(var listalineaF:plineaF;
var listalinea:plinea);
var
lf:lineaF;

begin
if not listavaciaLF(listalineaf) then
While (listalinea^.infolinea.nlinea=listalineaF^.infolineaF.nlineaf) do
begin
lf.nlineaF:=listalinea^.infolinea.nlinea;
lf.nfactura:=listalinea^.infolinea.numpedido;
lf.cantidad:=listalinea^.infolinea.cantidad;
lf.ipulf:=listalinea^.infolinea.ppu;
lf.itlf:=listalinea^.infolinea.pt;
anhadirlineaf(listalineaF,lf);{probar si fuciona}
listalinea:=listalinea^.sig;
listalineaF:=listalineaF^.sig;
end;
end;

{Procedure FacturaManualL(f:factura;VAR listalineaF:pLineaF;
var lF:lineaF; listalinea:pLinea;lp:Linea);
begin
clrscr;
If listavaciaLF(listalineaF) then
lF.nlineaF:=1
else
lF.nlineaF:=lF.nlineaF+1;
writeln('________________ LINEAS __________________');
writeln('Numero de Linea: ');
writeln(lF.nlineaF);
writeln('Numero de Pedido: ');
lF.nfactura:=f.nFactura;
writeln(lF.nFactura);
write('Cantidad: ');
LF.cantidad:=lp.cantidad;
Write(lF.cantidad);
Write('Importe de la Unidad: ');
lf.ipulf:=lp.ppu;
write(lF.ipulf);
write('Importe total: ');
lF.itlf:=(lF.cantidad*lF.ipulf);
writeln(lF.itlf:2);
anhadirlineaf(listalineaF,lF);

funcion importe total
recorrerlistaLF(listalineaF,listalinea);
end;}

Procedure llamarFactura(var listaPedido:pPedido;p:pedido;
var listaFactura:pFactura;lF:lineaF;
var listaLineaF:pLineaF; listalinea:pLinea;
var listacuota:pCuota;ct:cuota;lp:linea);
begin
If not listavaciaP(listapedido) then
begin
Facturamanualc(listaFactura,listaPedido,listacuota,ct,f,p);
if not busquedapendiente(listapedido,p) then
begin
recorrerlistaLF(listalineaF,listalinea);
apuntarFL(listaFactura,listalineaF);
end
end
else
clrscr;
writeln('Introduzca primero Pedidos');
end;

Procedure mostrarlistaf(listaFactura:pFactura);

VAR
op:char;

BEGIN
clrscr;
Repeat
If listaFactura=nil then
begin
Writeln('No hay nada que mostrar');
end
else
While (listaFactura<>nil) do
begin
Writeln;
Writeln('NIF/CIF: ',listaFactura^.infoFactura.cifcliente);
Writeln('Numero de pedido: ',listaFactura^.infoFactura.nFactura);
Writeln;
listaFactura:=listaFactura^.sig;
end;
Writeln('Presione [S] para continuar');
op:=readkey;
until (op='s');
end;

procedure guardarfacturas(f:factura);

var t:text;

begin
assign(t,'facturas.txt');
append(t);
writeln(t,f.nfactura);
writeln(t,f.cifcliente);
writeln(t,f.fecha);
writeln(t,f.impfactura);
close(t);
end;


Procedure FacturaManualD(var listafactura:pFactura;listaPedido:pPedido;
listacuota:pCuota;ct:cuota;var f:factura; p:pedido);
var
op:char;

begin
clrscr;
clrscr;
if busquedaPendiente(listapedido,p) then
begin
Writeln('___________ Facturas ____________');
busquedapedido(listapedido,p,listafactura);
Writeln('Numero de Facturas: ');
f.nfactura:=numerofactura(listafactura);
Writeln(f.nfactura);
f.cifcliente:=listafactura^.infofactura.cifcliente;
Writeln('CIF: ',listafactura^.infofactura.cifcliente);
Writeln('Fecha: ');
fechaf(f);
Write(f.fecha);
f.impfactura:=Listafactura^.infofactura.impfactura;
writeln('Importe total: ',Listafactura^.infofactura.impfactura);
Writeln('Estado:');
anhadirFactura(listafactura,f);
listaPedido^.infoPedido.estado:='F';
Writeln('Presione [S] para continuar');
readln(op);
end;

crearcuotas(listacliente,listacuota,listafactura,ct);
end;

Procedure FacturacionAutomatica (listaFactura:pFactura;listapedido:pPedido;
listacuota:pCuota;var ct:cuota;
var f:factura;var p:Pedido);
begin
If listavaciaP(listaPedido) then
Writeln('No hay datos')
else
While not listavaciaP(listaPedido) do
begin
If listapedido^.infopedido.estado='P' then
begin
FacturamanualD(listafactura,listapedido,listacuota,ct,f,p);
listaPedido:=listaPedido^.sig;
end
else
listapedido:=listapedido^.sig;
end;
end;

Procedure cargafacturas(var listafactura:pfactura;s:string);

var
f:text;
fact:factura;
begin
assign(f,s);
reset(f);
while not eof(f) do
begin
readln(f,fact.nfactura);
readln(f,fact.cifcliente);
readln(f,fact.impfactura);
readln(f,fact.fecha);
insertarlistaF(listafactura,fact);
mostrarlistaF(listafactura);
end;
end;

esta es la tercera parte del programa
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por Miguel (10 intervenciones) el 16/06/2011 20:57:57
begin
clrscr;
crealistavaciac(listacliente);
crearlistavaciaP(listapedido);
crearlistavaciaL(listalinea);
crearlistavaciaF(listafactura);
crearlistavacialf(listalineaf);
crearListaVaciaCu(listacuota);
s:='clientes.txt';
repeat
writeln('------------------MENé DEL PROGRAMA------------------- ');
writeln('OP 1: Dar de alta a un cliente ');
writeln('OP 2: Dar de baja a un cliente ');
writeln('OP 3: Dar de alta un pedido ');
writeln('OP 4: Anular un pedido realizado ');
writeln('OP 5: Facturar manualmente un pedido ');
writeln('OP 6: Facturar autom ticamente pedidos pendientes ');
writeln('OP 7: Cargar datos desde el disco ');
writeln('OP 8: Listados ');
writeln('OP 9: Crear archivo para guardar datos ');
writeln('OP 0: Salir del sistema ');
readln(opc);

if opc = 1 then
altascliente(listacliente,c);

if opc = 2 then
bajascliente(listacliente,c);

if opc = 3 then
llamarpedido(listacliente,p,listapedido,l,listalinea);

if opc = 4 then
AnularP(listapedido,p);

if opc = 5 then
llamarfactura(listapedido,p,listafactura,lf,listalineaf,listalinea,listacuota,ct,l);

if opc = 6 then
facturacionautomatica(listafactura,listapedido,listacuota,ct,f,p);

if opc = 7 then
begin
writeln('OP a: Cargar la lista de clientes ');
writeln('OP b: Cargar la lista de pedidos ');
writeln('OP c: Cargar la lista de facturas ');
readln(opc2);
if opc2 = 'a' then
begin
clrscr;
cargarclientes(listacliente);
end
else
if opc2 = 'b' then
begin
clrscr;
cargapedidos(listapedido);
end
else
if opc2 = 'c' then
begin
clrscr;
writeln('Esta opci¢n a£n no est  disponible...');
end;
end;

if opc = 8 then
begin
clrscr;
writeln('OP a: Listado de Clientes');
writeln('OP b: Listado de Pedidos ');
writeln('OP c: Listado de Facturas');
readln(opc3);
if opc3 = 'a' then
begin
clrscr;
mostrarlistac(listacliente);
end
else
if opc3 = 'b' then
begin
clrscr;
mostrarpedido(listapedido,listalinea);
end
else
if opc3 = 'c' then
begin
clrscr;
mostrarfactura(listafactura,listalineaf);
end;
end;
if opc = 9 then
begin
clrscr;
writeln('OP a: Crear archivo clientes');
writeln('OP b: Crear archivo pedidos ');
writeln('OP c: Crear archivo facturas');
readln(opc4);
if opc4 = 'a' then
begin
clrscr;
guardaclientes(c);
end
else
if opc4 = 'b' then
begin
clrscr;
guardarpedidos(p);
end
else
if opc4 = 'c' then
begin;
clrscr;
writeln('opci¢n no disponible por el momento...');
end;
end;
until (opc = 0);
end.

aqui esta la ultima (hay una parte del menu, la de guardar facturas que no esta incluida debido a que al no funcionar facturas decidi no incluirla por el momento, si ello condujese a error tambien podeis indicarlo) cualquier ayuda es bien recibida, muchisimas gracias.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por ramon (2072 intervenciones) el 16/06/2011 22:05:14
Examinare tu programa y intentare ver el el posible fallo .
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por ramon (2072 intervenciones) el 17/06/2011 00:14:07
El problema 1 que localizo en primera revisión es absorción de memoria del sistema con
unos cuantos datos metidos te quedaras sin memoria tienes que liberarla para poder volverla a usar
coloca la función que te dejo y comprueba lo que te comento ponlo después del repeat en el menú
como :

gotoxy(20,23);write(memori,´Kb´);

la función colócala antes del menú donde quieras.

function memori : longint;
begin
memori := MemAvail div 1000;
end;

se gire mirando mas por si acaso y te comentare.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por Miguel (10 intervenciones) el 17/06/2011 00:22:15
vale muchas gracias lo pruebo ahora haber que tal va, si consigo avanzar algo. Si encuentras algun fallo mas por favor dimelo
Gracias¡¡¡
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por Miguel (10 intervenciones) el 17/06/2011 00:27:09
una cosa, no me ha quedado claro que es el memavail, ya que el freepascal me dice que no esta declarado, que es exactamente "MemAvail"??

gracias!
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por ramon (2072 intervenciones) el 17/06/2011 13:16:25
es una funcion de pascal estandar que proporciona la memoria de todos los bloques
libres del heap
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por ramon (2072 intervenciones) el 17/06/2011 16:52:05
De todas formas me parece que free pascal si compilas con go32 v2 dos si que te acertara
esa función me parece que desapareció a partir de la versión 2 de free pascal
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por Miguel (10 intervenciones) el 18/06/2011 17:51:14
vale, muchas gracias, no me lo reconocia por mi free pascal que era el 2.2 xD si encuentras mas fallos por favor dimelo
gracias¡¡
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por ramon (2072 intervenciones) el 18/06/2011 23:05:56
{El guardado o recuperación de archivos esta mal pues se trata asín:

{Asin mal}
procedure guardarpedidos2(p : pedido);
var
f : text;
begin
assign(f,'pedidos.txt');
{$I-} append(f); {$I+}
writeln(f,p.npedido);
writeln(f,p.cifcliente);
writeln(f,p.fecha);
writeln(f,p.estado);
writeln;
close(f);
end;

{Para guardar registros}
procedure guardarpedidos2(p : pedido);
var
f : file of pedido;
begin
assign(f,'pedidos.txt'); { La extension es lo mismo vale cualquiera}
{$I-} reset(f); {$I+}
if ioresult <> 0 then
begin
rewrite(f);
seek(f,0); {Si no existe lo creamos}
write(f,p);
close(f);
end
else
begin
seek(f,filesize(f));
write(f,p); {Si esiste a¤adimos}
close(f);
end;
end;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

programa completo

Publicado por Miguel (10 intervenciones) el 19/06/2011 15:54:28
Muchas gracias, lo cierto es que esa forma no la conocia y la que mas habia visto era la anterior, muchas gracias¡¡
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar