カラーパレット作成ツール

 投稿者：しばっち  投稿日：2018年 2月 6日(火)20時10分20秒
  カラーパレットを作成します。
まだまだ改良の余地はありますが、とりあえず動きます。汗(￣◇￣;)

実行すると、カラーパレットが表示されます。
まず、設定したいパレットコード(0～255)をクリックして選択してください。

★「MODE 1」,「MODE 2」,「MODE 3」をクリック
   カラー選択用の画面が出ます。
   MODE 3では色の選択に画像ファイルを使用します。

   選択画面から登録したい色をクリックして選びます。
   なお、マウスカーソルがグラフィックウインドゥからはみ出した時は、
   スペシャルモードが発動しますのでクリックではなく、TABキーを押して選択してください。

   ★ 「登録」をクリック
      登録してコード設定に戻ります。
   ★ 「戻る」をクリック
　　　登録はせずにコード設定に戻ります。

★ 「終了」をクリック
   登録したコードのみを出力するか、問い合わせます。
      ★ 「YES」 で登録コードのみ出力して終了します。
      ★ 「NO」  で全色分出力するか、問い合わせます。
          ★ 「YES」 で全色分出力して終了。
          ★ 「NO」  で出力キャンセルして終了。

出力されたBASICコードはコピペして使用して下さい。


OPTION ARITHMETIC NATIVE
OPTION BASE 0
RANDOMIZE
PUBLIC NUMERIC FLG(255)
DIM R(255),G(255),B(255)
SET COLOR MODE "REGULAR"
FOR I=0 TO 255
   ASK COLOR MIX(I) R(I),G(I),B(I) !'パレット読み出し
   LET R(I)=INT(R(I)*255)
   LET G(I)=INT(G(I)*255)
   LET B(I)=INT(B(I)*255)
NEXT I
CALL GINIT(900,800)
DO
   CLEAR
   LET XSIZE=600
   LET YSIZE=500
   LET STY=INT(YSIZE/16)
   LET STX=INT(XSIZE/16)
   CALL DRAWPALLET(XSIZE,YSIZE,STX,STY,R,G,B) !'カラーパレットの描画
   LET X1=700
   LET Y1=30
   LET X2=850
   LET Y2=75
   LET DY1=70
   LET DY2=140
   CALL DRAWBOTTON(X1,Y1,X2,Y2,DY1, "MODE 1","MODE 2") !'ボタンを描く
   CALL DRAWBOTTON(X1,Y1+DY2,X2,Y2+DY2,70,"MODE 3","終 了")
   IF CODE=0 THEN
      LET X=STX
      LET Y=STY
   ELSE
      LET X=MOD(CODE,16)*STX+STX+5
      LET Y=INT(CODE/16)*STY+STY+5
   END IF
   DO
      IF X>=STX AND X<=STX+16*STX AND Y>=STY AND Y<=STY+16*STY THEN !'座標で振り分け
         LET CODE=INT((Y-STY)/STY)*16+INT((X-STX)/STX) !'設定用のコード
         CALL DRAWCOLORCODE(X,Y,STX,STY,CODE,R,G,B)
      ELSEIF X>X1 AND X<X2 AND Y>Y1 AND Y<Y2 THEN    !' MODE 1をクリック
         CALL  DRAWMODE(1,17*STX,17*STY,CODE,R,G,B)
         EXIT DO
      ELSEIF X>X1 AND X<X2 AND Y>Y1+DY1 AND Y<Y2+DY1 THEN   !' MODE 2をクリック
         CALL  DRAWMODE(2,17*STX,17*STY,CODE,R,G,B)
         EXIT DO
      ELSEIF X>X1 AND X<X2 AND Y>Y1+DY2 AND Y<Y2+DY2 THEN   !' MODE 3をクリック
         CALL DRAWMODE(3,17*STX,17*STY,CODE,R,G,B)
         EXIT DO
      ELSEIF X>X1 AND X<X2 AND Y>Y1+DY2+70 AND Y<Y2+DY2+70 THEN  !' 終了をクリック
         SELECT CASE CONFIRM$("登録のみ出力しますか?")
         CASE "YES"
            FOR I=0 TO 255
               IF FLG(I)<>0 THEN       !'登録したコードのみ
                  PRINT "SET COLOR MIX(";STR$(I);") ";STR$(R(I));"/255,";STR$(G(I));"/255,";STR$(B(I));"/255" !'BASICコード出力
               END IF
            NEXT I
         CASE "NO"
            SELECT CASE CONFIRM$("全色出力しますか?")
            CASE "YES"
               FOR I=0 TO 255
                  PRINT "SET COLOR MIX(";STR$(I);") ";STR$(R(I));"/255,";STR$(G(I));"/255,";STR$(B(I));"/255"
               NEXT I
            CASE "NO"
               CALL MESSAGEBOX("出力を取り消しました")
            END SELECT
         END SELECT
         STOP
      END IF
      DO
         MOUSE POLL X,Y,LL,RR
      LOOP UNTIL LL<>0 OR RR<>0 OR GETKEYSTATE(9)<0 !'クリックするかTABキーを押すまで待つ
      DO
         MOUSE POLL X,Y,LL,RR
      LOOP WHILE LL<>0 OR RR<>0 OR GETKEYSTATE(9)<0 !'指が離れるまで待つ
   LOOP
LOOP
END

EXTERNAL  SUB DRAWBOTTON(X1,Y1,X2,Y2,DY,A$,B$) !'ボタンを描く
OPTION ARITHMETIC NATIVE
CALL BOXFULL(X1,Y1,X2,Y2,128,128,128)
IF B$<>"" THEN CALL BOXFULL(X1,Y1+DY,X2,Y2+DY,128,128,128)
SET TEXT HEIGHT 38
SET TEXT COLOR COLORINDEX(0,0,0)
PLOT TEXT ,AT X1,Y1:A$
IF B$<>"" THEN PLOT TEXT ,AT X1,Y1+DY:B$
END SUB

EXTERNAL  SUB ERASEBOTTON(X1,Y1,X2,Y2,DY) !'ボタンを消す
OPTION ARITHMETIC NATIVE
CALL BOXFULL(X1,Y1,X2,Y2,255,255,255)
CALL BOXFULL(X1,Y1+DY,X2,Y2+DY,255,255,255)
END SUB

EXTERNAL  SUB DRAWCOLORCODE(X,Y,STX,STY,K,R(),G(),B()) !'コード情報出力
OPTION ARITHMETIC NATIVE
CALL BOXFULL(STX,540,899,799,255,255,255)
SET TEXT COLOR COLORINDEX(0,0,0)
SET TEXT HEIGHT 28
PLOT TEXT ,AT STX,540:"登録CODE:"&RIGHT$("0"&BSTR$(K,16),2)&"("&STR$(K)&")"
SET TEXT HEIGHT 26
PLOT TEXT ,AT STX,574:"R="&STR$(R(K))&" G="&STR$(G(K))&" B="&STR$(B(K))
CALL BOXFULL(STX,610,336,770,R(K),G(K),B(K))
IF FLG(K)<>0 THEN
   SET TEXT HEIGHT 45
   SET TEXT COLOR COLORINDEX(0,0,0)
   PLOT TEXT ,AT 415,650:"登録済"
ELSE
   SET TEXT HEIGHT 45
   SET TEXT COLOR COLORINDEX(0,0,0)
   PLOT TEXT ,AT 415,650:"未登録"
END IF
END SUB

EXTERNAL  SUB DRAWMODE(MODE,XSIZE,YSIZE,K,R(),G(),B()) !'MODE 1～3を処理
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
LET X1=700
LET Y1=30
LET X2=850
LET Y2=75
LET DY1=70
LET DY2=140
CALL DRAWBOTTON(X1,Y1,X2,Y2,DY1,"登録","戻る")
CALL ERASEBOTTON(X1,Y1+DY2,X2,Y2+DY2,DY1)
SELECT CASE MODE !'モードにより色選択用の画面を描画する
CASE 1
   LET S=255
   FOR Y=0 TO YSIZE
      FOR X=0 TO XSIZE
         CALL HSV2RGB(INT(X/XSIZE*360),S,255-INT(Y/YSIZE*255),RR,GG,BB)
         CALL PSET(X,Y,RR,GG,BB)
      NEXT  X
   NEXT  Y
CASE 2
   LET V=255
   FOR Y=0 TO YSIZE
      FOR X=0 TO XSIZE
         IF X=INT(XSIZE/2) AND Y=INT(YSIZE/2) THEN LET H=0 ELSE  LET H=MOD(ANGLE(X-XSIZE/2,Y-YSIZE/2)+360,360)
         LET S=INT(SQR((X-XSIZE/2)^2+(Y-YSIZE/2)^2)/SQR((XSIZE/2)^2+(YSIZE/2)^2)*255)
         IF S>255 THEN LET S=255
         CALL HSV2RGB(H,S,V,RR,GG,BB)
         CALL PSET(X,Y,RR,GG,BB)
      NEXT  X
   NEXT  Y
CASE 3
   OPTION BASE 0
   LET XSIZE=600
   LET YSIZE=500
   LET STY=INT(YSIZE/16)
   LET STX=INT(XSIZE/16)
   FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" !'画像ファイル読み込み
   IF N$="" THEN
      CALL MESSAGEBOX("キャンセルしました")
      EXIT SUB
   END IF
   GLOAD N$
   LET BIWIDTH=PIXELX(1)+1
   LET BIHEIGHT=PIXELY(1)+1
   SET BITMAP SIZE BIWIDTH,BIHEIGHT
   SET WINDOW 0,BIWIDTH-1,BIHEIGHT-1,0
   DIM VM(BIWIDTH,BIHEIGHT)
   ASK PIXEL ARRAY(0,0) VM
   CALL GINIT(900,800)
   CALL DRAWBOTTON(X1,Y1,X2,Y2,DY1,"登録","戻る")
   CALL DRAWCOLORCODE(STX,STY,STX,STY,K,R,G,B)
   FOR Y=0 TO YSIZE
      FOR X=0 TO XSIZE
         CALL BILINEAR(BIWIDTH,BIHEIGHT,X*BIWIDTH/XSIZE,Y*BIHEIGHT/YSIZE,VM,RR,GG,BB)
         CALL PSET(X,Y,RR,GG,BB)
      NEXT  X
   NEXT  Y
END SELECT
LET RR=-1
LET GG=-1
LET BB=-1
DO
   DO
      MOUSE POLL XX,YY,L1,R1    !'マウス操作
      IF SPECIAL=0 THEN CALL GETPOINT(XX,YY,R0,G0,B0) ELSE CALL GETCOLOR(R0,G0,B0)
      SET DRAW MODE HIDDEN
      SET TEXT HEIGHT 10
      CALL BOXFULL(740,670,899,690,255,255,255)
      SET TEXT COLOR COLORINDEX(0,0,0)
      PLOT TEXT ,AT 740,670:"(R,G,B)=("&USING$("###",R0)&","&USING$("###",G0)&","&USING$("###",B0)&")" !'カラーピッカー表示
      CALL BOXFULL(750,700,850,770,R0,G0,B0)
      SET DRAW MODE EXPLICIT
      CALL MOUSECURSOR(MX,MY)
      IF MX>=0 AND MX<=899 AND MY>=0 AND MY<=799 THEN LET SPECIAL=0 ELSE LET SPECIAL=1
   LOOP UNTIL L1<>0 OR R1<>0 OR GETKEYSTATE(9)<0          !'クリックするかTABキーを押す
   IF XX<=XSIZE AND YY<=YSIZE OR GETKEYSTATE(9)<0 THEN    !'座標で振り分け
      IF SPECIAL=0 THEN CALL GETPOINT(XX,YY,RR,GG,BB) ELSE CALL GETCOLOR(RR,GG,BB)
      SET TEXT COLOR COLORINDEX(0,0,0)
      SET TEXT HEIGHT 28
      PLOT TEXT ,AT 350,670:"→"
      CALL BOXFULL(400,572,770,603,255,255,255)
      SET TEXT COLOR COLORINDEX(0,0,0)
      SET TEXT HEIGHT 26
      PLOT TEXT ,AT 400,574:"R="&STR$(RR)&" G="&STR$(GG)&" B="&STR$(BB)
      CALL BOXFULL(400,610,700,770,RR,GG,BB)
   ELSEIF XX>X1 AND XX<X2 AND YY>Y1 AND YY<Y2 THEN !'登録ボタン処理
      IF RR>=0 AND GG>=0 AND BB>=0 THEN
         SELECT CASE CONFIRM$("登録しますか?")
         CASE "YES"
            LET R(K)=RR
            LET G(K)=GG
            LET B(K)=BB
            LET FLG(K)=1
            SET TEXT HEIGHT 30
            SET TEXT COLOR COLORINDEX(0,0,0)
            PLOT TEXT ,AT 650,440:"登録しました"
            WAIT DELAY 2
            EXIT DO
         CASE "NO"
            SET TEXT HEIGHT 20
            SET TEXT COLOR COLORINDEX(0,0,0)
            PLOT TEXT ,AT 650,440:"キャンセルしました"
            WAIT DELAY 2
            EXIT DO
         END SELECT
      ELSE
         CALL MESSAGEBOX("色が選択されていません")
      END IF
   ELSEIF XX>X1 AND XX<X2 AND YY>Y1+70 AND YY<Y2+70 THEN !'戻るボタン処理
      CALL MESSAGEBOX("キャンセルしました")
      EXIT DO
   END IF
   DO
      MOUSE POLL XX,YY,L1,R1
   LOOP WHILE L1<>0 OR R1<>0 OR GETKEYSTATE(9)<0 !'指が離れるまで待つ
LOOP
END SUB

EXTERNAL  SUB DRAWPALLET(XSIZE,YSIZE,STX,STY,R(),G(),B()) !'パレット描画
OPTION ARITHMETIC NATIVE
SET TEXT HEIGHT 16
SET TEXT COLOR COLORINDEX(0,0,0)
SET TEXT JUSTIFY "LEFT" , "TOP"
SET LINE WIDTH 3
FOR X=0 TO 15
   PLOT TEXT ,AT STX*1.2+X*STX,STY*.4:RIGHT$("0"&BSTR$(X,16),2)
NEXT X
FOR Y=0 TO 15
   PLOT TEXT ,AT STX*.4,STY*1.2+Y*STY:RIGHT$("0"&BSTR$(Y*16,16),2)
NEXT  Y
FOR Y=0 TO 15
   FOR X=0 TO 15
      LET K=INT(Y*16+X)
      CALL BOXFULL(X*STX+STX,Y*STY+STY,(X+1)*STX+STX,(Y+1)*STY+STY,R(K),G(K),B(K))
      IF FLG(K)<>0 THEN
         LET R0=INT(RND*256) !'色が被らないように
         LET G0=INT(RND*256)
         LET B0=INT(RND*256)
         CALL LINE(X*STX+STX,Y*STY+STY,(X+1)*STX+STX,(Y+1)*STY+STY,R0,G0,B0) !'登録済には×印
         CALL LINE((X+1)*STX+STX,Y*STY+STY,X*STX+STX,(Y+1)*STY+STY,R0,G0,B0)
      END IF
   NEXT X
NEXT Y
END SUB

EXTERNAL SUB HSV2RGB(H,S,V,R,G,B) !'HSVカラーをRGBカラーに変換
OPTION ARITHMETIC NATIVE
IF S=0 THEN
   LET R=V
   LET G=V
   LET B=V
   EXIT SUB
END IF
LET T=V-S*V/255
LET HH=H
IF H>=300 OR H<60 THEN
   IF H>=300 THEN LET HH=360-HH
   IF H<60 THEN LET HH=-HH
   LET HH=HH/60
   LET RR=0
   IF HH<0 THEN
      LET BB=1
      LET GG=HH+BB
   ELSE
      LET GG=1
      LET BB=GG-HH
   END IF
END IF
IF H>=60 AND H<180 THEN
   LET HH=HH-120
   LET HH=HH/60
   LET GG=0
   IF HH<0 THEN
      LET BB=1
      LET RR=HH+BB
   ELSE
      LET RR=1
      LET BB=RR-HH
   END IF
END IF
IF H>=180 AND H<300 THEN
   LET HH=HH-240
   LET HH=HH/60
   LET BB=0
   IF HH<0 THEN
      LET RR=1
      LET GG=HH+RR
   ELSE
      LET GG=1
      LET RR=GG-HH
   END IF
END IF
LET R=-RR*(V-T)+V
LET R=INT(R)
LET G=-GG*(V-T)+V
LET G=INT(G)
LET B=-BB*(V-T)+V
LET B=INT(B)
END SUB

EXTERNAL SUB BILINEAR(XSIZE,YSIZE,X,Y,IMAGE(,),R,G,B) !'バイリニア法
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
LET C1=IMAGE(X0,Y0)
IF X0+1<=XSIZE THEN LET C2=IMAGE(X0+1,Y0)
IF Y0+1<=YSIZE THEN LET C3=IMAGE(X0,Y0+1)
IF X0+1<=XSIZE AND Y0+1<=YSIZE THEN LET C4=IMAGE(X0+1,Y0+1)
CALL RGB(C1,R1,G1,B1)
CALL RGB(C2,R2,G2,B2)
CALL RGB(C3,R3,G3,B3)
CALL RGB(C4,R4,G4,B4)
LET R=(1-YY)*((1-XX)*R1+XX*R2)+YY*((1-XX)*R3+XX*R4)
LET G=(1-YY)*((1-XX)*G1+XX*G2)+YY*((1-XX)*G3+XX*G4)
LET B=(1-YY)*((1-XX)*B1+XX*B2)+YY*((1-XX)*B3+XX*B4)
LET R=MAX(0,MIN(255,R))
LET G=MAX(0,MIN(255,G))
LET B=MAX(0,MIN(255,B))
END SUB

EXTERNAL  SUB MESSAGEBOX(M$)
OPTION ARITHMETIC NATIVE
LET N=MESSBOX(0,M$,"BASIC",0)

FUNCTION MESSBOX(OWNER,TEXT$,CAPTION$,FLAG)
   ASSIGN "user32.dll","MessageBoxA"
END FUNCTION
END SUB

EXTERNAL  SUB MOUSECURSOR(MX,MY)
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
LET  PNT$=REPEAT$("#",2*4)
LET  RC=GETCURSORPOS(PNT$)
LET  RC=SCREENTOCLIENT(WINHANDLE("GRAPHICS"),PNT$)
LET  MX=INT32(PNT$,0)
LET  MY=INT32(PNT$,4)
END SUB

EXTERNAL  SUB GETCOLOR(R,G,B)
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
LET PNT$=REPEAT$("#",2*4)
LET RC=GETCURSORPOS(PNT$)
LET MX=INT32(PNT$,0)
LET MY=INT32(PNT$,4)
LET HDC=GETDC(0)
LET C=GETPIXEL(HDC,MX,MY)
LET DMY=RELEASEDC(0,HDC)
CALL RGB(C,R,G,B)
END SUB

EXTERNAL FUNCTION SCREENTOCLIENT(HWND, LPPOINT$)
OPTION ARITHMETIC NATIVE
ASSIGN "user32.dll" ,"ScreenToClient"
END FUNCTION

EXTERNAL FUNCTION GETCURSORPOS(LPPOINT$)
OPTION ARITHMETIC NATIVE
ASSIGN "user32.dll" ,"GetCursorPos"
END FUNCTION

EXTERNAL  FUNCTION GETPIXEL(HDC,X,Y)
OPTION ARITHMETIC NATIVE
ASSIGN "gdi32.dll" ,"GetPixel"
END FUNCTION

EXTERNAL  FUNCTION GETDC(HDC)
OPTION ARITHMETIC NATIVE
ASSIGN "user32.dll" ,"GetDC"
END FUNCTION

EXTERNAL  FUNCTION RELEASEDC(HWND,HDC)
OPTION ARITHMETIC NATIVE
ASSIGN "user32.dll" ,"ReleaseDC"
END FUNCTION

EXTERNAL FUNCTION INT32(S$,P)
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
LET N=0
FOR I=1 TO 4
   LET N=N+256^(I-1)*ORD(S$(P+I:P+I))
NEXT I
IF N<2^31 THEN LET INT32=N ELSE LET INT32=N-2^32
END FUNCTION

EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB

EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB

EXTERNAL SUB BOX(XS,YS,XE,YE,R,G,B)
OPTION ARITHMETIC NATIVE
CALL LINE(XS,YS,XE,YS,R,G,B)
CALL LINE(XE,YS,XE,YE,R,G,B)
CALL LINE(XE,YE,XS,YE,R,G,B)
CALL LINE(XS,YE,XS,YS,R,G,B)
END SUB

EXTERNAL SUB LINE(X0,Y0,X1,Y1,R,G,B)
OPTION ARITHMETIC NATIVE
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT LINES:X0,Y0;X1,Y1
END SUB

EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB

EXTERNAL SUB BOXFULL(X0,Y0,X1,Y1,R,G,B)
OPTION ARITHMETIC NATIVE
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT AREA:X0,Y0;X1,Y0;X1,Y1;X0,Y1;X0,Y0
END SUB
 		 

戻る