|
|
ありがとうございます。
訂正させていただきました。
確認お願いします。
DECLARE EXTERNAL SUB sort
DECLARE NUMERIC MX,IDmin,IDmax,lenID,lenname,lentel,dmx,f,n,id,li,sa,sr,i,j,j2
DECLARE STRING idrange$,u$,s$,name$,tel$,d$,c$,sa$,t$,f$,n$,id$,sa2$,li$
OPTION CHARACTER KANJI
LET MX=200 ! data数の上限(変更可)
LET IDmin=1001 ! ID番号の下限(変更可) IDmin>=1
LET IDmax=9999 ! ID番号の上限(変更可)
LET lenID=CEIL(LOG10(IDmax))+1
LET lenNAME=8 ! 氏名の最大文字数(変更可)
LET lenTEL=14 ! 電話番号の最大文字数(変更可)
DIM DT$(MX,3),DTid(MX),DTtel$(MX),sortID(MX)
LET idrange$=STR$(IDmin)&"～"&STR$(IDmax)
LET u$=REPEAT$("#",lenID)&" <"&REPEAT$("#",2*lenNAME-1)&" <"&REPEAT$("#",lenTEL)
SET ECHO "OFF"
LET dmx=0
!
WHEN EXCEPTION IN
DO
INPUT PROMPT "【ファイル】1.新規作成 2.読込み (終了は 0)":f$
LET f=VAL(f$)
LOOP UNTIL f=INT(f) AND f>=0 AND f<=2
USE
LET f=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF f=1 THEN
CALL main(1)
ELSEIF f=2 THEN
FILE GETOPENNAME s$ ! 電話帳ファイルの読込み
OPEN #1: NAME s$
DO
LET dmx=dmx+1
INPUT #1, IF MISSING THEN EXIT DO: DT$(dmx,1),DT$(dmx,2),DT$(dmx,3)
LET DTid(dmx)=VAL(DT$(dmx,1))
CALL tel(DTtel$(dmx),DT$(dmx,3))
LOOP
LET dmx=dmx-1
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
ELSE
STOP
END IF
!
WHEN EXCEPTION IN
DO ! メインルーチン
DO
INPUT PROMPT " 1.入力 2.削除 3.更新 4.検索 5.一覧 6.保存 0.終了" :n$
LET n=VAL(n$)
LOOP UNTIL n=INT(n) AND n>=0 AND n<=6
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
CALL main(n)
LOOP UNTIL n=0
USE
LET n=0
CONTINUE
END WHEN
!
SUB main(n)
SELECT CASE n
CASE 1 ! [入力]
DO
IF dmx>=MX THEN
WAIT DELAY "DATA数が上限 "&STR$(MX)&" に達していて、入力が出来ません"
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
WHEN EXCEPTION IN
DO
LET check=0
DO
INPUT PROMPT " ID番号入力 "&idrange$&" (入力終了は 0)" :id$
LET id=VAL(id$)
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET c$="ID番号 "&id$&" は既に使われています。"&CHR$(10)
LET c$=c$&"他の番号にするか、[削除]または[更新]を利用してください。"
WAIT DELAY c$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
LET check=1
EXIT FOR
END IF
NEXT i
LOOP UNTIL check=0
USE
LET id=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF id=0 THEN EXIT DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF name$="0" OR name$="" THEN EXIT DO
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF tel$="0" OR tel$="" THEN EXIT DO
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET dmx=dmx+1
LET DT$(dmx,1)=STR$(id)
LET DT$(dmx,2)=name$
LET DT$(dmx,3)=tel$
LET DTid(dmx)=id
CALL tel(DTtel$(dmx),DT$(dmx,3))
END IF
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
LOOP
CASE 2 ! [削除]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 削除するDATAのID番号を入力 (キャンセルは 0)" :id$
LET id=VAL(id$)
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
USE
LET id=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを削除しますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="YES" THEN
PRINT "削除したDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
FOR j=i+1 TO dmx
LET DT$(j-1,1)=DT$(j,1)
LET DT$(j-1,2)=DT$(j,2)
LET DT$(j-1,3)=DT$(j,3)
LET DTid(j-1)=VAL(DT$(j,1))
LET DTtel$(j-1)=DTtel$(j)
NEXT j
LET DT$(dmx,1),DT$(dmx,2),DT$(dmx,3),DTtel$(dmx)=""
LET DTid(dmx)=0
LET dmx=dmx-1
END IF
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 3 ! [更新]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 更新するDATAのID番号を入力 (キャンセルは 0)" :id$
LET id=VAL(id$)
LOOP UNTIL id=INT(id) AND id>=IDmin AND id<=IDmax OR id=0
USE
LET id=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF id=0 THEN EXIT SUB
FOR i=1 TO dmx
IF DTid(i)=id THEN
LET d$="下記のDATAを書き換えますか？"&CHR$(10)&"ID："&DT$(i,1)
LET d$=d$&CHR$(10)&"氏名："&DT$(i,2)&CHR$(10)&"電話番号："&DT$(i,3)
IF CONFIRM$(d$)="NO" THEN EXIT SUB
PRINT "更新前のDATA"
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
DO
INPUT PROMPT " 氏名を入力 (入力終了は 0)" :name$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF name$="0" OR name$="" THEN EXIT SUB
INPUT PROMPT " 電話番号を入力 (入力終了は 0)" :tel$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF tel$="0" OR tel$="" THEN EXIT SUB
LET c$="このDATAで良いですか？ 訂正は [いいえ]"&CHR$(10)&"ID："
LET c$=c$&STR$(id)&CHR$(10)&"氏名："&name$&CHR$(10)&"電話番号："&tel$
IF CONFIRM$(c$)="YES" THEN
LET DT$(i,2)=name$
LET DT$(i,3)=tel$
CALL tel(DTtel$(i),DT$(i,3))
EXIT DO
END IF
LOOP
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
NEXT i
WAIT DELAY "ID番号 "&STR$(id)&" のDATAが見つかりません"
CASE 4 ! [検索]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 検索項目 1.氏名 2.電話番号 (キャンセルは 0)": sa2$
LET sa=VAL(sa2$)
LOOP UNTIL sa=INT(sa) AND sa>=0 AND sa<=2
USE
LET sa=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF sa=0 THEN EXIT SUB
INPUT PROMPT " 検索文字列 (一部分でも可, キャンセルは 0)": sa$
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF sa$="0" OR sa$="" THEN EXIT SUB
IF sa=1 THEN LET t$="氏名" ELSE LET t$="電話番号"
PRINT "検索結果 [";t$;",""";sa$;"""]"
LET sr=0
IF sa=1 THEN
FOR i=1 TO dmx
IF POS(DT$(i,2),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
ELSE ! sa=2
FOR j=LEN(sa$) TO 1 STEP -1
IF sa$(j:j)<"0" OR sa$(j:j)>"9" THEN LET sa$(j:j)=""
NEXT j
FOR i=1 TO dmx
IF POS(DTtel$(i),sa$)>0 THEN
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
LET sr=sr+1
END IF
NEXT i
END IF
IF sr=0 THEN PRINT "該当するDATAはありませんでした"
CASE 5 ! [一覧]
WHEN EXCEPTION IN
DO
INPUT PROMPT " 1.DATA順 2.ID番号順 (キャンセルは 0)" : li$
LET li=VAL(li$)
LOOP UNTIL li=INT(li) AND li>=0 AND li<=2
USE
LET li=0
CONTINUE
END WHEN
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF li=1 THEN
PRINT "DATA一覧"
FOR i=1 TO dmx
PRINT USING u$: DT$(i,1),DT$(i,2),DT$(i,3)
NEXT i
ELSEIF li=2 THEN
MAT sortID=ZER
CALL sort(DTid,sortID,dmx)
PRINT "DATA一覧 (ID番号順)"
FOR i=1 TO dmx
PRINT USING u$: DT$(sortID(i),1),DT$(sortID(i),2),DT$(sortID(i),3)
NEXT i
END IF
CASE 6 ! [保存]
CALL save
CASE 0 ! [終了]
IF CONFIRM$("プログラムを終了しますか？")="NO" THEN
LET n=7
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
EXIT SUB
END IF
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
IF CONFIRM$("DATAをファイルに保存しますか？")="YES" THEN CALL save
CLOSE #1
END SELECT
DO
LOOP UNTIL GetKeyState(1)>=0 AND GetKeyState(13)>=0
END SUB
!
SUB save
IF f=1 THEN
FILE GETSAVENAME s$
OPEN #1: NAME s$
LET f=f+10
END IF
ERASE #1
FOR i=1 TO dmx
IF DTid(i)<>0 THEN PRINT#1: DT$(i,1)&","&DT$(i,2)&","&DT$(i,3)
NEXT i
END SUB
!
SUB tel(t$,d$)
LET t$=""
FOR j2=1 TO LEN(d$)
IF d$(j2:j2)>="0" AND d$(j2:j2)<="9" THEN LET t$=t$&d$(j2:j2)
NEXT j2
END SUB
!
END
! 十進BASICライブラリ"\Decimal BASIC\BASICw32\Library\SORT2.LIB"
! ixにはmと下限，上限を一致させた空の配列を指定する。
! mは参照されるのみ。
! ixにmの添字を大きさの順に並べて返す。
! つまり，m(ix(1))≦m(ix(2))≦m(ix(3))≦･･･となる。
EXTERNAL SUB sort(m(),ix(),n) ! ソート
DECLARE EXTERNAL SUB q_sort
DECLARE NUMERIC i
FOR i=1 TO n
LET ix(i)=i
NEXT i
CALL q_sort(m,ix,1,n)
END SUB
!
EXTERNAL SUB q_sort(m(),a(),l,r)
DECLARE NUMERIC i,j,pv,t
IF r<=l THEN
EXIT SUB
ELSE
LET i=l-1
LET j=r
LET pv=m(a(r))
DO
DO
LET i=i+1
LOOP UNTIL pv<=m(a(i))
DO
LET j=j-1
LOOP UNTIL j<=i OR m(a(j))<=pv
IF j<=i THEN EXIT DO
LET t=a(i)
LET a(i)=a(j)
LET a(j)=t
LOOP
LET t=a(i)
LET a(i)=a(r)
LET a(r)=t
CALL q_sort(m,a,l,i-1)
CALL q_sort(m,a,i+1,r)
END IF
END SUB
END
|
|