PureBasic Forums - English

Code: Select all

Procedure EnumFontProc(*lpelf.ENUMLOGFONT, *lpntm.NEWTEXTMETRIC, FontType, lParam)
  font$ = PeekS(@*lpelf\elfLogFont\lfFaceName[0])
  LoadFont(0,font$,10)
  StartDrawing(WindowOutput(0))
    DrawingFont(FontID(0))
    tw1 = TextWidth("W")
    tw2 = TextWidth("i")
    If tw1 = tw2 And Left(font$,1) <> "@"
      AddGadgetItem (0,-1,font$)
    EndIf
  StopDrawing()
  FreeFont(0)
  ProcedureReturn 1
EndProcedure

Procedure Monospace_fonts()
  hDC = GetDC_(WindowID(0))
  EnumFontFamilies_(hDC, 0, @EnumFontProc(), 0)
  ReleaseDC_ (WindowID(0), hDC)
EndProcedure

OpenWindow(0,0,0,200,200,"Monospace Fonts",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
ListViewGadget(0,10,10,180,180)

Monospace_fonts()
Repeat    
  Select WaitWindowEvent()
    
  Case #PB_Event_CloseWindow 
      Quit = 1
      
  EndSelect
Until Quit = 1

Code: Select all

Global font$,oldfont$,hDC,item
Global NewList sList.i()

Procedure EnumFontSizes(*plf.LOGFONT,*ptm.TEXTMETRIC,FontType,lParam)
  logsize = *ptm\tmHeight - *ptm\tmInternalLeading
  pointsize  = MulDiv_(logsize, 72, GetDeviceCaps_(hdc, #LOGPIXELSY))
    Restore FontData
    For n = 0 To 15
      Read.l fsize
        If fsize <> pointsize And pointsize < 24
            AddElement(sList())
            sList() = pointsize
            ProcedureReturn 1
        Else
           ProcedureReturn 0
        EndIf      
    Next
EndProcedure

Procedure GetFontSizes(font$)
  lf.LOGFONT
  lf\lfHeight = 0
  lf\lfCharSet = #DEFAULT_CHARSET
  lf\lfPitchAndFamily = #FIXED_PITCH|#FF_DONTCARE
  PokeS(@lf\lfFaceName,font$)
  hDC = GetDC_(WindowID(0))
  EnumFontFamiliesEx_(hDC, lf, @EnumFontSizes(), 0 ,0)
  ReleaseDC_ (WindowID(0), hDC)
EndProcedure

Procedure EnumFixedFonts(*lpelfe.ENUMLOGFONTEX, *lpntme.NEWTEXTMETRICEX,FontType,lParam)
  font$ = PeekS(@*lpelfe\elfFullName) 
    If *lpelfe\elfLogFont\lfPitchAndFamily & #FIXED_PITCH And font$ <> oldfont$ And Left(font$,1) <> "@"
        AddGadgetItem (0,-1,font$)
        oldfont$ = font$
    EndIf
    ProcedureReturn 1
EndProcedure

Procedure Monospace_fonts()
  lf.LOGFONT
  lf\lfCharSet = #DEFAULT_CHARSET
  lf\lfPitchAndFamily = #FIXED_PITCH|#FF_DONTCARE
  hDC = GetDC_(WindowID(0))
  EnumFontFamiliesEx_(hDC, lf, @EnumFixedFonts(), 0 ,0)
  ReleaseDC_ (WindowID(0), hDC)
EndProcedure

LoadFont(0,"tahoma",14)
OpenWindow(0,0,0,700,300,"Monospace Fonts",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
ListIconGadget(0,10,10,680,280,"Font Name",220,#PB_ListIcon_GridLines|#PB_ListIcon_FullRowSelect)
SetGadgetFont(0,FontID(0))
AddGadgetColumn(0, 1, "Font Size",420)

Monospace_fonts()
For item = 0 To CountGadgetItems(0)-1
  GetFontSizes(GetGadgetItemText(0,item,0))
    SortList(sList(),#PB_Sort_Ascending)
    ForEach sList() 
      If sList() = curelement
        DeleteElement(sList())
      EndIf
      curelement = sList()          
    Next
    ForEach sList()      
      Text$ = Text$ +Str(slist())+" "  
    Next
    If Text$ = ""
        Text$ = "8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72"
        SetGadgetItemText(0, item, Text$ , 1)
    Else 
        SetGadgetItemText(0, item, Text$ , 1)
    EndIf
    text$ = ""
    ClearList(sList()) 
Next
Repeat    
  Select WaitWindowEvent()
    
  Case #PB_Event_CloseWindow 
      Quit = 1
      
  EndSelect
Until Quit = 1

DataSection
  FontData:
    Data.l 8, 9, 10, 11, 12, 14, 16, 18, 20, 22, 24, 26, 28, 36, 48, 72
EndDataSection

Code: Select all

FontName$ = "Arial"   ; set initial font  (could also be blank)
FontSize  = 14        ; set initial size  (could also be null)
Result = FontRequester(FontName$, FontSize, #CF_WYSIWYG|#CF_EFFECTS|#CF_FIXEDPITCHONLY )
If Result
  Message$ = "You have selected following font:"  + #LF$ 
  Message$ + "Name:  " + SelectedFontName()       + #LF$
  Message$ + "Size:  " + Str(SelectedFontSize())  + #LF$
  Message$ + "Color: " + Str(SelectedFontColor()) + #LF$
  If SelectedFontStyle() & #PB_Font_Bold
    Message$ + "Bold" + #LF$
  EndIf
  If SelectedFontStyle() & #PB_Font_StrikeOut
    Message$ + "StrikeOut" + #LF$
  EndIf
  If SelectedFontStyle() & #PB_Font_Underline
    Message$ + "Underline" + #LF$
  EndIf
Else 
  Message$ = "The requester was canceled."
EndIf

MessageRequester("FontRequester", Message$, #PB_MessageRequester_Ok)