CopyFont / CopyGadgetFont

[eddy]

Code updated for 5.20+

2 fonctions to copy some using fonts.
They work like LoadFont command.

- Result = CopyFont (#FONT, WindowHandle)
- Result = CopyGadgetFont (#FONT, #GADGET)

Code: Select all

Procedure CopyFont(Font,hwnd)
   Protected fnt.i,fntName$,fntWeight.l,fntHeight.l,fntStyle.l,fntInfo.LOGFONT
   Protected result.i
   fnt.i = SendMessage_(hwnd, #WM_GETFONT, 0, 0)
   If fnt
      GetObject_(fnt, SizeOf(LOGFONT), @fntInfo) 
      fntName$ = PeekS(@fntInfo\lfFacename)
      fntWeight.l = fntInfo\lfWeight
      fntHeight.l = Round(-fntInfo\lfHeight*72/GetDeviceCaps_(GetDC_(hwnd),#LOGPIXELSY),1)
      fntStyle=0   
      If fntInfo\lfWeight>400
         fntStyle|#PB_Font_Bold
      EndIf
      If fntInfo\lfItalic
         fntStyle|#PB_Font_Italic
      EndIf
      If fntInfo\lfUnderline
         fntStyle|#PB_Font_Underline
      EndIf
      If fntInfo\lfStrikeOut
         fntStyle|#PB_Font_StrikeOut
      EndIf
      If fntInfo\lfQuality<>#DEFAULT_QUALITY
         fntStyle|#PB_Font_HighQuality
      EndIf     
      result=LoadFont(Font,fntName$,fntHeight,fntStyle)
   EndIf
   ProcedureReturn result
EndProcedure

Procedure CopyGadgetFont(Font,Gadget)
   ProcedureReturn CopyFont(Font,GadgetID(Gadget))
EndProcedure

[srod]

Just what I was searching for.

Nice one and thanks.