Etwas gefunden...
Code:
;-TOP
; http://www.purebasic.fr/german/viewtopic.php?t=13491&start=5
Procedure.s GetFontNameFromGadget(gadget)
Protected *otm.OUTLINETEXTMETRIC
Protected bsize.l,Font.l,hWnd.l
Protected FontName.s
hWnd = GadgetID(gadget)
Font = GetGadgetFont(gadget)
hdc = GetDC_(hWnd)
Font = SelectObject_(hdc,Font)
bsize = GetOutlineTextMetrics_(hdc,0,0)
If bsize = 0
SelectObject_(hdc,Font)
ReleaseDC_(hWnd,hdc)
ProcedureReturn
EndIf
*otm = AllocateMemory(bsize)
*otm\otmSize = bsize
GetOutlineTextMetrics_(hdc,bsize,*otm)
FontName = PeekS(*otm+*otm\otmpFamilyName)
FreeMemory(*otm)
SelectObject_(hdc,Font)
ReleaseDC_(hWnd,hdc)
ProcedureReturn FontName
EndProcedure
Procedure.s GetFontStyleFromGadget(gadget)
Protected *otm.OUTLINETEXTMETRIC
Protected bsize.l,Font.l,hWnd.l
Protected FontStyle.s
hWnd = GadgetID(gadget)
Font = GetGadgetFont(gadget)
hdc = GetDC_(hWnd)
Font = SelectObject_(hdc,Font)
bsize = GetOutlineTextMetrics_(hdc,0,0)
If bsize = 0
SelectObject_(hdc,Font)
ReleaseDC_(hWnd,hdc)
ProcedureReturn
EndIf
*otm = AllocateMemory(bsize)
*otm\otmSize = bsize
GetOutlineTextMetrics_(hdc,bsize,*otm)
FontStyle = PeekS(*otm+*otm\otmpStyleName)
FreeMemory(*otm)
SelectObject_(hdc,Font)
ReleaseDC_(hWnd,hdc)
ProcedureReturn FontStyle
EndProcedure
Procedure.l GetFontSizeFromGadget(gadget)
Protected *otm.OUTLINETEXTMETRIC
Protected bsize.l,Font.l,hWnd.l
Protected FontSize.l , val.f
hWnd = GadgetID(gadget)
Font = GetGadgetFont(gadget)
hdc = GetDC_(hWnd)
Font = SelectObject_(hdc,Font)
bsize = GetOutlineTextMetrics_(hdc,0,0)
If bsize = 0
SelectObject_(hdc,Font)
ReleaseDC_(hWnd,hdc)
ProcedureReturn
EndIf
*otm = AllocateMemory(bsize)
*otm\otmSize = bsize
GetOutlineTextMetrics_(hdc,bsize,*otm)
val.f = (*otm\otmTextMetrics\tmHeight-*otm\otmTextMetrics\tmInternalLeading)
FontSize = Int(Round((val * 72 / GetDeviceCaps_(hdc,#LOGPIXELSY)),1))
FreeMemory(*otm)
SelectObject_(hdc,Font)
ReleaseDC_(hWnd,hdc)
ProcedureReturn FontSize
EndProcedure
;-TOP
Enumeration Windows
#Main
EndEnumeration
Enumeration Gadgets
EndEnumeration
Enumeration Status
#MainStatusBar
EndEnumeration
Global FontPB_V570 = LoadFont(#PB_Any, "Microsoft Sans Serif", 9)
SetGadgetFont(#PB_Default, FontID(FontPB_V570))
Procedure Main()
If OpenWindow(#Main, #PB_Ignore, #PB_Ignore, 800, 600, "Window" , #PB_Window_SystemMenu)
ButtonGadget(0, 10, 10, 120, 25, "Default")
Info$ + "Font name: " + GetFontNameFromGadget(i) + #CR$
Info$ + "Font style: " + GetFontStyleFromGadget(i) + #CR$
Info$ + "Font size: " + Str(GetFontSizeFromGadget(i)) + #CR$ + #CR$
Debug Info$
Repeat
Select WaitWindowEvent()
Case #PB_Event_CloseWindow
Break
EndSelect
ForEver
EndIf
EndProcedure : Main()