1 REM Ins{nd av Erik Wetterberg <5948> 1987-01-21 Diskett 2 ! 10 ! LIST MEDLSKRV.BAS 11 ! -------------- MEDLSKRV --------------- 20 ! hantering av medlemregister 21 ! INFO i MEDLEM.INF 22 ! ---------------------------------------- 23 ! Rev 19870314.1848 B Sandgren <2776>: 24 ! CHAIN "NUL:" borttaget p} rad 2140 25 ! Skrivaren initieras p} rad 440 !! Kolla att det passar 26 ! Rev 19870627 Kristoffer Eriksson <5357>: 27 ! Rad 1970, 1980 {ndrade f|r tangentkoder p} alla ABC80x. 28 ! Rad 1855,1860 undviker BLK p} ABC800 som saknar den 29 ! Rad 2010 Del {ndrad till CTRL-D som i MEDLEM 30 ! Rad 34 f|r r{tt inladdning i BAS-form. (30 flyttad till 35) 32 ! ---------------------------------------- 34 INTEGER : EXTEND 35 COMMON Klubb$=4 40 DIM Medlpost$=136 : Medlpost$=CHR$(255,255,255)+SPACE$(133) 50 DIM Persnr1$=0,Persnr2$=0,Mnamn$=0,Coadr$=0,Adr$=0,Postnr$=0,Padr$=0,Tele$=0 60 Adr=VARPTR(Medlpost$) 70 POKE VAROOT(Persnr1$),6,0,Adr+5,SWAP%(Adr+5),6,0 80 POKE VAROOT(Persnr2$),4,0,Adr+11,SWAP%(Adr+11),4,0 90 POKE VAROOT(Mnamn$),30,0,Adr+15,SWAP%(Adr+15),30,0 100 POKE VAROOT(Coadr$),30,0,Adr+45,SWAP%(Adr+45),30,0 110 POKE VAROOT(Adr$),30,0,Adr+75,SWAP%(Adr+75),30,0 120 POKE VAROOT(Postnr$),5,0,Adr+105,SWAP%(Adr+105),5,0 130 POKE VAROOT(Padr$),16,0,Adr+110,SWAP%(Adr+110),16,0 140 POKE VAROOT(Tele$),10,0,Adr+126,SWAP%(Adr+126),10,0 150 DIM Mkodpost$=17,Mkod$=0,Datkod$=0 160 Adr=VARPTR(Mkodpost$) 170 POKE VAROOT(Mkod$),6,0,Adr+5,SWAP%(Adr+5),6,0 180 POKE VAROOT(Datkod$),6,0,Adr+11,SWAP%(Adr+11),6,0 190 DIM Koder$=160 200 True=(1=1) 210 PRINT CHR$(12) 220 Z=FNInittang 230 PRINT CUR(2,0) "MEDLEMREGISTER F\R " Klubb$; 240 IF NOT FNInitfile(Klubb$) THEN Z=FNErr("Inget s}dant register !!") : STOP 250 PRINT CUR(4,0) "ANGE KOD: "; 260 PRINT CUR(6,0) "ANGE FORMAT :"; 270 PRINT CUR(8,0) "SKRIVARE:"; 280 PRINT CUR(10,0) "RADER:"; 290 PRINT CUR(12,0) "RUBRIK:"; 300 PRINT CUR(14,0) "MARGINAL:"; 310 Selkod$=SPACE$(7) : Format$="L" : Skriv$="J" 320 Rubr$=Klubb$+SPACE$(46)+LEFT$(TIME$,10) : Vmarg=6 330 WHILE Kom$<>Esc$ 340 Fltnr=1 350 WHILE Fltnr<=6 360 Selkod$=FNTxtflt$(1,Selkod$,4,13) 370 WHILE NOT FNKodfinns(Selkod$) 380 Z=FNErr("Ingen s}dan kod i registret !!") 390 Selkod$=FNTxtflt$(0,Selkod$,4,13) 400 WEND 410 Format$=FNValflt$(2,Format$,"ETL",6,13) 420 IF Format$="E" THEN Radant=2 ELSE Radant=65 430 Skriv$=FNValflt$(3,Skriv$,"JN",8,13) 440 IF Skrivare THEN PREPARE "PR:VSA40A72.55A" AS FILE 9 450 IF Format$="E" THEN Radant=FNTalflt(4,Radant,10,13,1,10) 460 IF Format$<>"E" THEN Radant=FNTalflt(4,Radant,10,13,5,68) 470 Rubr$=FNTxtflt$(5,Rubr$,12,13) 480 Vmarg=FNTalflt(6,Vmarg,14,13,0,20) 490 WEND 500 Rad=0 : Sid=1 510 IF Skriv$="J" THEN PREPARE "PR:VSA40A72.55A" AS FILE 9 520 Eof=NOT True 530 Z=FNMsg("Tryck vad som helst f|r pause") 540 Z=FNFirst(Selkod$) 550 WHILE NOT Eof 560 IF NOT FNPause THEN GOTO 630 570 IF Format$="T" THEN Koder$=FNKodstr$(CVT$%(MID$(Medlpost$,4,2))) 580 PRINT CUR(16,0) SPACE$(320) CUR(16,0); 590 Z=FNSkriv(Format$,0) 600 IF Skriv$="J" THEN Z=FNSkriv(Format$,9) 610 Z=FNNext(Selkod$) 620 WEND 630 Z=FNMsg("Tryck Esc f|r }ter, Return f|r ny utskrift") 640 GET Kom$ 650 WEND 660 CLOSE 670 CHAIN "MEDLEM" 680 ! ------------------------------ 690 DEF FNInitfile(In$) LOCAL Fil$=12 700 ON ERROR GOTO 770 710 Fil$=FNNoblank$(In$+"medl.ism") 720 ISAM OPEN Fil$ AS FILE 1 730 Fil$=FNNoblank$(In$+"mkod.ism") 740 ISAM OPEN Fil$ AS FILE 2 750 RETURN True 760 RETURN NOT True 770 RESUME 760 780 FNEND 790 ! -------------- 800 DEF FNKodfinns(In$) LOCAL T$=6 810 IF In$=SPACE$(LEN(In$)) THEN RETURN True 820 IF LEFT$(In$,1)="-" THEN T$=RIGHT$(In$,2) ELSE T$=LEFT$(In$,6) 830 ON ERROR GOTO 860 840 ISAM READ #2,Mkodpost$ INDEX "MKOD" KEY T$ 850 RETURN True 860 RESUME 870 870 RETURN NOT True 880 FNEND 890 ! ---------------------------- 900 DEF FNKodkoll(Nr$,In$) LOCAL T$=6,T 910 IF LEFT$(In$,1)="-" THEN T$=RIGHT$(In$,2) : T=NOT True ELSE T$=LEFT$(In$,6) : T=True 920 ON ERROR GOTO 950 930 ISAM READ #2,Mkodpost$ INDEX "MNRKOD" KEY Nr$+T$ 940 RETURN T 950 RESUME 960 960 RETURN NOT T 970 FNEND 980 ! -------------------- 990 DEF FNFirst(In$) 1000 ON ERROR GOTO 1070 1010 ISAM READ #1,Medlpost$ FIRST 1020 IF In$=SPACE$(LEN(In$)) THEN RETURN 0 1030 WHILE NOT FNKodkoll(MID$(Medlpost$,4,2),In$) 1040 ISAM READ #1,Medlpost$ NEXT 1050 WEND 1060 RETURN 0 1070 PRINT "FNFirst errcode: " ERRCODE : STOP 1080 FNEND 1090 ! ---------------------------- 1100 DEF FNNext(In$) 1110 ON ERROR GOTO 1180 1120 ISAM READ #1,Medlpost$ NEXT 1130 IF In$=SPACE$(LEN(In$)) THEN RETURN 0 1140 WHILE NOT FNKodkoll(MID$(Medlpost$,4,2),In$) 1150 ISAM READ #1,Medlpost$ NEXT 1160 WEND 1170 RETURN 0 1180 IF ERRCODE=34 THEN Eof=True : RESUME 1170 1190 PRINT "FNNext error: " ERRCODE : STOP 1200 FNEND 1210 ! ---------------------------- 1220 DEF FNSkriv(Inform$,Inskr) 1230 IF Inform$="E" THEN RETURN FNEtik(Inskr) 1240 IF Rad=0 AND Inskr<>0 THEN PRINT #Inskr,SPACE$(Vmarg)+Rubr$+" SIDA:" Sid : PRINT #Inskr,"" 1250 PRINT #Inskr,SPACE$(Vmarg)+Mnamn$; 1260 IF Coadr$=SPACE$(30) THEN PRINT #Inskr,Adr$ Tele$ ELSE PRINT #Inskr,Coadr$ Tele$ 1270 PRINT #Inskr,SPACE$(Vmarg)+Persnr1$; 1280 IF Persnr2$<>SPACE$(4) THEN PRINT #Inskr,"-"+Persnr2$+SPACE$(19); ELSE PRINT #Inskr,SPACE$(24); 1290 IF Coadr$<>SPACE$(30) THEN PRINT #Inskr,Adr$ : PRINT #Inskr,SPACE$(30+Vmarg); 1300 PRINT #Inskr,LEFT$(Postnr$,3) " " RIGHT$(Postnr$,4) " " Padr$ 1310 IF Inform$="T" THEN PRINT #Inskr,SPACE$(Vmarg)+Koder$ 1320 PRINT #Inskr,"" 1330 IF Inskr=0 THEN RETURN 0 1340 IF Inform$="T" THEN Rad=Rad+4 ELSE Rad=Rad+3 1350 IF Rad+3SPACE$(6) THEN Str$=Str$+" "+FNStrip$(Datkod$) 1560 Str$=Str$+" / " 1570 ISAM READ #2,Mkodpost$ NEXT 1580 WEND 1590 IF LEN(Str$)=0 THEN RETURN "" ELSE RETURN LEFT$(Str$,LEN(Str$)-2) 1600 IF ERRCODE=34 OR ERRCODE=120 THEN RESUME 1590 1610 PRINT "FNKodstr error:" ERRCODE : STOP 1620 FNEND 1630 ! ------------------------------ 1640 DEF FNPause LOCAL T$=1 1650 IF SYS(5)=0 RETURN True 1660 WHILE SYS(5)<>0 1670 GET T$ 1680 WEND 1690 Z=FNMsg("Tryck Esc f|r avbryt Return f|r forts{tt") 1700 WHILE T$<>Esc$ AND T$<>Ret$ 1710 GET T$ 1720 WEND 1730 Z=FNMsg("Tryck vad som helst f|r pause") 1740 RETURN T$<>Esc$ 1750 FNEND 1760 ! ------------------------------ 1770 ! 1780 DEF FNErr(In$) LOCAL Rad,Kol 1790 PRINT CHR$(7); 1800 RETURN FNMsg(In$) 1810 FNEND 1820 ! 1830 DEF FNMsg(In$) LOCAL Rad,Kol 1840 IF LEN(In$)>48 THEN RETURN FNMsg(LEFT$(In$,48)) 1850 Rad=PEEK(65363) : Kol=PEEK(65362) 1855 PRINT CUR(0,30); : IF PEEK(39)<>10 THEN PRINT WHT NWBG Blk; 1860 PRINT In$ SPACE$(48-LEN(In$)) BLBG WHT CUR(Rad,Kol); 1870 RETURN 0 1880 FNEND 1890 ! 1900 DEF FNInittang 1910 DIM Rad25$=0 : POKE VAROOT(Rad25$),0,80,32640,SWAP%(32640),0,80 1920 DIM Esc$=1,Ret$=1,Del$=1,Linedel$=1,Fram$=1,Back$=1,Sfram$=1,Sback$=1 1930 DIM Upp$=1,Quit$=1 1940 DIM Pf$(1:14)=1 1950 Pf$(1)=CHR$(192) : Pf$(2)=CHR$(193) : Pf$(3)=CHR$(194) : Pf$(4)=CHR$(195) 1960 Pf$(5)=CHR$(196) : Pf$(6)=CHR$(197) : Pf$(7)=CHR$(198) : Pf$(8)=CHR$(199) 1970 IF PEEK(39)<>3 AND PEEK(39)<>4 AND PEEK(39)<>10 THEN GOTO 2050 1980 ! ----- tangentkoder ABC 80x ---------------- 1990 OUT 56,6,57,25 2000 Esc$=CHR$(198) : Ret$=CHR$(13) 2010 Del$=CHR$(4) : Linedel$=CHR$(24) 2020 Fram$=CHR$(9) : Back$=CHR$(8) 2030 Upp$=CHR$(21) : Quit$=CHR$(17) 2040 RETURN 0 2050 IF PEEK(39)<>6 THEN GOTO 2130 2060 ! ----- tangentkoder Facit DTC 2 ------------ 2070 Esc$=CHR$(27) : Ret$=CHR$(13) 2080 Del$=CHR$(8) : Linedel$=CHR$(24) 2090 Fram$=CHR$(163) : Back$=CHR$(162) 2100 Sback$=CHR$(178) : Sfram$=CHR$(179) 2110 Upp$=CHR$(160) : Quit$=CHR$(10) 2120 RETURN 0 2130 PRINT CHR$(12)+"Programmet ej anpassat f|r denna dator"+CHR$(7) 2140 RETURN 0 ! CHAIN "NUL:" 2150 FNEND 2160 ! ------------------------------------------------ 2170 DEF FNNoblank$(In$) LOCAL Pos 2180 Pos=INSTR(1,In$," ") 2190 IF Pos=0 RETURN In$ 2200 RETURN LEFT$(In$,Pos-1)+FNNoblank$(RIGHT$(In$,Pos+1)) 2210 FNEND 2220 ! ------------------------------------------------ 2230 DEF FNStrip$(In$) LOCAL Pos 2240 IF In$=SPACE$(LEN(In$)) THEN RETURN "" 2250 Pos=LEN(In$) 2260 WHILE Pos>0 AND MID$(In$,Pos,1)=" " 2270 Pos=Pos-1 2280 WEND 2290 RETURN LEFT$(In$,Pos) 2300 FNEND 2310 DEF FNValflt$(Innr,In$,Inalt$,Inrad,Inkol) LOCAL Lch$=1,Lsv$=1 2320 IF Innr<>Fltnr AND Innr<>0 THEN RETURN In$ 2330 Lsv$=In$ 2340 WHILE True 2350 PRINT CUR(Inrad,Inkol) Lsv$; 2360 PRINT CUR(Inrad,Inkol); 2370 GET Lch$ 2380 IF Lch$=Ret$ THEN Fltnr=Fltnr+1 : RETURN Lsv$ 2390 IF Lch$=Upp$ THEN Fltnr=Fltnr-1 : RETURN Lsv$ 2400 IF Lch$=Quit$ THEN Fltnr=99 : RETURN Lsv$ 2410 IF Lch$>CHR$(95) THEN Lch$=CHR$(ASCII(Lch$) AND NOT 32) 2420 IF INSTR(1,Inalt$,Lch$)=0 THEN Z=FNErr("Ange n}got av "+Inalt$+" !") ELSE Lsv$=Lch$ 2430 WEND 2440 FNEND 2450 ! --------------------------------- 2460 DEF FNTxtflt$(Innr,In$,Inrad,Inkol) LOCAL Lch$=1,Lnr,Ltxt$=80 2470 ! inl{sning av en textstr{ng 2480 IF Innr<>Fltnr AND Innr<>0 THEN RETURN In$ 2490 Ltxt$=SPACE$(80) 2500 MID$(Ltxt$,1,LEN(In$))=In$ 2510 Lnr=1 2520 PRINT CUR(Inrad,Inkol) MID$(Ltxt$,1,LEN(In$)); 2530 PRINT CUR(Inrad,Inkol+Lnr-1); 2540 GET Lch$ 2550 IF Lch$=Ret$ THEN Fltnr=Fltnr+1 : RETURN MID$(Ltxt$,1,LEN(In$)) 2560 IF Lch$=Upp$ THEN Fltnr=Fltnr-1 : RETURN MID$(Ltxt$,1,LEN(In$)) 2570 IF Lch$=Quit$ THEN Fltnr=99 : RETURN MID$(Ltxt$,1,LEN(In$)) 2580 IF Lch$=Del$ AND Lnr>1 THEN MID$(Ltxt$,Lnr-1,81-Lnr)=RIGHT$(Ltxt$,Lnr) : Lnr=Lnr-1 : GOTO 2520 2590 IF Lch$=Linedel$ THEN MID$(Ltxt$,1,LEN(In$))=SPACE$(LEN(In$)) : Lnr=1 : GOTO 2520 2600 IF Lch$=Back$ AND Lnr>1 THEN Lnr=Lnr-1 : GOTO 2530 2610 IF Lch$=Fram$ AND Lnr126 THEN PRINT CHR$(7); : GOTO 2540 2630 IF Lnr>LEN(In$) THEN PRINT CHR$(7); : GOTO 2540 2640 IF Lch$>CHR$(95) THEN Lch$=CHR$(ASCII(Lch$) AND NOT 32) 2650 PRINT Lch$; : MID$(Ltxt$,Lnr,1)=Lch$ 2660 Lnr=Lnr+1 : GOTO 2540 2670 FNEND 2680 ! 2690 DEF FNTalflt(Innr,In,Inrad,Inkol,Inmin,Inmax) LOCAL Ltxt$=5,Llen,Ltal 2700 ! inl{sning av ett heltal 2710 ON ERROR GOTO 2790 2720 Llen=LEN(NUM$(Inmax)) 2730 IF LEN(NUM$(Inmin))>Llen THEN Llen=LEN(NUM$(Inmin)) 2740 Ltxt$=FNTxtflt$(Innr,NUM$(In)+SPACE$(Llen-LEN(NUM$(In))),Inrad,Inkol) 2750 IF Ltxt$=SPACE$(Llen) THEN Ltal=0 ELSE Ltal=VAL(Ltxt$) 2760 IF Ltal>Inmax OR Ltal