DP Tool Club 17/CD_ASCQ_17_101194.iso/dos/fr/gesdoc16/v1archcr.prg

Text File | 1992-11-11 | 8KB | 436 lines

set score off
set color to
set date french
set confirm on
set key 28 to v1help
set key -1 to retourmenu
clear
set cursor on
do while .t.
public vtitre,vpub,vnumero,vdate,vpage,vsigne,vgr1,vgr2,vgr3,vmat1,vmat2,vmat3,vmotcle,hvar,memovar
hvar="cre01"
vmemo=0
vnumero=0
vtitre=space(75)
vpub=space(35)
vdate=ctod("../../..")
vpage=space(4)
vsigne=space(25)
vmat1=space(50)
vmat2=space(50)
vmat3=space(50)
vmotcle=space(25)
varquitte=0
set color to w/b+
@ 0,0 clear to 3,79
@ 1,3 say "F1"
@ 2,3 say "Aide"
@ 1,15 say "F2"
@ 2,15 say "Accès Menu"
@ 3,1 to 3,78
set color to n/w
@ 4,0 clear to 24,79
@ 4,0 to 24,79
@ 5,30 say "Référence :"
@ 5,44 say "....."
@ 7,05 say "Titre de l'article :"
@ 8,02 say ".........................................................................."
@ 10,05 say "Publication"
@ 11,05 say "................................."
@ 10,40 say "Numéro :"
@ 11,40 say "....."
@ 10,60 say "Date :"
@ 11,60 say "../../.."
@ 13,40 say "Page :"
@ 14,40 say "...."
@ 13,05 say "Signature :"
@ 14,05 say "...................."
@ 16,34 say "Matière 1 :"
@ 17,15 say ".................................................."
@ 18,34 say "Matière 2"
@ 19,15 say ".................................................."
@ 20,34 say "Matière 3"
@ 21,15 say ".................................................."
do while .t.
set color to b+/w,w/n
do while .t.
@ 8,02 get vtitre picture "@!"
read
if varquitte=1
set color to
clear
return
endif
controlvar=alltrim(vtitre)
if len(controlvar)=0
do controle
loop
endif
exit
enddo
@ 8,02 say vtitre
do v1pub1
set color to b+/w,w/n
if lastkey()<>27
vpub=vpub1
endif
if len(alltrim(vpub))=0
do while .t.
@ 11,05 get vpub  picture "@!"
read
if varquitte=1
set color to
clear
return
endif
controlvar=alltrim(vpub)
if len(controlvar)=0
do controle
loop
endif
do ajoutpub
exit
enddo
endif
@ 11,05 say vpub
do while .t.
@ 11,40 get vnumero  picture "99999"
read
if varquitte=1
set color to
clear
return
endif
controlvar=alltrim(vpub)
if len(controlvar)=0
do controle
loop
endif
exit
enddo
@ 11,40 say vnumero
refpub=substr(vpub,1,3)
num=strzero(vnumero,5)
use v1articl
num2=lastrec()+1
use
num1=strzero(num2,4)
vref=refpub+num+num1
@ 5,44 say vref
do while .t.
@ 11,60 get vdate
read
if varquitte=1
set color to
clear
return
endif
controlvar=dtoc(vdate)
if controlvar="  /  /  "
do controle
loop
endif
exit
enddo
@ 11,60 say vdate
@ 14,05 get vsigne picture "@!"
read
if varquitte=1
set color to
clear
return
endif
@ 14,05 say vsigne
do while .T.
@ 14,40 get vpage picture "@!"
read
if varquitte=1
set color to
clear
return
endif
controlvar=alltrim(vpage)
if len(controlvar)=0
do controle
loop
endif
exit
enddo
@ 14,40 say vpage
varmat=1
do v1mat
if lastkey()<>27
vmat1=vmat
endif
if len(alltrim(vmat1))=0
do while .t.
@ 17,15 get vmat1
read
vmat1=upper(vmat1)
if varquitte=1
set color to
clear
return
endif
controlvar=alltrim(vmat1)
if len(controlvar)=0
do controle
loop
endif
do matiere
exit
enddo
endif
set color to b+/w,w/n
@ 17,15 say vmat1
varmat=2
do v1mat
if lastkey()<>27
vmat2=vmat
endif
if len(alltrim(vmat2))=0
@ 19,15 get vmat2
read
vmat2=upper(vmat2)
if varquitte=1
set color to
clear
return
endif
endif
if len(alltrim(vmat2))<>0
do matiere
endif
set color to b+/w,w/n
@ 19,15 say vmat2
varmat=3
do v1mat
if lastkey()<>27
vmat3=vmat
endif
if len(alltrim(vmat3))=0
@ 21,15 get vmat3
read
vmat3=upper(vmat3)
if varquitte=1
set color to
clear
return
endif
endif
if len(alltrim(vmat3))<>0
do matiere
endif
set color to b+/w,w/n
@ 21,15 say vmat3
set color to W/B+,n/w
rep=space(1)
@ 0,0 clear to 3,79
@ 1,10 to 3,70
@ 2,18 say "LA SAISIE DE CETTE FICHE EST-ELLE CORRECTE ? (O/N)"get rep picture "@!"
read
if upper(rep)="N"
loop
endif
if upper(rep)="O"
rep1=space(1)
set color to W/B+,n/w
@ 0,0 clear to 3,79
@ 1,10 to 3,74
@ 2,12 say "VOULEZ VOUS ASSOCIER UN COMMENTAIRE A CETTE FICHE ? (0/N)"get rep1 picture "@!"
read
if upper(rep1)="O"
do commentaire
endif
set color to W/B+,n/w
@ 0,0 clear to 3,79
@ 1,10 to 3,70
@ 2,18 say "CONTROLE DES DOUBLONS, PATIENTER SVP..."
do doublons
exit
endif
if varquitte=1
exit
endif
enddo
if varquitte=1
exit
endif
enddo



procedure v1help
set key 28 to
do v1aide
set color to n/w,w/n
set key 28 to v1help
return

procedure retourmenu
set key -1 to
varquitte=1
set color to
set confirm off
clear
set key -1 to retourmenu
return

* ---------------------
* contrôle des doublons
procedure doublons
* ---------------------
do while .t.
use v1articl
go top
locate for titre==vtitre
        if .not. found()
        append blank
        replace titre with vtitre,publicatio with vpub,num_pub with vnumero
        replace signature with vsigne,page with val(vpage),date with vdate
        replace mat1 with vmat1
        if len(alltrim(vmat2))<>0
        replace mat2 with vmat2
        endif
        if len(alltrim(vmat3))<>0
        replace mat3 with vmat3
        endif
        replace reference with vref
        if vmemo=1
        replace commentair with memovar
        endif
else
set color to W/B+,n/w
        @ 0,0 clear to 3,79
        @ 2,10 say "LA FICHE CI DESSOUS CORRESPOND A LA SAISIE...Appuyer sur une touche"
        set color to n/w
        @ 4,0 clear to 24,79
        @ 4,0 to 24,79
        @ 5,30 say "Référence :"
        @ 5,44 say reference
        @ 7,05 say "Titre de l'article :"
        @ 8,02 say titre
        @ 10,05 say "Publication"
        @ 11,05 say publicatio
        @ 10,60 say "Date :"
        @ 11,60 say dtoc(date)
        @ 13,40 say "Page :"
        @ 14,40 say page
        @ 13,05 say "Signature :"
        @ 14,05 say signature
        @ 16,34 say "Matière 1 :"
        @ 17,15 say mat1
        @ 18,34 say "Matière 2"
        @ 19,15 say mat2
        @ 20,34 say "Matière 3"
        @ 21,15 say mat3
INKEY(0)
rep1=space(1)
set color to W/B+,n/w
@ 0,0 clear to 3,79
@ 2,10 say "VOULEZ VOUS MALGRE TOUT ENREGISTRER VOTRE SAISIE...? 0/N" get rep1 picture "@!"
read
if upper(rep1)="O"
        append blank
        replace titre with vtitre,publicatio with vpub,num_pub with vnumero
        replace signature with vsigne,page with val(vpage),date with vdate
        replace mat1 with vmat1
        if len(alltrim(vmat2))<>0
        replace mat2 with vmat2
        endif
        if len(alltrim(vmat3))<>0
        replace mat3 with vmat3
        endif
        replace reference with vref
        if vmemo=1
        replace commentair with memovar
        endif
endif
endif
exit
enddo
use
return


* saisie d'un commentaire dans un champs mémo
* -------------------------------------------
procedure commentaire
ecran3=savescreen(1,1,24,79)
select a
use v1articl
go bottom
set color to W/B+
@ 6,6 to 21,76
@ 5,10 say "ARTICLE : "+substr(alltrim(vtitre),1,60)
@ 21,50 say "F10 pour finir la saisie"
memovar=memoedit(commentair,7,7,20,75,.t.,"finmemo1")
set color to
restscreen(1,1,24,79,ecran3)
use
return

procedure finmemo1
if lastkey()=-9
keyboard chr(23)
vmemo=1
endif
return



* contrôle de la saisie
* ---------------------
procedure controle
controlscreen=savescreen(0,0,3,79)
set color to w/r
@ 0,0 clear to 3,79
@ 1,10 say "VOUS DEVEZ SAISIR QUELQUE CHOSE DANS CETTE ZONE..."
@ 3,50 say "Presser sur une touche..."
inkey(0)
set color to b+/w,w/n
restscreen(0,0,3,79,controlscreen)
return

* mise à jour de la table des matières
* ------------------------------------
procedure matiere
if varmat=1
matier=vmat1
endif
if varmat=2
matier=vmat2
endif
if varmat=3
matier=vmat3
endif
select b
set softseek off
use v1matier index v1matmat
reindex
seek upper(matier)
if .not. found()
append blank
replace matiere with upper(matier)
reindex
use
endif
return


* mise a jour de la table des publications
* ----------------------------------------
procedure ajoutpub
set softseek off
use v1public index v1pubnom
reindex
seek upper(vpub)
if .not. found()
append blank
replace nom with upper(vpub)
reindex
use
endif
return