Re: Свои шрифты
Вложений: 2
Вот делал импорт виндовых шрифтов (обробленых прогой пот винду (тоже мою))
тоесть шрфит печатается с учетом ширины и высоты каждого отдельного символа, тоесть точка и тере будет иметь разную ширину выглядет красиво...
Впринципи все работает отл... тока скорость маленькая отрисовки если идет расбеение текста на страници, сделайте алг какойто покруче если хотите, ато у меня время не стало и забросил это дело...
Я вообще хотел сделать интерпритатор формы тоесть сделать такиеже процедуры как и в форме тока все меню обрисовываются...
Это нада чтобы добится красоты и одинакового вида разных мабайлах
Если кому интересно могу выложить все сорцы проги на мп и дельфе
вот ниже срц
Код:
program TextPrintTest;
uses TextPrint;
Var s:string;
N,i,nk,t,xx,yy,ii,key:integer;
im:image;
begin
clrscr;
//coolClear(3);
//ramka(1,(getWidth-100)/2,(getHeight-100)/2,100,100);
SetColor(0, 0, 0);
drawText('Загрузка...', ((getWidth - getStringWidth('Загрузка...'))/2),(getHeight-getStringHeight('Загрузка...'))/2 );
repaint; delay(1000);
//*********************************************************************************************************
// Самый простой пример
FontInit('Arial8');//инициализировать шрифт можно и один раз за всю роботу программы...
n:=String2Lines_rect('ЗАГОЛОВОК | |Дальше идет наш пробный тест который может иметь любое содержание. | Абзац пошел типа и началась новая тема... и так дальше...',getWidth);//n - колчиество строк
clrscr;
TextOutREctFAST(0,0,getWidth,GetHeight,true,0);//0 - это с какой строчки стартуем выводить наш текст
Repaint;
delay(1000);
//*********************************************************************************************************
//delay(1000);
//delay(3000);
clrscr; //- очищаем екран
//*********************************************************************************************************
// пример с использованием авто скролинга и загрузкой теста из ресурсного файлика скролинг текста идет в опр области екрана. управляется клавиатурой
im:=loadimage('/large_scroll.png');
xx:=trunc((getWidth-getImageWidth(im))/2);
yy:=trunc((getHeight-getImageHeight(im))/2);
FontInit('Verdana_7');
SetLinesHeight(-1);
n:=String2Lines_rect(ResToString('test.txt'),getImageWidth(im)-15);//n - колчиество строк
nk:=NlinesInRect(1,1,getImageWidth(im)-15,getImageHeight(im)-20);
t:=n-(nk); if t<=0 then t:=0;
drawimage(loadimage('/bomber plane.jpg'),0,0);
ii:=0;
repeat
If (ii<=n/nk) and (KeyToAction(key) = GA_DOWN )or (ii=0) then
begin
ii:=ii+1;
if ii=1 then
begin
DrawImage(im, xx, yy);
TextOutREctFAST(xx+10,yy+18,xx+getImageWidth(im)-10,yy+getImageHeight(im)-15,true,i);
repaint;
end
else
For i:=(ii*nk)-2*nk to (ii*nk)-nk do
Begin
DrawImage(im, xx, yy);
TextOutREctFAST(xx+11,yy+18,xx+getImageWidth(im)-10,yy+getImageHeight(im)-15,true,i);
repaint;
//if (i=0) or (i=(t)) then delay(nk*320) else delay(300);
end;
end;
If (ii>=2) and (KeyToAction(key) = GA_UP ) then
begin
ii:=ii-1;
For i:=(ii*nk) downto (ii*nk)-nk do
Begin
DrawImage(im, xx, yy);
TextOutREctFAST(xx+11,yy+18,xx+getImageWidth(im)-10,yy+getImageHeight(im)-15,true,i);
repaint;
//if (i=0) or (i=(t)) then delay(nk*320) else delay(300);
end;
end;
delay(50);
key:=getkeyclicked;
until KeyToAction(key) = GA_FIRE;
//**********************************************************************************************************
clrscr;
drawText('Загрузка...', ((getWidth - getStringWidth('Загрузка...'))/2),(getHeight-getStringHeight('Загрузка...'))/2 );repaint;//- очищаем екран
delay(3000);
//*********************************************************************************************************
// пример с использованием авто скролинга и загрузкой теста из ресурсного файлика скролинг текста идет в опр области екрана.
im:=loadimage('/large_scroll.png');
xx:=trunc((getWidth-getImageWidth(im))/2);
yy:=trunc((getHeight-getImageHeight(im))/2);
FontInit('Verdana_7');
SetLinesHeight(-1);
n:=String2Lines_rect(ResToString('test.txt'),getImageWidth(im)-15);//n - колчиество строк
nk:=NlinesInRect(1,1,getImageWidth(im)-15,getImageHeight(im)-20);
t:=n-(nk); if t<=0 then t:=0;
drawimage(loadimage('/bomber plane.jpg'),0,0);
For i:= 0 to t do
begin
//clrscr;
DrawImage(im, xx, yy);
TextOutREctFAST(xx+10,yy+18,xx+getImageWidth(im)-10,yy+getImageHeight(im)-15,true,i);
repaint;
if (i=0) or (i=(t)) then delay(nk*320) else delay(300);
end;
//**********************************************************************************************************
//*********************************************************************************************************
// пример с использованием авто скролинга и загрузкой теста из ресурсного файлика
im:=loadimage('/bomber plane.jpg');
FontInit('a_Simpler3D_11');
SetLinesHeight(-1);
n:=String2Lines_rect(ResToString('test.txt'),getWidth);//n - колчиество строк
nk:=NlinesInRect(1,1,getWidth-2,GetHeight-2);
t:=n-(nk); if t<=0 then t:=0;
For i:= 0 to t do
begin
clrscr;
drawimage(im,0,0);
drawrect(0,0,getWidth-1,GetHeight-1);
TextOutREctFAST(1,1,getWidth-2,GetHeight-2,false,i);
repaint;
if (i=0) or (i=(t)) then delay(nk*220) else delay(250);
end;
//**********************************************************************************************************
delay(3000);
clrscr; //- очищаем екран
//clrscr;SetColor(0, 0, 0);
//drawText('Загрузка...', ((getWidth - getStringWidth('Загрузка...'))/2),(getHeight-getStringHeight('Загрузка...'))/2 );repaint;
//DrawText('Потсчет прошел '+n+' строк',0,15);repaint;delay(500);
///DrawText('Первая строка: '+textprint.Getline(1),0,30);repaint;delay(5000);
{
s:=ChkString('Поскольку MIDletPascal создаёт непосредственно низкоуровневой байт-код Java, полученные мидлеты имеют небольшой размер и эффективное время исполнения. Аналогичные средства, которые можно найти в Internet, создают промежуточный код и компонуют его в архив JAR вместе с интерпретатором; при подобном подходе получаются большие и медленно исполняющиеся JAR-файлы. MIDletPascal создаёт непосредственно байт-код Java, так что вам не нужно иметь установленный на вашем компьютере компилятор Java, а компиляция с помощью MIDletPascal происходит очень быстро.');
TextOutREct(s,0,0,getWidth,0,true,0);repaint;
delay(15000);
coolClear(1);
drawimage(loadimage('/bomber plane.jpg'),0,0);
TextOutREct(s,0,0,getWidth,0,false,0); repaint;
delay(20000);
}
end.
Это был пример реализации
а вот сама либва
Код:
unit textprint;
interface
procedure clrscr;
Function ChkString(s:string):string;
Procedure FontInit(fname:string);
Function FGetTextWidth(s:string):integer;
Function FGetTextHeight:integer;
Procedure TextOut(s:string;x,y:integer);
Procedure TextOutREct(s:string;x,y,xx,yy:integer;center:boolean;ot:integer);
procedure coolClear(tp:integer);
Procedure ramka(tp,x,y,xx,yy:integer);
Function String2Lines_rect(s:string;w:integer):integer;
Function Getline(n:integer):string;
Function ResToString(resurs:string):string;
Procedure TextOutREctFAST(x,y,xx,yy:integer;center:boolean;line:integer);
Procedure SetLinesHeight(h:integer);
Function NlinesInRect(x,y,xx,yy:integer):integer;;//количество строк в квадрате
{ add public declarations here }
implementation
{ add unit functions & procedures here }
uses im2im;
const maxlines = 1000;
Var FontCH:array[13..255] of integer;
FontIm:image;
lines:array[1..maxlines] of string;//строки
Nlines,LinesHeight:integer;//количество строк
procedure clrscr;//очищение экрана
begin
setcolor(255,0,0);
fillRect(0, 0,getWidth , getHeight);
end;
//**********************************************************
Procedure SetLinesHeight(h:integer);
Begin
LinesHeight:=h;
end;
//**********************************************************
function Str2UTF8(s: string):string;
var i: integer; a : string;
begin
a:='';
for i:= 0 to Length(s) do
if GetChar(s, i) > '~' then a:= a + Chr(Ord(GetChar(s, i)) - 64432)
else a:= a + GetChar(s, i);
Str2UTF8:= Copy(a, 0, Length(a)-1);
end;
Function ResToString(resurs:string):string;
var
res:resource;
line:string;
Buf:string;
Begin
res:=OpenResource('/'+resurs);
if(resourceAvailable(res))then
begin
line:=ReadLine(res);
while line<>'+++'do
begin
Buf:=buf+Str2UTF8(line)+chr(13);
// DrawText(integertostring(ord(getchar(Buf,1))),0,30);repaint;delay(1500);
line := ReadLine(res);
end;
CloseResource(res);
end;
/// DrawText('тест'+Buf,0,30);repaint;delay(1500);
ResToString:=Buf;
end;
//**********************************************************
Function Getline(n:integer):string;
Begin
Getline:=lines[n];
end;
//**********************************************************
Function ChkString(s:string):string;
Var i,len ,a: integer;
ch:char;
out:string;
Begin
len:=Length(s)-1;
For i:= 0 to Len do
begin
ch:=GetChar(s, i);
if ch='ё'then ch:=GetChar('е', 0);
if ch='Ё'then ch:=GetChar('Е', 0);
if ch='і'then ch:=GetChar('i', 0);
if ch='І'then ch:=GetChar('I', 0);
if ch='|'then ch:=chr(13);
a:=ord(ch);
if a > 255 then a:= a - 848;
if ((a>=32)and(a<=255) or(a=13) ) then
BEGIN
If a=13 then out:=out+' ';
out:=out+ch;
END;
end;
ChkString:=out+' ';
End;
//**********************************************************
// Инициализация шрифта
Procedure FontInit(fname:string);
Var i,w,Wd,old,he:integer;
res:resource;
line:string;
Begin
res:=OpenResource('/'+fname+'.dat');
FontIm:=loadimage('/'+fname+'.png');
he:=GetImageHeight(FontIm);
old:=0;
if (resourceAvailable(res)) then
For i:= 32 to 255 do
Begin
line := ReadLine(res);
FontCH[i]:=stringtointeger(line);
//drawregion(random(176),random(220),FontIm,old,0,FontCH[i]-old,he);repaint;
old:=FontCH[i];
end;
set_clip(0,0,getWidth,getHeight);
end;
//*******************************************************
Function FGetTextWidth(s:string):integer;
Var a,i,len,Xs,ws,he:integer;
Begin
len:=Length(s)-1;
he:=GetImageHeight(FontIm);
For i:= 0 to Len do
begin
a:= Ord(GetChar(s, i));
if a > 255 then a:= a - 848;
if a=32 then xs:=0;
If a>32 then xs:=FontCH[a-1];
ws:=ws+FontCH[a]-xs;
end;
FGetTextWidth:=ws;
End;
//*******************************************************
Function FGetTextHeight:integer;
Begin
FGetTextHeight:=GetImageHeight(FontIm);
end;
//*******************************************************
Procedure TextOut(s:string;x,y:integer);
Var a,i,len,Xs,ws,he:integer;
Begin
//saveregion;
len:=Length(s)-1;
he:=FGetTextHeight;
For i:= 0 to Len do
begin
a:= Ord(GetChar(s, i));
if a > 255 then a:= a - 848;
If (a>=32)and(a<=255) then begin
if a=32 then xs:=0;
If a>32 then xs:=FontCH[a-1];
// cnv2.draw_image(x+ws,y,FontIm,xs,0,FontCH[a]-xs,he);
drawregion(x+ws,y,FontIm,xs,0,FontCH[a]-xs,he);
//repaint;
//repaint_part(x+ws,y,x+ws+FontCH[a]-xs,y+he);
//repaint;
ws:=ws+FontCH[a]-xs;
end;
end;
//restoreregion;
set_clip(0,0,getWidth,getHeight);
End;
//**********************************************************
Function String2Lines_rect(s:string;w:integer):integer;
Var buf,line:string;
ch:char;
a,i,len,xs,StrWidth,nowx:integer;
Begin
s:=ChkString(s);
len:=Length(s)-1;
Nlines:=0;
For i:= 0 to Len do
begin
ch:=GetChar(s, i);
a:= Ord(ch);
if a > 255 then a:= a - 848;
if a=32 then xs:=FontCH[32];
If a>32 then xs:=FontCH[a]-FontCH[a-1]; // xs - это ширина текущего символа
if a>=32 then Buf:=buf+ch;
If (a=32)or (a=13) then
Begin
StrWidth:=FGetTextWidth(buf);
If (nowx+StrWidth-xs>= w)or (a=13) then
Begin
nowx:=0;
Nlines:=Nlines+1;
if Nlines<=maxlines then lines[Nlines]:=Line;
Line:='';
end;
line:=line+buf;
//DrawText(buf,0,random(220));repaint;delay(1000);
nowx:=nowx+StrWidth;
buf:='';
end;
end;
if line<>'' then begin
Nlines:=Nlines+1;
lines[Nlines]:=Line;
end;
String2Lines_rect:=Nlines;
end;
//*******************************************************
Procedure TextOutREct(s:string;x,y,xx,yy:integer;center:boolean;ot:integer);
Var a,i,len,Xs,ws,he,Shirina,visota,nowX,nowY,StrWidth:integer;
buf,line:string;
ch:char;
Begin
Shirina:=xx-x;
visota:=yy-y;
nowx:=x;
nowy:=y;
//if ot<>0 then nowx:=ot;
len:=Length(s)-1;
he:=FGetTextHeight;
For i:= 0 to Len do
begin
ch:=GetChar(s, i);
a:= Ord(ch);
if a > 255 then a:= a - 848;
If (a<=255)and(a>=32) then begin
if a=32 then xs:=FontCH[32];
If a>32 then xs:=FontCH[a]-FontCH[a-1]; // xs - это ширина текущего символа
end;
if a>=32 then
Begin
Buf:=buf+ch;
end;
If (a=32)or (a=13) then {If buf<>'' then}
Begin
StrWidth:=FGetTextWidth(buf);
If (nowx+StrWidth+ot-xs> xx)or (a=13) then
begin
// nowx-x : длинна строки x - координата первая екрана (типа 0 ) xx-x :ширина екрана
if center then TextOut(line,x+(((xx-x)-(nowx-x))/2),nowY);
nowx:=x;
if not center then TextOut(line,nowx+ot,nowY);
if ot<>0 then ot:=0;
nowY:=nowy+he;
line:='';
end;
If (nowY+he<=yy)or(yy=0) then line:=line+buf; // TextOut(buf,nowx,nowY);
nowx:=nowx+StrWidth;
buf:='';
end;
end;
If (nowY+he<=yy)or(yy=0) then
begin
// nowx:=x;
if line<>'' then begin
// TextOut(line,nowx,nowY);
if center then TextOut(line,x+(((xx-x)-(nowx-x))/2),nowY);
if not center then TextOut(line,nowx+ot,nowY);
if ot<>0 then ot:=0;
end;
end;
//ws:=ws+FontCH[a]-xs;
End;
//**************************************************************************
Function NlinesInRect(x,y,xx,yy:integer):integer;//количество строк в квадрате
Var r:real;
h:integer;
Begin
h:=(FGetTextHeight+LinesHeight);
//количество строк
r:=(yy-y)/h;
NlinesInRect:=trunc(r);
end;
//**************************************************************************
Procedure TextOutREctFAST(x,y,xx,yy:integer;center:boolean;line:integer);
Var r:real;
i,nlt,too,h:integer;
Begin
h:=(FGetTextHeight+LinesHeight);
//количество строк
r:=(yy-y)/h;
nlt:=trunc(r);
If nlt>=nlines-line then too:=nlines;
If nlt<=nlines-line then too:=line+nlt;
nlt:=0;
For i:=Line to too-1 do
begin
if not center then TextOut(lines[i+1],x,y+(h*nlt))
else
Begin
TextOut(lines[i+1],x+((xx-x)-(FGetTextWidth(lines[i+1])))/2,y+(h*nlt)); // намного медленнее
end;
nlt:=nlt+1;
end;
end;
//**************************************************************************
procedure coolClear(tp:integer);//очищение экрана
Var i,j,w,h:integer;
jm:real;
begin
setcolor(0,0,0);
jm:=200/(getHeight/2);
If tp = 4 then
begin
jm:=200/(getHeight);
For i:= 0 to getHeight do begin
//setcolor(trunc(i*jm+50),trunc(i*jm+50),0);
setcolor(0,0,trunc(i*jm+50));
Drawline(0,i,getWidth,i);//repaint;delay(20);
end;
end else
For i:= 0 to getHeight/2 do begin
//setcolor(50+i*2,50+i*2,50+i*2);
if (tp=1)or(tp=3) then setcolor(trunc(i*jm+50),trunc(i*jm+50),trunc(i*jm+50));
DrawRect(i,i,getWidth-i*2,getHeight-i*2);
//DrawEllipse(0,0,i,i);
if tp<>3 then if Odd(i) then repaint;
//delay(10);
end;
end;
//*********************************************************************************
Procedure ramka(tp,x,y,xx,yy:integer);
Var i:integer;
Begin
x:=x-4;
y:=y-4;
xx:=xx+8;
yy:=yy+8;
for i:= 0 to 4 do begin
if tp = 0 then setcolor(190+i*10,190-i*10,i*5+55);
if tp = 1 then setcolor(110-i*20,110-i*20,110-i*20);
DrawRect(i+x,i+y,xx-5,yy-5);
end;
end;
//*********************************************************************************
initialization
{ add initialization code here }
end.
|
