[WIN]-New font requester for monospaced

Share your advanced PureBasic knowledge/code with the community.
Post Reply
User avatar
flaith
Enthusiast
Enthusiast
Posts: 704
Joined: Mon Apr 25, 2005 9:28 pm
Location: $300:20 58 FC 60 - Rennes
Contact:
Contact flaith

[WIN]-New font requester for monospaced

Post by flaith »

Hi,

it's a windows only program, he's using API

You can choose to see all the fonts or only the monospaced fonts :
the include file :

Code: Select all

; FontRequesterEX.pbi
; Enumerate all or monospaced fonts available for your window
; Nicolas "flaith" Djurovic 05-2013
; Resources : 
;       * MSDN
;       * http://www.codeproject.com/Articles/30357/XMonoFontDialog-Customizing-CFontDialog-Part-II-Se
;       * Google
EnableExplicit

#SAMPLE_FONT_TXT  = "AaBbYyZz 0123456789"

Enumeration #PB_Compiler_EnumerationValue
  #WIN_FONT_DIALOG
EndEnumeration

Enumeration #PB_Compiler_EnumerationValue
  #BUTTON_OK
  #BUTTON_CANCEL
  #LIST_FONT
  #LIST_SIZE
  #CURRENT_SIZE
  #TXT_FONT
  #TXT_NB_FONT
  #TXT_SIZE
  #FRAME_SAMPLE
  #TEXT_SAMPLE
EndEnumeration

Enumeration #PB_Compiler_EnumerationValue
  #FONT_ALL
  #FONT_MONO  
EndEnumeration

Structure CS_Font
  Width.i
  Height.l
  FontList.s
  FontType.i
  Monospaced.i
  List FontSize.i()
EndStructure

Structure CS_SortFont Extends CS_Font
  FontName.s
  Element.i
EndStructure

Global NewMap AllFont.CS_Font()
Global Dim TBL_FONT.i(0)
Global FONT_HDC.i

Procedure EnumFontFamExProcSize(*elfx.ENUMLOGFONTEX,      ; pointer to logical-font Data
                                 *ntmx.NEWTEXTMETRICEX,    ; pointer to physical-font Data
                                 FontType.i,               ; font type
                                 lParam.i)                 ; pointer to application-defined Data
  Protected.i _PointSize, _index
  Protected Dim _TrueTypeSize.i(15)
  
  _TrueTypeSize(0) = 8
  _TrueTypeSize(1) = 9
  _TrueTypeSize(2) = 10
  _TrueTypeSize(3) = 11
  _TrueTypeSize(4) = 12
  _TrueTypeSize(5) = 14
  _TrueTypeSize(6) = 16
  _TrueTypeSize(7) = 18
  _TrueTypeSize(8) = 20
  _TrueTypeSize(9) = 22
  _TrueTypeSize(10) = 24
  _TrueTypeSize(11) = 26
  _TrueTypeSize(12) = 28
  _TrueTypeSize(13) = 36
  _TrueTypeSize(14) = 48
  _TrueTypeSize(15) = 72

  If FontType <> #TRUETYPE_FONTTYPE
    _PointSize = MulDiv_(*ntmx\ntmTm\tmHeight - *ntmx\ntmTm\tmInternalLeading, 72, GetDeviceCaps_(FONT_HDC, #LOGPIXELSY))

    If FontType = #RASTER_FONTTYPE
      AddElement(AllFont()\FontSize())
        AllFont()\FontSize() = _PointSize
    Else
      For _index = 0 To 15
      AddElement(AllFont()\FontSize())
        AllFont()\FontSize() = _TrueTypeSize(_index)
      Next
    EndIf
    ProcedureReturn 1           ;Continue enumeration
  Else
    For _index = 0 To 15
      AddElement(AllFont()\FontSize())
        AllFont()\FontSize() = _TrueTypeSize(_index)
    Next
    ProcedureReturn 0           ;Stop enumeration
  EndIf
EndProcedure

;Callback function processes the enumerated fonts.
Procedure EnumFontFamExProc(*elfx.ENUMLOGFONTEX, 
                             *ntmx.NEWTEXTMETRICEX,
                             FontType.i,
                             lParam.i)
  Protected tm.NEWTEXTMETRICEX         ; receives text metrics for non-TrueType fonts
  Protected Size1.SIZE
  Protected Size2.SIZE
  Protected.i _Weight    = *ntmx\ntmTm\tmWeight
	Protected.i _Family    = *ntmx\ntmTm\tmPitchAndFamily & $F0
	Protected.s _FontName  = PeekS(@*elfx\elfLogFont\lfFaceName[0])
	Protected.i _Font, _Value
  Protected.i _MonoSpaced = #False
  Protected.LOGFONT lf
  
  FontType  = *ntmx\ntmTm\tmPitchAndFamily & $6

  ;Add to the map
  AddMapElement(AllFont(), _FontName)
  AllFont()\Width      = *ntmx\ntmTm\tmAveCharWidth
  AllFont()\Height     = *ntmx\ntmTm\tmHeight
  AllFont()\FontType   = FontType
  AllFont()\FontList   = _FontName
  AllFont()\Monospaced = #False
  
  ;Create a font
  FillMemory(@lf, SizeOf(LOGFONT))
  PokeS(@lf\lfFaceName[0], _FontName)
  lf\lfWeight   = #FW_NORMAL
  lf\lfCharSet  = #DEFAULT_CHARSET
  _Font = CreateFontIndirect_(@lf)

  If _Font
    ;Get the size of each font
    EnumFontFamiliesEx_(FONT_HDC, @lf, @EnumFontFamExProcSize(), FontType, 0)
    ;Check double value and delete if found
    ForEach AllFont()\FontSize()
      _Value = AllFont()\FontSize()
      PushListPosition(AllFont()\FontSize())
      While NextElement(AllFont()\FontSize())
        If AllFont()\FontSize() = _Value
          DeleteElement(AllFont()\FontSize())
        EndIf
      Wend
      PopListPosition(AllFont()\FontSize())
    Next

    ;Now check for monospaced
    ;-Should try with TextWidth...
    SelectObject_(FONT_HDC, _Font)
    GetTextMetrics_(FONT_HDC, @tm)
    GetTextExtentPoint32_(FONT_HDC, "W", 1, @Size1)
    GetTextExtentPoint32_(FONT_HDC, "!", 1, @Size2)
    _MonoSpaced = Bool(size1\cx = size2\cx)

    If tm\ntmTm\tmCharSet = #SYMBOL_CHARSET
  	  _MonoSpaced = #False
  	EndIf
  	DeleteObject_(_Font)

  	If _MonoSpaced
  	  If FindMapElement(AllFont(), _FontName)
  	    AllFont()\Monospaced = #True
  	  EndIf
    EndIf
  EndIf

  ; Tell EnumFontFamiliesEx to continue enumeration.
  ProcedureReturn #True
EndProcedure

Procedure.i InitEnumerateFont(__WinID.i, List this.CS_SortFont())
  Protected logfont.LOGFONT  ; describes enumeration attributes

  ; Get the FONT_HDC of the current window
  FONT_HDC     = GetDC_(WindowID(__WinID))
  
  ; Initialize the structure to describe the fonts we want.
  FillMemory(@logfont, SizeOf(LOGFONT))
  logfont\lfCharSet        = #DEFAULT_CHARSET
  logfont\lfFaceName[0]    = 0
  
  ; Enumerate fonts available on window
  If EnumFontFamiliesEx_(FONT_HDC, @logfont, @EnumFontFamExProc(), 0, 0)
  Else
    ProcedureReturn #False
  EndIf
  
  ;Filling our list of font
  ForEach AllFont()
    AddElement(this())
      this()\FontName   = MapKey(AllFont())
      this()\Height     = AllFont()\Height
      this()\Width      = AllFont()\Width
      this()\FontList   = AllFont()\FontList
      this()\FontType   = AllFont()\FontType
      this()\Monospaced = AllFont()\Monospaced
      ;And each available size
      ForEach AllFont()\FontSize()
        AddElement(this()\FontSize())
          this()\FontSize() = AllFont()\FontSize()
      Next
    SortList(this()\FontSize(), #PB_Sort_Ascending)
  Next
  ; Now we add each element position (need to sort first before)
  SortStructuredList(this(), #PB_Sort_Ascending | #PB_Sort_NoCase, OffsetOf(CS_SortFont\FontName), #PB_String)
  ForEach this()
    this()\Element    = ListIndex(this())
  Next
  ProcedureReturn #True
EndProcedure

Procedure FontRequesterEX(__Type.i = #FONT_ALL, __Text.s = #SAMPLE_FONT_TXT)
  Protected.i _Quit = 0, _Index
  Protected.i _elementInCombo, _element, _Event, _SizeOfFont
  Protected.i _WinID, _FontID
  Protected Dim TBL_FONT.i(0)
  Protected NewList SortFont.CS_SortFont()

  _WinID = OpenWindow(#PB_Any, 0, 0, 360, 270, "Font Requester Dialog", #PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget)
  If _WinID
    TextGadget(#TXT_FONT, 10, 10, 70, 20, "Font:")
    TextGadget(#TXT_NB_FONT, 80, 10, 70, 20, "")
    ListViewGadget(#LIST_FONT, 10, 25, 200, 161)

    TextGadget(#TXT_SIZE, 220, 10, 40, 20, "Size:")
    StringGadget(#CURRENT_SIZE, 220, 25, 50, 17, "", #PB_String_Numeric)
    ListViewGadget(#LIST_SIZE, 220, 41, 50, 145)

    ButtonGadget(#BUTTON_OK, 280, 24, 70, 30, "OK")
    ButtonGadget(#BUTTON_CANCEL, 280, 55, 70, 30, "Cancel")

    Frame3DGadget(#FRAME_SAMPLE, 10, 190, 340, 70, "Sample")
    TextGadget(#TEXT_SAMPLE, 20, 210, 320, 40, "", #SS_CENTERIMAGE | #PB_Text_Center)

    If InitEnumerateFont(_WinID, SortFont())
      ;How many font ?
      SetGadgetText(#TXT_NB_FONT, "("+Str(ListSize(SortFont()))+")")

      ;Redim the tbl for positionning the element
      ReDim TBL_FONT(ListSize(SortFont()))

      ;Fill our GadgetList of fonts name
      _Index = 0
      If __Type = #FONT_MONO
        ForEach SortFont()
          If SortFont()\Monospaced
            AddGadgetItem(#LIST_FONT, -1, SortFont()\FontName)
            TBL_FONT(_Index) = SortFont()\Element
            _Index + 1
          EndIf
        Next
        ;How many monospaced font ?
        SetGadgetText(#TXT_NB_FONT, "("+Str(_Index)+" Mono)")
      Else
        ForEach SortFont()
          AddGadgetItem(#LIST_FONT, -1, SortFont()\FontName)
          TBL_FONT(_Index) = SortFont()\Element
          _Index + 1
        Next
      EndIf

      ;Select first font
      SetGadgetState(#LIST_FONT, 0)

      ;Get the position
      _elementInCombo = GetGadgetState(#LIST_FONT)
      If _elementInCombo >= 0
        ;Now get the position in the list
        _element = TBL_FONT(_elementInCombo)
        SelectElement(SortFont(), _element)
        ;Display all the size available for this font
        ForEach SortFont()\FontSize()
          AddGadgetItem(#LIST_SIZE, -1, Str(SortFont()\FontSize()))
        Next
      EndIf
      ;Select first size
      SetGadgetState(#LIST_SIZE, 0)
      SetGadgetText(#CURRENT_SIZE, GetGadgetItemText(#LIST_SIZE, GetGadgetState(#LIST_SIZE)))

      _SizeOfFont = Val(GetGadgetItemText(#LIST_SIZE, GetGadgetState(#LIST_SIZE)))
      ;and load the font
      _FontID = LoadFont(#PB_Any, GetGadgetItemText(#LIST_FONT, _element), _SizeOfFont)
      
      ;Draw the text with the specific font
      ClearGadgetItems(#TEXT_SAMPLE)
      SetGadgetFont(#TEXT_SAMPLE, FontID(_FontID))
      SetGadgetText(#TEXT_SAMPLE, __Text)
      FreeFont(_FontID)
      ;Focus on list of font name
      SetActiveGadget(#LIST_FONT)
    
      Repeat
        _Event = WaitWindowEvent()
        If _Event = #PB_Event_CloseWindow
          ProcedureReturn #False
        EndIf
        If _Event = #PB_Event_Gadget
          Select EventGadget()
            Case #BUTTON_OK
              _Quit = 1
            Case #BUTTON_CANCEL
              ProcedureReturn #False
            Case #CURRENT_SIZE
              _FontID = LoadFont(#PB_Any, GetGadgetItemText(#LIST_FONT, GetGadgetState(#LIST_FONT)), Val(GetGadgetText(#CURRENT_SIZE)))
              If _FontID
                ClearGadgetItems(#TEXT_SAMPLE)
                SetGadgetFont(#TEXT_SAMPLE, FontID(_FontID))
                SetGadgetText(#TEXT_SAMPLE, __Text)
                FreeFont(_FontID)
              Else
                ProcedureReturn #False
              EndIf
            Case #LIST_FONT
              _elementInCombo = GetGadgetState(#LIST_FONT)
              If _elementInCombo >= 0
                _element = TBL_FONT(_elementInCombo)
                SelectElement(SortFont(), _element)
                ClearGadgetItems(#LIST_SIZE)
                ForEach SortFont()\FontSize()
                  AddGadgetItem(#LIST_SIZE, -1, Str(SortFont()\FontSize()))
                Next
              EndIf
              SetGadgetState(#LIST_SIZE, 0)
              _FontID = LoadFont(#PB_Any, GetGadgetItemText(#LIST_FONT, GetGadgetState(#LIST_FONT)), Val(GetGadgetText(#CURRENT_SIZE)))
              If _FontID
                ClearGadgetItems(#TEXT_SAMPLE)
                SetGadgetFont(#TEXT_SAMPLE, FontID(_FontID))
                SetGadgetText(#TEXT_SAMPLE, __Text)
                FreeFont(_FontID)
              Else
                ProcedureReturn #False
              EndIf
            Case #LIST_SIZE
              SetGadgetText(#CURRENT_SIZE, GetGadgetItemText(#LIST_SIZE, GetGadgetState(#LIST_SIZE)))
              _FontID = LoadFont(#PB_Any, GetGadgetItemText(#LIST_FONT, GetGadgetState(#LIST_FONT)), Val(GetGadgetText(#CURRENT_SIZE)))
              If _FontID
                ClearGadgetItems(#TEXT_SAMPLE)
                SetGadgetFont(#TEXT_SAMPLE, FontID(_FontID))
                SetGadgetText(#TEXT_SAMPLE, __Text)
                FreeFont(_FontID)
              Else
                ProcedureReturn #False
              EndIf
          EndSelect
        EndIf
        
      Until _Quit = 1
      ProcedureReturn _FontID
    Else
      ProcedureReturn #False
    EndIf
  EndIf
EndProcedure
Example:

Code: Select all

XIncludeFile "FontRequesterEX.pbi"
Define.i FontID

FontID = FontRequesterEX(#FONT_MONO, "New font requester !")
;FontID = FontRequesterEX(#FONT_ALL)

If FontID > 0
  MessageRequester("Font Selected","You choose FontID:"+Str(FontID))
EndIf
“Fear is a reaction. Courage is a decision.” - WC
Top
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5494
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: [WIN]-New font requester for monospaced

Post by Kwai chang caine »

Hello FLAITH
Happy to see, you are always "in live" :lol:
Works great
Thanks for sharing 8)
ImageThe happiness is a road...
Not a destination
Top
User avatar
flaith
Enthusiast
Enthusiast
Posts: 704
Joined: Mon Apr 25, 2005 9:28 pm
Location: $300:20 58 FC 60 - Rennes
Contact:
Contact flaith

Re: [WIN]-New font requester for monospaced

Post by flaith »

Hi KCC :D
Yes still alive, but I come infrequently on the forum because I left France to another beautiful country :wink:
See you :)
“Fear is a reaction. Courage is a decision.” - WC
Top
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5494
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: [WIN]-New font requester for monospaced

Post by Kwai chang caine »

You have right too much country are also and even better nice than france :shock:
And it's always interesting to learning the "strange" behaviour of aliens :D
I hope you return a day in the country of wine and saussage :mrgreen:
ImageThe happiness is a road...
Not a destination
Top
User avatar
flaith
Enthusiast
Enthusiast
Posts: 704
Joined: Mon Apr 25, 2005 9:28 pm
Location: $300:20 58 FC 60 - Rennes
Contact:
Contact flaith

Re: [WIN]-New font requester for monospaced

Post by flaith »

Kwaï chang caïne wrote:You have right too much country are also and even better nice than france :shock:
And it's always interesting to learning the "strange" behaviour of aliens :D
I hope you return a day in the country of wine and saussage :mrgreen:
Thanks KCC, I will return only for holidays :wink:
Since I'm in Vietnam, my health got better, no stress, no angriness, ... and happier :D
“Fear is a reaction. Courage is a decision.” - WC
Top
Zach
Addict
Addict
Posts: 1676
Joined: Sun Dec 12, 2010 12:36 am
Location: Somewhere in the midwest
Contact:
Contact Zach

Re: [WIN]-New font requester for monospaced

Post by Zach »

....I always knew France was a sausage fest :lol:
Top
User avatar
flaith
Enthusiast
Enthusiast
Posts: 704
Joined: Mon Apr 25, 2005 9:28 pm
Location: $300:20 58 FC 60 - Rennes
Contact:
Contact flaith

Re: [WIN]-New font requester for monospaced

Post by flaith »

Zach wrote:....I always knew France was a sausage fest :lol:
Well ... :lol:
“Fear is a reaction. Courage is a decision.” - WC
Top
Post Reply

Return to “Tricks 'n' Tips”