Тема: Text2Image
Показать сообщение отдельно
Старый 05.01.2008, 21:06   #2
impersonalis
Зануда с интернетом
 
Аватар для impersonalis
 
Регистрация: 04.09.2005
Сообщений: 14,014
Написано 6,798 полезных сообщений
(для 20,935 пользователей)
Переделал с нуля (в том числе учёл нелюбовь Б3д к кирилице)
Dim Text2Image_buffer$(0)
Dim Text2Image_buffer2%(0)
Dim Text2Image_buffer3%(0)

Function AdaptText2Len$(InputString$,max%,SEP%)
	Local Rstr$=InputString
	Local P%=0
	Local P2%
	Local t%
	While P<>Len(Rstr)
		P2=Instr(Rstr,Chr(SEP),P+1)
		If P2=0 P2=Len(Rstr)
		If P2-P-1>max
			Rstr=Left(RStr,P+max)+Chr(SEP)+Mid(Rstr,P+max+1,-1)
			P2=P+max
		EndIf
		t=P2
		P2=P
		P=t
	Wend
	Return Rstr
End Function

Function TextSplit(InputString$,crt_%=0)
	Local Separator%=32
	Local Maxlen%=Len(InputString)
	If crt_=0 crt_=Ceil(Sqr(Maxlen))
	Local CRT%=crt_
	;=
	InputString$=AdaptText2Len$(InputString$,CRT,Separator)
	Maxlen%=Len(InputString)
	;=
	Local Z%
	Local Z0%
	Dim Text2Image_buffer2(Maxlen)
	Text2Image_buffer2(0)=Instr(InputString,Chr(Separator),1)
	For i=1 To Maxlen
		Text2Image_buffer2(i)=Instr(InputString,Chr(Separator),Text2Image_buffer2(i-1)+1)
		If Text2Image_buffer2(i)=0
			Exit
		EndIf
	Next
	Dim Text2Image_buffer3(Maxlen)
	Text2Image_buffer3(0)=0
	Z=0
	Z0=0
	While Text2Image_buffer2(Z)<>0
		While Text2Image_buffer2(Z)-Text2Image_buffer3(Z0)-1<=CRT And Text2Image_buffer2(Z)<>0
			Z=Z+1
		Wend
		Z0=Z0+1
		Text2Image_buffer3(Z0)=Text2Image_buffer2(Z-Sgn(Z))
	Wend
	Z0=Z0+1
	Text2Image_buffer3(Z0)=Maxlen
	Dim Text2Image_buffer$(Z0+1)
	For i=0 To Z0
		Text2Image_buffer(i)=Mid(InputString,Text2Image_buffer3(i)+1,Text2Image_buffer3(i+1)-Text2Image_buffer3(i))
	Next
	Text2Image_buffer(i)=""
	Dim Text2Image_buffer2(0)
	Dim Text2Image_buffer3(0)
End Function

Function Text2Image%(InputString$)
	TextSplit(InputString$)
	Local imX=0
	Local imY=0
	Local imXt=0
	Local imYt=0
	Local tt$
	Local X
	
	Local I
	
	I=0
	While Text2Image_buffer(i)<>""
		imXt=StringWidth(Text2Image_buffer(i))
		imYt=StringHeight(Text2Image_buffer(i))
		If imXt>imX
			imX=imXt
		EndIf
		imY=imY+imYt
		I=I+1
	Wend
	
	Local image=CreateImage(imX,imY)
	Local y=0
	SetBuffer ImageBuffer(image)
		Color 255,255,255
		Rect 0,0,imX,imY
		Color 0,0,0
		I=0
		While Text2Image_buffer(i)<>""
			X=0
			For iZ=1 To Len(Text2Image_buffer(i))
				tt=Mid(Text2Image_buffer(i),iZ,1)
				Text X,y,tt
				X=X+StringWidth(tt)
			Next
			y=y+StringHeight(Text2Image_buffer(i))
			I=I+1
		Wend
	SetBuffer BackBuffer()
	
	Dim Text2Image_buffer(0)
	Return image
End Function

SetFont LoadFont("Arial",16)
im=Text2Image("вот как так можно,а? я спросил у яндекса, генератор случайных слов, а он мне предлагает скачать песни укупника!")
DrawImage im,0,0
Flip
WaitKey()
Теперь функции нарезки сторки и формирования из нарезки картинки - разнесены
__________________
http://nabatchikov.com
Мир нужно делать лучше и чище. Иначе, зачем мы живем? tormoz
А я растила сына на преданьях
о принцах, троллях, потайных свиданьях,
погонях, похищениях невест.
Да кто же знал, что сказка душу съест?
(Offline)
 
Ответить с цитированием