![](images/chestnut/misc/left.gif) |
Полезные функции Выкладываем полезные функции, чтоб не изобретать велосипед заново... |
10.09.2010, 18:02
|
#1
|
Элита
Регистрация: 16.01.2008
Сообщений: 1,800
Написано 958 полезных сообщений (для 3,833 пользователей)
|
Перенос текста
Еще одна функция связанная с текстом: перенос текста по слову\букве в новый столбец + маленькое дополнение...возможность отображенния тени текста.
![](images/chestnut/misc/code_html.gif)
; ************************************************************
; * Project Name: Text Wrapp
; * Author: Dzirt (Olexander Ponomariov)
; * Date Started: 24/04/2010
; * Last Updated: 24/04/2010
; * Website: -
; * Email: [email protected]
; * Version: 1.00
; * Product: Freeware
; ************************************************************
Graphics3D 800, 600,32,2
SetFont LoadFont("Arial Cyr", 18,0,0,0)
;Увеличте этот параметр для переноса больших текстов.
Dim FuncTextM$(100)
ClsColor 125,125,125
While Not KeyHit(1)
Cls
RenderWorld
;побуквенный перенос
TextWrapp("Привет дорогой и любимый монитор!",1,10,5,0,1)
;пословный перенос
TextWrapp("Привет дорогой и любимый монитор!",100,10,80,1,1)
;пословный перенос без тени
TextWrapp("Привет дорогой и любимый монитор!",250,10,180,1,0)
Flip
Wend
WaitKey()
;---------------------------------------------------------
;MText$ - ваш текст
;Х - начальная координата Х текста
;У - начальная координата У текста
;width - максимальная ширина текста, по достижении
;которой текст будет печататся с новой строки
;WrappMode - 0. Для переноса побуквенно
; 1. Для переноса пословно(имейте введу что для коректной работы функции с
; пословным переносом, параметр width - должен быть больше чем самое длинное
; слово в вашем тексте.)
;Shadow - 0. Отрисовка текста без тени
; 1. Отрисовка текста с тенью
;---------------------------------------------------------
Function TextWrapp(MText$,x#,y#,width,WrappMode,Shadow)
;string prepare to function
MText$=MText$+" "
;get current color
red = ColorRed()
green = ColorGreen()
blue = ColorBlue()
;dlina stroki
FuncWidth=StringWidth(MText$)
;esli stroka bolwe chem dopustimaja wurina....
If FuncWidth>width
FuncText$=MText$
Numm_of_pars=(StringWidth(MText)/width)+1
If Numm_of_pars>1
For i=Len(FuncText) To 1 Step -1
FuncText$=Left(FuncText,i)
left_width=StringWidth(FuncText)
If WrappMode=1
If left_width<width And Mid(FuncText,i,1)=" " Exit
Else
If left_width<width Exit
EndIf
Next
If Shadow=1
Color 0,0,0
Text x +1.1, y+1.1, FuncText
Color red, green, blue
Text x,y,""+FuncText
Else
Text x,y,""+FuncText
EndIf
FuncTextM(1)=FuncText
minus=Len(FuncTextM(1))
For c=2 To Numm_of_pars+1
FuncTextM(c)=Mid(MText,minus+1,(Len(MText)-minus))
For i=Len(FuncTextM(c)) To 1 Step -1
FuncTextM(c)=Left(FuncTextM(c),i)
left_width=StringWidth(FuncTextM(c))
If WrappMode=1
If left_width<width And Mid(FuncTextM(c),i,1)=" " Exit
Else
If left_width<width Exit
EndIf
proba$=Mid(FuncTextM(c),i,1)
Next
If c=2
mnoj=1
Else
mnoj=c-1
EndIf
If Shadow=1
Color 0,0,0
Text x+1.1,(y+StringHeight(FuncTextM(1))*mnoj)+1.1,""+FuncTextM(c)
Color red, green, blue
Text x,y+StringHeight(FuncTextM(1))*mnoj,""+FuncTextM(c)
Else
Text x,y+StringHeight(FuncTextM(1))*mnoj,""+FuncTextM(c)
EndIf
proba$=FuncTextM(c)
minus=minus+Len(FuncTextM(c))
Next
EndIf
Else
functext$=MText
If Shadow=1
Text x,y,""+FuncText
Color 0,0,0
Text x +1.1, y+1.1, FuncText
Color red, green, blue
Else
Text x,y,""+FuncText
EndIf
EndIf
End Function
|
(Offline)
|
|
Эти 5 пользователя(ей) сказали Спасибо Dzirt за это полезное сообщение:
|
|
14.04.2012, 23:35
|
#2
|
AnyKey`щик
Регистрация: 27.08.2007
Сообщений: 17
Написано одно полезное сообщение
|
Ответ: Перенос текста
А вот упрощенный вариант (так сказать - консольный)
Function Print_f (x = 0, y = 0, ln$ = "", width = 80)
old = 1: now = 1: temp = 1: i = 0
For counter = now To Len (ln$)
now = Instr (ln$, " ", temp)
If width < (now - old) Then
Locate x, y + i
Print Mid$(ln$, old, temp - old-1)
old = temp: i = i + FontHeight () + 1
Else
temp = now + 1
EndIf
Next
Locate x, y + i
Print Mid$(ln$, old, temp - old-1)
End Function
|
(Offline)
|
|
14.04.2012, 23:37
|
#3
|
AnyKey`щик
Регистрация: 27.08.2007
Сообщений: 17
Написано одно полезное сообщение
|
Ответ: Перенос текста
кстати как решить проблемму, что Blitz режет длинные руские строки?
|
(Offline)
|
|
15.04.2012, 09:02
|
#4
|
Дэвелопер
Регистрация: 04.09.2005
Адрес: Красноярск
Сообщений: 1,376
Написано 491 полезных сообщений (для 886 пользователей)
|
Ответ: Перенос текста
Можно рисовать их побуквенно. А вообще текст в блитце тормознутый, свой рисованый шрифт лучше использовать.
|
(Offline)
|
|
Сообщение было полезно следующим пользователям:
|
|
15.04.2012, 14:23
|
#5
|
Гигант индустрии
Регистрация: 14.12.2005
Сообщений: 2,785
Написано 1,183 полезных сообщений (для 4,437 пользователей)
|
Ответ: Перенос текста
Сообщение от kostya261
кстати как решить проблемму, что Blitz режет длинные руские строки?
|
fasttext.dll
__________________
|
(Offline)
|
|
Сообщение было полезно следующим пользователям:
|
|
15.04.2012, 14:28
|
#6
|
Гигант индустрии
Регистрация: 13.09.2008
Сообщений: 2,893
Написано 1,185 полезных сообщений (для 3,298 пользователей)
|
Ответ: Перенос текста
Сообщение от kostya261
кстати как решить проблемму, что Blitz режет длинные руские строки?
|
Еще Upper и Lower не действует на кириллицу.
|
(Offline)
|
|
15.04.2012, 20:01
|
#7
|
AnyKey`щик
Регистрация: 27.08.2007
Сообщений: 17
Написано одно полезное сообщение
|
Ответ: Перенос текста
Сообщение от tormoz
fasttext.dll
|
Спасибо сейчас скачаю, попробую.
Сообщение от Nex
Еще Upper и Lower не действует на кириллицу.
|
Я в использовании этих команд ограничился только для командной строки и чтения ini файлов. Пока другого применения не нашел ![:)](images/smilies/smile.gif)
|
(Offline)
|
|
19.06.2012, 17:59
|
#8
|
Нуждающийся
Регистрация: 14.06.2012
Сообщений: 66
Написано 6 полезных сообщений (для 10 пользователей)
|
Ответ: Перенос текста
А у меня ничего не режет - дело в кривизне рук и мозгоф!
|
(Offline)
|
|
05.07.2012, 15:11
|
#9
|
Нуждающийся
Регистрация: 14.06.2012
Сообщений: 66
Написано 6 полезных сообщений (для 10 пользователей)
|
Ответ: Перенос текста
"Еще Upper и Lower не действует на кириллицу." <--- У МЕНЯ ВСЕ ДЕЙСТВУЕТ!!!
ДУМАТЬ!!!
|
(Offline)
|
|
Ваши права в разделе
|
Вы не можете создавать темы
Вы не можете отвечать на сообщения
Вы не можете прикреплять файлы
Вы не можете редактировать сообщения
HTML код Выкл.
|
|
|
Часовой пояс GMT +4, время: 23:53.
|