hier nun etwas einfaches. beschränkt sich auf die Funktionen des Textgadgets nur eben mehrfarbig.
Die Farben werden mit im Text verstreuten Klammern definiert. Unterschiedliche Fonts, Bilder etc sind momentan nicht vorgesehen.
Ich will es für Überschriften nutzen darum habe ich es TitleGadget genannt.
Da Canvasgadget stehen natürlich die entsprechenden EventTypes() zur Verfügung. Die Canvasflags werden nicht unterstützt.
Fehler ? was ist das ?
Code: Alles auswählen
;- Modul TitleGadget V1.00 - 05.2023 - HJBremer
;TitleGadget(pbnr, x, y, w, h, text$, flags=0, backcolor=0, fontid=0)
; ersetzt TextGadget, nur farbig
; Parameter: wie TextGadget, zusätzlich: backcolor + fontid
; Flags: nur #PB_Text_Center, #PB_Text_Right, #PB_Text_Border, keine CanvasFlags
; Beispiel text$ = "Hallo {#red}B{$aa44}a{\}nanen und {#orange}Äpfel {}sind {#blue}blau"
; Farben: {#red} PB Konstanten oder selbst definierte Farben in Procedure Text2Array()
; {$aa44} oder {$FF4400} = Hexwerte
; {} leere Klammer = Black
; {\} Backslash = zurück zur vorherigen Farbe, im Beispiel oben #red
; Vorgaben: siehe Global
DeclareModule TitleGadget
Declare.i TitleGadget(pbnr, x, y, w, h, text$, flags=0, backcolor=0, fontid=0) ;wie TextGadget
Declare.i SetTitleText(pbnr, text$) ;wie SetGadgetText
Declare.i SetTitleFont(pbnr, fontid) ;wie SetGadgetFont
Declare.i SetTitleColor(pbnr, flag, color) ;wie SetGadgetColor (color = #PB_Default nur bei BackColor)
Declare.i SetTitleBorder(pbnr, flag) ;flag = 0 oder #true
EndDeclareModule
;-
Module TitleGadget
EnableExplicit
#defaultBackColor = $F0F0F0 ;GetSysColor_(#COLOR_3DFACE) unter Windows 10
;Vorgaben: können von SetTitle...() geändert werden
Global titleFontid = FontID(LoadFont(#PB_Any, "Arial", 11))
Global titleBorder = #False
Global titleBorderColor = #Gray
Global titleBackColor = #defaultBackColor
Global titleTextColor.s = "#Blue" ;oder "#Black"
Structure TitleGadget
pbnr.i ;Purebasic Nr
text.s ;text incl.Klammern
align.i ;Ausrichtung 0=links, oder #PB_Text_Center, #PB_Text_Right
fontid.i
border.i ;0=ohne, #true mit Border
bordercolor.i
backcolor.i
EndStructure
Procedure.i Text2Array(Array text$(1), Array color(1))
;zerlegt einen String in Farbwerte und Text
Protected t$ = text$(0)
;wenn am Anfang eines Textes keine Farbe steht, dann Vorgabe
If Left(t$,1) <> "{": t$ = "{"+titleTextColor+"}" + t$: EndIf
Protected anz = CountString(t$,"{")
ReDim color(anz) : ReDim text$(anz)
Protected c$, j, f, p = 1
For j = 1 To anz
f = FindString(t$, "{", p)+1
p = FindString(t$, "}", f)
c$ = Mid(t$, f, p-f)
If FindString(c$, "#") ;PB Farben suchen + eigene hier angeben
Select LCase(c$)
Case "#red": c$ = "$0000FF"
Case "#blue": c$ = "$FF0000"
Case "#cyan": c$ = "$FFFF00"
Case "#gray": c$ = "$808080"
Case "#green": c$ = "$00FF00"
Case "#yellow": c$ = "$00FFFF"
Case "#magenta": c$ = "$FF00FF"
Case "#white": c$ = "$FFFFFF"
Case "#black": c$ = "$000000"
Case "#orange": c$ = "$007FFF" ;<-- eigene Farbe(n)
Default: c$ = "$000000"
EndSelect
EndIf
color(j) = Val(c$) ;:Debug c$
If FindString(c$, "\") ;zurück zur vorherigen Farbe {\}
If j > 1: color(j) = color(j-2): EndIf
EndIf
f = FindString(t$, "{", p) ;nächste Klammer suchen für Text nach Farbe = {#red}Text{
If f = 0: f=Len(t$)+1: EndIf ;wenn keine nächste Klammer vorhanden
text$(j) = Mid(t$,p+1, f-p-1) ;:Debug text$(j)
Next
ProcedureReturn anz
EndProcedure
Procedure.i DrawTitleText(pbnr)
Protected *data.TitleGadget = GetGadgetData(pbnr)
Protected anz, j, x, y, th, tw, gw = GadgetWidth(pbnr), gh = GadgetHeight(pbnr)
StartDrawing(CanvasOutput(pbnr))
DrawingMode(#PB_2DDrawing_Transparent)
DrawingFont(*data\fontid)
If *data\border
Box(0, 0, gw, gh, *data\bordercolor)
Box(1, 1, gw-2, gh-2, #White)
Box(2, 2, gw-2-2, gh-2-2, *data\backcolor)
x = 3
Else
Box(0, 0, gw, gh, *data\backcolor)
x = 0
EndIf
;zentriert senkrecht
th = TextHeight(*data\text)
y = ((gh-th) / 2)
;Anzahl Farben / Text
Dim color(0): Dim text$(0)
text$(0) = *data\text
anz = Text2Array(text$(), color())
;Ausrichtung
For j = 1 To anz
tw + TextWidth(text$(j)) ;ganze Textbreite ohne Klammern
Next
Select *data\align
Case 0: ;links - x siehe oben bei *data\border Box
Case 1: x = (gw - tw) / 2 ;zentriert waagerecht
Case 2: x = (gw - tw) - x ;rechtsbündig
EndSelect
;draw
For j = 1 To anz
DrawText(x, y, text$(j), color(j))
x + TextWidth(text$(j))
Next
StopDrawing()
EndProcedure
;-extern
Procedure.i SetTitleText(pbnr, text$)
Protected *data.TitleGadget
*data = GetGadgetData(pbnr)
*data\text = text$
DrawTitleText(pbnr)
EndProcedure
Procedure.i SetTitleFont(pbnr, fontid)
Protected *data.TitleGadget
If pbnr = #PB_Default ;oder #pb_any
titlefontid = fontid
Else
*data = GetGadgetData(pbnr)
*data\fontid = fontid
DrawTitleText(pbnr)
EndIf
EndProcedure
Procedure.i SetTitleBorder(pbnr, flag)
Protected *data.TitleGadget
If pbnr = #PB_Default ;oder #pb_any
titleBorder = flag
Else
*data = GetGadgetData(pbnr)
*data\border = flag
DrawTitleText(pbnr)
EndIf
EndProcedure
Procedure.i SetTitleColor(pbnr, flag, color)
Protected old$, *data.TitleGadget
Select flag
Case #PB_Gadget_BackColor
If color = #PB_Default: color = #defaultBackColor: EndIf
If pbnr = #PB_Default ;oder #pb_any
titlebackcolor = color
Else
*data = GetGadgetData(pbnr)
*data\backcolor = color
DrawTitleText(pbnr)
EndIf
Case #PB_Gadget_FrontColor
If pbnr = #PB_Default
titleTextColor = "$" + Hex(color)
Else
old$ = titleTextColor
titleTextColor = "$" + Hex(color)
DrawTitleText(pbnr)
titleTextColor = old$
EndIf
Case #PB_Gadget_LineColor
If pbnr = #PB_Default
titleBorderColor = color
Else
*data = GetGadgetData(pbnr)
*data\bordercolor = color
DrawTitleText(pbnr)
EndIf
EndSelect
EndProcedure
Procedure.i TitleGadget(pbnr, x, y, w, h, text$, flags=0, backcolor=0, fontid=0)
Protected id, nr, *data.TitleGadget = AllocateStructure(TitleGadget)
nr = CanvasGadget(pbnr, x, y, w, h)
If pbnr = #PB_Any : pbnr = nr: EndIf
*data\pbnr = pbnr
*data\text = text$
*data\align = 0
*data\fontid = titlefontid
*data\border = titleBorder
*data\bordercolor = titleBorderColor
*data\backcolor = titlebackcolor
If flags & #PB_Text_Center: *data\align = 1: EndIf
If flags & #PB_Text_Right: *data\align = 2: EndIf
If flags & #PB_Text_Border: *data\border = #True: EndIf
If fontid: *data\fontid = fontid: EndIf
If backcolor: *data\backcolor = backcolor: EndIf
SetGadgetData(pbnr, *data)
DrawTitleText(pbnr)
ProcedureReturn nr
EndProcedure
EndModule
UseModule TitleGadget
Define font = LoadFont(#PB_Any, "Arial", 16)
Define font2 = LoadFont(#PB_Any, "Arial", 10)
OpenWindow(0, 0, 0, 500, 250, "CanvasGadget", #PB_Window_SizeGadget|#PB_Window_MinimizeGadget|#PB_Window_SystemMenu | #PB_Window_ScreenCentered)
SetTitleBorder(#PB_Default, #True)
SetTitleFont(#PB_Default, FontID(font))
SetTitleColor(#PB_Default, #PB_Gadget_LineColor, #Blue)
SetTitleColor(#PB_Default, #PB_Gadget_BackColor, #Yellow)
SetTitleColor(#PB_Default, #PB_Gadget_FrontColor, #Magenta)
Define text$ = "Hallo {#red}B{$aa44}a{\}nanen und {#orange}Äpfel {}sind {#blue}blau"
Define nr = TitleGadget(#PB_Any, 11, 11, 450, 44, text$, #PB_Text_Center)
text$ = "{#yellow}Autos und Räder {#orange}haben {#blue}Reifen"
TitleGadget(10, 11, 66, 450, 40, text$, #PB_Text_Center, #Gray, FontID(font2))
ButtonGadget(11, 11, 120, 80, 24, "new text")
ButtonGadget(12, 11, 160, 80, 24, "new Font")
ButtonGadget(13, 11, 200, 80, 24, " free gadget ")
TitleGadget(20, 110, 130, 200, 30, "Ü{} b e r s c h r i f t", #PB_Text_Center)
SetTitleBorder(20, #False)
SetTitleColor(20, #PB_Gadget_BackColor, #PB_Default)
SetTitleColor(nr, #PB_Gadget_FrontColor, $d055a4)
SetTitleColor(10, #PB_Gadget_LineColor, #Red)
Repeat
Define Event = WaitWindowEvent()
Select Event
Case #PB_Event_CloseWindow ;13116
Break
Case #PB_Event_Gadget ;13100
Select EventGadget()
Case nr:
Select EventType() ;siehe Hilfe CanvasGadget
Case #PB_EventType_LeftButtonDown: Debug "LeftButtonDown"
EndSelect
Case 10 ;2.TitleGadget
Case 11
text$ = "Guten {$AA8800}Tag die Äpfel {#red}sind {#blue}blau"
SetTitleText(nr, text$)
Case 12
SetTitleFont(10, FontID(font))
Case 13
If IsGadget(nr)
FreeGadget(nr) ;hier ev. auch Structure löschen
EndIf
EndSelect
Default : ;Debug "event " + event
EndSelect
ForEver