回 帖 发 新 帖 刷新版面

主题:《作图模式显示汉字》的扩展

谢谢jtchang老师提供的[url=http://www.programfan.com/club/showbbs.asp?id=14025]作图模式显示16×16汉字[/url]程序,但jtchang老师特别注明“内容必须全部为全角符号或者是汉字”。我想,能否可以让程序也能显示英文字母或是半角字符呢?我考虑过用 Outtext 过程,但Outtext是8×8点阵的,与16×16的汉字混合会不美观。于是我找到了“ASC16”这个 UCDOS 98 的16×8点阵西文字库。我使用它仿照jtchang老师的程序添加了显示西文的过程,并把程序做成了单元文件。以下是程序代码:

(*   UCDOS 16*16 fonts unit.
     Need file: HZK16 and ASC16 to run.
     display Chinese in graphics mode.
     programmed by jtchang.
     improved by Ben.
*)
Unit Chinese;

interface

Uses Graph;
procedure OutChinese(x,y:integer;s:string;blank:integer);

implementation

function inttostr(n:integer):string;
var
  s:string;
begin
    s:='';
    repeat
       s:=chr(ord('0')+n mod 10)+s;
       n:=n div 10;
    until n=0;
    inttostr:=s;
end;


procedure putone(x,y:integer;s:string);
type
    chinesep=array[1..32] of byte;
var
    a:chinesep;
    f:file of chinesep;
    i,j,x0,y0:integer;
    k:byte;
    q,w:longint;
    color:byte;

begin
    color:=getcolor;
    q:=ord(s[1])-160;
    w:=ord(s[2])-160;
    q:=(q-1)*94+(w-1);
    assign(f,'HZK16');
    reset(f);
    if (q<0) or (q>=filesize(f)) then
      begin
         close(f);
         exit;
      end;
    seek(f,q);
    read(f,a);
    close(f);
    y0:=y;
    for i:=1 to 32 do
     begin
       k:=a[i];
       if i mod 2=1 then
         begin
           x0:=7+x;
           y0:=y0+1;
         end
        else
              x0:=15+x;
       for j:=1 to 8 do
        begin
           if k and 1 =1 then putpixel(x0,y0,color);
            x0:=x0-1;
            k:=k shr 1;
        end;
     end;
end;

回复列表 (共9个回复)

沙发

procedure putletter(x,y:integer;s:char);
type
   letterp=array[1..16] of byte;
var
   a:letterp;
   f:file of letterp;
   i,j,x0,y0:integer;
   q:longint;
   k:byte;
   color:byte;
begin
   color:=getcolor;
   q:=ord(s);
   assign(f,'ASC16');
   reset(f);
   seek(f,q);
   read(f,a);
   close(f);
   y0:=y;
   for i:=1 to 16 do
    begin
      k:=a[i];
      x0:=7+x;
      y0:=y0+1;
      for j:=1 to 8 do
       begin
          if k and 1 =1 then putpixel(x0,y0,color);
           x0:=x0-1;
           k:=k shr 1;
       end;
    end;
end;

procedure outchinese(x,y:integer;s:string;blank:integer);
var
   temps:string[2];
   k:integer;
   long:integer;
begin
   k:=1;
   long:=0;
   while k<=length(s) do
    begin
      if s[k]>#160 then begin
       temps:=s[k]; k:=k+1;
       temps:=temps+s[k]; k:=k+1;
       putone(x+long,y,temps);
       long:=long+16+blank;
      end else begin
       putletter(x+long,y,s[k]);
       k:=k+1;
       if (s[k]=#32)or(ord(s[k])>160) then
        long:=long+8+blank
       else
        long:=long+8;
      end;
    end;
end;

End.

本程序如有不足之处或有更好的建议,请jtchang老师和各位网友赐教!!

板凳

好!顶!这个功能使我编的游戏增色不少啊

3 楼

哦对了,这个单元和jtchang老师的程序有点不同,outchinese 过程去掉了最后的 color:byte ,汉字的颜色要用 setcolor 过程来设置。

4 楼

哇呀呀!这帖子虽然加了“精”又加了“热”,但怎么没人回呀???

5 楼

呵呵!好!以前我确实想过编这样的程序,把半角部分和汉字合起来,成一个函数。但怕编太长,没接触的人不容易看懂,又要调到两个字库,于是就只编了主要部分,留下半角部分,让有兴趣的人自己去完成。帖子挂很久了,要不是加了精,早被删了。现在终于有人想到这个问题并完成了!(^_^)

6 楼

呵!再次多谢jtchang老师!

7 楼

还有一个问题要请教jtchang老师:
我的UCDOS 版本是98特别袖珍版,里面只有HZK16和ASC16两个字库。
而在UCDOS 6.0版本里,中文字库有8个。
请问西文字库除ASC16外,是不是也有像ASC12等字库?

8 楼


outchinese(x,y:integer;s:string;blank:integer)这个函数如何使用?{blank,s,x,y代表什么?




感谢提供单元

9 楼

x,y是文字显示的坐标,blank是两个字之间的间距(像素),s就是你要显示的文字。
如:outchinese(100,100,'PFan中快乐灌水',1)
则在(100,100)坐标中显示“PFan中快乐灌水”。

详情请参阅原创者的帖子:
[url]http://www.programfan.com/club/showbbs.asp?id=14025[/url]

我来回复

您尚未登录,请登录后再回复。点此登录或注册