nagramさんへ

 投稿者:RCカー  投稿日:2021年 8月15日(日)20時26分50秒
  ありがとうございます。

訂正させていただきました。

確認お願いします。



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
 

Re: nagramさんへ

 投稿者:nagram  投稿日:2021年 8月16日(月)17時33分22秒
  > No.4951[元記事へ]

RCカーさんへのお返事です。

> ありがとうございます。
>
> 訂正させていただきました。
>
> 確認お願いします。

はい、これで大丈夫だと思います。
 

Re: nagramさんへ

 投稿者:RCカー  投稿日:2021年 8月16日(月)17時35分13秒
  nagramさんへのお返事です。

> RCカーさんへのお返事です。
>
> > ありがとうございます。
> >
> > 訂正させていただきました。
> >
> > 確認お願いします。
>
> はい、これで大丈夫だと思います。

nagramさんへ、ありがとう。
嬉しいです。
 

戻る