Seite 1 von 2
Cprint(pText) - Color Print in der Konsole
Verfasst: 09.11.2004 22:49
von MVXA
Hallo !
Ich hab vor einiger Zeit eine Funktion geschrieben, die colorierten Text in der Konsole ausgibt. In der Schleife ist ein in Kommentar geseztes Delay(1). Ich habe dies wahlweise rein gemacht, wenn jemand seine CPU nicht so auslasten will. Ohne Delay(1) läuft die Procedure übrigens wesentlich schneller durch.
Code: Alles auswählen
Procedure CPrint(pText.s)
DefType.l i
DefType.s Color, tmpChar
For i = 1 To Len(pText)
If Mid(pText, i, 1) = "^"
Color = UCase(Mid(pText, i + 1, 1))
Select Color
Case "0": Color = "0" ; 0 Schwarz -_-
Case "1": Color = "1" ; 1 Blau
Case "2": Color = "2" ; 2 Grün
Case "3": Color = "3" ; 3 Türkis
Case "4": Color = "4" ; 4 Rot
Case "5": Color = "5" ; 5 Magenta
Case "6": Color = "6" ; 6 Braun
Case "7": Color = "7" ; 7 Hellgrau (Std.)
Case "8": Color = "8" ; 8 Dunkelgrau
Case "9": Color = "9" ; 9 Hellblau
Case "A": Color = "10" ; 10 Hellgrün
Case "B": Color = "11" ; 11 Cyan
Case "C": Color = "12" ; 12 Hellrot
Case "D": Color = "13" ; 13 Helles Magenta
Case "E": Color = "14" ; 14 Gelb
Case "F": Color = "15" ; 15 Weiß
EndSelect
ConsoleColor(Val(Color), 0)
i = i + 1
ElseIf Mid(pText, i, 1) = "#"
PrintN("")
Else
tmpChar = Mid(pText, i, 1): CharToOem_(@tmpChar, @tmpChar): Print(tmpChar)
EndIf
;Delay(1)
Next
ConsoleColor(7, 0)
EndProcedure
benuzt wird die Funktion so:
würde ausgeben:
Hallo
Welt
Verfasst: 09.11.2004 23:32
von Ynnus
Uff, warum verknüpfst du denn den Text mit der Farbe? Wieso machst du nicht 2 Parameter, einer für den Text und einer der direkt die Farbe angibt?
Man könnte es doch so schreiben:
Code: Alles auswählen
Procedure ColoredPrint(text$, Color)
ConsoleColor(Color, 0)
Print(text$)
ConsoleColor(7, 0)
EndProcedure
OpenConsole()
ColoredPrint("hallo Welt", 2)
Input()
closeconsole()
Dann hat man klar den String, klar die Farbe, und fertig. Die Position ist wie bei dem normalen Print. Man könnte nun noch ein "ColoredPrintN" dazu machen und das PrintN() damit ersetzen...
Verfasst: 10.11.2004 18:46
von MVXA
weil ich dank meiner funktion die farbe des textes wärend ich schreibe verändern kann.
Verfasst: 17.05.2006 14:39
von MVXA
Code: Alles auswählen
Procedure CPrint(sText.s, bHead.b = #True)
Protected *pKonsoleInfo.CONSOLE_SCREEN_BUFFER_INFO
Protected *pText.BYTE, lColor.l, lBGColor
If GetStdHandle_(#STD_OUTPUT_HANDLE)
*pKonsoleInfo = AllocateMemory(SizeOf(CONSOLE_SCREEN_BUFFER_INFO))
If *pKonsoleInfo
GetConsoleScreenBufferInfo_(GetStdHandle_(#STD_OUTPUT_HANDLE), *pKonsoleInfo)
lBGColor = (*pKonsoleInfo\wAttributes >> 4)&$FF
FreeMemory(*pKonsoleInfo)
EndIf
If bHead = #True: CPrint("^8> ", #False): ConsoleColor(7, lBGColor): EndIf
*pText = @sText
While *pText\b&$FF
Select *pText\b&$FF
Case '^': *pText + 1
If (*pText\b&$FF => '0') And (*pText\b&$FF <= 'F')
If *pText\b&$FF > 64: lColor = *pText\b&$FF - 55
Else : lColor = *pText\b&$FF - '0'
EndIf
ConsoleColor(lColor, lBGColor)
Else
*pText - 1: Print(Chr(*pText\b&$FF))
EndIf
Case 3
PrintN("")
Default
Print(Chr(*pText\b&$FF))
EndSelect
*pText + 1
Wend
ConsoleColor(7, lBGColor)
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
OpenConsole()
ConsoleColor(7, 3)
CPrint("^9h^Aa^Bl^Cl^Do" + #ETX$)
ConsoleColor(7, 6)
CPrint("^9h^Aa^Bl^Cl^Do" + #ETX$)
Input()
update
//edit:
noch ma was geupdatet, hab statt 7 da n t hin gesetzt x_X
Verfasst: 19.05.2006 09:18
von Xaby
Du kennst dich scheinbar aus.
Hast' den Text schon gesehen?
http://www.purebasic.fr/german/viewtopi ... k&start=20
Ist zwar keine bunte Schrift, aber dafür Text2Melodie.
Meine Variante ist allerdings nicht in den Hintergrund integrierbar und bestimmt auch sehr langsam. Vielleicht schaust sie dir ja mal an und wer weiß, mit ein zwei Handgriffen von dir, ist sie vielleicht dann fast so gut wie deine bunte Schrift.
Vielleicht kann man es auch irgendwie verknüpfen und einen MusikEditor draus machen, mit farbigem SyntaxHighLighting.
Danke im Voraus. Gruß, Folker
Verfasst: 28.05.2006 15:53
von DarkDragon
Code: Alles auswählen
;ConsoleSpezific
Procedure ConvertColor(Color.l)
r = Red(Color)
g = Green(Color)
b = Blue(Color)
If r>192 :r=255:ElseIf r>32:r=128:EndIf
If g>192 :g=255:ElseIf g>32:g=128:EndIf
If b>192 :b=255:ElseIf b>32:b=128:EndIf
If r= 0 And g= 0 And b= 0 : ProcedureReturn 0 : EndIf
If r= 0 And g= 0 And b=128 : ProcedureReturn 1 : EndIf
If r= 0 And g=128 And b= 0 : ProcedureReturn 2 : EndIf
If r= 0 And g=128 And b=128 : ProcedureReturn 3 : EndIf
If r=128 And g= 0 And b= 0 : ProcedureReturn 4 : EndIf
If r=128 And g= 0 And b=128 : ProcedureReturn 5 : EndIf
If r=128 And g=128 And b= 0 : ProcedureReturn 6 : EndIf
If r=128 And g=128 And b=128 : ProcedureReturn 7 : EndIf
If r= 0 And g= 0 And b=255 : ProcedureReturn 9 : EndIf
If r= 0 And g=255 And b= 0 : ProcedureReturn 10 : EndIf
If r= 0 And g=255 And b=255 : ProcedureReturn 11 : EndIf
If r=255 And g= 0 And b= 0 : ProcedureReturn 12 : EndIf
If r=255 And g= 0 And b=255 : ProcedureReturn 13 : EndIf
If r=255 And g=255 And b= 0 : ProcedureReturn 14 : EndIf
If r=255 And g=255 And b=255 : ProcedureReturn 15 : EndIf
EndProcedure
;||||||||||||||||||||
#HTML_FONT_COLOR = 2
#HTML_FONT_SIZE = 4
#HTML_FONT_FACE = 8
Procedure MyPrint(String.s)
Shared My_X, My_Y, My_SizeY
Print(String.s)
EndProcedure
Procedure MyPrintN(String.s)
Shared My_X, My_Y, My_SizeY
PrintN(String.s)
EndProcedure
Procedure MyChangeFont(Flag, Value)
Shared My_X, My_Y, My_SizeY
Select Flag
Case #HTML_FONT_COLOR
ConsoleColor(ConvertColor(Value), 0)
EndSelect
EndProcedure
;-HTML_Renderer
Procedure HexVal(a$)
a$=Trim(UCase(a$))
If Asc(a$)='$'
a$=Trim(Mid(a$,2,Len(a$)-1))
EndIf
result=0
*adr.byte=@a$
For i=1 To Len(a$)
result<<4
Select *adr\B
Case '0'
Case '1':result+1
Case '2':result+2
Case '3':result+3
Case '4':result+4
Case '5':result+5
Case '6':result+6
Case '7':result+7
Case '8':result+8
Case '9':result+9
Case 'A':result+10
Case 'B':result+11
Case 'C':result+12
Case 'D':result+13
Case 'E':result+14
Case 'F':result+15
Default:i=Len(a$)
EndSelect
*adr+1
Next
ProcedureReturn result
EndProcedure
Procedure HTMLColorCode(color.s)
Protected color2.s, k.l
For k=Len(color.s) To 1 Step -1
color2.s + Mid(color.s, k, 1)
Next
ProcedureReturn HexVal(color2)
EndProcedure
Structure HTML_Tag
name.s
prop.s
EndStructure
Structure HTML_Font
Color.l
EndStructure
NewList Tag.HTML_Tag()
Procedure.s GetProperity(PropName.s, Prop.s) ; Will filter the value of each properity(e.g. <... name="this or" color="this will be the result" ...>)
Protected i.l, char.b, cur.b, cap.l
result.s = ""
Start = FindString(LCase(Prop), LCase(PropName), 0)
If Start > 0
For i=Start-1 To Len(Prop)-1
cur = PeekB(@Prop+i)
If cap = 0
If cur = '"' Or cur = 39
cap = 1
EndIf
Else
If cur = '"' Or cur = 39
Break
Else
result + Chr(cur)
EndIf
EndIf
Next
EndIf
ProcedureReturn result
EndProcedure
Procedure.s FindLastTag(Name.s, PropName.s)
If LastElement(Tag())
Repeat
If LCase(Tag()\name) = LCase(Name)
result.s = GetProperity(PropName, Tag()\prop)
Break
EndIf
Until PreviousElement(Tag()) = 0
LastElement(Tag())
EndIf
ProcedureReturn result.s
EndProcedure
Procedure IsTag(Name.s)
If LastElement(Tag())
Repeat
If LCase(Tag()\name) = LCase(Name)
result = 1
Break
EndIf
Until PreviousElement(Tag()) = 0
LastElement(Tag())
EndIf
ProcedureReturn result
EndProcedure
Procedure.s ReplaceTag(Code.s, Tag.s, Rep.s)
Protected char.b, k.l, value.s
Start = -1
Stop = 0
For k=0 To Len(Code)-1
char.b = PeekB(@Code+k)
If char = '<'
Start = k
Stop = 0
value.s = ""
ElseIf char = '>' And Start <> -1
Stop = k+1
If LCase(Trim(value)) = LCase(Tag)
Code.s = Left(Code, Start)+Rep+Right(Code, Len(Code)-Stop)
k = Start
EndIf
Start = -1
Stop = 0
ElseIf Start <> -1 And Stop = 0
value.s + Chr(char)
EndIf
Next
ProcedureReturn Code.s
EndProcedure
Procedure ConsoleHTML(Code.s)
Protected size.l, k.l, tag_mode.l, cap_name.l, tag.s, char.b, Font.HTML_Font
size = Len(Code)
Code = ReplaceString(ReplaceTag(Code, "br", Chr(1)), " ", " ")
For k=0 To size-1
char.b = PeekB(@Code+k)
If char = '<'
tag_mode = 1
LastElement(Tag())
AddElement(Tag())
ElseIf char = '>'
;Here we will check if it is a </...> tag
If tag_mode = 1
tag.s = Trim(Tag()\name)
If PeekB(@tag) = '/'
tag = Trim(Right(tag, Len(tag)-1))
DeleteElement(Tag())
If LastElement(Tag())
Repeat
If LCase(Tag()\name) = LCase(tag)
DeleteElement(Tag())
Break
EndIf
Until PreviousElement(Tag()) = 0
EndIf
EndIf
EndIf
;Refresh the current values
Font\Color = HTMLColorCode(Trim(RemoveString(FindLastTag("font", "color"), "#")))
;Font\Size = Val(FindLastTag("font", "size"))
MyChangeFont(#HTML_FONT_COLOR, Font\Color)
;Set the modes to 0
tag_mode = 0
cap_name = 0
Else
If tag_mode = 1
If cap_name = 0
If char = ' '
tag.s = Trim(Tag()\name)
;Here we will check if it is a </...> tag
If PeekB(@tag) = '/'
tag = Trim(Right(tag, Len(tag)-1))
DeleteElement(Tag())
If LastElement(Tag())
Repeat
If LCase(Tag()\name) = LCase(tag)
DeleteElement(Tag())
Break
EndIf
Until PreviousElement(Tag()) = 0
EndIf
EndIf
cap_name = 1
Else
Tag()\name + Chr(char)
EndIf
Else
Tag()\prop + Chr(char)
EndIf
Else
If char = 1 : MyPrintN("") : ElseIf char >= 32 And char <= 128
MyPrint(Chr(char))
EndIf
EndIf
EndIf
Next
EndProcedure
Code.s = "<html>"
Code.s + "<font color="+Chr(34)+"#0000FF"+Chr(34)+">Blau<br> Blau<br>"+#LF$
Code.s + "<font color="+Chr(34)+"#FF0000"+Chr(34)+">Rot<br> Rot</font>(Blau alte<br>Farbe)</font>"+#LF$
Code.s + "</html>"
OpenConsole()
ConsoleHTML(Code.s)
PrintN("")
Input()
CloseConsole()
*übertreib*
Verfasst: 28.05.2006 16:26
von MVXA
---------------------------
PureBasic
---------------------------
Zeile 129: Tag() is not a function, array, macro or linked list
---------------------------
OK
---------------------------
Verfasst: 28.05.2006 16:31
von DarkDragon
Wer nutzt schon PB 4 wenn er PB 3.94 nutzen kann?
Verfasst: 28.05.2006 16:41
von MVXA
is neuer <_<?
Verfasst: 28.05.2006 16:42
von DarkDragon
MVXA hat geschrieben:is neuer <_<?
Ziehst wohl auch immer die neuesten Markenklamotten an, was?
Naja, mach einfach Global NewList und so Zeug, dürfte nicht mehr wie 4 mal vorkommen.
[EDIT]
Kommt nur 1 mal vor:
Code: Alles auswählen
;ConsoleSpezific
Procedure ConvertColor(Color.l)
r = Red(Color)
g = Green(Color)
b = Blue(Color)
If r>192 :r=255:ElseIf r>32:r=128:EndIf
If g>192 :g=255:ElseIf g>32:g=128:EndIf
If b>192 :b=255:ElseIf b>32:b=128:EndIf
If r= 0 And g= 0 And b= 0 : ProcedureReturn 0 : EndIf
If r= 0 And g= 0 And b=128 : ProcedureReturn 1 : EndIf
If r= 0 And g=128 And b= 0 : ProcedureReturn 2 : EndIf
If r= 0 And g=128 And b=128 : ProcedureReturn 3 : EndIf
If r=128 And g= 0 And b= 0 : ProcedureReturn 4 : EndIf
If r=128 And g= 0 And b=128 : ProcedureReturn 5 : EndIf
If r=128 And g=128 And b= 0 : ProcedureReturn 6 : EndIf
If r=128 And g=128 And b=128 : ProcedureReturn 7 : EndIf
If r= 0 And g= 0 And b=255 : ProcedureReturn 9 : EndIf
If r= 0 And g=255 And b= 0 : ProcedureReturn 10 : EndIf
If r= 0 And g=255 And b=255 : ProcedureReturn 11 : EndIf
If r=255 And g= 0 And b= 0 : ProcedureReturn 12 : EndIf
If r=255 And g= 0 And b=255 : ProcedureReturn 13 : EndIf
If r=255 And g=255 And b= 0 : ProcedureReturn 14 : EndIf
If r=255 And g=255 And b=255 : ProcedureReturn 15 : EndIf
EndProcedure
;||||||||||||||||||||
#HTML_FONT_COLOR = 2
#HTML_FONT_SIZE = 4
#HTML_FONT_FACE = 8
Procedure MyPrint(String.s)
Shared My_X, My_Y, My_SizeY
Print(String.s)
EndProcedure
Procedure MyPrintN(String.s)
Shared My_X, My_Y, My_SizeY
PrintN(String.s)
EndProcedure
Procedure MyChangeFont(Flag, Value)
Shared My_X, My_Y, My_SizeY
Select Flag
Case #HTML_FONT_COLOR
ConsoleColor(ConvertColor(Value), 0)
EndSelect
EndProcedure
;-HTML_Renderer
Procedure HexVal(a$)
a$=Trim(UCase(a$))
If Asc(a$)='$'
a$=Trim(Mid(a$,2,Len(a$)-1))
EndIf
result=0
*adr.byte=@a$
For i=1 To Len(a$)
result<<4
Select *adr\B
Case '0'
Case '1':result+1
Case '2':result+2
Case '3':result+3
Case '4':result+4
Case '5':result+5
Case '6':result+6
Case '7':result+7
Case '8':result+8
Case '9':result+9
Case 'A':result+10
Case 'B':result+11
Case 'C':result+12
Case 'D':result+13
Case 'E':result+14
Case 'F':result+15
Default:i=Len(a$)
EndSelect
*adr+1
Next
ProcedureReturn result
EndProcedure
Procedure HTMLColorCode(color.s)
Protected color2.s, k.l
For k=Len(color.s) To 1 Step -1
color2.s + Mid(color.s, k, 1)
Next
ProcedureReturn HexVal(color2)
EndProcedure
Structure HTML_Tag
name.s
prop.s
EndStructure
Structure HTML_Font
Color.l
EndStructure
Global NewList Tag.HTML_Tag()
Procedure.s GetProperity(PropName.s, Prop.s) ; Will filter the value of each properity(e.g. <... name="this or" color="this will be the result" ...>)
Protected i.l, char.b, cur.b, cap.l
result.s = ""
Start = FindString(LCase(Prop), LCase(PropName), 0)
If Start > 0
For i=Start-1 To Len(Prop)-1
cur = PeekB(@Prop+i)
If cap = 0
If cur = '"' Or cur = 39
cap = 1
EndIf
Else
If cur = '"' Or cur = 39
Break
Else
result + Chr(cur)
EndIf
EndIf
Next
EndIf
ProcedureReturn result
EndProcedure
Procedure.s FindLastTag(Name.s, PropName.s)
If LastElement(Tag())
Repeat
If LCase(Tag()\name) = LCase(Name)
result.s = GetProperity(PropName, Tag()\prop)
Break
EndIf
Until PreviousElement(Tag()) = 0
LastElement(Tag())
EndIf
ProcedureReturn result.s
EndProcedure
Procedure IsTag(Name.s)
If LastElement(Tag())
Repeat
If LCase(Tag()\name) = LCase(Name)
result = 1
Break
EndIf
Until PreviousElement(Tag()) = 0
LastElement(Tag())
EndIf
ProcedureReturn result
EndProcedure
Procedure.s ReplaceTag(Code.s, Tag.s, Rep.s)
Protected char.b, k.l, value.s
Start = -1
Stop = 0
For k=0 To Len(Code)-1
char.b = PeekB(@Code+k)
If char = '<'
Start = k
Stop = 0
value.s = ""
ElseIf char = '>' And Start <> -1
Stop = k+1
If LCase(Trim(value)) = LCase(Tag)
Code.s = Left(Code, Start)+Rep+Right(Code, Len(Code)-Stop)
k = Start
EndIf
Start = -1
Stop = 0
ElseIf Start <> -1 And Stop = 0
value.s + Chr(char)
EndIf
Next
ProcedureReturn Code.s
EndProcedure
Procedure ConsoleHTML(Code.s)
Protected size.l, k.l, tag_mode.l, cap_name.l, tag.s, char.b, Font.HTML_Font
size = Len(Code)
Code = ReplaceString(ReplaceTag(Code, "br", Chr(1)), " ", " ")
For k=0 To size-1
char.b = PeekB(@Code+k)
If char = '<'
tag_mode = 1
LastElement(Tag())
AddElement(Tag())
ElseIf char = '>'
;Here we will check if it is a </...> tag
If tag_mode = 1
tag.s = Trim(Tag()\name)
If PeekB(@tag) = '/'
tag = Trim(Right(tag, Len(tag)-1))
DeleteElement(Tag())
If LastElement(Tag())
Repeat
If LCase(Tag()\name) = LCase(tag)
DeleteElement(Tag())
Break
EndIf
Until PreviousElement(Tag()) = 0
EndIf
EndIf
EndIf
;Refresh the current values
Font\Color = HTMLColorCode(Trim(RemoveString(FindLastTag("font", "color"), "#")))
;Font\Size = Val(FindLastTag("font", "size"))
MyChangeFont(#HTML_FONT_COLOR, Font\Color)
;Set the modes to 0
tag_mode = 0
cap_name = 0
Else
If tag_mode = 1
If cap_name = 0
If char = ' '
tag.s = Trim(Tag()\name)
;Here we will check if it is a </...> tag
If PeekB(@tag) = '/'
tag = Trim(Right(tag, Len(tag)-1))
DeleteElement(Tag())
If LastElement(Tag())
Repeat
If LCase(Tag()\name) = LCase(tag)
DeleteElement(Tag())
Break
EndIf
Until PreviousElement(Tag()) = 0
EndIf
EndIf
cap_name = 1
Else
Tag()\name + Chr(char)
EndIf
Else
Tag()\prop + Chr(char)
EndIf
Else
If char = 1 : MyPrintN("") : ElseIf char >= 32 And char <= 128
MyPrint(Chr(char))
EndIf
EndIf
EndIf
Next
EndProcedure
Code.s = "<html>"
Code.s + "<font color="+Chr(34)+"#0000FF"+Chr(34)+">Blau<br> Blau<br>"+#LF$
Code.s + "<font color="+Chr(34)+"#FF0000"+Chr(34)+">Rot<br> Rot</font>(Blau alte<br>Farbe)</font>"+#LF$
Code.s + "</html>"
OpenConsole()
ConsoleHTML(Code.s)
PrintN("")
Input()
CloseConsole()