Извините, ничего не найдено.

DiS[IP] · 05.03.2006, 21:38

У меня тут интересная идея насчет своих шрифтов. Я тут поразбирался и набросал функции для шрифтов, Которым можно менять цвет. Чтобы создать такой шрифт я прогнал картинку со шрифтом через свою программу она создает из него некий бинарник каждый байт в котором указывает на следующую точку шрифта. Файл получился весьма небольшой (При шрифте 6x9 2.5 kb). Но есть ограничения длина символа не может быть более 15 пикселей

. Вот font.mpsrc

 unit font;

interface
var 
	fnt: array[32..258] of image;
 new_y: integer;
	res: resource;
	
procedure FontInit(fnm:string; fWidth, fHeight, sr, sg, sb, fr, fg, fb : integer);
function OutLongStr(str: string; x,y,x1, y1:integer):integer;

implementation

//---------------------------------------------------//

procedure FontInit(fnm:string; fWidth, fHeight, sr, sg, sb, fr, fg, fb : integer);
var 
 x, y : integer;
 bx: char;
 
begin
	x := 0;
	y := 0; 	
	bx := '1';
	
	res := OpenResource('/' + fnm);

	setcolor(fr, fg, fb);
	fillrect(0, 0, GetWidth, GetHeight);
	setcolor(sr, sg, sb);
  
	while ord(bx) <> 0 do 
 begin
  bx := Chr(ReadByte(res));
  
  if (ord(bx) = -1) then
   begin
    x := 0;
    y := y + 1;
   end
  else
   begin
   x := x + ord(bx);
    Plot(x, y);
   end;
 end; 
	CloseResource(res);
 for y:= 0 to 13 do 
 for x:= 0 to 15 do
 	fnt[y * 16 + x + 32]:= ImageFromCanvas(x*fwidth+1, y*fheight, fwidth, fheight);
end;

//---------------------------------------------------//

function OutLongStr(str: string; x,y,x1, y1:integer):integer;
var i,a,b, fx, fy : integer;
begin
 fx:= x; fy:=y;
	b:=0;
	OutLongStr:= -1;
	for i:= 0 to Length(str) - 1 do begin
  a:= Ord(GetChar(str, i));
  if a > 255 then a:= a - 848;
  fx:= x + b * GetImageWidth(fnt[32]);
  if (fx > x1 - 4) then begin
   fy:= fy + GetImageHeight(fnt[32]);
   fx:= x; b:=0;
  end;
  if fy > y1 then begin
   OutLongStr:= i;
   break;
  end; 
  DrawImage(fnt[a], fx, fy);b:=b+1;
	end;
	new_y:= fy+GetImageHeight(fnt[32]);
end;

//---------------------------------------------------//

initialization
	FontInit('font.txt', 6, 9, 0, 255, 0, 0, 0, 0);
end.

В комплекте шрифт 6x9 [attachmentid=805] и программа [attachmentid=804] для конвертации bmp => шрифт и просмотра.
Кто будет тейстить пусть отпишется сдесь

DiS[IP] · 12.03.2006, 12:45

И так вот второй вариант цветного шрифта сам тестил мне понравился
Особенности:
1. Возможность смены как самого шрифта так и его цвета во время выполнения мидлета.
2. Быстрота Инициализации около 1 сек. на Moto с380
3. Поддержка перехода на новую строку
4. Возможность отображения выделенного текста другим цветом (при отключении время инициализации уменьшается в двое!)
Минусы:
1. Максимальный размер 1 буквы равен (Ширина экрана / 16) высота равна Высоте экрана
2. Воспренимает только формат шрифта созданного конвертором (см. 1 сообщение)

Если кому нужен способ создания файла со шрифтом я опишу!

unit font;

interface
var 
	fnt: array[32..258] of image;
	caret: array[32..258] of image;
 new_y: integer;
	res: resource;
	
// Требуется передать fnm - имя файла со шрифтом, fWidth, fHeight - высота ширина буквы,
// sR, sG, sB - цвет букв, fR, fG, fB - цвет фона (прозрачный фон как сделать пока не понял) 
	
procedure FontInit(fnm:string; fWidth, fHeight, sr, sg, sb, fr, fg, fb : integer);

// Требуется передать текст и координаты прямоугольника для вывода текста
// (Подерживается символ #13 - переход на новую строку)

function OutLongStr(str: string; x,y,x1, y1:integer):integer;
function OutLongCaret(str: string; x,y,x1, y1:integer):integer;

implementation

//---------------------------------------------------//

procedure FontInit(fnm:string; fWidth, fHeight, sr, sg, sb, fr, fg, fb : integer);
var 
 x, y, k : integer;
 bx: char;
 
begin
	x := 0;
	y := 1;
	k := 0; 	
	bx := '1';
	
	res := OpenResource('/' + fnm);

	setcolor(fr, fg, fb);
	fillrect(0, 0, 128, fHeight+1);
	setcolor(sr, sg, sb);
  
	while ord(bx) <> 0 do 
 begin
  bx := Chr(ReadByte(res));
  
  if (ord(bx) = -1) then
   begin  
  	x := 0;
  	y := y + 1;   
    if (y - 1 = fHeight) then 
   begin
   
  	for x:= 0 to 15 do
     fnt[32 + k * 16 + x] := ImageFromCanvas(x*6+1, 1, fWidth, fHeight);   
     
  	setcolor(fr, fg, fb);
  	fillrect(0, 0, 128, fHeight+1);
  	setcolor(sr, sg, sb);
  	
  	y := 1;
  	x := 0;
  	k := k + 1;
    end;
   end
  else
   begin
   
    x := x + ord(bx);
    Plot(x, y);
   end;
	end; 
 
	CloseResource(res);
	setcolor(fr, fg, fb);
 fillrect(0, 0, GetWidth, GetHeight);
 setcolor(sr, sg, sb);
 
 //--------------------------------------------------//
	x := 0;
	y := 1;
	k := 0; 	
	bx := '1';
	
	res := OpenResource('/' + fnm);
	
	setcolor(sr, sg, sb);
	fillrect(0, 0, 128, fHeight+1);
	setcolor(fr, fg, fb);
  
	while ord(bx) <> 0 do 
 begin
  bx := Chr(ReadByte(res));
  
  if (ord(bx) = -1) then
   begin  
  	x := 0;
  	y := y + 1;   
    if (y - 1 = fHeight) then 
   begin
   
  	for x:= 0 to 15 do
     caret[32 + k * 16 + x] := ImageFromCanvas(x*6+1, 1, fWidth, fHeight); 
  
  	setcolor(sr, sg, sb);     
  	fillrect(0, 0, 128, fHeight+1);
  	setcolor(fr, fg, fb);
  	
  	y := 1;
  	x := 0;
  	k := k + 1;
    end;
   end
  else
   begin
   
    x := x + ord(bx);
    Plot(x, y);
   end;
	end;
 
 setcolor(sr, sg, sb); 
	CloseResource(res);
	fillrect(0, 0, GetWidth, GetHeight);
 setcolor(fr, fg, fb);

end;

//---------------------------------------------------//
 // Функция вывода текста в заданный регион 
 // Внимание! Обновления экрана производить самим!

function OutLongStr(str: string; x,y,x1, y1:integer):integer;
var i,a,b, fx, fy : integer;
begin
 fx:= x; fy:=y;
	b:=0;
	OutLongStr:= -1;
	for i:= 0 to Length(str) - 1 do begin
  a:= Ord(GetChar(str, i));
  if a > 255 then a:= a - 848;
  fx:= x + b * GetImageWidth(fnt[32]);
  if a = 13 then begin 
   fy := fy + GetImageHeight(fnt[32]);
   fx:= x; b:=0;
  end;
  if (fx > x1 - 4) then begin
   fy:= fy + GetImageHeight(fnt[32]);
   fx:= x; b:=0;
  end;
  if fy > y1 then begin
   OutLongStr:= i;
   break;
  end; 
  if a <> 13 then begin
   DrawImage(fnt[a], fx, fy);b:=b+1;
  end;
	end;
	new_y:= fy+GetImageHeight(fnt[32]);
end;

//---------------------------------------------------//
  // Печатает текст с перевернутыми цветами
  // пригодится для выделения фрагмента текста

function OutLongCaret(str: string; x,y,x1, y1:integer):integer;
var i,a,b, fx, fy : integer;
begin
 fx:= x; fy:=y;
	b:=0;
	OutLongCaret:= -1;
	for i:= 0 to Length(str) - 1 do begin
  a:= Ord(GetChar(str, i));
  if a > 255 then a:= a - 848;
  if a = 13 then begin 
   fy := fy + GetImageHeight(caret[32]);
   fx:= x; b:=0;
  end;
  fx:= x + b * GetImageWidth(caret[32]);
  if (fx > x1 - 4) then begin
   fy:= fy + GetImageHeight(caret[32]);
   fx:= x; b:=0;
  end;
  if fy > y1 then begin
   OutLongCaret:= i;
   break;
  end;
  if a <> 13 then begin 
   DrawImage(caret[a], fx, fy);b:=b+1;
  end;
	end;
	new_y:= fy+GetImageHeight(caret[32]);
end;

//---------------------------------------------------//

initialization
	//FontInit('font.txt', 6, 9, 0, 255, 0, 0, 0, 0);
end.

ViNT · 03.12.2007, 17:53

2 0vZ:
Есть у меня такая программка.
Можно сохранять в BMP, PNG и BIN(В виде чистых данных).

Используется просто:
1. Выбираешь параметры шрифта(Кнопка "Щрифт...")
2. В поле "Набор" указываешь диапазон символов.
3. Нажимаешь "Генерить" (появится изображение шрифта)
4. Нажимаешь "Сохранить как..." , выбираешь в каком формате и куда сохранить.
P.S. Если будут обнаружены глюки, просьба сообщить.

kyb66 · 03.12.2007, 18:29

Сообщение от DiS[IP]

У меня тут интересная идея насчет своих шрифтов. Я тут поразбирался и набросал функции для шрифтов, Которым можно менять цвет. Чтобы создать такой шрифт я прогнал картинку со шрифтом через свою программу она создает из него некий бинарник каждый байт в котором указывает на следующую точку шрифта. Файл получился весьма небольшой (При шрифте 6x9 2.5 kb). Но есть ограничения длина символа не может быть более 15 пикселей

. Вот font.mpsrc

 unit font;
 FontInit('font.txt', 6, 9, 0, 255, 0, 0, 0, 0);
end.

В комплекте шрифт 6x9 [attachmentid=805] и программа [attachmentid=804] для конвертации bmp => шрифт и просмотра.
Кто будет тейстить пусть отпишется сдесь

font.txt не загружается

Kurdt · 03.12.2007, 23:19

Вот делал импорт виндовых шрифтов (обробленых прогой пот винду (тоже мою))
тоесть шрфит печатается с учетом ширины и высоты каждого отдельного символа, тоесть точка и тере будет иметь разную ширину выглядет красиво...

Впринципи все работает отл... тока скорость маленькая отрисовки если идет расбеение текста на страници, сделайте алг какойто покруче если хотите, ато у меня время не стало и забросил это дело...
Я вообще хотел сделать интерпритатор формы тоесть сделать такиеже процедуры как и в форме тока все меню обрисовываются...
Это нада чтобы добится красоты и одинакового вида разных мабайлах

Если кому интересно могу выложить все сорцы проги на мп и дельфе

вот ниже срц

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.

kyb66 · 04.12.2007, 10:25

>>Kurdt
по скомпилированному примеру видно, что вестч интересная, однако в MP, когда начинаешь компилить, вылетает ряд ошибок и не хватает ешшо некого модуля :
http://yurec66.narod.ru/Vopros/errcomp.png

kyb66 · 04.12.2007, 14:26

>>Kurdt
С ошибками разобрался, когда извлек из ресурса либу требуемую. Однако вопрос остается в силе следующий: В ресурсах наряду с картинкой шрифта есть некий файл DAT. Для чего он нужен, как получается , откуда берется и т.д. Хозяин поста думает отвечать на все поставленные вопросы или где ?

Kurdt · 04.12.2007, 20:09

Там описана ширина каждого символа
Файл создается моей прогой на дельфи по хоуд можно импортировать любой шрифт виндовый создаются 2 файла.шас недома поже выложу прогу..

Kurdt · 04.12.2007, 20:10

да забыл библиотеку я еще написал для этого спец... искал способ быстрой отрисовки... для мидп 1.0 так и не нашел... (( тока возможно если ен резать картинку доится прозрачности тоесть 255 картинок, много выходит (

kyb66 · 05.12.2007, 10:32

Сообщение от Kurdt

Там описана ширина каждого символа
Файл создается моей прогой на дельфи по хоуд можно импортировать любой шрифт виндовый создаются 2 файла.шас недома поже выложу прогу..

ПО твоим словам и по содержимому dat-файла получается, что каждый символ с увиличением имеет свою ширину . Файлы в студию

Kurdt · 05.12.2007, 22:51

первое вложение прога с создателем шрфтов вторая слайдер картинок. как вам потход?)

Kurdt · 06.12.2007, 18:47

вуаля

kyb66 · 11.12.2007, 12:00

Ну раз мыло не даешь, выкладываю так на форум от твоего имени

. Несколько упростил. По своему усмотрению убрал лишнее, типа сдвиги и тени. Всеравно по коду они не корректно отрисовыались. Теперь выходной формат сразу получается PNG транспарентный. Не нужен лишний конверт.

Kurdt · 13.12.2007, 19:08

молодца

beloff · 18.12.2007, 09:33

Сообщение от Kurdt

Вот делал импорт виндовых шрифтов (обробленых прогой пот винду (тоже мою))

Что-то не компиляет.
Жалуется на im2im и на структуру модуля...