'以下是字模提取程序的源代码
'在QB编辑器生成EXE文件后再在文件后面接上汉字及ASCII的字模数据
'我把字模的数据合并到可执行文件,所以程序不使用数据文件
'源码中注释部分是程序未完成时的测试所需要的参数
'如果你对编写此类程序有兴趣,请与我联系

DECLARE FUNCTION GetName$ ()
DECLARE FUNCTION get.self.path$ (ProName$)
DECLARE SUB MyPrn (x%, y%, St$, bfclr%, bkclr%, over%)
DECLARE FUNCTION Mode$ (St$)
TYPE RegType
     ax    AS INTEGER
     bx    AS INTEGER
     cx    AS INTEGER
     dx    AS INTEGER
     bp    AS INTEGER
     si    AS INTEGER
     di    AS INTEGER
     flags AS INTEGER
END TYPE
DECLARE SUB Interrupt (intnum AS INTEGER, inreg AS RegType, outreg AS RegType)
DEFINT A-Z
DIM SHARED MyPath$, MyFileName$
CONST DataBgn% = 3465
'-----------------------------------------------
MyPath$ = get.self.path(MyFileName$)
'MyPath$ = "f:\GetMode\"
'MyFileName$ = "getMode.exe"
Cmd$ = COMMAND$
'Cmd$ = "/l test.txt"
Md$ = UCASE$(MID$(Cmd$, 2, 1))
SF$ = LTRIM$(RTRIM$(MID$(Cmd$, 3, LEN(Cmd$))))
'-----------------------------------------------
PosY% = POS(x): PosX% = CSRLIN
DIM sv(4000) AS INTEGER
DEF SEG = &HB800
FOR i% = 0 TO 3999
    sv(i%) = PEEK(i%)
NEXT
DEF SEG
SCREEN 12
'***********************************************
MyPrn 1, 1, "字模提取器 V1.1 2004.10 秋风", 8, 0, 0
MyPrn 0, 0, "字模提取器 V1.1 2004.10 秋风", 11, 0, 0
MyPrn 0, 20, "参数说明：", 7, 0, 0
MyPrn 0, 40, MyFileName$ + "[/F][/L] [FILENAME]/[LINEINPUT]", 7, 0, 0
MyPrn 0, 60, "/F 指定提取一个文件的内容", 7, 0, 0
MyPrn 0, 80, "/L 在命令行输入内容", 7, 0, 0
MyPrn 0, 100, "FILENAME 文件名（使用/F参数时）", 7, 0, 0
MyPrn 0, 120, "LINEINPUT 字符行（使用/L参数时）注意所有的英文字母将都被转成大写的", 7, 0, 0
MyPrn 0, 140, "程序将在当前目录下生成一个目标文件，文件名将由程序确定", 7, 0, 0
'---------------------------------------------
IF LEFT$(Cmd$, 1) <> "/" OR (Md$ <> "F" AND Md$ <> "L") THEN
    MyPrn 0, 160, "请确认参数行没有错误...... 按任意键退出......", 4, 0, 0
    WHILE INKEY$ = "": WEND: GOSUB ReTrunScreenBack: END
END IF
'---------------------------------------------
IF DIR$(SF$) = "" AND Md$ = "F" THEN
    MyPrn 0, 160, "文件没有找到,请确认文件名没有写错...... 按任意键退出......", 4, 0, 0
    WHILE INKEY$ = "": WEND: GOSUB ReTrunScreenBack: END
END IF
'---------------------------------------------
oName$ = GetName$
MyPrn 0, 160, "正在生成字模数据文件" + oName$ + ",请稍候......", 11, 0, 0
oFile% = FREEFILE
OPEN oName$ FOR OUTPUT AS #oFile%
'---------------------------------------------
IF Md$ = "L" THEN
    FOR i% = 1 TO LEN(SF$)
              L$ = MID$(SF$, i%, 1)
              IF ASC(L$) < 161 THEN
                  R$ = "DATA " + Mode(L$)
                  PRINT #oFile%, L$
                  PRINT #oFile%, R$
              END IF
              IF ASC(L$) > 160 THEN
                  L$ = MID$(SF$, i%, 2)
                  R$ = "DATA " + Mode(L$)
                  PRINT #oFile%, L$
                  PRINT #oFile%, R$
                  i% = i% + 1
              END IF
    NEXT
    CLOSE oFile%
END IF
IF Md$ = "F" THEN
    iFile% = FREEFILE
    OPEN SF$ FOR INPUT AS #iFile%
    WHILE NOT EOF(iFile%)
         LINE INPUT #iFile%, Buf$
         FOR i% = 1 TO LEN(Buf$)
              L$ = MID$(Buf$, i%, 1)
              IF ASC(L$) < 161 THEN
                  R$ = "DATA " + Mode(L$)
                  PRINT #oFile%, L$
                  PRINT #oFile%, R$
              END IF
              IF ASC(L$) > 160 THEN
                  L$ = MID$(Buf$, i%, 2)
                  R$ = "DATA " + Mode(L$)
                  PRINT #oFile%, L$
                  PRINT #oFile%, R$
                  i% = i% + 1
              END IF
         NEXT i%
    WEND
    CLOSE iFile%, oFile%
END IF
LINE (0, 160)-(639, 176), 0, BF
MyPrn 0, 160, "字模数据文件" + oName$ + "已生成,按任意键退出......", 11, 0, 0
WHILE INKEY$ = "": WEND: GOSUB ReTrunScreenBack: END
ReTrunScreenBack:
    SCREEN 0
    DEF SEG = &HB800
    FOR i% = 0 TO 3999
        POKE i%, sv(i%)
    NEXT
    DEF SEG
    LOCATE PosX%, PosY%, 1
RETURN

FUNCTION get.self.path$ (ProName$)
'*********************************
'       获得运行程序的所在目录
'     调用DOS &H62中断 0号子功能
'*********************************
DIM mystr AS STRING
DIM Regs AS RegType
Regs.ax = &H6200
Interrupt &H21, Regs, Regs
DEF SEG = Regs.bx
EnvSeg& = PEEK(&H2C) + PEEK(&H2D) * 256&
DEF SEG = EnvSeg&
'-----------------------
DO
      DO
           byte% = PEEK(i%)
           i% = i% + 1
      LOOP WHILE byte%
      '------------------
      byte% = PEEK(i%)
      i% = i% + 1
      mystr$ = mystr$ + CHR$(byte%)
LOOP WHILE byte%
'-----------------------
i% = i% + 2
DO
      byte% = PEEK(i%)
      IF byte% THEN
          Prog$ = Prog$ + CHR$(byte%)
      END IF
      i% = i% + 1
      mystr$ = mystr$ + CHR$(byte%)
LOOP WHILE byte%
DEF SEG
'-----------------------
L% = LEN(Prog$)
WHILE MID$(Prog$, L%, 1) <> "\" AND L% > 0
       L% = L% - 1
       mystr$ = mystr$ + CHR$(byte%)
WEND
'-----------------------
IF L% > 1 THEN
       Path$ = LEFT$(Prog$, L%)
       IF RIGHT$(Path$, 1) <> "\" THEN Path$ = Path$ + "\"
       get.self.path$ = Path$
       ProName$ = MID$(Prog$, L% + 1, 12)
   ELSE
       get.self.path$ = ""
       ProName$ = Prog$
END IF
END FUNCTION

FUNCTION GetName$
    t$ = "Mode0000.txt"
    WHILE DIR$(t$) <> ""
          N% = N% + 1
          R$ = LTRIM$(RTRIM$(STR$(N%)))
          R$ = STRING$(4 - LEN(R$), "0") + R$
          t$ = "Mode" + R$ + ".txt"
    WEND
    GetName$ = t$
END FUNCTION

FUNCTION Mode$ (St$)
    STATIC Lc%
    STATIC FontFile%, FontBuf$
    IF Lc% = 0 THEN
         Lc% = 1: FontFile% = FREEFILE
         OPEN MyPath$ + MyFileName$ FOR RANDOM AS #FontFile% LEN = 16
         FIELD #FontFile, 16 AS FontBuf$
    END IF
    '************************************************************************
    byte% = ASC(St$)
    IF LEN(St$) = 1 THEN
         GET #FontFile%, byte% + DataBgn%
         Buf$ = FontBuf$
    END IF
    IF LEN(St$) = 2 THEN
         Byte0% = ASC(MID$(St$, N% + 1, 1)) - 161
         Index% = ((byte% - 161) * 94 + Byte0%) * 2 + 257 + DataBgn%
         GET #FontFile%, Index%
         Buf$ = FontBuf$
         GET #FontFile%, Index% + 1
         Buf$ = Buf$ + FontBuf$
    END IF
    N% = ASC(Buf$)
    Tmp$ = LTRIM$(RTRIM$(STR$(N%)))
    FOR i% = 2 TO LEN(Buf$)
         N% = ASC(MID$(Buf$, i%, 1))
         Tmp$ = Tmp$ + "," + LTRIM$(RTRIM$(STR$(N%)))
    NEXT
    Mode$ = Tmp$
END FUNCTION

SUB MyPrn (x%, y%, St$, bfclr%, bkclr%, over%)
    IF LEN(St$) = 0 THEN EXIT SUB
    Slen% = LEN(St$)
    IF over% <> 0 THEN LINE (x%, y%)-(x% + Slen% * 8, y% + 16), bkclr%, BF
    '************************************************************************
    STATIC Lc%
    STATIC FontFile%, FontBuf$
    IF Lc% = 0 THEN
         Lc% = 1: FontFile% = FREEFILE
         OPEN MyPath$ + MyFileName$ FOR RANDOM AS #FontFile% LEN = 16
         FIELD #FontFile, 16 AS FontBuf$
    END IF
    '************************************************************************
    rx% = x%: N% = 1
    WHILE N% <= Slen%
         byte% = ASC(MID$(St$, N%, 1))
         IF byte% < 161 AND byte% > 32 THEN
              GET #FontFile%, byte% + DataBgn%
              FOR i% = 0 TO 15
                     LINE (rx%, y% + i%)-(rx% + 7, y% + i%), bfclr%, B, ASC(MID$(FontBuf$, i% + 1, 1))
              NEXT
         END IF
         '===================================================================
         IF byte% >= 161 AND N% <> Slen% THEN
              Byte0% = ASC(MID$(St$, N% + 1, 1)) - 161
              IF Byte0% >= 0 THEN
                   Index% = ((byte% - 161) * 94 + Byte0%) * 2 + 256 + DataBgn%
                   GET #FontFile%, Index%
                   Buf$ = FontBuf$
                   GET #FontFile%, Index% + 1
                   Buf$ = Buf$ + FontBuf$
                   FOR i% = 0 TO 15
                       LINE (rx%, y% + i%)-(rx% + 7, y% + i%), bfclr%, B, ASC(MID$(Buf$, i% * 2 + 1, 1))
                       LINE (rx% + 8, y% + i%)-(rx% + 15, y% + i%), bfclr%, B, ASC(MID$(Buf$, i% * 2 + 2, 1))
                   NEXT
                   N% = N% + 1: rx% = rx% + 8
              END IF
         END IF
         N% = N% + 1: rx% = rx% + 8
    WEND
END SUB