'■
'■for Actuve BASIC 2.62
'■他のバージョンでは動作しません。
'■

Dim A As WORD
Dim B As WORD
Dim i As Long
Dim recode As Long
Dim C(256) As Byte	'■大きい時は増やす
Dim x As WORD
Dim y As WORD
Dim tmp As Byte
Dim w As WORD
Dim h As WORD
Dim BPC As WORD
Dim bit(8) As Byte
bit(0)=1
bit(1)=2
bit(2)=4
bit(3)=8
bit(4)=16
bit(5)=32
bit(6)=64
bit(7)=128

cls 3

w=12
h=12

Print "フォント"
Input fontName$
if fontName$="" then fontName$="ＭＳ ゴシック"
'fontName$="あずきフォント"
'fontName$="ことり文字ふぉんと"

Print "幅(px)"
Input w
Print "高(px)"
Input h

cls 3

BPC=h*w\8

'Open "sjis.txt" For Append As 1

Open fontName$+".dat" As 2
Field #2, ((255-64+1)*(h*w\8)) , As FILE$
recode=1

For B=&h81 to &hfc
'if(B=&h85) then B=&h87
if(B=&hA0) then B=&hE0
if(B=&hEB) then B=&hED
if(B=&hEF) then B=&hFA

For A=&h40 to &hff
'print A,B
  if(B=&h85) then 
    out$=Chr$((A-&h40)*2+&h20)+Chr$((A-&h40)*2+1+&h20)
  else
    out$=Chr$(B)+Chr$(A)
  end if
'  sjis$=sjis$+out$
  Line (0,0)-(h,w),0,Bf
  TextOut 0,0, out$,7,0,h,w\2,fontName$

  for x=0 to w-1
  for y=0 to h-1
'    tmp=Point(x,y)
'    PSet(x,y),tmp+7
    if Point(x,y) then
      i=(x*h+y)\8
      C(i)=C(i)+bit((x*h+y) Mod 8)
    end if
  next y
  next x
  for i=0 to BPC-1
    FILE$=FILE$+Chr$(C(i))
    C(i)=0
  next i

Next A
'Write #1, sjis$
'sjis$=""

Put #2, recode
recode=recode+1
FILE$=""
Next B
Close #2
TextOut 0,0, "完了",7,0,h,w\2,fontName$