Das alte Codearchive

Buchstaben in nem "Textfield" (nicht BBPlus) Fett von hugo

Hi,

habe ein kleines Programm geschrieben, welches TextFields erstellt, deren Textman verändern kann.

dabei werden begriffe die zwischen [ b ] und [ / b] stehen fett geschrieben. also so wie hier :-)

werde demnächst noch unterstrichen und kursiv einfügen.

wenn ichs hinbekomme werden auch smilys eingefügt.

hier de code:

editiert. anderer code...

viel spaß. cu

===

von ???

neuer, verbesserter code:

[code:1:e731a08ddb]
Graphics 640,480,16,2
ClsColor 192,192,192

Type TextField
Field x%
Field y%
Field w%
Field h%
Field txt$
End Type

Global TextFieldFont_Standart = LoadFont ("Courier",10)
Global TextFieldFont_Bold = LoadFont ("Courier",10,1)
Global TextFieldFont_Italic = LoadFont ("Courier",10,0,1)
Global TextFieldFont_Underlined = LoadFont ("Courier",10,0,0,1)
Global TextFieldFont_Bold_Plus_Italic = LoadFont ("Courier",10,1,1)
Global TextFieldFont_Bold_Plus_Underlined = LoadFont ("Courier",10,1,0,1)
Global TextFieldFont_Italic_Plus_Underlined = LoadFont ("Courier",10,0,1,1)
Global TextFieldFont_Bold_Plus_Italic_Plus_Underlined = LoadFont ("Courier",10,1,1,1)

TextStr$ = TextStr$ + "Standart" + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + "[b]Fett[/b]" + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + "[i]Kursiv[/i]" + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + "[u]Unterstrichen[/u]" + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + "[b][i]Fett + Kursiv[/b][/i]" + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + "[b][u]Fett + Unterstrichen[/u][/b]" + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + "[i][u]Kursiv + Unterstrichen[/u][/i]" + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + Chr$ (10) + Chr$ (13)
TextStr$ = TextStr$ + "automatischer Zeilenumbruch............ist cool ! :-)"

TextF% = CreateTextField% (160,120,320,240)
SetTextFieldText% (TextF%,TextStr$)

Repeat
Cls

Scroller = MouseZSpeed ()
If Scroller = + 1 Then CurrentLine% = CurrentLine% - 1
If Scroller = - 1 Then CurrentLine% = CurrentLine% + 1

If CurrentLine% < 0 Then CurrentLine% = 0

ShowTextField% (TextF%,CurrentLine%)

Flip
Until KeyHit (1)

WaitKey
End

;----------------------------------- FUNCTIONs

Function CreateTextField% (x%,y%,w%,h%)
TextField.TextField = New TextField
TextFieldx% = x%
TextFieldy% = y%
TextFieldw% = w%
TextFieldh% = h%
TextField xt$ = ""
hTextField% = Handle (TextField.TextField)
Return hTextField%
End Function

Function SetTextFieldText% (hTextField%,TextFieldText$)
TextField.TextField = Object.TextField (hTextField%)
TextField xt$ = TextFieldText$
End Function

Function GetTextFieldText$ (hTextField%)
TextField.TextField = Object.TextField (hTextField%)
Return TextField xt$
End Function

Function ShowTextField% (hTextField%,TextFieldCurrentLine% = 0)
TextField.TextField = Object.TextField (hTextField%)
Color 255,255,255
Rect (TextFieldx%,TextFieldy%,TextFieldw%,TextFieldh%,0)
Color 128,128,128
Rect (TextFieldx%,TextFieldy%,TextFieldw% - 1,TextFieldh% - 1,0)
Color 223,223,223
Rect (TextFieldx% + 1,TextFieldy% + 1,TextFieldw% - 2,TextFieldh% - 2,0)
Color 0,0,0
Rect (TextFieldx% + 1,TextFieldy% + 1,TextFieldw% - 3,TextFieldh% - 3,0)
Color 255,255,255
Rect (TextFieldx% + 2,TextFieldy% + 2,TextFieldw% - 4,TextFieldh% - 4,1)
ShowTextFieldText% (hTextField%,TextFieldCurrentLine%)
End Function

Function ShowTextFieldText% (hTextField%,TextFieldCurrentLine%)
Color 0,0,0
SetFont TextFieldFont_Standart
TextField.TextField = Object.TextField (hTextField%)
TextFieldTemp2% = 0
TextFieldTemp3% = - TextFieldCurrentLine%
If TextFieldTemp3% => 0 Then TextFieldTemp3% = 0
For TextFieldTemp1% = 1 To Len (TextField xt$)
TextFieldTemp2% = TextFieldTemp2% + 1
.TextFieldVerify
TextFieldChanged = 0
If ((TextFieldTemp2% * 8) > (TextFieldw% - 6)) Or (TextFieldNextLetter$ = Chr$ (13)) Then
TextFieldTemp2% = 1
TextFieldTemp3% = TextFieldTemp3% + 1
End If
TextFieldNextLetter$ = Mid$ (TextField xt$,TextFieldTemp1%,1)
If TextFieldTemp3% => 0 Then
If TextFieldNextLetter$ = "[" Then
TextFieldNextLetterTemp$ = Mid$ (TextField xt$,TextFieldTemp1% + 1,1)
Select Upper$ (TextFieldNextLetterTemp$)
Case "B"
If Mid$ (TextField xt$,TextFieldTemp1% + 2,1) = "]" Then
TextFieldBold = 1
TextFieldChanged = 1
TextFieldTemp1% = TextFieldTemp1% + 3
TextFieldNextLetter$ = Mid$ (TextField xt$,TextFieldTemp1%,1)
End If
Case "I"
If Mid$ (TextField xt$,TextFieldTemp1% + 2,1) = "]" Then
TextFieldItalic = 1
TextFieldChanged = 1
TextFieldTemp1% = TextFieldTemp1% + 3
TextFieldNextLetter$ = Mid$ (TextField xt$,TextFieldTemp1%,1)
End If
Case "U"
If Mid$ (TextField xt$,TextFieldTemp1% + 2,1) = "]" Then
TextFieldUnderlined = 1
TextFieldChanged = 1
TextFieldTemp1% = TextFieldTemp1% + 3
TextFieldNextLetter$ = Mid$ (TextField xt$,TextFieldTemp1%,1)
End If
Case "/"
If Mid$ (Upper$ (TextField xt$),TextFieldTemp1% + 2,1) = "B" And Mid$ (TextField xt$,TextFieldTemp1% + 3,1) = "]" Then
TextFieldBold = 0
TextFieldChanged = 1
TextFieldTemp1% = TextFieldTemp1% + 4
TextFieldNextLetter$ = Mid$ (TextField xt$,TextFieldTemp1%,1)
End If
If Mid$ (Upper$ (TextField xt$),TextFieldTemp1% + 2,1) = "I" And Mid$ (TextField xt$,TextFieldTemp1% + 3,1) = "]" Then
TextFieldItalic = 0
TextFieldChanged = 1
TextFieldTemp1% = TextFieldTemp1% + 4
TextFieldNextLetter$ = Mid$ (TextField xt$,TextFieldTemp1%,1)
End If
If Mid$ (Upper$ (TextField xt$),TextFieldTemp1% + 2,1) = "U" And Mid$ (TextField xt$,TextFieldTemp1% + 3,1) = "]" Then
TextFieldUnderlined = 0
TextFieldChanged = 1
TextFieldTemp1% = TextFieldTemp1% + 4
TextFieldNextLetter$ = Mid$ (TextField xt$,TextFieldTemp1%,1)
End If
End Select
If TextFieldBold = 0 And TextFieldItalic = 0 And TextFieldUnderlined = 0 Then SetFont TextFieldFont_Standart
If TextFieldBold = 1 And TextFieldItalic = 0 And TextFieldUnderlined = 0 Then SetFont TextFieldFont_Bold
If TextFieldBold = 0 And TextFieldItalic = 1 And TextFieldUnderlined = 0 Then SetFont TextFieldFont_Italic
If TextFieldBold = 0 And TextFieldItalic = 0 And TextFieldUnderlined = 1 Then SetFont TextFieldFont_Underlined
If TextFieldBold = 1 And TextFieldItalic = 1 And TextFieldUnderlined = 0 Then SetFont TextFieldFont_Bold_Plus_Italic
If TextFieldBold = 1 And TextFieldItalic = 0 And TextFieldUnderlined = 1 Then SetFont TextFieldFont_Bold_Plus_Underlined
If TextFieldBold = 0 And TextFieldItalic = 1 And TextFieldUnderlined = 1 Then SetFont TextFieldFont_Italic_Plus_Underlined
If TextFieldBold = 1 And TextFieldItalic = 1 And TextFieldUnderlined = 1 Then SetFont TextFieldFont_Bold_Plus_Italic_Plus_Underlined
If TextFieldChanged = 1 Then Goto TextFieldVerify
End If
If (TextFieldNextLetter$ <> Chr$ (13)) And (TextFieldNextLetter$ <> Chr$ (10)) Then Text ((((TextFieldTemp2% - 1) * 8) + TextFieldx% + 3),(TextFieldy% + 3 + (TextFieldTemp3% * 12)),TextFieldNextLetter$)
End If
Next
End Function
[/code:1:e731a08ddb]

===

von ???

Sieht prima aus.

Allerdings sollte der Zeilenumbruch keine Wörter in der mitte abschneiden solange es auch anders geht. Und bei langen Texten ist das ziemlich langsam.

===

von ???

Bei mir gibts bei kursiven Schriften nen Fehler... Die Buchstaben sind einfach abgeschnitten.

===

von ???

@usernamemahe:
ist geplant mit dem umbruch. mal sehen wann ich zeit dafür finde :-)
das das so langsam ist ist mir noch nicht aufgefallen... hast du zufällig nen alten nvidia treiber ?
da ist "Text" ja immer so lahm.

@Apocalyptic
den fehler habe ich auch schon auf nem pcs gesehn (habs auf 4 getestet - bei 3 gings)
liegt aber nicht am code sondern an der hardware oder bb oder was weiß ich...
als mir der fehler aufgefallen ist hab ich die buchstaben weeeeeiiiiiit auseinadner gemacht und das wurde trotzdem abgeschnitten.
liegt wohl an den kursiven fonts allgemein... keine ahnung. das kann ich nicht beheben.

===

von ???

[quote:642b6627f6="BBPro"]@usernamemahe:
ist geplant mit dem umbruch. mal sehen wann ich zeit dafür finde :-)
das das so langsam ist ist mir noch nicht aufgefallen... hast du zufällig nen alten nvidia treiber ?
da ist "Text" ja immer so lahm.
[/quote:642b6627f6]

Naja, mein Treiber (nvidia) ist schon ca. 100 Jahre alt :wink:
Aber ich denke mit dem ganz alten gehts auch oder?

Ich werds nochmal testen wenn ich Zeit habe.

Suche:
(unterstützt mySQL Wildcards ala %)