PureBasic

Forums PureBasic
Nous sommes le Lun 22/Juil/2019 23:44

Heures au format UTC + 1 heure




Poster un nouveau sujet Répondre au sujet  [ 11 messages ] 
Auteur Message
 Sujet du message: Pure BitmapFont
MessagePosté: Ven 07/Déc/2018 18:25 
Hors ligne

Inscription: Jeu 07/Juin/2007 22:54
Messages: 261
De quoi afficher du text sans perdre tous ses PFS d'un seul coup ! Je vous présente mon module PureBF accompagné de son générateur de bitmapfont.
Le module comporte quelques effets (tremblement, text en vaguelette, clignottement). 2 moyens d'afficher du text :
Soit via affichage directe d'un text (ne permet pas l'utilisation d'effets)
Soit via un système de box qui gérera automatiquement les retour à la ligne et la succétion d'ajout de text dans cette box.
Les fonctions sont doccumentés dans le DeclareModule.
Image
(Réglé volontairement à 30 FPS pour le GIF)

Le générateur "Awesome bitmapFont Generation" (rien que ça) :
Code:
EnableExplicit

UsePNGImageEncoder()
UseLZMAPacker()

Enumeration
  #Str_Char
  #Btn_Font
  #Btn_Generate
  #Btn_Refresh
  #Btn_Load
  #Txt_Font
  #Cnv_Sample
  ;------------------Setting window----------
  #Cmb_Font
  #Chk_Bold
  #Chk_Italic
  #Chk_StrikeOut
  #Chk_Shadow
  #Btn_Color
  #Btn_ShadowColor
  #Btn_BackgroundColor
  #Str_Alpha
  #Str_OffsetX
  #Str_OffsetY
  #Str_Size
  #Str_MargeUp
  #Str_MargeDown
  #Str_MargeLeft
  #Str_MargeRight
  #Lst_Size
  #Cnv_Preview
EndEnumeration
Enumeration
  #Window_Main
  #Window_Font
EndEnumeration

Structure Font
  Name.s
  Size.c
  Shadow.a
  ShadowX.a
  ShadowY.a
  Color.i
  ShadowColor.i
  BackGroundColor.i
  FntAlpha.a
  ShadowAlpha.a
  String.s
  Height.c
  Width.c
  Flag.i
  MargeUp.C
  MargeDown.c
  MargeLeft.c
  MargeRight.c
  MaxValue.c
EndStructure

Structure Char
  X.i
  Y.i
  Width.i
  Height.i
EndStructure

Structure CFP_FONTDATA
   Type.b
   Symbol.b
   Name.s
EndStructure

Structure CFP_USERDATA
   himlFontType.i
   FontSize.b
   hwndParent.i
EndStructure

Declare OpenMainWindow()
Declare OpenFontWindow()
Declare RefreshSample()
Declare GenerateFont()
Declare Loadfnt()
Declare Close()
Declare ChangeSize()
Declare ChangeColor()
Declare Style()
Declare Shadow()
Declare ShadowAlpha()
Declare Offset()
Declare Marging()
Declare RefreshPreview()
Declare Load()
;----------------CFP fonctions declaration---------------------------
Declare CFP_CreateGagdet(Gadget,X,Y,Width,Height,ItemHeight=20,FontSize=11)
Declare.s CFP_GetGadgetText(Gadget,Item)
Declare CFP_FreeGadget(Gadget)
Declare CFP_EnumFonts(Gadget)
Declare CFP_EnumProc(*lpelfe.ENUMLOGFONTEX,*lpntme.NEWTEXTMETRICEX,FontType,lParam)
Declare CFP_WndProc(hWnd,uMsg,wParam,lParam)
Declare CFP_Change()

Global Font.font, FntList.LOGFONT
Global NewList ftd.CFP_FONTDATA()

With Font
  \Name = "Arial"
  \String = "!"+Chr(34)+"# $%&'()*+,-./0123456789:;<=>?ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюяЄІЇЎҐєіїўґÄäÀàÂâÁáÃãÅåÆæÈèÊêÉéÇçĞğÎîÍíİıÑñÖöÒòÔôÓóÕõŒœØøŞşÜüÙùÛûÚúŸÿ¿¡ßŐőŰű"
  \Size = 72
  \Shadow = 0
  \ShadowX = 5
  \ShadowY = 5
  \ShadowAlpha = 128
  \Color = RGBA(255,255,255,255)
  \ShadowColor = RGBA(0,0,0,128)
  \BackGroundColor = RGB(204,204,204)
  \FntAlpha = 255
EndWith

OpenMainWindow()
Repeat : WaitWindowEvent() : ForEver
Procedure OpenMainWindow()
  If OpenWindow(#Window_Main,0,0,1200,768,"Awesome bitmapFont Generator",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
    StringGadget(#Str_Char,10,10,1100,50,Font\String)
    ButtonGadget(#Btn_Refresh,1130,10,60,20,"Refresh")
    ButtonGadget(#Btn_Font,10,80,40,20,"Font")
    ButtonGadget(#Btn_Load,650,80,60,20,"Load")
    TextGadget(#Txt_Font,60,80,500,20,Font\Name+","+Font\Size,#PB_Text_Border)
    CanvasGadget(#Cnv_Sample,10,110,1180,628)
    ButtonGadget(#Btn_Generate,580,80,60,20,"Save")
    BindEvent(#PB_Event_CloseWindow,@Close())
    BindGadgetEvent(#Btn_Font,@OpenFontWindow())
    BindGadgetEvent(#Btn_Refresh,@RefreshSample())
    BindGadgetEvent(#Btn_Generate,@GenerateFont())
    BindGadgetEvent(#Btn_Load,@Load())
    RefreshSample()
  EndIf
EndProcedure

Procedure OpenFontWindow()
  Protected FontLoop
  If OpenWindow(#Window_Font,0,0,800,400,"Configure font",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
    TextGadget(#PB_Any,10,10,100,20,"Font :")
    TextGadget(#PB_Any,340,10,100,20,"Style :")
    TextGadget(#PB_Any,460,10,100,20,"Size :")
    CFP_CreateGagdet(#Cmb_Font,10,40,300,24)
    CheckBoxGadget(#Chk_Bold,340,40,80,20,"Bold")
    CheckBoxGadget(#Chk_Italic,340,70,80,20,"Italic")
    CheckBoxGadget(#Chk_StrikeOut,340,100,80,20,"StrikeOut")
    StringGadget(#Str_Size,460,40,150,20,Str(Font\Size),#PB_String_Numeric)
    ListViewGadget(#Lst_Size,460,60,150,60)
    TextGadget(#PB_Any,10,150,100,20,"Text color")
    CheckBoxGadget(#Chk_Shadow,10,170,100,20,"Shadow color")
    TextGadget(#PB_Any,200,150,100,20,"Background color")
    TextGadget(#PB_Any,630,40,40,20,"Padding")
    StringGadget(#Str_MargeUp,700,40,30,20,Str(Font\MargeUp),#PB_String_Numeric)
    StringGadget(#Str_MargeLeft,665,65,30,20,Str(Font\MargeLeft),#PB_String_Numeric)
    StringGadget(#Str_MargeDown,700,90,30,20,Str(Font\MargeDown),#PB_String_Numeric)
    StringGadget(#Str_MargeRight,735,65,30,20,Str(Font\MargeRight),#PB_String_Numeric)
    TextGadget(#PB_Any,700,65,30,20,"A",#PB_Text_Border|#PB_Text_Center)
    CreateImage(0,30,20)
    CreateImage(1,30,20)
    CreateImage(2,30,20)
    StartDrawing(ImageOutput(0))
    Box(0,0,30,20,Font\Color)
    StopDrawing()
    StartDrawing(ImageOutput(1))
    Box(0,0,30,20,Font\ShadowColor)
    StopDrawing()
    StartDrawing(ImageOutput(2))
    Box(0,0,30,20,Font\BackGroundColor)
    StopDrawing()
    ButtonImageGadget(#Btn_Color,150,150,30,20,ImageID(0))
    ButtonImageGadget(#Btn_ShadowColor,150,170,30,20,ImageID(1))
    ButtonImageGadget(#Btn_BackgroundColor,300,150,30,20,ImageID(2))
    TextGadget(#PB_Any,220,170,40,20,"Alpha :")
    StringGadget(#Str_Alpha,300,170,40,20,Str(Font\ShadowAlpha),#PB_String_Numeric)
    TextGadget(#PB_Any,370,170,40,20,"OffestX :")
    StringGadget(#Str_OffsetX,450,170,40,20,Str(Font\ShadowX),#PB_String_Numeric)
    TextGadget(#PB_Any,520,170,40,20,"OffsetY :")
    StringGadget(#Str_OffsetY,600,170,40,20,Str(Font\ShadowY),#PB_String_Numeric)
    CanvasGadget(#Cnv_Preview,10,200,780,180)
    For FontLoop = 0 To 14
      AddGadgetItem(#Lst_Size,-1,Str(32+FontLoop*8))
    Next FontLoop
    If Font\Shadow
      SetGadgetState(#Chk_Shadow,#PB_Checkbox_Checked)
    EndIf
    BindGadgetEvent(#Chk_Bold,@Style())
    BindGadgetEvent(#Chk_Italic,@Style())
    BindGadgetEvent(#Chk_StrikeOut,@Style())
    BindGadgetEvent(#Chk_Shadow,@Shadow())
    BindGadgetEvent(#Lst_Size,@ChangeSize(),#PB_EventType_LeftClick)
    BindGadgetEvent(#Str_Size,@ChangeSize(),#PB_EventType_Change)
    BindGadgetEvent(#Btn_Color,@ChangeColor())
    BindGadgetEvent(#Btn_ShadowColor,@ChangeColor())
    BindGadgetEvent(#Btn_BackgroundColor,@ChangeColor())
    BindGadgetEvent(#Str_Alpha,@ShadowAlpha(),#PB_EventType_Change)
    BindGadgetEvent(#Str_OffsetX,@Offset(),#PB_EventType_Change)
    BindGadgetEvent(#Str_OffsetY,@Offset(),#PB_EventType_Change)
    BindGadgetEvent(#Str_MargeDown,@Marging(),#PB_EventType_Change)
    BindGadgetEvent(#Str_MargeLeft,@Marging(),#PB_EventType_Change)
    BindGadgetEvent(#Str_MargeRight,@Marging(),#PB_EventType_Change)
    BindGadgetEvent(#Str_MargeUp,@Marging(),#PB_EventType_Change)
    RefreshPreview()
  EndIf
EndProcedure

Procedure Load()
  Protected File$, *Buffer
  File$ = OpenFileRequester("Load file",GetCurrentDirectory(),"Font file(*.afg) | *.afg",0)
  If File$
    OpenPack(0,File$,#PB_PackerPlugin_Lzma )
    ExaminePack(0)
    NextPackEntry(0)
    *Buffer = AllocateMemory(PackEntrySize(0))
    UncompressPackMemory(0,*Buffer,MemorySize(*Buffer),PackEntryName(0))
    ClosePack(0)
    CatchJSON(0,*Buffer,MemorySize(*Buffer))
    ExtractJSONStructure(JSONValue(0),@Font,Font)
    FreeMemory(*Buffer)
    RefreshSample()
  EndIf
EndProcedure

Procedure GenerateFont()
  Font\String = GetGadgetText(#Str_Char)
  Protected X = Font\Width * 14, Y = Font\Height * Round((Len(Font\String)/14),#PB_Round_Up)
  Protected Img, LoopX, LoopY,OffsetX,OffsetY, JsonData, *Buffer,JsonSize,Temp$
  Protected NewMap Charset.char()
  X + 14 * (Font\MargeLeft+Font\MargeRight)
  Y + Round((Len(Font\String)/14),#PB_Round_Up) * (Font\MargeUp+Font\MargeDown)
  img = CreateImage(#PB_Any,X,Y,32,#PB_Image_Transparent)
  If img
    StartDrawing(ImageOutput(img))
    DrawingMode(#PB_2DDrawing_Transparent|#PB_2DDrawing_AlphaBlend)
    DrawingFont(FontID(0))
    For Loopy = 0 To Y/Font\Height-1
      For LoopX = 0 To 14
        If Font\Shadow
          DrawText(LoopX * Font\Width + Font\ShadowX + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight , LoopY * Font\Height + Font\ShadowY + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown, Mid(Font\String,(LoopX+1)+LoopY * 14,1),Font\ShadowColor)
          OffsetX = Font\ShadowX
          OffsetY = Font\ShadowY
        Else
          OffsetX = 0 : OffsetY = 0
        EndIf
        DrawText(LoopX * Font\Width + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight, LoopY * Font\Height + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown, Mid(Font\String,(LoopX+1)+LoopY * 14,1),Font\Color)
        If Not Mid(Font\String,(LoopX+1)+LoopY * 14,1) = ""
          Temp$ = Mid(Font\String,(LoopX+1)+LoopY * 14,1)
          If PeekC(@Temp$) > Font\MaxValue
            Font\MaxValue = PeekC(@Temp$)
          EndIf
          Charset(Mid(Font\String,(LoopX+1)+LoopY * 14,1))\X = LoopX * Font\Width + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight
          Charset()\Y = LoopY * Font\Height + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown
          Charset()\Height = TextHeight(Mid(Font\String,(LoopX+1)+LoopY * 14,1))+OffsetX + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight
          Charset()\Width = TextWidth(Mid(Font\String,(LoopX+1)+LoopY * 14,1))+OffsetY + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown
        EndIf
      Next LoopX
    Next LoopY
    StopDrawing()
    CreateJSON(0)
    InsertJSONStructure(JSONValue(0),@Font,Font)
    JsonData = AddJSONMember(JSONValue(0),"Chardata")
    InsertJSONMap(JsonData,Charset())
    *Buffer = AllocateMemory(ExportJSONSize(0))
    ExportJSON(0,*Buffer,MemorySize(*Buffer))
    CreatePack(0,Font\Name+".afg",#PB_PackerPlugin_Lzma)
    AddPackMemory(0,*Buffer,MemorySize(*Buffer),Font\Name+".json")
    FreeMemory(*Buffer)
    *Buffer = EncodeImage(img,#PB_ImagePlugin_PNG)
    AddPackMemory(0,*Buffer,MemorySize(*Buffer),Font\Name+".png")
    FreeMemory(*Buffer)
    ClosePack(0)   
    FreeImage(img)
    FreeJSON(0)
    MessageRequester("Awesome bitmapFont Generator","Font succefully generated")
    ProcedureReturn #True
  EndIf
  MessageRequester("Awesome bitmapFont Generator","An error has ocurred...")
EndProcedure

Procedure RefreshSample()
  Protected LoopX,LoopY, x, y, str$ = GetGadgetText(#Str_Char)
  Loadfnt()
  StartDrawing(CanvasOutput(#Cnv_Sample))
  Box(0,0,1180,628,Font\BackGroundColor)
  DrawingFont(FontID(0))
  DrawingMode(#PB_2DDrawing_Transparent|#PB_2DDrawing_AlphaBlend)
  Font\Height = TextHeight("A")
  Font\Width = TextWidth("A")+30
  x = 1180/Font\Width +1
  y = 628 / Font\Height
  For LoopY = 0 To y
    For LoopX = 0 To x
      If Font\Shadow
        DrawText(LoopX * Font\Width + Font\ShadowX,LoopY * Font\Height + Font\ShadowY,Mid(str$,LoopX + LoopY * x+1,1),Font\ShadowColor)
      EndIf
      DrawText(LoopX * Font\Width,LoopY * Font\Height,Mid(str$,LoopX + LoopY * x+1,1),Font\Color)
    Next LoopX
  Next LoopY
  StopDrawing()
EndProcedure

Procedure ChangeSize()
  If EventGadget() = #Lst_Size
    SetGadgetText(#Str_Size,GetGadgetText(#Lst_Size))
  EndIf
  font\Size = Val(GetGadgetText(#Str_Size))
  Loadfnt()
  RefreshPreview()
EndProcedure

Procedure Loadfnt()
  LoadFont(0,Font\Name,font\Size,Font\Flag)
EndProcedure

Procedure Marging()
  Select EventGadget()
    Case #Str_MargeDown
      Font\MargeDown = Val(GetGadgetText(#Str_MargeDown))
    Case #Str_MargeLeft
      Font\MargeLeft = Val(GetGadgetText(#Str_MargeLeft))
    Case #Str_MargeRight
      Font\MargeRight = Val(GetGadgetText(#Str_MargeRight))
    Case #Str_MargeUp
      Font\MargeUp = Val(GetGadgetText(#Str_MargeUp))
  EndSelect
EndProcedure

Procedure ChangeColor()
  Protected Color
  If EventGadget() = #Btn_Color
    Color = ColorRequester(font\Color)
    If Not Color = -1
      Font\Color = RGBA(Red(Color),Green(Color),Blue(Color),255)
    StartDrawing(ImageOutput(0))
    Box(0,0,30,20,Color)
    StopDrawing()
    EndIf
  ElseIf EventGadget() = #Btn_ShadowColor
    Color = ColorRequester(font\ShadowColor)
    If Not Color = -1
      Font\ShadowColor = RGBA(Red(Color),Green(Color),Blue(Color),Val(GetGadgetText(#Str_Alpha)))
    StartDrawing(ImageOutput(1))
    Box(0,0,30,20,Color)
    StopDrawing()
    EndIf
  Else
    Color = ColorRequester(Font\BackGroundColor)
    If Not Color = -1
      Font\BackGroundColor = Color
    StartDrawing(ImageOutput(2))
    Box(0,0,30,20,Color)
    StopDrawing()
    EndIf
  EndIf
  If Not Color = -1
    RefreshPreview()
  EndIf
EndProcedure

Procedure Style()
  font\Flag = 0
  If GetGadgetState(#Chk_Bold) = #PB_Checkbox_Checked
    Font\Flag | #PB_Font_Bold
  EndIf
  If GetGadgetState(#Chk_Italic) = #PB_Checkbox_Checked
    Font\Flag | #PB_Font_Italic
  EndIf
  If GetGadgetState(#Chk_StrikeOut) = #PB_Checkbox_Checked
    Font\Flag | #PB_Font_StrikeOut
  EndIf
  Loadfnt()
  RefreshPreview()
EndProcedure

Procedure Offset()
  Font\ShadowX = Val(GetGadgetText(EventGadget()))
  RefreshPreview()
EndProcedure

Procedure ShadowAlpha()
  Font\ShadowAlpha = Val(GetGadgetText(#Str_Alpha))
  Font\ShadowColor = RGBA(Red(Font\ShadowColor),Green(Font\ShadowColor),Blue(Font\ShadowColor),Font\ShadowAlpha)
  RefreshPreview()
EndProcedure

Procedure Shadow()
  If GetGadgetState(#Chk_Shadow) = #PB_Checkbox_Checked
    Font\Shadow = 1
  Else
    Font\Shadow = 0
  EndIf
  RefreshPreview()
EndProcedure

Procedure RefreshPreview()
  StartDrawing(CanvasOutput(#Cnv_Preview))
  Box(0,0,780,180,Font\BackGroundColor)
  DrawingMode(#PB_2DDrawing_Transparent|#PB_2DDrawing_AlphaBlend)
  DrawingFont(FontID(0))
  If Font\Shadow
    DrawText(10+Font\ShadowX,10+Font\ShadowY,"The quick brown fox jumped over the lazy dog.",Font\ShadowColor)
  EndIf
  DrawText(10,10,"The quick brown fox jumped over the lazy dog.",Font\Color)
  StopDrawing()
EndProcedure

Procedure Close()
  If GetActiveWindow() = #Window_Main
    End
  Else
    CFP_FreeGadget(101)
    CloseWindow(#Window_Font)
    FreeImage(0)
    FreeImage(1)
    FreeImage(2)
    SetGadgetText(#Txt_Font,Font\Name+","+Font\Size)
    RefreshSample()
  EndIf
EndProcedure

;===============================================================
;Display font with style & icon ================================
; Title: Font Preview ComboBox =================================
; Author: Fluid Byte ===========================================
; Platform: Windows ============================================
; Created: Jan 27, 2009 ========================================
; Updated: May 29, 2017 ========================================
; E-Mail: fluidbyte@web.de =====================================
;http://forums.purebasic.com/english/viewtopic.php?f=12&t=36198=
;===============================================================

Procedure CFP_Change()
  Font\Name = CFP_GetGadgetText(#Cmb_Font,GetGadgetState(#Cmb_Font))
  Loadfnt()
  RefreshPreview()
EndProcedure

Procedure CFP_CreateGagdet(Gadget,X,Y,Width,Height,ItemHeight=20,FontSize=11)
   Protected himlFontType, hwndParent, *cfpu.CFP_USERDATA
   
   himlFontType = ImageList_Create_(16,12,#ILC_MASK,0,0)
   ImageList_AddMasked_(himlFontType,CatchImage(0,?FontType),#Yellow)   
     
   hwndParent = GadgetID(ContainerGadget(#PB_Any,X,Y,Width,Height))
   ComboBoxGadget(Gadget,0,0,Width,Height,#CBS_OWNERDRAWFIXED)
   SendMessage_(GadgetID(Gadget),#CB_SETITEMHEIGHT,0,ItemHeight)   
   CloseGadgetList()
   
   *cfpu = AllocateMemory(SizeOf(CFP_USERDATA))
   *cfpu\himlFontType = himlFontType
   *cfpu\FontSize = FontSize
   *cfpu\hwndParent = hwndParent
   SetWindowLongPtr_(GadgetID(Gadget),#GWLP_USERDATA,*cfpu)
   
   SetWindowLongPtr_(hwndParent,#GWL_WNDPROC,@CFP_WndProc())
   
   CFP_EnumFonts(Gadget)
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure.s CFP_GetGadgetText(Gadget,Item)
   If IsGadget(Gadget)
      Protected *cfpf.CFP_FONTDATA
      *cfpf = GetGadgetItemData(Gadget,Item)     
      ProcedureReturn *cfpf\Name
   EndIf
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_FreeGadget(Gadget)
   If IsGadget(Gadget)
      Protected *cfpu.CFP_USERDATA, Result
     
      *cfpu = GetWindowLongPtr_(GadgetID(Gadget),#GWLP_USERDATA)

      If *cfpu
         Result = ImageList_Destroy_(*cfpu\himlFontType)
         
         If Result : Result = FreeMemory(*cfpu) : EndIf
      EndIf
   EndIf
   
   ProcedureReturn Result
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_WndProc(hWnd,uMsg,wParam,lParam)
  Select uMsg
    Case #WM_COMMAND
      Select (wParam >> 16) & $ffff
        Case  #CBN_SELCHANGE
          CFP_Change()
      EndSelect
    Case #WM_DRAWITEM
      Protected *lpdis.DRAWITEMSTRUCT = lParam   
     
      ; --- Draw item focus rectangle or normal state     
      If *lpdis\itemState & #ODS_SELECTED
         Protected hbrFocus = CreateSolidBrush_(GetSysColor_(#COLOR_HIGHLIGHT))
         FillRect_(*lpdis\hDC,*lpdis\rcItem,hbrFocus)
         DeleteObject_(hbrFocus)
         DrawFocusRect_(*lpdis\hDC,*lpdis\rcItem)           
         SetTextColor_(*lpdis\hDC,GetSysColor_(#COLOR_HIGHLIGHTTEXT))
      Else
         Protected hbrFace = CreateSolidBrush_(GetSysColor_(#COLOR_WINDOW))
         FillRect_(*lpdis\hDC,*lpdis\rcItem,hbrFace)
         DeleteObject_(hbrFace)
         SetTextColor_(*lpdis\hDC,GetSysColor_(#COLOR_WINDOWTEXT))
      EndIf   
 
      Protected *ftd.CFP_FONTDATA = GetGadgetItemData(wParam,*lpdis\itemID)         
      Protected *cfpu.CFP_USERDATA = GetWindowLongPtr_(*lpdis\hwndItem,#GWLP_USERDATA)
 
      ; --- Draw Font Icons
      If *ftd\Type > -1
         ImageList_Draw_(*cfpu\himlFontType,*ftd\Type,*lpdis\hDC,2,*lpdis\rcItem\top + 3,#ILD_TRANSPARENT)
      EndIf
     
      ; --- Create Preview Font
      Protected lplf.LOGFONT, hfntPreview
     
      lplf\lfHeight = -MulDiv_(*cfpu\FontSize,GetDeviceCaps_(*lpdis\hDC,#LOGPIXELSY),72)         
     
      If *ftd\Symbol : lplf\lfCharSet = #SYMBOL_CHARSET : EndIf         
     
      PokeS(@lplf\lfFaceName,*ftd\name)         
     
      hfntPreview = CreateFontIndirect_(lplf)
 
      ; --- Draw Preview Text
      SetBkMode_(*lpdis\hDC,#TRANSPARENT)   
     
      If *ftd\Symbol ; If it's a smybol font like Webdings
         Protected fsz.SIZE
         
         ; Write the fonts name
         *lpdis\rcItem\left + 20
         SelectObject_(*lpdis\hDC,GetStockObject_(#DEFAULT_GUI_FONT))
         GetTextExtentPoint32_(*lpdis\hDC,*ftd\Name,Len(*ftd\Name),fsz)
         DrawText_(*lpdis\hDC,*ftd\Name,-1,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)   
         
         ; Display demo charachters next to the name
         *lpdis\rcItem\left + fsz\cx + 3
         SelectObject_(*lpdis\hDC,hfntPreview)
         DrawText_(*lpdis\hDC,"ABC123",6,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)
      Else
         *lpdis\rcItem\left + 20
         SelectObject_(*lpdis\hDC,hfntPreview)         
         DrawText_(*lpdis\hDC,*ftd\Name,-1,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)
      EndIf   
     
      DeleteObject_(hfntPreview)
     
      ProcedureReturn #True
  EndSelect
  ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_EnumFonts(Gadget)
  Protected lplf.LOGFONT, hdc, Index, start
 
  lplf\lfCharset = #DEFAULT_CHARSET
 
  hdc = GetDC_(0)
  EnumFontFamiliesEx_(hdc,lplf,@CFP_EnumProc(),hdc,0)
  ReleaseDC_(0,hdc)
 
  SortStructuredList(ftd(),#PB_Sort_Ascending,OffsetOf(CFP_FONTDATA\Name),#PB_String)
 
  ForEach ftd()
    AddGadgetItem(Gadget,-1,ftd()\Name)
    If ftd()\Name = Font\Name
      start = Index
    EndIf
    SetGadgetItemData(Gadget,Index,ftd())
    Index + 1           
  Next
  SetGadgetState(Gadget,start)
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_EnumProc(*lpelfe.ENUMLOGFONTEX,*lpntme.NEWTEXTMETRICEX,FontType,lParam)
   Protected CHRSET = *lpelfe\elfLogFont\lfCharSet & 255
   
   ; WESTERN FONTS / SYSTEM FONTS / SYMBOL FONTS
    If Not Left(PeekS(@*lpelfe\elfLogFont\lfFaceName),1) = "@"
      If CHRSET = #ANSI_CHARSET Or CHRSET = #OEM_CHARSET Or CHRSET = #SYMBOL_CHARSET
        AddElement(ftd())
       
        Select FontType
           Case #TRUETYPE_FONTTYPE : ftd()\Type = 0
           Case #DEVICE_FONTTYPE : ftd()\Type = 1
           Case #RASTER_FONTTYPE : ftd()\Type = 2
           Default : ftd()\Type = -1
        EndSelect
       
        If CHRSET = #SYMBOL_CHARSET : ftd()\Symbol = 1 : EndIf
       
        ; Using 'lfFaceName' of the LOGFONT structure gives unique fontnames and avoids dublicates.
        ; When using 'elfFullName' of the ENUMLOGFONTEX structure you still can get dublicates even
        ; though you limit the character set like above. Also you don't need to cycle through the
        ; whole LinkedList everytime to find out if a fontname already exists.
        ;
        ; The created fontlist SHOULD be identical to the one in MS Wordpad + bitmap fonts (Courier, etc.)
          ftd()\Name = PeekS(@*lpelfe\elfLogFont\lfFaceName)
      EndIf
    EndIf

   ProcedureReturn #True
EndProcedure

DataSection
   FontType:
   Data.l $01964D42,$00000000,$00760000,$00280000,$00300000,$000C0000,$00010000,$00000004,$01200000,$00000000
   Data.l $00000000,$00000000,$00000000,$00000000,$00000000,$80000080,$80000000,$00800080,$00800000,$80800080
   Data.l $80800000,$C0C00080,$000000C0,$FF0000FF,$FF000000,$00FF00FF,$00FF0000,$FFFF00FF,$FFFF0000,$BBBB00FF
   Data.l $5555BBBB,$BBBBBB55,$BB7B77B8,$B9BBBBBB,$97B97B99,$BBBBBBBB,$55BBBBBB,$BBBBBBBB,$8B868870,$99BBBBBB
   Data.l $79999799,$BBBBBBBB,$55BBBBBB,$B8BBBBBB,$68B8BB00,$99BBBBBB,$B799797B,$BBBBBB9B,$55666666,$B8BBBBBB
   Data.l $76BBBB00,$99BBBB8B,$7B99B77B,$BBBBBBBB,$55BB66BB,$B8BBBBBB,$86BBBB00,$99BBBB6B,$9B79BB7B,$BBBBBBBB
   Data.l $55BB65BB,$B8BB5BBB,$B6BB8B00,$79BBBB68,$97B9BB9B,$BBBBBBBB,$55BB65BB,$BBBB5BBB,$B6BB7B00,$B9BBBB68
   Data.l $99B7BB97,$BBBBBBBB,$555B65BB,$BBBB5BB5,$B7BB0B70,$B7BBBB66,$99BBBB99,$B6BBBB7B,$555565BB,$BBBB5B55
   Data.l $B7BB08B0,$BBBBBB68,$79BB9B79,$B6BBBB9B,$6BBB66BB,$BBBBBBBB,$B7BB00B8,$BBBBBB68,$79BB99B7,$B6BBBB97
   Data.l $6BB6666B,$BBBBBBBB,$867880BB,$BBBBBB6B,$9799B9BB,$B6BBBB79,$6B666666,$BBBBBBBB,$6887BBBB,$BBBBBBBB
   Data.l $BBBBBBBB
   Data.b $BB,$BB
EndDataSection


Le module (avec l'exemple servant à faire le GIF) :
Code:
DeclareModule PureBF
  Declare LoadBitmapFont(File$) ;Return the generated number on success, 0 otherwise.
  Declare CatchBitmapFont(*MemoryAddress,Size)  ;Return the generated number on success, 0 otherwise. (Need to write file in temp directory... Not sure this is the best way, probably not a secure to use fonction)
  Declare DisplayText(*Font,X,Y,Text$,Zoom.f,Opacity,Color=#PB_Default) ;Fast display a raw text, no tag can or effect can be use. #CR$ or #CRLF$ character can be use for carriage return.
  Declare GetTextWidth(*Font,Text$,Zoom.f) ;Return the width of a text displayed with DisplayText() function.
  Declare GetTextHeight(*Font,Text$,Zoom.f) ;Return the height of a text displayed with DisplayText() function.
  Declare CreateTextBox(X,Y,Width,Height,Flag=0)   ;Create a new empty text box. Return the generated number. Flag use PB's text constante (#PB_Text_Center | #PB_Text_Right)
  Declare FreeTextBox(*TextBox)             ;Delete a text box and all the text contained.
  Declare DisplayTextBox(*TextBox)          ;Display the text box and process the effect is needed.
  Declare AddTextBoxString(*TextBox,*Font,String$,Zoom.f,Opacity,Color=#PB_Default) ;Add a string to the TextBox, String will be add after the previous one.
  Declare AddTextBoxStringN(*TextBox,*Font,String$,Zoom.f,Opacity,Color=#PB_Default) ;Add a string to the TextBox followed by a carriage return charactere.
  Declare SetShakeAttribut(Speed.f,Target.f) ;Set the shake effect speed and target. (Target is the delta in pixel letters will move, Speed in pixel).
  Declare SetWaveAttribut(Speed.f,Target.f) ;Set the Wave effect speed and target. (Target is the delta in pixel letters will move, Speed in pixel).
  Declare SetBlinkSpeed(Speed) ;Blink effect will switch status every #Speed frames.
  Declare SetBlinkColor(Color)
  Declare SetRainbowAttribut(Speed.f,RStep.f) ;Set the Rainbow effect speed and color gap between each letters.
  Declare.f GetShakeSpeed()
  Declare.f GetWaveSpeed()
  Declare.f GetShakeTarget()
  Declare.f GetWaveTarget()
  Declare GetBlinkSpeed()
  Declare GetBlinkColor()
  Declare.f GetRainbowSpeed()
  Declare.f GetRainbowStep()
  Declare.f GetTextBoxX(*TextBox)
  Declare.f GetTextBoxY(*TextBox)
  Declare MoveTextBox(*TextBox,X,Y,Mode = #PB_Absolute)
EndDeclareModule
Module PureBF
  #PBF_Compatibility = 0 ; 0 Mean faster render time but Unicode only and require low memory acces. /!\ Requesting to display a charactere unavaliable in the font can result in a crash /!\
                         ; 1 Mean slower render time but compatible with every text mode and SpiderBasic
                         ; Compatibility set to 1 can have faster render time with short text especialy on hardware with slow memory acces
 
  ;--------- Declaration-------------------------------------------------
  EnableExplicit
  UsePNGImageDecoder()
  UseLZMAPacker()
  ;{ Structures
  Structure Font
    Name.s
    Size.c
    Shadow.a
    ShadowX.a
    ShadowY.a
    Color.i
    ShadowColor.i
    BackGroundColor.i
    FntAlpha.a
    ShadowAlpha.a
    String.s
    Height.c
    Width.c
    Flag.i
    MargeUp.C
    MargeDown.c
    MargeLeft.c
    MargeRight.c
    MaxValue.c
  EndStructure
 
  Structure Char
    X.i
    Y.i
    Width.i
    Height.i
  EndStructure
 
  Structure BitmapFont
    Sprite.i
    FontInto.Font
    CompilerIf #PBF_Compatibility = 0
      Array CharInfo.Char(1)
    CompilerElse
      Map MapInfo.Char()
    CompilerEndIf
  EndStructure
   
  Structure Shake
    Enable.a
    Speed.f
    Target.c
    Delta.f
  EndStructure
 
  Structure Wave
    Enable.a
    Speed.f
    Target.c
    Delta.f
  EndStructure
 
  Structure Blink
    Enable.a
    Speed.i
    Count.i
    Color.i
    State.a
  EndStructure
 
  Structure Rainbow
    Enable.a
    Speed.f
    RainbowStep.f
    Delta.f
  EndStructure
 
  Structure TextList
    Line.c
    Text.s
    X.i
    Y.i
    Color.i
    Opacity.a
    Zoom.f
    ClipHeight.i
    *Font.BitmapFont
    Shake.Shake
    Wave.Wave     
    Blink.Blink
    Rainbow.Rainbow
  EndStructure
 
  Structure TextBox
    X.f
    Y.f
    CursorX.i
    CursorY.i
    CurentLine.c
    Width.i
    Height.i
    Flag.a
    List Text.TextList()
  EndStructure
     
  ;} End structures
 
  ; Variables
  Global  ShakeSpeed.f=2, WaveSpeed.f=0.15, ShakeTarget.f=2, WaveTarget.f=5, BlinkSpeed = 30, BlinkColor, RainbowSpeed.f = 0.04, RainbowStep.f = 0.1
  Global NewList TextBoxList.TextBox()
  ;{Procedures
  Declare AddTextToBox(*TextBox,*Font,Text$,Shake,Wave,Blink,ColorBlink,Rainbow,Zoom.f,Opacity,Color)
  Declare AligneText(*TextBox)
  Declare AddLineToBox(*TextBox)
  Declare SetShake(*TextBox)
  Declare SetWave(*TextBox)
  Declare SetBlink(*TextBox)
  Declare SetColorBlink(*TextBox)
  Declare SetRainbow(*TextBox)
  Declare MakeShake(*TextBox)
  Declare MakeWave(*TextBox,Delta)
  Declare MakeBlink(*textBox)
  Declare MakeRainbow(*TextBox,Delta)
 
  ; }

  ;---------End Declaration-----------------------------------------------
 
  ;---------Public Procedures---------------------------------------------
 
  Procedure LoadBitmapFont(File$) ;LoadBitmapFont function for PureBasic only
    Protected *PackBuffer, *Return.BitmapFont,Loop, LoopMax, Temp$
    CompilerIf #PBF_Compatibility = 0
      Protected NewMap MapInfo.Char()
    CompilerEndIf
    If OpenPack(0,File$,#PB_PackerPlugin_Lzma)
      ExaminePack(0)
      NextPackEntry(0)
      *PackBuffer = AllocateMemory(PackEntrySize(0))
      UncompressPackMemory(0,*PackBuffer,MemorySize(*PackBuffer),PackEntryName(0))
      *Return = AllocateMemory(SizeOf(BitmapFont))
      InitializeStructure(*Return,BitmapFont)
      CatchJSON(0,*PackBuffer,MemorySize(*PackBuffer))
      ExtractJSONStructure(JSONValue(0),*Return\FontInto,Font)
      ExamineJSONMembers(JSONValue(0))
      While NextJSONMember(JSONValue(0))
        If JSONMemberKey(JSONValue(0)) = "Chardata"
          CompilerIf #PBF_Compatibility = 0
            ExtractJSONMap(JSONMemberValue(JSONValue(0)),MapInfo())
          CompilerElse
            ExtractJSONMap(JSONMemberValue(JSONValue(0)),*Return\MapInfo())
          CompilerEndIf
        EndIf
      Wend
      FreeMemory(*PackBuffer)
      NextPackEntry(0)
      *PackBuffer = AllocateMemory(PackEntrySize(0))
      UncompressPackMemory(0,*PackBuffer,MemorySize(*PackBuffer))
      *Return\Sprite = CatchSprite(#PB_Any,*PackBuffer,#PB_Sprite_AlphaBlending)
      FreeMemory(*PackBuffer)
      ClosePack(0)
      *Return\FontInto\Width / 2
      CompilerIf #PBF_Compatibility = 0
        ReDim *Return\CharInfo(*Return\FontInto\MaxValue)
        LoopMax = Len(*Return\FontInto\String)
        For Loop = 1 To LoopMax
          Temp$ = Mid(*Return\FontInto\String,Loop,1)
          If FindMapElement(MapInfo(),Temp$)
            CopyStructure(@MapInfo(),@*Return\CharInfo(PeekC(@Temp$)),Char)
          EndIf
        Next Loop
        FreeMap(MapInfo())
      CompilerEndIf
      ProcedureReturn *Return
    EndIf
    ProcedureReturn #False
  EndProcedure
 
  Procedure CatchBitmapFont(*Memory,Size)
    Protected *Return.Font
    If CreateFile(0,GetTemporaryDirectory()+"PureBFTemp")
      WriteData(0,*Memory,Size)
      CloseFile(0)
      *Return = LoadBitmapFont(GetTemporaryDirectory()+"PureBFTemp")
      If *Return
        DeleteFile(GetTemporaryDirectory()+"PureBFTemp")
        ProcedureReturn *Return
      EndIf
    EndIf
    ProcedureReturn #False
  EndProcedure
 
  Procedure DisplayText(*Font.BitmapFont,X,Y,Text$,Zoom.f,Opacity,Color=#PB_Default)
    Protected loop,loopmax = Len(text$),DeltaX
    CompilerIf #PBF_Compatibility = 0
      Protected Index
      loopmax - 1
      For loop = 0 To loopmax
        Index = PeekC(@Text$+(loop)*2)
        If Index = #LF
          DeltaX = 0 : Y + *Font\FontInto\Height * Zoom
        Else
          ClipSprite(*Font\Sprite,*Font\CharInfo(Index)\X,*Font\CharInfo(Index)\Y,*Font\CharInfo(Index)\Width,*Font\CharInfo(Index)\Height)
          ZoomSprite(*Font\Sprite,*Font\CharInfo(Index)\Width*Zoom,*Font\CharInfo(Index)\Height * Zoom)
          DisplayTransparentSprite(*Font\Sprite,X+DeltaX,Y,Opacity,Color)
          DeltaX+*Font\CharInfo(Index)\Width * Zoom
        EndIf
    CompilerElse
      Protected Char$ 
      For loop = 1 To loopmax
        Char$ = Mid(Text$,loop,1)
        If Char$ = #LF$
          DeltaX = 0 : Y + *Font\FontInto\Height * Zoom
        Else
          If FindMapElement(*Font\MapInfo(),Char$)
            ClipSprite(*Font\Sprite,*Font\MapInfo()\X,*Font\MapInfo()\Y,*Font\MapInfo()\Width,*Font\MapInfo()\Height)
            ZoomSprite(*Font\Sprite,*Font\MapInfo()\Width*Zoom,*Font\MapInfo()\Height * Zoom)
            DisplayTransparentSprite(*Font\Sprite,X+DeltaX,Y,Opacity,Color)
            DeltaX+*Font\MapInfo()\Width * Zoom
          EndIf
        EndIf
    CompilerEndIf
    Next loop
  EndProcedure
 
  Procedure CreateTextBox(X,Y,Width,Height,Flag=0)
    AddElement(TextBoxList())
    Define *TextBox.Textbox = @TextBoxList() ;AllocateStructure(TextBox)
    *TextBox\X = X
    *TextBox\Y = Y
    *TextBox\Width = Width
    *TextBox\Height = Height
    *TextBox\CurentLine = 1
    *TextBox\Flag = Flag
    ProcedureReturn *TextBox
  EndProcedure 
 
  Procedure FreeTextBox(*TextBox)
    ;FreeStructure(*TextBox)
    ChangeCurrentElement(TextBoxList(),*TextBox)
    DeleteElement(TextBoxList())
  EndProcedure
 
  Procedure DisplayTextBox(*TextBox.TextBox)
    Protected loop, loopmax, DeltaX, DeltaY, Color, Blink
    ForEach *TextBox\Text()
      If *TextBox\Text()\Blink\Enable
        Blink = MakeBlink(*TextBox)
        If Blink = -2
          Continue
        Else
          Color = Blink
        EndIf
      Else
        Color = *TextBox\Text()\Color
      EndIf
      loopmax = Len(*TextBox\Text()\Text) : DeltaX = 0 : DeltaY = 0
      If *TextBox\Text()\Shake\Enable
        DeltaX + MakeShake(*TextBox) : DeltaY = DeltaX/2
      EndIf
      CompilerIf #PBF_Compatibility = 0
        Protected Index
        loopmax - 1
        For loop = 0 To loopmax
          If *TextBox\Text()\Wave\Enable
            DeltaY = MakeWave(*TextBox,loop)
          EndIf
          If *TextBox\Text()\Rainbow\Enable
            Color = MakeRainbow(*TextBox,loop)
          EndIf
          Index = PeekC(@*TextBox\Text()\Text + loop * 2)
          ClipSprite(*TextBox\Text()\Font\Sprite,*TextBox\Text()\Font\CharInfo(Index)\X,*TextBox\Text()\Font\CharInfo(Index)\Y,*TextBox\Text()\Font\CharInfo(Index)\Width,*TextBox\Text()\ClipHeight)
          ZoomSprite(*TextBox\Text()\Font\Sprite,*TextBox\Text()\Font\CharInfo(Index)\Width * *TextBox\Text()\Zoom, *TextBox\Text()\ClipHeight * *TextBox\Text()\Zoom)
          DisplayTransparentSprite(*TextBox\Text()\Font\Sprite,*TextBox\X + *TextBox\Text()\X+DeltaX, *TextBox\Y + *TextBox\Text()\Y+DeltaY, *TextBox\Text()\Opacity, Color)
          DeltaX+*TextBox\Text()\Font\CharInfo(Index)\Width * *TextBox\Text()\Zoom
         
    CompilerElse
        Protected Char$
        For loop = 1 To loopmax
          If *TextBox\Text()\Wave\Enable
            DeltaY = MakeWave(*TextBox,loop)
          EndIf
          If *TextBox\Text()\Rainbow\Enable
            Color = MakeRainbow(*TextBox,loop)
          EndIf
          Char$ = Mid(*TextBox\Text()\Text,loop,1)
          If FindMapElement(*TextBox\Text()\Font\MapInfo(),Char$)
            ClipSprite(*TextBox\Text()\Font\Sprite,*TextBox\Text()\Font\MapInfo()\X,*TextBox\Text()\Font\MapInfo()\Y,*TextBox\Text()\Font\MapInfo()\Width,*TextBox\Text()\ClipHeight)
            ZoomSprite(*TextBox\Text()\Font\Sprite,*TextBox\Text()\Font\MapInfo()\Width * *TextBox\Text()\Zoom, *TextBox\Text()\ClipHeight * *TextBox\Text()\Zoom)
            DisplayTransparentSprite(*TextBox\Text()\Font\Sprite,*TextBox\X + *TextBox\Text()\X+DeltaX, *TextBox\Y + *TextBox\Text()\Y+DeltaY, *TextBox\Text()\Opacity, Color)
            DeltaX + *TextBox\Text()\Font\MapInfo()\Width * *TextBox\Text()\Zoom
          EndIf
     
    CompilerEndIf
          Next
        Next
  EndProcedure
 
  Procedure AddTextBoxString(*TextBox.TextBox,*Font.BitmapFont,String$,Zoom.f,Opacity,Color=#PB_Default)
    Protected Index = 1, Text$, TempText$, SpaceCount, Shake, Wave, Blink,Rainbow, ColorBlink
    SpaceCount = CountString(String$," ") + 2
    Repeat
      TempText$ = StringField(String$,Index," ")
      If TempText$ = "{\}"
        If Not Text$ = ""
          AddTextToBox(*TextBox,*Font,Text$+" ",Shake,Wave,Blink,ColorBlink,Rainbow,Zoom,Opacity,Color)
          Text$ = ""
        EndIf
        If Shake : *TextBox\CursorX + ShakeTarget : EndIf
         Shake = 0 : Wave = 0 : Blink = 0 : ColorBlink = 0 : Rainbow = 0
      ElseIf Mid(TempText$,1,2) = "${"
        If Not Text$ = ""
          AddTextToBox(*TextBox,*Font,Text$+" ",Shake,Wave,Blink,ColorBlink,Rainbow,Zoom,Opacity,Color)
          Text$ = ""
        EndIf
        TempText$ = LCase(Mid(TempText$,3,Len(TempText$)-3))
        Select TempText$
          Case "shake"
            Shake = 1
          Case "wave"
            Wave = 1
          Case "blink"
            Blink = 1
          Case "colorblink"
            ColorBlink = 1
          Case "rainbow"
            Rainbow = 1
        EndSelect
      Else
        If GetTextWidth(*Font,Text$ + RTrim(TempText$),Zoom) + *TextBox\CursorX < *TextBox\Width
          If Text$ = ""
            Text$ + TempText$
          Else
            Text$ + " "+TempText$
          EndIf
        Else
          AddTextToBox(*TextBox,*Font,Text$,Shake,Wave,Blink,ColorBlink,Rainbow,Zoom,Opacity,Color)
          AddLineToBox(*TextBox)
          Text$ = TempText$
        EndIf
      EndIf
      Index + 1
    Until Index = SpaceCount
    If Not Text$ = ""
      AddTextToBox(*TextBox,*Font,Text$,Shake,Wave,Blink,ColorBlink,Rainbow,Zoom,Opacity,Color)
    EndIf
  EndProcedure
 
  Procedure AddTextBoxStringN(*TextBox,*Font,String$,Zoom.f,Opacity,Color=#PB_Default)
    AddTextBoxString(*TextBox,*Font,String$,Zoom,Opacity,Color)
    AddLineToBox(*TextBox)
  EndProcedure
 
  Procedure MoveTextBox(*TextBox.TextBox,X,Y,Mode = #PB_Absolute)
    Select Mode
      Case #PB_Absolute
        *TextBox\X = X
        *TextBox\Y = Y
      Case #PB_Relative
        *TextBox\X + X
        *TextBox\Y + Y
    EndSelect
  EndProcedure
 
  ;---------------Setter and Getter procedures---------------------------
 
  Procedure SetShakeAttribut(Speed.f,Target.f)
    ShakeSpeed = Speed
    ShakeTarget = Target
  EndProcedure
 
  Procedure SetWaveAttribut(Speed.f,Target.f)
    WaveSpeed = Speed
    WaveTarget = Target
  EndProcedure
 
  Procedure SetBlinkSpeed(Speed)
    BlinkSpeed = Speed
  EndProcedure
 
  Procedure SetBlinkColor(Color)
    BlinkColor = Color
  EndProcedure
 
  Procedure SetRainbowAttribut(Speed.f,RStep.f)
    RainbowSpeed = Speed
    RainbowStep = RStep
  EndProcedure
 
  Procedure.f GetShakeSpeed()
    ProcedureReturn ShakeSpeed
  EndProcedure
 
  Procedure.f GetShakeTarget()
    ProcedureReturn ShakeTarget
  EndProcedure
 
  Procedure.f GetWaveSpeed()
    ProcedureReturn WaveSpeed
  EndProcedure
 
  Procedure.f GetWaveTarget()
    ProcedureReturn WaveTarget
  EndProcedure
 
  Procedure GetBlinkSpeed()
    ProcedureReturn BlinkSpeed
  EndProcedure
 
  Procedure GetBlinkColor()
    ProcedureReturn BlinkColor
  EndProcedure
 
  Procedure.f GetRainbowSpeed()
    ProcedureReturn RainbowSpeed
  EndProcedure
 
  Procedure.f GetRainbowStep()
    ProcedureReturn RainbowStep
  EndProcedure
 
  Procedure.f GetTextBoxX(*TextBox.TextBox)
    ProcedureReturn *TextBox\X
  EndProcedure
 
  Procedure.f GetTextBoxY(*TextBox.TextBox)
    ProcedureReturn *TextBox\Y
  EndProcedure
 
  Procedure GetTextWidth(*Font.BitmapFont,Text$,Zoom.f)
    Protected Loop, LoopMax=Len(Text$),Width, Index,MemWidth
    CompilerIf #PBF_Compatibility = 0
      LoopMax - 1
      For loop = 0 To LoopMax
        Index = PeekC(@Text$+(loop)*2)
        If Index = #LF
          If Width > MemWidth : MemWidth = Width : EndIf
          Width = 0
        Else
          Width + *Font\CharInfo(Index)\Width * Zoom
        EndIf
    CompilerElse
      Protected Char$   
      For Loop = 1 To LoopMax
        Char$ = Mid(Text$,Loop,1)
        If Char$ = #LF$
          If Width > MemWidth : MemWidth = Width : EndIf
          Width = 0
        Else
          If FindMapElement(*Font\MapInfo(),Char$)
            Width+*Font\MapInfo()\Width * Zoom
          EndIf
        EndIf
    CompilerEndIf
    Next Loop
    If MemWidth > Width : Width = MemWidth : EndIf
    ProcedureReturn Width
  EndProcedure
 
  Procedure GetTextHeight(*Font.BitmapFont,Text$,Zoom.f)
    Protected Height
    Height = *Font\FontInto\Height * (CountString(Text$,#LF$)+1) * Zoom
    ProcedureReturn Height   
  EndProcedure 
  ;-----------------------------------------------------------------------
 
 
  ;--------Private Procedures---------------------------------------------
 
  Procedure AddTextToBox(*TextBox.TextBox,*Font.BitmapFont,Text$,Shake,Wave,Blink,ColorBlink,Rainbow,Zoom.f,Opacity,Color)
    If Not Text$ = ""
      If *TextBox\CursorY < *TextBox\Height
        AddElement(*TextBox\Text())
        *TextBox\Text()\Font = *Font
        *TextBox\Text()\Text = Text$
        If Shake : SetShake(*TextBox) : EndIf
        If Wave : PushListPosition(*TextBox\Text()): SetWave(*TextBox) : PopListPosition(*TextBox\Text()) : EndIf
        If Blink : SetBlink(*TextBox) : EndIf
        If ColorBlink : SetColorBlink(*TextBox) : EndIf
        If Rainbow : SetRainbow(*TextBox) : EndIf
        *TextBox\Text()\Color = Color
        *TextBox\Text()\Opacity = Opacity
        *TextBox\Text()\Zoom = Zoom
        *TextBox\Text()\X = *TextBox\CursorX
        *TextBox\Text()\Y = *TextBox\CursorY
        If *TextBox\CursorY + *Font\FontInto\Height * Zoom > *TextBox\Height
          *TextBox\Text()\ClipHeight = *Font\FontInto\Height - (*Font\FontInto\Height - (*TextBox\Height - *TextBox\CursorY) / Zoom)
        Else
          *TextBox\Text()\ClipHeight = *Font\FontInto\Height
        EndIf
        *TextBox\Text()\Line = *TextBox\CurentLine
        *TextBox\CursorX + GetTextWidth(*Font,Text$,Zoom)
        If *TextBox\Flag
          AligneText(*TextBox)
        EndIf
      EndIf
    EndIf
  EndProcedure
 
  Procedure AligneText(*TextBox.TextBox)
    Protected DeltaX
    If *TextBox\Flag = #PB_Text_Center
      DeltaX = (*TextBox\Width - *TextBox\CursorX) / 2
    Else
      DeltaX = *TextBox\Width - *TextBox\CursorX
    EndIf
    ForEach *TextBox\Text()
      If *TextBox\Text()\Line = *TextBox\CurentLine
        *TextBox\Text()\X =  DeltaX
        DeltaX + GetTextWidth(*TextBox\Text()\Font,*TextBox\Text()\Text,*TextBox\Text()\Zoom)
      EndIf
    Next
  EndProcedure
 
  Procedure AddLineToBox(*TextBox.TextBox)
    Protected DeltaLine
    *TextBox\CursorY + *TextBox\Text()\Font\FontInto\Height * *TextBox\Text()\Zoom
    *TextBox\CursorX = 0
    *TextBox\CurentLine + 1
    ForEach *TextBox\Text()
      If *TextBox\Text()\Wave\Target > DeltaLine
        DeltaLine = *TextBox\Text()\Wave\Target
      EndIf
    Next
    *TextBox\CursorY + DeltaLine
  EndProcedure
 
  Procedure SetShake(*TextBox.TextBox)
    *TextBox\Text()\Shake\Enable = 1
    *TextBox\Text()\Shake\Speed = ShakeSpeed
    *TextBox\Text()\Shake\Target = ShakeTarget
    *TextBox\CursorX + ShakeTarget
  EndProcedure
 
  Procedure SetWave(*TextBox.TextBox)
    Protected DeltaLine
    *TextBox\Text()\Wave\Enable = 1
    *TextBox\Text()\Wave\Speed = WaveSpeed
    *TextBox\Text()\Wave\Target = WaveTarget
    ForEach *TextBox\Text()
      If *TextBox\Text()\Line = *TextBox\CurentLine
        If *TextBox\Text()\Wave\Enable
          If *TextBox\Text()\Wave\Target >= WaveTarget
            ProcedureReturn
          Else
            If *TextBox\Text()\Wave\Target > DeltaLine
              DeltaLine = *TextBox\Text()\Wave\Target
            EndIf
          EndIf
        EndIf
      EndIf
    Next
    DeltaLine = WaveTarget - DeltaLine
    ForEach *TextBox\Text()
      If *TextBox\Text()\Line = *TextBox\CurentLine
        *TextBox\Text()\Y + DeltaLine
      EndIf
    Next
    *TextBox\CursorY + DeltaLine
  EndProcedure
   
  Procedure SetBlink(*TextBox.TextBox)
    *TextBox\Text()\Blink\Enable = 1
    *TextBox\Text()\Blink\Speed = BlinkSpeed
  EndProcedure
 
  Procedure SetColorBlink(*TextBox.TextBox)
    *TextBox\Text()\Blink\Enable = 2
    *TextBox\Text()\Blink\Speed = BlinkSpeed
    *TextBox\Text()\Blink\Color = BlinkColor
  EndProcedure
 
  Procedure SetRainbow(*TextBox.TextBox)
    *TextBox\Text()\Rainbow\Enable = 1
    *TextBox\Text()\Rainbow\Speed = RainbowSpeed
    *TextBox\Text()\Rainbow\RainbowStep = RainbowStep
  EndProcedure
 
  Procedure MakeShake(*TextBox.TextBox)
    *TextBox\Text()\Shake\Delta + *TextBox\Text()\Shake\Speed
    If *TextBox\Text()\Shake\Delta >= *TextBox\Text()\Shake\Target
      *TextBox\Text()\Shake\Speed = - *TextBox\Text()\Shake\Speed
    ElseIf *TextBox\Text()\Shake\Delta <= - *TextBox\Text()\Shake\Target
      *TextBox\Text()\Shake\Speed =  Abs(*TextBox\Text()\Shake\Speed)
    EndIf
    ProcedureReturn *TextBox\Text()\Shake\Delta
  EndProcedure
 
  Procedure MakeWave(*TextBox.TextBox,Delta)
    If Delta = 1
      *TextBox\Text()\Wave\Delta + *TextBox\Text()\Wave\Speed
      If *TextBox\Text()\Wave\Delta >= *TextBox\Text()\Wave\Target
        *TextBox\Text()\Wave\Delta = 0
      EndIf
    EndIf
    ProcedureReturn *TextBox\Text()\Wave\Target * Sin(2 * #PI / *TextBox\Text()\Wave\Target * (Delta+ *TextBox\Text()\Wave\Delta))
  EndProcedure
 
  Procedure MakeRainbow(*TextBox.TextBox,Delta)
    Protected Result.f,H.f,R,G,B
    If Delta = 1
      *TextBox\Text()\Rainbow\Delta + *TextBox\Text()\Rainbow\Speed
      If *TextBox\Text()\Rainbow\Delta > #PI * 2
        *TextBox\Text()\Rainbow\Delta = 0
      EndIf
    EndIf
    Result =Cos((Delta * *TextBox\Text()\Rainbow\RainbowStep + *TextBox\Text()\Rainbow\Delta))
    Result = Degree(#PI * (Result+1))
    H = Result / 60
    Select Result
      Case 0 To 59
        R = 255 : G = Mod(H,2) * 255 : B = 0
      Case 60 To 119
        R = (1-(Mod(H,2)-1)) * 255 : G = 255 : B = 0
      Case 120 To 179
        R = 0 : G = 255 : B = Mod(H,2) * 255
      Case 180 To 239
        R = 0 : G = (1-(Mod(H,2)-1)) * 255 : B = 255
      Case 240 To 299
        R = Mod(H,2) * 255 : G = 0 : B = 255
      Case 300 To 360
        R = 255 : G = 0 : B = (1-(Mod(H,2)-1)) * 255
    EndSelect
    ProcedureReturn RGB(R,G,B)
  EndProcedure
 
  Procedure MakeBlink(*TextBox.TextBox)
    *TextBox\Text()\Blink\Count + 1
    If *TextBox\Text()\Blink\Count = *TextBox\Text()\Blink\Speed
      *TextBox\Text()\Blink\State = (*TextBox\Text()\Blink\State + 1) % 2
      *TextBox\Text()\Blink\Count = 0
    EndIf
    If *TextBox\Text()\Blink\State
      ProcedureReturn *TextBox\Text()\Color
    Else
      If *TextBox\Text()\Blink\Enable = 1 ; Perform if tag is Blik
        ProcedureReturn -2
      Else ; Perform if tag is BlinkColor
        ProcedureReturn *TextBox\Text()\Blink\Color
      EndIf
    EndIf
  EndProcedure
 
EndModule


;-------------------------------------------------------------------------------------------
;----------------------------------Exemple of use-------------------------------------------
;-------------------------------------------------------------------------------------------
CompilerIf #PB_Compiler_IsMainFile
  InitSprite()
  OpenWindow(0,0,0,800,300,"",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
  OpenWindowedScreen(WindowID(0),0,0,800,300);,0,0,0,#PB_Screen_NoSynchronization)
  SetFrameRate(60)
  Define a.f = 1 , b.f = 1
  fnt=PureBF::LoadBitmapFont("Arial.afg")
  time = ElapsedMilliseconds()
  box = PureBF::CreateTextBox(400,100,300,150,#PB_Text_Center)
  box2 = PureBF::CreateTextBox(30,150,300,150,#PB_Text_Right)
  PureBF::SetBlinkColor($FF2200)
  PureBF::AddTextBoxString(box,fnt,"Ceci est un essais de ${shake} phrase {\} longue pour ${blink} voir {\} ",0.25,255)
  PureBF::SetBlinkSpeed(60)
  PureBF::AddTextBoxString(box,fnt,"si le ${Wave} retour ${colorblink} à la ligne {\} est pris en compte.",0.25,255,#Red)
  PureBF::AddTextBoxString(box2,fnt,"Une deuxième ${rainbow} ${wave} textbox avec d'autres effets {\} est-ce que ça fonctionne aussi ?",0.25,140)
  Repeat
    ClearScreen($000000)
    PureBF::DisplayText(fnt,10,10,"Testouille "+#LF$+"???",0.25,255)
    PureBF::DisplayText(fnt,10,PureBF::GetTextHeight(fnt,"Testouille "+#LF$+"???",0.25)+10,"Là aussi !!",0.33,100,RGB(128,130,12))
    PureBF::DisplayText(fnt,PureBF::GetTextWidth(fnt,"Testouille "+#LF$+"???",0.25)+10+PureBF::GetTextWidth(fnt," ",0.25),10,"Ca marche !!",0.25,128,128)
    PureBF::DisplayText(fnt,10,100,"Яабвгдеёжзийкл",0.25,255)
    FPS + 1
    PureBF::DisplayText(fnt,650,10,"FPS : "+FPSCount,0.25,255)
;     PureBF::MoveTextBox(box,a,b,#PB_Relative)
;     If PureBF::GetTextBoxX(box)  >= 400
;       a = - Random(30,10)/10
;     ElseIf PureBF::GetTextBoxX(box) <= 200
;       a = Random(30,10)/10
;     EndIf
;     If PureBF::GetTextBoxY(box) >= 150
;       b = - Random(20,10)/10
;     ElseIf PureBF::GetTextBoxY(box) <= 50
;       b = Random(20,10)/10
;     EndIf
    PureBF::DisplayTextBox(box)
    PureBF::DisplayTextBox(box2)
    If ElapsedMilliseconds() - time >= 1000
      FPSCount = FPS : FPS = 0 : time = ElapsedMilliseconds()
    EndIf
    FlipBuffers()
  Until WindowEvent() = #PB_Event_CloseWindow
CompilerEndIf




Enjoy.


Dernière édition par boby le Mer 12/Déc/2018 16:08, édité 3 fois.

Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Dim 09/Déc/2018 9:39 
Hors ligne
Avatar de l’utilisateur

Inscription: Dim 02/Oct/2011 16:17
Messages: 2153
Localisation: 50200 Coutances
Merci beaucoup, boby, pour le partage, c'est un merveilleux cadeau pour Noël, j'adore.

_________________
Microsoft Windows 10 Famille 64 bits : Carte mère : ASRock 970 Extreme3 R2.0 : Carte Graphique NVIDIA GeForce GT 640 : Processeur AMD FX 6300 6 cœurs 12 threads 3,50 GHz PB 5.62, 5.70 LTS
Un homme doit être poli, mais il doit aussi être libre !


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Dim 09/Déc/2018 14:15 
Hors ligne
Avatar de l’utilisateur

Inscription: Lun 17/Déc/2007 12:44
Messages: 1626
Merci pour le partage "Papala" ^^.

GallyHC

_________________
Image

Image

Image Official site of PureBasic
Image Official site of SpiderBasic

Configuration : Tower: Windows 7 (Processeur: i7 "x64") (Mémoire: 16Go) (GeForce GTX 760 - 2Go) - PureBasic 5.62 (x86 et x64)


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Mar 11/Déc/2018 13:33 
Hors ligne

Inscription: Jeu 07/Juin/2007 22:54
Messages: 261
MAJ : Remplacement du tag "Snake" par "Wave"... Je ne sais pas d'où m'était venu l'idée de l'appeler comme ça... Il faut croire que quand on est con c'est pour la vie.
Ajout de l'argument Flag dans la procédure CreateTextBox() prenant en compte les flag de PB #PB_Text_Center et #PB_Text_Right pour centrer ou aligner à droite automatiquement le texte contenu dans les TextBox.

Edit : Ajout du tag (et son effet) rainbow. SetRainbowAttribut(Speed,RStep) permet de regler l'effet, Speed défini la vitesse de défilement, RStep l'écart sur la roue des couleur entre chaques lettres.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Mar 11/Déc/2018 20:20 
Hors ligne
Avatar de l’utilisateur

Inscription: Jeu 14/Oct/2004 19:48
Messages: 1121
Est ce que c'est une fonction similaire ou une extension de ça : https://www.purebasic.fr/english/viewto ... 12&t=43223 ?
Image

_________________
Il y a deux méthodes pour écrire des programmes sans erreurs. Mais il n’y a que la troisième qui marche.
Version de PB : 5.45LTS - 32 bits


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Mar 11/Déc/2018 21:15 
Hors ligne

Inscription: Jeu 07/Juin/2007 22:54
Messages: 261
C'est une autre approche que Typeface (c'est par-ce qu'elle existe déjà que je n'ai repris aucun des effets qu'elle permet).
Typeface forme des sprites contenant le text puis travail dessus pour les "deformer" et jouer avec.
Ma lib préscalcule l'emplacement des texts quand on ajoute du text à une "box" (comme je les ais appelées), au moment de l'affichage il ne reste plus qu'à jouer les effets et afficher les sprites aux positions près calculé, ça ne permet donc pas des effets tel que la rotation ou la courbure, par contre ça permet des traiter lettres par lettres (example l'effet wave ou rainbow).

J'avais vu cette lib mais ne répondais pas à mes besoins précis, j'ai donc fait la mienne et profité de l'occasion pour apporter une autre approche. (En therme de perf je dirais qu'elles sont relativement proche, si je coupe la limitation de FPS lié au Vsync j'ai environ 6000 FPS pour environ 200 caractères)

(Un petit GIF de la dernière MAJ, le "phrase" ne shake plus à cause de la conversion en GIF :p)
Image


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Mer 12/Déc/2018 16:11 
Hors ligne

Inscription: Jeu 07/Juin/2007 22:54
Messages: 261
Petite MAJ : Correction de quelques bugs et suppression de l'utilisation des pointeurs, en activant le mode de compatibilité : #PBF_Compatibility = 1 (et en refaisant la procedure LoadBitmapFont) ça devrait être compatible SpiderBasic. Je n'ai pas encore pris ma liscence de SB, si quelqu'un est motivé pour tester, je serais intéressé d'un retour pour savoir si ça fonctionne.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Mer 12/Déc/2018 16:27 
Hors ligne
Avatar de l’utilisateur

Inscription: Dim 09/Oct/2005 16:51
Messages: 8705
Salut et merci pour ce partage qui va être pratique.
Dans ton exemple GIF, j'ai une erreur accés mémoire invalide ligne 469 en #PBF_Compatibility = 0
et la même erreur en #PBF_Compatibility = 1 Ligne 479
J'ai compilé en 5.62 x64 et x86

_________________
~~~~Règles du forum ~~~~
.: Ar-S :. Tour + portable W10 x64 PB 5.4x / 5.6x
LDV MULTIMEDIA : Dépannage informatique & mes Logiciels PB
RESIZER GOLD : Mon logiciel de redimensionnement par lot 100% PB


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Mer 12/Déc/2018 17:47 
Hors ligne

Inscription: Jeu 07/Juin/2007 22:54
Messages: 261
@Ar-S tu n'as probablement pas utilisé la générateur de font pour générer la font arial que j'utilise dans mon exemple :
Ligne 685 : fnt=PureBF::LoadBitmapFont("Arial.afg")

Compile le premier code (l'éditeur de Font) fait sauvegarder sans toucher à rien, il te sortira la bitmapfont (Arial.afg) que j'utilise pour mon exemple.
Il est vrai que dans l'exemple je ne vérifi pas si la font est bien chargée.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Mer 12/Déc/2018 21:34 
Hors ligne
Avatar de l’utilisateur

Inscription: Dim 09/Oct/2005 16:51
Messages: 8705
Effectivement c'est nickel.

_________________
~~~~Règles du forum ~~~~
.: Ar-S :. Tour + portable W10 x64 PB 5.4x / 5.6x
LDV MULTIMEDIA : Dépannage informatique & mes Logiciels PB
RESIZER GOLD : Mon logiciel de redimensionnement par lot 100% PB


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Pure BitmapFont
MessagePosté: Sam 08/Juin/2019 12:38 
Hors ligne
Avatar de l’utilisateur

Inscription: Sam 31/Juil/2004 22:32
Messages: 1140
Code:
EnableExplicit

UsePNGImageEncoder()
UseLZMAPacker()

Enumeration
   #Str_Char
   #Btn_Font
   #Btn_Generate
   #Btn_Refresh
   #Btn_Load
   #Txt_Font
   #Cnv_Sample
   ;------------------Setting window----------
   #Cmb_Font
   #Chk_Bold
   #Chk_Italic
   #Chk_StrikeOut
   #Chk_Shadow
   #Btn_Color
   #Btn_ShadowColor
   #Btn_BackgroundColor
   #Str_Alpha
   #Str_OffsetX
   #Str_OffsetY
   #Str_Size
   #Str_MargeUp
   #Str_MargeDown
   #Str_MargeLeft
   #Str_MargeRight
   #Lst_Size
   #Cnv_Preview
EndEnumeration
Enumeration
   #Window_Main
   #Window_Font
EndEnumeration

Structure Font
   Name.s
   Size.c
   Shadow.a
   ShadowX.a
   ShadowY.a
   Color.i
   ShadowColor.i
   BackGroundColor.i
   FntAlpha.a
   ShadowAlpha.a
   String.s
   Height.c
   Width.c
   Flag.i
   MargeUp.C
   MargeDown.c
   MargeLeft.c
   MargeRight.c
   MaxValue.c
EndStructure

Structure Char
   X.i
   Y.i
   Width.i
   Height.i
EndStructure

Structure CFP_FONTDATA
   Type.b
   Symbol.b
   Name.s
EndStructure

Structure CFP_USERDATA
   himlFontType.i
   FontSize.b
   hwndParent.i
EndStructure

Declare OpenMainWindow()
Declare OpenFontWindow()
Declare RefreshSample()
Declare GenerateFont()
Declare Loadfnt()
Declare Close()
Declare ChangeSize()
Declare ChangeColor()
Declare Style()
Declare Shadow()
Declare ShadowAlpha()
Declare Offset()
Declare Marging()
Declare RefreshPreview()
Declare Load()
;----------------CFP fonctions declaration---------------------------
Declare CFP_CreateGagdet(Gadget,X,Y,Width,Height,ItemHeight=20,FontSize=11)
Declare.s CFP_GetGadgetText(Gadget,Item)
Declare CFP_FreeGadget(Gadget)
Declare CFP_EnumFonts(Gadget)
Declare CFP_EnumProc(*lpelfe.ENUMLOGFONTEX,*lpntme.NEWTEXTMETRICEX,FontType,lParam)
Declare CFP_WndProc(hWnd,uMsg,wParam,lParam)
Declare CFP_Change()

Global Font.font, FntList.LOGFONT
Global NewList ftd.CFP_FONTDATA()

With Font
   \Name = "Arial"
   \String = "!"+Chr(34)+"# $%&'()*+,-./0123456789:;<=>?ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюяЄІЇЎҐєіїўґÄäÀàÂâÁáÃãÅåÆæÈèÊêÉéÇçĞğÎîÍíİıÑñÖöÒòÔôÓóÕõŒœØøŞşÜüÙùÛûÚúŸÿ¿¡ßŐőŰű"
   \Size = 72
   \Shadow = 0
   \ShadowX = 5
   \ShadowY = 5
   \ShadowAlpha = 128
   \Color = RGBA(255,255,255,255)
   \ShadowColor = RGBA(0,0,0,128)
   \BackGroundColor = RGB(204,204,204)
   \FntAlpha = 255
EndWith

OpenMainWindow()
Repeat : WaitWindowEvent() : ForEver
Procedure OpenMainWindow()
   If OpenWindow(#Window_Main,0,0,1200,768,"Awesome bitmapFont Generator",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
      StringGadget(#Str_Char,10,10,1100,50,Font\String)
      ButtonGadget(#Btn_Refresh,1130,10,60,20,"Refresh")
      ButtonGadget(#Btn_Font,10,80,40,20,"Font")
      ButtonGadget(#Btn_Load,650,80,60,20,"Load")
      TextGadget(#Txt_Font,60,80,500,20,Font\Name+","+Font\Size,#PB_Text_Border)
      CanvasGadget(#Cnv_Sample,10,110,1180,628)
      ButtonGadget(#Btn_Generate,580,80,60,20,"Save")
      BindEvent(#PB_Event_CloseWindow,@Close())
      BindGadgetEvent(#Btn_Font,@OpenFontWindow())
      BindGadgetEvent(#Btn_Refresh,@RefreshSample())
      BindGadgetEvent(#Btn_Generate,@GenerateFont())
      BindGadgetEvent(#Btn_Load,@Load())
      RefreshSample()
   EndIf
EndProcedure

Procedure OpenFontWindow()
   Protected FontLoop
   ClearList(ftd())
   
   If OpenWindow(#Window_Font,0,0,800,400,"Configure font",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
      TextGadget(#PB_Any,10,10,100,20,"Font :")
      TextGadget(#PB_Any,340,10,100,20,"Style :")
      TextGadget(#PB_Any,460,10,100,20,"Size :")
      CFP_CreateGagdet(#Cmb_Font,10,40,300,24)
      CheckBoxGadget(#Chk_Bold,340,40,80,20,"Bold")
      CheckBoxGadget(#Chk_Italic,340,70,80,20,"Italic")
      CheckBoxGadget(#Chk_StrikeOut,340,100,80,20,"StrikeOut")
      StringGadget(#Str_Size,460,40,150,20,Str(Font\Size),#PB_String_Numeric)
      ListViewGadget(#Lst_Size,460,60,150,60)
      TextGadget(#PB_Any,10,150,100,20,"Text color")
      CheckBoxGadget(#Chk_Shadow,10,170,100,20,"Shadow color")
      TextGadget(#PB_Any,200,150,100,20,"Background color")
      TextGadget(#PB_Any,630,40,40,20,"Padding")
      StringGadget(#Str_MargeUp,700,40,30,20,Str(Font\MargeUp),#PB_String_Numeric)
      StringGadget(#Str_MargeLeft,665,65,30,20,Str(Font\MargeLeft),#PB_String_Numeric)
      StringGadget(#Str_MargeDown,700,90,30,20,Str(Font\MargeDown),#PB_String_Numeric)
      StringGadget(#Str_MargeRight,735,65,30,20,Str(Font\MargeRight),#PB_String_Numeric)
      TextGadget(#PB_Any,700,65,30,20,"A",#PB_Text_Border|#PB_Text_Center)
      CreateImage(0,30,20)
      CreateImage(1,30,20)
      CreateImage(2,30,20)
      StartDrawing(ImageOutput(0))
      Box(0,0,30,20,Font\Color)
      StopDrawing()
      StartDrawing(ImageOutput(1))
      Box(0,0,30,20,Font\ShadowColor)
      StopDrawing()
      StartDrawing(ImageOutput(2))
      Box(0,0,30,20,Font\BackGroundColor)
      StopDrawing()
      ButtonImageGadget(#Btn_Color,150,150,30,20,ImageID(0))
      ButtonImageGadget(#Btn_ShadowColor,150,170,30,20,ImageID(1))
      ButtonImageGadget(#Btn_BackgroundColor,300,150,30,20,ImageID(2))
      TextGadget(#PB_Any,220,170,40,20,"Alpha :")
      StringGadget(#Str_Alpha,300,170,40,20,Str(Font\ShadowAlpha),#PB_String_Numeric)
      TextGadget(#PB_Any,370,170,40,20,"OffestX :")
      StringGadget(#Str_OffsetX,450,170,40,20,Str(Font\ShadowX),#PB_String_Numeric)
      TextGadget(#PB_Any,520,170,40,20,"OffsetY :")
      StringGadget(#Str_OffsetY,600,170,40,20,Str(Font\ShadowY),#PB_String_Numeric)
      CanvasGadget(#Cnv_Preview,10,200,780,180)
      For FontLoop = 0 To 14
         AddGadgetItem(#Lst_Size,-1,Str(32+FontLoop*8))
      Next FontLoop
      If Font\Shadow
         SetGadgetState(#Chk_Shadow,#PB_Checkbox_Checked)
      EndIf
      BindGadgetEvent(#Chk_Bold,@Style())
      BindGadgetEvent(#Chk_Italic,@Style())
      BindGadgetEvent(#Chk_StrikeOut,@Style())
      BindGadgetEvent(#Chk_Shadow,@Shadow())
      BindGadgetEvent(#Lst_Size,@ChangeSize(),#PB_EventType_LeftClick)
      BindGadgetEvent(#Str_Size,@ChangeSize(),#PB_EventType_Change)
      BindGadgetEvent(#Btn_Color,@ChangeColor())
      BindGadgetEvent(#Btn_ShadowColor,@ChangeColor())
      BindGadgetEvent(#Btn_BackgroundColor,@ChangeColor())
      BindGadgetEvent(#Str_Alpha,@ShadowAlpha(),#PB_EventType_Change)
      BindGadgetEvent(#Str_OffsetX,@Offset(),#PB_EventType_Change)
      BindGadgetEvent(#Str_OffsetY,@Offset(),#PB_EventType_Change)
      BindGadgetEvent(#Str_MargeDown,@Marging(),#PB_EventType_Change)
      BindGadgetEvent(#Str_MargeLeft,@Marging(),#PB_EventType_Change)
      BindGadgetEvent(#Str_MargeRight,@Marging(),#PB_EventType_Change)
      BindGadgetEvent(#Str_MargeUp,@Marging(),#PB_EventType_Change)
      RefreshPreview()
   EndIf
EndProcedure

Procedure Load()
   Protected File$, *Buffer
   File$ = OpenFileRequester("Load file",GetCurrentDirectory(),"Font file(*.afg) | *.afg",0)
   If File$
      OpenPack(0,File$,#PB_PackerPlugin_Lzma )
      ExaminePack(0)
      NextPackEntry(0)
      *Buffer = AllocateMemory(PackEntrySize(0))
      UncompressPackMemory(0,*Buffer,MemorySize(*Buffer),PackEntryName(0))
      ClosePack(0)
      CatchJSON(0,*Buffer,MemorySize(*Buffer))
      ExtractJSONStructure(JSONValue(0),@Font,Font)
      FreeMemory(*Buffer)
      RefreshSample()
   EndIf
EndProcedure

Procedure GenerateFont()
   Font\String = GetGadgetText(#Str_Char)
   Protected X = Font\Width * 14, Y = Font\Height * Round((Len(Font\String)/14),#PB_Round_Up)
   Protected Img, LoopX, LoopY,OffsetX,OffsetY, JsonData, *Buffer,JsonSize,Temp$
   Protected NewMap Charset.char()
   X + 14 * (Font\MargeLeft+Font\MargeRight)
   Y + Round((Len(Font\String)/14),#PB_Round_Up) * (Font\MargeUp+Font\MargeDown)
   img = CreateImage(#PB_Any,X,Y,32,#PB_Image_Transparent)
   If img
      StartDrawing(ImageOutput(img))
      DrawingMode(#PB_2DDrawing_Transparent|#PB_2DDrawing_AlphaBlend)
      DrawingFont(FontID(0))
      For Loopy = 0 To Y/Font\Height-1
         For LoopX = 0 To 14
            If Font\Shadow
               DrawText(LoopX * Font\Width + Font\ShadowX + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight , LoopY * Font\Height + Font\ShadowY + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown, Mid(Font\String,(LoopX+1)+LoopY * 14,1),Font\ShadowColor)
               OffsetX = Font\ShadowX
               OffsetY = Font\ShadowY
            Else
               OffsetX = 0 : OffsetY = 0
            EndIf
            DrawText(LoopX * Font\Width + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight, LoopY * Font\Height + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown, Mid(Font\String,(LoopX+1)+LoopY * 14,1),Font\Color)
            If Not Mid(Font\String,(LoopX+1)+LoopY * 14,1) = ""
               Temp$ = Mid(Font\String,(LoopX+1)+LoopY * 14,1)
               If PeekC(@Temp$) > Font\MaxValue
                  Font\MaxValue = PeekC(@Temp$)
               EndIf
               Charset(Mid(Font\String,(LoopX+1)+LoopY * 14,1))\X = LoopX * Font\Width + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight
               Charset()\Y = LoopY * Font\Height + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown
               Charset()\Height = TextHeight(Mid(Font\String,(LoopX+1)+LoopY * 14,1))+OffsetX + (LoopX+1)* Font\MargeLeft + LoopX * Font\MargeRight
               Charset()\Width = TextWidth(Mid(Font\String,(LoopX+1)+LoopY * 14,1))+OffsetY + (LoopY+1) * Font\MargeUp + LoopY * Font\MargeDown
            EndIf
         Next LoopX
      Next LoopY
      StopDrawing()
      CreateJSON(0)
      InsertJSONStructure(JSONValue(0),@Font,Font)
      JsonData = AddJSONMember(JSONValue(0),"Chardata")
      InsertJSONMap(JsonData,Charset())
      *Buffer = AllocateMemory(ExportJSONSize(0))
      ExportJSON(0,*Buffer,MemorySize(*Buffer))
      CreatePack(0,Font\Name+".afg",#PB_PackerPlugin_Lzma)
      AddPackMemory(0,*Buffer,MemorySize(*Buffer),Font\Name+".json")
      FreeMemory(*Buffer)
      *Buffer = EncodeImage(img,#PB_ImagePlugin_PNG)
      AddPackMemory(0,*Buffer,MemorySize(*Buffer),Font\Name+".png")
      FreeMemory(*Buffer)
      ClosePack(0)   
      FreeImage(img)
      FreeJSON(0)
      MessageRequester("Awesome bitmapFont Generator","Font succefully generated")
      ProcedureReturn #True
   EndIf
   MessageRequester("Awesome bitmapFont Generator","An error has ocurred...")
EndProcedure

Procedure RefreshSample()
   Protected LoopX,LoopY, x, y, str$ = GetGadgetText(#Str_Char)
   Loadfnt()
   StartDrawing(CanvasOutput(#Cnv_Sample))
   Box(0,0,1180,628,Font\BackGroundColor)
   DrawingFont(FontID(0))
   DrawingMode(#PB_2DDrawing_Transparent|#PB_2DDrawing_AlphaBlend)
   Font\Height = TextHeight("A")
   Font\Width = TextWidth("A")+30
   x = 1180/Font\Width +1
   y = 628 / Font\Height
   For LoopY = 0 To y
      For LoopX = 0 To x
         If Font\Shadow
            DrawText(LoopX * Font\Width + Font\ShadowX,LoopY * Font\Height + Font\ShadowY,Mid(str$,LoopX + LoopY * x+1,1),Font\ShadowColor)
         EndIf
         DrawText(LoopX * Font\Width,LoopY * Font\Height,Mid(str$,LoopX + LoopY * x+1,1),Font\Color)
      Next LoopX
   Next LoopY
   StopDrawing()
EndProcedure

Procedure ChangeSize()
   If EventGadget() = #Lst_Size
      SetGadgetText(#Str_Size,GetGadgetText(#Lst_Size))
   EndIf
   font\Size = Val(GetGadgetText(#Str_Size))
   Loadfnt()
   RefreshPreview()
EndProcedure

Procedure Loadfnt()
   LoadFont(0,Font\Name,font\Size,Font\Flag)
EndProcedure

Procedure Marging()
   Select EventGadget()
      Case #Str_MargeDown
         Font\MargeDown = Val(GetGadgetText(#Str_MargeDown))
      Case #Str_MargeLeft
         Font\MargeLeft = Val(GetGadgetText(#Str_MargeLeft))
      Case #Str_MargeRight
         Font\MargeRight = Val(GetGadgetText(#Str_MargeRight))
      Case #Str_MargeUp
         Font\MargeUp = Val(GetGadgetText(#Str_MargeUp))
   EndSelect
EndProcedure

Procedure ChangeColor()
   Protected Color
   If EventGadget() = #Btn_Color
      Color = ColorRequester(font\Color)
      If Not Color = -1
         Font\Color = RGBA(Red(Color),Green(Color),Blue(Color),255)
         StartDrawing(ImageOutput(0))
         Box(0,0,30,20,Color)
         StopDrawing()
      EndIf
   ElseIf EventGadget() = #Btn_ShadowColor
      Color = ColorRequester(font\ShadowColor)
      If Not Color = -1
         Font\ShadowColor = RGBA(Red(Color),Green(Color),Blue(Color),Val(GetGadgetText(#Str_Alpha)))
         StartDrawing(ImageOutput(1))
         Box(0,0,30,20,Color)
         StopDrawing()
      EndIf
   Else
      Color = ColorRequester(Font\BackGroundColor)
      If Not Color = -1
         Font\BackGroundColor = Color
         StartDrawing(ImageOutput(2))
         Box(0,0,30,20,Color)
         StopDrawing()
      EndIf
   EndIf
   If Not Color = -1
      RefreshPreview()
   EndIf
EndProcedure

Procedure Style()
   font\Flag = 0
   If GetGadgetState(#Chk_Bold) = #PB_Checkbox_Checked
      Font\Flag | #PB_Font_Bold
   EndIf
   If GetGadgetState(#Chk_Italic) = #PB_Checkbox_Checked
      Font\Flag | #PB_Font_Italic
   EndIf
   If GetGadgetState(#Chk_StrikeOut) = #PB_Checkbox_Checked
      Font\Flag | #PB_Font_StrikeOut
   EndIf
   Loadfnt()
   RefreshPreview()
EndProcedure

Procedure Offset()
   Font\ShadowX = Val(GetGadgetText(EventGadget()))
   RefreshPreview()
EndProcedure

Procedure ShadowAlpha()
   Font\ShadowAlpha = Val(GetGadgetText(#Str_Alpha))
   Font\ShadowColor = RGBA(Red(Font\ShadowColor),Green(Font\ShadowColor),Blue(Font\ShadowColor),Font\ShadowAlpha)
   RefreshPreview()
EndProcedure

Procedure Shadow()
   If GetGadgetState(#Chk_Shadow) = #PB_Checkbox_Checked
      Font\Shadow = 1
   Else
      Font\Shadow = 0
   EndIf
   RefreshPreview()
EndProcedure

Procedure RefreshPreview()
   StartDrawing(CanvasOutput(#Cnv_Preview))
   Box(0,0,780,180,Font\BackGroundColor)
   DrawingMode(#PB_2DDrawing_Transparent|#PB_2DDrawing_AlphaBlend)
   DrawingFont(FontID(0))
   If Font\Shadow
      DrawText(10+Font\ShadowX,10+Font\ShadowY,"The quick brown fox jumped over the lazy dog.",Font\ShadowColor)
   EndIf
   DrawText(10,10,"The quick brown fox jumped over the lazy dog.",Font\Color)
   StopDrawing()
EndProcedure

Procedure Close()
   If GetActiveWindow() = #Window_Main
      End
   Else
      CFP_FreeGadget(101)
      CloseWindow(#Window_Font)
      FreeImage(0)
      FreeImage(1)
      FreeImage(2)
      SetGadgetText(#Txt_Font,Font\Name+","+Font\Size)
      RefreshSample()
   EndIf
EndProcedure

;===============================================================
;Display font with style & icon ================================
; Title: Font Preview ComboBox =================================
; Author: Fluid Byte ===========================================
; Platform: Windows ============================================
; Created: Jan 27, 2009 ========================================
; Updated: May 29, 2017 ========================================
; E-Mail: fluidbyte@web.de =====================================
;http://forums.purebasic.com/english/viewtopic.php?f=12&t=36198=
;===============================================================

Procedure CFP_Change()
   Font\Name = CFP_GetGadgetText(#Cmb_Font,GetGadgetState(#Cmb_Font))
   Loadfnt()
   RefreshPreview()
EndProcedure

Procedure CFP_CreateGagdet(Gadget,X,Y,Width,Height,ItemHeight=20,FontSize=11)
   Protected himlFontType, hwndParent, *cfpu.CFP_USERDATA
   
   himlFontType = ImageList_Create_(16,12,#ILC_MASK,0,0)
   ImageList_AddMasked_(himlFontType,CatchImage(0,?FontType),#Yellow)   
   
   hwndParent = GadgetID(ContainerGadget(#PB_Any,X,Y,Width,Height))
   ComboBoxGadget(Gadget,0,0,Width,Height,#CBS_OWNERDRAWFIXED)
   SendMessage_(GadgetID(Gadget),#CB_SETITEMHEIGHT,0,ItemHeight)   
   CloseGadgetList()
   
   *cfpu = AllocateMemory(SizeOf(CFP_USERDATA))
   *cfpu\himlFontType = himlFontType
   *cfpu\FontSize = FontSize
   *cfpu\hwndParent = hwndParent
   SetWindowLongPtr_(GadgetID(Gadget),#GWLP_USERDATA,*cfpu)
   
   SetWindowLongPtr_(hwndParent,#GWL_WNDPROC,@CFP_WndProc())
   
   CFP_EnumFonts(Gadget)
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure.s CFP_GetGadgetText(Gadget,Item)
   If IsGadget(Gadget)
      Protected *cfpf.CFP_FONTDATA
      *cfpf = GetGadgetItemData(Gadget,Item)     
      ProcedureReturn *cfpf\Name
   EndIf
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_FreeGadget(Gadget)
   If IsGadget(Gadget)
      Protected *cfpu.CFP_USERDATA, Result
      
      *cfpu = GetWindowLongPtr_(GadgetID(Gadget),#GWLP_USERDATA)
      
      If *cfpu
         Result = ImageList_Destroy_(*cfpu\himlFontType)
         
         If Result : Result = FreeMemory(*cfpu) : EndIf
      EndIf
   EndIf
   
   ProcedureReturn Result
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_WndProc(hWnd,uMsg,wParam,lParam)
   Select uMsg
      Case #WM_COMMAND
         Select (wParam >> 16) & $ffff
            Case  #CBN_SELCHANGE
               CFP_Change()
         EndSelect
      Case #WM_DRAWITEM
         Protected *lpdis.DRAWITEMSTRUCT = lParam   
         
         ; --- Draw item focus rectangle or normal state     
         If *lpdis\itemState & #ODS_SELECTED
            Protected hbrFocus = CreateSolidBrush_(GetSysColor_(#COLOR_HIGHLIGHT))
            FillRect_(*lpdis\hDC,*lpdis\rcItem,hbrFocus)
            DeleteObject_(hbrFocus)
            DrawFocusRect_(*lpdis\hDC,*lpdis\rcItem)           
            SetTextColor_(*lpdis\hDC,GetSysColor_(#COLOR_HIGHLIGHTTEXT))
         Else
            Protected hbrFace = CreateSolidBrush_(GetSysColor_(#COLOR_WINDOW))
            FillRect_(*lpdis\hDC,*lpdis\rcItem,hbrFace)
            DeleteObject_(hbrFace)
            SetTextColor_(*lpdis\hDC,GetSysColor_(#COLOR_WINDOWTEXT))
         EndIf   
         
         Protected *ftd.CFP_FONTDATA = GetGadgetItemData(wParam,*lpdis\itemID)         
         Protected *cfpu.CFP_USERDATA = GetWindowLongPtr_(*lpdis\hwndItem,#GWLP_USERDATA)
         
         ; --- Draw Font Icons
         If *ftd\Type > -1
            ImageList_Draw_(*cfpu\himlFontType,*ftd\Type,*lpdis\hDC,2,*lpdis\rcItem\top + 3,#ILD_TRANSPARENT)
         EndIf
         
         ; --- Create Preview Font
         Protected lplf.LOGFONT, hfntPreview
         
         lplf\lfHeight = -MulDiv_(*cfpu\FontSize,GetDeviceCaps_(*lpdis\hDC,#LOGPIXELSY),72)         
         
         If *ftd\Symbol : lplf\lfCharSet = #SYMBOL_CHARSET : EndIf         
         
         PokeS(@lplf\lfFaceName,*ftd\name)         
         
         hfntPreview = CreateFontIndirect_(lplf)
         
         ; --- Draw Preview Text
         SetBkMode_(*lpdis\hDC,#TRANSPARENT)   
         
         If *ftd\Symbol ; If it's a smybol font like Webdings
            Protected fsz.SIZE
            
            ; Write the fonts name
            *lpdis\rcItem\left + 20
            SelectObject_(*lpdis\hDC,GetStockObject_(#DEFAULT_GUI_FONT))
            GetTextExtentPoint32_(*lpdis\hDC,*ftd\Name,Len(*ftd\Name),fsz)
            DrawText_(*lpdis\hDC,*ftd\Name,-1,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)   
            
            ; Display demo charachters next to the name
            *lpdis\rcItem\left + fsz\cx + 3
            SelectObject_(*lpdis\hDC,hfntPreview)
            DrawText_(*lpdis\hDC,"ABC123",6,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)
         Else
            *lpdis\rcItem\left + 20
            SelectObject_(*lpdis\hDC,hfntPreview)         
            DrawText_(*lpdis\hDC,*ftd\Name,-1,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)
         EndIf   
         
         DeleteObject_(hfntPreview)
         
         ProcedureReturn #True
   EndSelect
   ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_EnumFonts(Gadget)
   Protected lplf.LOGFONT, hdc, Index, start
   
   lplf\lfCharset = #DEFAULT_CHARSET
   
   hdc = GetDC_(0)
   EnumFontFamiliesEx_(hdc,lplf,@CFP_EnumProc(),hdc,0)
   ReleaseDC_(0,hdc)
   
   SortStructuredList(ftd(),#PB_Sort_Ascending,OffsetOf(CFP_FONTDATA\Name),#PB_String)
   
   ForEach ftd()
      AddGadgetItem(Gadget,-1,ftd()\Name)
      If ftd()\Name = Font\Name
         start = Index
      EndIf
      SetGadgetItemData(Gadget,Index,ftd())
      Index + 1           
   Next
   SetGadgetState(Gadget,start)
EndProcedure

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Procedure CFP_EnumProc(*lpelfe.ENUMLOGFONTEX,*lpntme.NEWTEXTMETRICEX,FontType,lParam)
   Protected CHRSET = *lpelfe\elfLogFont\lfCharSet & 255
   
   ; WESTERN FONTS / SYSTEM FONTS / SYMBOL FONTS
   If Not Left(PeekS(@*lpelfe\elfLogFont\lfFaceName),1) = "@"
      If CHRSET = #ANSI_CHARSET Or CHRSET = #OEM_CHARSET Or CHRSET = #SYMBOL_CHARSET
         AddElement(ftd())
         
         Select FontType
            Case #TRUETYPE_FONTTYPE : ftd()\Type = 0
            Case #DEVICE_FONTTYPE : ftd()\Type = 1
            Case #RASTER_FONTTYPE : ftd()\Type = 2
            Default : ftd()\Type = -1
         EndSelect
         
         If CHRSET = #SYMBOL_CHARSET : ftd()\Symbol = 1 : EndIf
         
         ; Using 'lfFaceName' of the LOGFONT structure gives unique fontnames and avoids dublicates.
         ; When using 'elfFullName' of the ENUMLOGFONTEX structure you still can get dublicates even
         ; though you limit the character set like above. Also you don't need to cycle through the
         ; whole LinkedList everytime to find out if a fontname already exists.
         ;
         ; The created fontlist SHOULD be identical to the one in MS Wordpad + bitmap fonts (Courier, etc.)
         ftd()\Name = PeekS(@*lpelfe\elfLogFont\lfFaceName)
      EndIf
   EndIf
   
   ProcedureReturn #True
EndProcedure

DataSection
   FontType:
   Data.l $01964D42,$00000000,$00760000,$00280000,$00300000,$000C0000,$00010000,$00000004,$01200000,$00000000
   Data.l $00000000,$00000000,$00000000,$00000000,$00000000,$80000080,$80000000,$00800080,$00800000,$80800080
   Data.l $80800000,$C0C00080,$000000C0,$FF0000FF,$FF000000,$00FF00FF,$00FF0000,$FFFF00FF,$FFFF0000,$BBBB00FF
   Data.l $5555BBBB,$BBBBBB55,$BB7B77B8,$B9BBBBBB,$97B97B99,$BBBBBBBB,$55BBBBBB,$BBBBBBBB,$8B868870,$99BBBBBB
   Data.l $79999799,$BBBBBBBB,$55BBBBBB,$B8BBBBBB,$68B8BB00,$99BBBBBB,$B799797B,$BBBBBB9B,$55666666,$B8BBBBBB
   Data.l $76BBBB00,$99BBBB8B,$7B99B77B,$BBBBBBBB,$55BB66BB,$B8BBBBBB,$86BBBB00,$99BBBB6B,$9B79BB7B,$BBBBBBBB
   Data.l $55BB65BB,$B8BB5BBB,$B6BB8B00,$79BBBB68,$97B9BB9B,$BBBBBBBB,$55BB65BB,$BBBB5BBB,$B6BB7B00,$B9BBBB68
   Data.l $99B7BB97,$BBBBBBBB,$555B65BB,$BBBB5BB5,$B7BB0B70,$B7BBBB66,$99BBBB99,$B6BBBB7B,$555565BB,$BBBB5B55
   Data.l $B7BB08B0,$BBBBBB68,$79BB9B79,$B6BBBB9B,$6BBB66BB,$BBBBBBBB,$B7BB00B8,$BBBBBB68,$79BB99B7,$B6BBBB97
   Data.l $6BB6666B,$BBBBBBBB,$867880BB,$BBBBBB6B,$9799B9BB,$B6BBBB79,$6B666666,$BBBBBBBB,$6887BBBB,$BBBBBBBB
   Data.l $BBBBBBBB
   Data.b $BB,$BB
EndDataSection


Tout petit Bugfix sur l'éditeur.


Haut
 Profil  
Répondre en citant le message  
Afficher les messages postés depuis:  Trier par  
Poster un nouveau sujet Répondre au sujet  [ 11 messages ] 

Heures au format UTC + 1 heure


Qui est en ligne

Utilisateurs parcourant ce forum: Aucun utilisateur enregistré et 1 invité


Vous ne pouvez pas poster de nouveaux sujets
Vous ne pouvez pas répondre aux sujets
Vous ne pouvez pas éditer vos messages
Vous ne pouvez pas supprimer vos messages

Rechercher:
Aller à:  

 


Powered by phpBB © 2008 phpBB Group | Traduction par: phpBB-fr.com
subSilver+ theme by Canver Software, sponsor Sanal Modifiye