PureBoard

;-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()