PureBoard

Code: Alles auswählen

;by HJBremer - Februar 2015 - 2.10, ab Purebasic 5.20(x86) Windows XP

;Hinweis für GetDC() etc.: Alles mit Create benötigt ein Delete, alles mit Get ein Release.

If Defined(euro, #PB_Constant) = 0  
   CompilerIf #PB_Compiler_Unicode
      #euro = Chr(8364)
   CompilerElse
      #euro = Chr(0128)
   CompilerEndIf
EndIf
   
DeclareModule FontListe
   
   Declare.i FontSize(pbnr, gap = 9)
   Declare.i FontSearch(pbnr, name$, fonthh, style = 0) 
   
   Declare.i GetTextWidth(pbnr, t$)
   
EndDeclareModule

Module FontListe     
   EnableExplicit
   
   Structure FontList  ;zur Verwaltung der Fonts
      name.s
      fontid.i
      fonthh.i
      style.i
   EndStructure
   
   Global NewList font.Fontlist()
   
   Procedure.i FontSize(pbnr, gap = 9)
      ;welche Fonthöhe passt ins Gadget; gap steht für Rahmen + Abstand 
      Protected dc = GetDC_(0)
      Protected gadgethh = GadgetHeight(pbnr) - gap  
      Protected logpixel = GetDeviceCaps_(dc, #LOGPIXELSY): ReleaseDC_(0, dc)      
      Protected fontsize = -MulDiv_(-gadgethh, 72, logpixel)   
      ProcedureReturn fontsize
   EndProcedure 
   
   Procedure.i FontSearch(pbnr, name$, fonthh, style = 0)
      Protected fontid      
      ForEach font()
         If fonthh = font()\fonthh
            If style = font()\style
               If name$ = font()\name
                  fontid = font()\fontid
               EndIf
            EndIf   
         EndIf
      Next   
      If fontid = 0
         fontid = FontID(LoadFont(#PB_Any, name$, fonthh, style))
         AddElement(font())
         font()\fontid = fontid 
         font()\fonthh = fonthh 
         font()\style  = style 
         font()\name   = name$ 
      EndIf      
      SetGadgetFont(pbnr, fontid)      
      ProcedureReturn fontid
   EndProcedure  
   
   Procedure.i GetTextWidth(pbnr, t$)
      ;wie GadgetWidth(pbnr, #PB_Gadget_RequiredSize) nur ohne Border
      Protected size.size, dc = GetDC_(0)
      SelectObject_(dc, GetGadgetFont(pbnr))
      GetTextExtentPoint32_(dc, @t$, Len(t$), size)      
      ReleaseDC_(0, dc)
      ProcedureReturn size\cx       
   EndProcedure    
      
EndModule

UseModule FontListe

OpenWindow(0, 0, 0, 270, 160, "TextGadget", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
    TextGadget(0, 10,  10, 250, 20, "TextGadget Standard (Left)")
    TextGadget(1, 10,  40, 250, 22, "TextGadget Center", #PB_Text_Center)
    TextGadget(2, 10,  70, 250, 24, "TextGadget Right", #PB_Text_Right)
    TextGadget(3, 10, 100, 250, 27, "TextGadget Border für 3 " + #euro, #PB_Text_Border)
    TextGadget(4, 10, 130, 250, 30, "TextGadget Center", #PB_Text_Center | #PB_Text_Border)
    
    fonthh = FontSize(0)
    fontid = FontSearch(0, "Arial", fonthh, #PB_Font_Bold)
    
    FontSearch(1, "Arial", FontSize(1), #PB_Font_Italic)
    FontSearch(2, "Arial", FontSize(2))
    FontSearch(3, "Arial", FontSize(3))
    FontSearch(4, "Arial", FontSize(4))
    
    Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow