abspeichern als Fontliste.pbi ohne den Demoteil
Code: Alles auswählen
;Infobox by HJBremer - Februar 2015 - 1.12, ab Purebasic 5.20(x86) Windows Vista
;Hinweis: es gibt Fonts welche sich nicht eignen für Text in einer Box
; weil Unter- und/oder Oberlängen zu groß sind.
XIncludeFile "Fontliste.pbi"
DeclareModule InfoBox
Declare.i InfoBox(pbnr, x, y, w, h, text$, flag = 0)
Declare.i InfoBox_Font(pbnr, lmr, fontname$, fontstyle = 0)
Declare.i InfoBox_Color(pbnr, left, info, right, back = #PB_Ignore)
Declare.i InfoBox_Text(pbnr, pos, text$, width = -1, flag = 0)
Macro InfoBox_Left(pbnr, text, width = -1, flag = 0)
InfoBox_Text(pbnr, 0, text, width, flag)
EndMacro
Macro InfoBox_Right(pbnr, text, width = -1, flag = 0)
InfoBox_Text(pbnr, 1, text, width, flag)
EndMacro
EndDeclareModule
Module Infobox
EnableExplicit
UseModule FontListe
Structure Infobox ;interne Struktur
pbnr.i
oldproc.i
borders.i
bkbrush.i
midpbnr.i : midhwnd.i : midcolor.i
leftpbnr.i : lefthwnd.i : leftcolor.i
rightpbnr.i: righthwnd.i: rightcolor.i
EndStructure
#leftmargin = 2 ;linker Rand
#infomargin = 3 ;Abstand zwischen den TextGadgets
#rightmargin = 2 ;rechter Rand
Global NewList infolist() ;Liste verwaltet Gadgetdaten
Procedure InfoBox_CB(hWnd, Msg, wParam, lParam)
Protected *ib.Infobox = GetWindowLongPtr_(hwnd, #GWL_USERDATA)
Protected oldwndproc = *ib\oldproc
Select msg
Case #WM_DESTROY: ;first Destroy Message (PB destroy all Childs)
Case #WM_NCDESTROY: ;last Destroy Message (PB destroy Parent)
DeleteObject_(*ib\bkbrush): FreeMemory(*ib)
Case #WM_CTLCOLORSTATIC
SetBkMode_(wParam, #TRANSPARENT) ;wParam ist das DC
Select lparam ;TextColor setzen
Case *ib\lefthwnd: SetTextColor_(wparam, *ib\leftcolor)
Case *ib\midhwnd: SetTextColor_(wparam, *ib\midcolor)
Case *ib\righthwnd: SetTextColor_(wparam, *ib\rightcolor)
EndSelect
ProcedureReturn *ib\bkbrush ;BackBrush (Color) setzen
Case #WM_SETTEXT: ; SetText umleiten aufs ChildTextgadget
msg = 0: SetGadgetText(*ib\midpbnr, PeekS(lparam))
Case #WM_COMMAND, #WM_PARENTNOTIFY: ;from RightTextGadget (Future)
EndSelect
ProcedureReturn CallWindowProc_(oldwndproc, hwnd, msg, wParam, lParam)
EndProcedure
Procedure.i InfoBox_Text(pbnr, pos, text$, width = -1, flag = 0)
Protected *ib.Infobox
Protected x, w, gadget, innerwidth, leftwidth, rightwidth
ForEach infolist()
*ib = infolist()
If *ib\pbnr = pbnr
If pos = 0: gadget = *ib\leftpbnr: Else: gadget = *ib\rightpbnr: EndIf
SetGadgetText(gadget, text$)
If width = -1: width = GadgetWidth(gadget, #PB_Gadget_RequiredSize): EndIf
innerwidth = GadgetWidth(*ib\pbnr) - *ib\borders - #leftmargin - #rightmargin
If gadget = *ib\leftpbnr
ResizeGadget(gadget, #leftmargin, 0, width, #PB_Ignore) ;TextGadget links
If width: width + #infomargin: EndIf ;Abstand danach addieren
rightwidth = GadgetWidth(*ib\rightpbnr) ;
If rightwidth: rightwidth + #infomargin: EndIf ;Abstand davor addieren
x = #leftmargin + width ;Spalte mittleres Gadget
w = innerwidth - rightwidth - width ;dessen Breite
ResizeGadget(*ib\midpbnr, x, 0, w, #PB_Ignore)
Else
x = GadgetWidth(*ib\pbnr) - *ib\borders - #rightmargin - width
ResizeGadget(gadget, x, 0, width, #PB_Ignore)
If width: width + #infomargin: EndIf
leftwidth = GadgetWidth(*ib\leftpbnr)
If leftwidth: leftwidth + #infomargin: EndIf
w = innerwidth - width - leftwidth
ResizeGadget(*ib\midpbnr, #PB_Ignore, 0, w, #PB_Ignore)
EndIf
If Bool(flag & #PB_Text_Right)
flag = GetWindowLongPtr_(GadgetID(gadget), #GWL_STYLE)
SetWindowLongPtr_(GadgetID(gadget), #GWL_STYLE, flag|#SS_RIGHT)
EndIf
EndIf
Next
ProcedureReturn width
EndProcedure
Procedure.i InfoBox_Color(pbnr, left, info, right, back = #PB_Ignore)
Protected *ib.Infobox
ForEach infolist()
*ib = infolist()
If *ib\pbnr = pbnr Or pbnr = #PB_All
If left <> #PB_Ignore: *ib\leftcolor = left: EndIf
If info <> #PB_Ignore: *ib\midcolor = info: EndIf
If right <> #PB_Ignore: *ib\rightcolor = right: EndIf
If back <> #PB_Ignore
DeleteObject_(*ib\bkbrush)
*ib\bkbrush = CreateSolidBrush_(back)
SetGadgetColor(*ib\pbnr, #PB_Gadget_BackColor, back)
EndIf
InvalidateRect_(GadgetID(*ib\pbnr), 0, 1): UpdateWindow_(GadgetID(*ib\pbnr))
;oder RedrawWindow_(GadgetID(*ib\pbnr), 0, 0, #RDW_ERASE|#RDW_INTERNALPAINT|#RDW_INVALIDATE)
EndIf
Next
EndProcedure
Procedure.i InfoBox_Font(pbnr, lmr, fontname$, fontstyle = 0)
Protected *ib.Infobox
ForEach infolist()
*ib = infolist()
If *ib\pbnr = pbnr Or pbnr = #PB_All
Select lmr
Case 0: FontSearch(*ib\leftpbnr, fontname$, FontSize(*ib\leftpbnr), fontstyle)
Case 1: FontSearch(*ib\midpbnr, fontname$, FontSize(*ib\midpbnr), fontstyle)
Case 2: FontSearch(*ib\rightpbnr, fontname$, FontSize(*ib\rightpbnr), fontstyle)
Case #PB_All
FontSearch(*ib\leftpbnr, fontname$, FontSize(*ib\leftpbnr), fontstyle)
FontSearch(*ib\midpbnr, fontname$, FontSize(*ib\midpbnr), fontstyle)
FontSearch(*ib\rightpbnr, fontname$, FontSize(*ib\rightpbnr), fontstyle)
EndSelect
EndIf
Next
EndProcedure
Procedure.i InfoBox(pbnr, x, y, w, h, text$, flag = 0)
Protected *ib.Infobox, nr, id, fonthh, fontid
If IsGadget(pbnr): FreeGadget(pbnr): EndIf
*ib = AllocateMemory(SizeOf(Infobox))
flag & ~ #PB_Text_Border ;Standard entfernen, falls existiert
flag | #SS_SUNKEN ;neuen Border setzen
*ib\borders = 2 ;je 1 links + rechts
If pbnr = #PB_Any
nr = TextGadget(#PB_Any, x, y, w, h, "", flag): id = GadgetID(nr)
Else
nr = pbnr: id = TextGadget(pbnr, x, y, w, h, "", flag)
EndIf
fonthh = FontSize(nr)
fontid = FontSearch(nr, "Arial", fonthh) ;Font zuweisen, falls abgefragt wird
With *ib
\pbnr = nr
\midpbnr = TextGadget(#PB_Any, 0, 0, 0, h, "", #SS_CENTERIMAGE|#SS_ENDELLIPSIS)
\leftpbnr = TextGadget(#PB_Any, 0, 0, 0, h, "", #SS_CENTERIMAGE|#SS_ENDELLIPSIS)
\rightpbnr = TextGadget(#PB_Any, 0, 0, 0, h, "", #SS_CENTERIMAGE|#SS_ENDELLIPSIS|#SS_NOTIFY)
SetGadgetFont(\midpbnr, fontid)
SetGadgetFont(\leftpbnr, fontid): SetGadgetFont(\rightpbnr, fontid)
SetGadgetColor(nr, #PB_Gadget_BackColor, $FAFAFA) ;#red zum Testen
\bkbrush = CreateSolidBrush_($FAFAFA) ;Backcolor für Textgadgets
\midcolor = #Blue: \leftcolor = #Gray: \rightcolor = #Gray
\midhwnd = GadgetID(\midpbnr): SetParent_(\midhwnd, id)
\lefthwnd = GadgetID(\leftpbnr): SetParent_(\lefthwnd, id)
\righthwnd = GadgetID(\rightpbnr): SetParent_(\righthwnd, id)
\oldproc = SetWindowLongPtr_(id, #GWL_WNDPROC, @InfoBox_CB())
SetWindowLongPtr_(id, #GWL_USERDATA, *ib)
;mittleres TextGadget
w = w - \borders - #leftmargin - #rightmargin
ResizeGadget(\midpbnr, #leftmargin, 0, w, #PB_Ignore)
If Bool(flag & #PB_Text_Right)
flag = GetWindowLongPtr_(\midhwnd, #GWL_STYLE)
SetWindowLongPtr_(\midhwnd, #GWL_STYLE, flag|#SS_RIGHT)
EndIf
SetGadgetText(\midpbnr, text$)
EndWith
AddElement(infolist()): infolist() = *ib
If pbnr = #PB_Any
ProcedureReturn nr
Else
ProcedureReturn id
EndIf
EndProcedure
EndModule
UseModule Infobox
OpenWindow(0, 0, 0, 320, 250, "Infobox", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
InfoBox(1, 11, 11, 200, 22, "3,99", #PB_Text_Right)
InfoBox_Left(1, "Bananen")
InfoBox_Right(1, #euro)
InfoBox(2, 11, 60, 250, 22, "100", #PB_Text_Right)
InfoBox_Left(2, "Klopapier:", 90, #PB_Text_Right)
InfoBox_Right(2, "Rollen", 66)
InfoBox(3, 11, 90, 250, 22, "22", #PB_Text_Right)
InfoBox_Left(3, "Latten:", 90, #PB_Text_Right)
InfoBox_Right(3, "3x6 cm", 66)
InfoBox(4, 11, 120, 150, 22, "45")
InfoBox_Left(4, "Schuhgröße:")
InfoBox(5, 11, 150, 100, 18, "45")
InfoBox_Left(5, "Schuhgröße:")
InfoBox(6, 11, 180, 100, 22, "1003", #PB_Text_Right)
InfoBox_Right(6, "Kg")
InfoBox_Font(1, 0, "Arial", #PB_Font_Bold|#PB_Font_Italic)
InfoBox_Left(1, "Bananen")
InfoBox_Font(2, 2, "New Times", #PB_Font_Bold)
InfoBox_Font(3, #PB_All, "Courier New")
ButtonGadget(9, 10, 210, 88, 22, "new colors")
Repeat
Event = WaitWindowEvent()
Select Event
Case #PB_Event_Gadget
Select EventGadget()
Case 9 :
InfoBox_Color(#PB_All, #Blue, #Red, #Black, #White)
SetGadgetText(1, "102,55")
InfoBox_Left(1, "Äpfel")
EndSelect
EndSelect
Until Event = #PB_Event_CloseWindow