Code: Alles auswählen
;by HJBremer - Februar 2015 - 2.10, ab Purebasic 5.20(x86) Windows XP
;Hinweis für GetDC() etc.: Alles mit Create benötigt ein Delete, alles mit Get ein Release.
If Defined(euro, #PB_Constant) = 0
CompilerIf #PB_Compiler_Unicode
#euro = Chr(8364)
CompilerElse
#euro = Chr(0128)
CompilerEndIf
EndIf
DeclareModule FontListe
Declare.i FontSize(pbnr, gap = 9)
Declare.i FontSearch(pbnr, name$, fonthh, style = 0)
Declare.i GetTextWidth(pbnr, t$)
EndDeclareModule
Module FontListe
EnableExplicit
Structure FontList ;zur Verwaltung der Fonts
name.s
fontid.i
fonthh.i
style.i
EndStructure
Global NewList font.Fontlist()
Procedure.i FontSize(pbnr, gap = 9)
;welche Fonthöhe passt ins Gadget; gap steht für Rahmen + Abstand
Protected dc = GetDC_(0)
Protected gadgethh = GadgetHeight(pbnr) - gap
Protected logpixel = GetDeviceCaps_(dc, #LOGPIXELSY): ReleaseDC_(0, dc)
Protected fontsize = -MulDiv_(-gadgethh, 72, logpixel)
ProcedureReturn fontsize
EndProcedure
Procedure.i FontSearch(pbnr, name$, fonthh, style = 0)
Protected fontid
ForEach font()
If fonthh = font()\fonthh
If style = font()\style
If name$ = font()\name
fontid = font()\fontid
EndIf
EndIf
EndIf
Next
If fontid = 0
fontid = FontID(LoadFont(#PB_Any, name$, fonthh, style))
AddElement(font())
font()\fontid = fontid
font()\fonthh = fonthh
font()\style = style
font()\name = name$
EndIf
SetGadgetFont(pbnr, fontid)
ProcedureReturn fontid
EndProcedure
Procedure.i GetTextWidth(pbnr, t$)
;wie GadgetWidth(pbnr, #PB_Gadget_RequiredSize) nur ohne Border
Protected size.size, dc = GetDC_(0)
SelectObject_(dc, GetGadgetFont(pbnr))
GetTextExtentPoint32_(dc, @t$, Len(t$), size)
ReleaseDC_(0, dc)
ProcedureReturn size\cx
EndProcedure
EndModule
UseModule FontListe
OpenWindow(0, 0, 0, 270, 160, "TextGadget", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
TextGadget(0, 10, 10, 250, 20, "TextGadget Standard (Left)")
TextGadget(1, 10, 40, 250, 22, "TextGadget Center", #PB_Text_Center)
TextGadget(2, 10, 70, 250, 24, "TextGadget Right", #PB_Text_Right)
TextGadget(3, 10, 100, 250, 27, "TextGadget Border für 3 " + #euro, #PB_Text_Border)
TextGadget(4, 10, 130, 250, 30, "TextGadget Center", #PB_Text_Center | #PB_Text_Border)
fonthh = FontSize(0)
fontid = FontSearch(0, "Arial", fonthh, #PB_Font_Bold)
FontSearch(1, "Arial", FontSize(1), #PB_Font_Italic)
FontSearch(2, "Arial", FontSize(2))
FontSearch(3, "Arial", FontSize(3))
FontSearch(4, "Arial", FontSize(4))
Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow