kleines Tool zur Fontverwaltung

Hier könnt Ihr gute, von Euch geschriebene Codes posten. Sie müssen auf jeden Fall funktionieren und sollten möglichst effizient, elegant und beispielhaft oder einfach nur cool sein.
Benutzeravatar
hjbremer
Beiträge: 822
Registriert: 27.02.2006 22:30
Computerausstattung: von gestern
Wohnort: Neumünster

kleines Tool zur Fontverwaltung

Beitrag von hjbremer »

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

Purebasic 5.70 x86 5.72 X 64 - Windows 10

Der Computer hat dem menschlichen Gehirn gegenüber nur einen Vorteil: Er wird benutzt
grüße hjbremer