PureBasic

Code : Tout sélectionner

;Coded by celtic88 2016(c)
;Update For PB 5.50

; EnableExplicit

; Function : 

; LoadFontFromMemoiryEx() : Load Font From memory ==> Return : Point to  _FontExInfo
; LoadFontFromFileEx() : Load Font From File ==> Return : Point to  _FontExInfo
; LoadFontEx() : Load Font By The Face Name Of Font ==> Return : Point to  _FontExInfo
; GetFontIDEx() : Get handle of font ==> Return : handle *integer
; FreeFontEx() : destroy font and free the occupied memory. ==> Return : Success ==> #True 

; Parameters :

; HFontInfo : Point given by : LoadFontFromMemoiryEx() ; LoadFontFromFileEx() ; LoadFontEx()

; sFaceName; The typeface name of the font (Not including style). For example, "Arial", "Tahoma", etc ..

; *pData : The pointer To the font memory

; iSizepData : The number of bytes in the font

; sFilePath : String that contains a valid font file name. This parameter can specify any of the following files:
;     .fon - Font resource file.
;     .fnt - Raw bitmap font file.
;     .ttf - Raw TrueType file.
;     .ttc - East Asian Windows: TrueType font collection.
;     .fot - TrueType resource file.
;     .otf - PostScript OpenType font.
;     .mmm - Multiple master Type1 font resource file. It must be used With .pfm And .pfb files.
;     .pfb - Type 1 font bits file. It is used With a .pfm file.
;     .pfm - Type 1 font metrics file. It is used With a .pfb file.

; iHeight : The height of the font's character cell or character, in logical units. 
; 
; iWidth : [optional] The average width, in logical units. Default is 0. 
; 
; iEscapement : [optional] The angle, in tenths of degrees, between the escapement vector And the x-axis of the device. Default is 0 
; 
; iOrientation : [optional] The angle, in tenths of degrees, between each character's base line and the x-axis of the device. Default is 0 

; iWeight : [optional] The weight of the font in the range 0 through 1000, Or one of the following values.
;     #FW_DONTCARE
;     #FW_THIN
;     #FW_EXTRALIGHT
;     #FW_ULTRALIGHT
;     #FW_LIGHT
;     #FW_NORMAL (Default)
;     #FW_REGULAR
;     #FW_MEDIUM
;     #FW_SEMIBOLD
;     #FW_DEMIBOLD
;     #FW_BOLD
;     #FW_EXTRABOLD
;     #FW_ULTRABOLD
;     #FW_HEAVY
;     #FW_BLACK 
; 	
; bItalic : [optional] Specifies whether To set italic font attribute, valid values:
;     #True - The attribute is set.
;     #False - The attribute is Not set (Default). 
; 	
; bUnderline : [optional] Specifies whether To set underlined font attribute, valid values:
;     #True - The attribute is set.
;     #False - The attribute is Not set (Default). 
; 	
; bStrikeOut : [optional] Specifies whether To set strikeout font attribute, valid values:
;     #True - The attribute is set.
;     #False - The attribute is Not set (Default). 
; 	
; iCharSet : [optional] The character set. It can be one of the following values.
;     #ANSI_CHARSET
;     #BALTIC_CHARSET
;     #CHINESEBIG5_CHARSET
;     #DEFAULT_CHARSET (Default)
;     #EASTEUROPE_CHARSET
;     #GB2312_CHARSET
;     #GREEK_CHARSET
;     #HANGEUL_CHARSET
;     #MAC_CHARSET
;     #OEM_CHARSET
;     #RUSSIAN_CHARSET
;     #SHIFTJIS_CHARSET
;     #SYMBOL_CHARSET
;     #TURKISH_CHARSET
;     #VIETNAMESE_CHARSET
; Korean language edition of Windows:
;     #JOHAB_CHARSET
; Middle East language edition of Windows:
;     #ARABIC_CHARSET
;     #HEBREW_CHARSET
; Thai language edition of Windows:
;     #THAI_CHARSET
; 	
; iOutPrecision : [optional] The output precision. It can be one of the following values.
;     #OUT_CHARACTER_PRECIS
;     #OUT_DEFAULT_PRECIS (Default)
;     #OUT_DEVICE_PRECIS
;     #OUT_OUTLINE_PRECIS
;     #OUT_PS_ONLY_PRECIS
;     #OUT_RASTER_PRECIS
;     #OUT_STRING_PRECIS
;     #OUT_STROKE_PRECIS
;     #OUT_TT_ONLY_PRECIS
;     #OUT_TT_PRECIS 
; 	
; iClipPrecision : [optional] The clipping precision. It can be one Or more of the following values.
;     #CLIP_CHARACTER_PRECIS
;     #CLIP_DEFAULT_PRECIS (Default)
;     #CLIP_DFA_DISABLE
;     #CLIP_EMBEDDED
;     #CLIP_LH_ANGLES
;     #CLIP_DFA_OVERRIDE
;     #CLIP_STROKE_PRECIS
; 	
; iQuality : [optional] The output quality. It can be one of the following values.
;     #ANTIALIASED_QUALITY
;     #CLEARTYPE_QUALITY
;     #DEFAULT_QUALITY (Default)
;     #DRAFT_QUALITY
;     #NONANTIALIASED_QUALITY
;     #PROOF_QUALITY
; 	
; iPitchAndFamily : [optional] The pitch And family of the font. The two low-order bits specify the pitch of the font And can be one of the following values.
;     #DEFAULT_PITCH (Default)
;     #FIXED_PITCH
;     #VARIABLE_PITCH
; The four high-order bits specify the font family And can be one of the following values.
;     #FF_DECORATIVE
;     #FF_DONTCARE
;     #FF_MODERN
;     #FF_ROMAN
;     #FF_SCRIPT
;     #FF_SWISS
; 
; iStyle : [optional] The style of the font. It can be one Or more of the following values.
;     #FS_REGULAR (Default)
;     #FS_BOLD
;     #FS_ITALIC

;For more info : https://msdn.microsoft.com/en-us/library/windows/desktop/dd145037(v=vs.85).aspx

#FS_REGULAR = $00
#FS_BOLD = $01
#FS_ITALIC = $02

Define iFunicod.s = Chr(65 + (22*#PB_Compiler_Unicode))
Define gdi32 = OpenLibrary(#PB_Any, "gdi32.dll")
Prototype.l AddFontResourceEx_(*name, fl.l, *res)
Prototype.l RemoveFontResourceEx_(*name, fl.l, *res)
Prototype.l GetFontResourceInfo_(*psFont,*pLenstrBuff,*pstrBuff,iFlag.l)
Global AddFontResourceEx_.AddFontResourceEx_ = GetFunction(gdi32,"AddFontResourceEx" + iFunicod)
Global RemoveFontResourceEx_.RemoveFontResourceEx_ = GetFunction(gdi32,"RemoveFontResourceEx"+ iFunicod)
Global GetFontResourceInfo.GetFontResourceInfo_ = GetFunction(gdi32,"GetFontResourceInfo"+ iFunicod)

Structure _FontExInfo
  IfType.b
  HfontID.i
  HFFMem.i
  FFFileS.s
EndStructure

Structure FN_GetFontName
  iFlags.l
  Fontname.c[64]
EndStructure

Structure LOGFONTEx Extends LOGFONT 
  FullName.c[64]
  Style.c[32]
  Script.c[32]
EndStructure

Structure TT_OFFSET_TABLE
  uMajorVersion.w
  uMinorVersion.w
  uNumOfTables.w
  uSearchRange.w
  uEntrySelector.w
  uRangeShift.w
EndStructure

Structure TT_TABLE_DIRECTORY
  szTag.b[4]
  uCheckSum.l
  uOffset.l
  uLength.l
EndStructure

Structure TT_NAME_TABLE_HEADER
  uFSelector.w
  uNRCount.w
  uStorageOffset.w
EndStructure

Structure TT_NAME_RECORD
  uPlatformID.w
  uEncodingID.w
  uLanguageID.w
  uNameID.w
  uStringLength.w
  uStringOffset.w
EndStructure

;======= Internal Procedure =================

Procedure.l OLDFONTENUMPROC(*logfonta.LOGFONTEx, *textmetrica.NEWTEXTMETRICEX, iFontType.l, *lparam.FN_GetFontName)
  If (*textmetrica\ntmTm\ntmFlags & #NTM_BOLD|#NTM_ITALIC|#NTM_REGULAR) = *lparam\iFlags 
    PokeS(*lparam+ OffsetOf(FN_GetFontName\Fontname) ,Left(PeekS(@*logfonta\FullName),64)) : ProcedureReturn 0
  EndIf
  ProcedureReturn 1
EndProcedure

Procedure.s GetFontNameEx(sFaceName.s, iStyle.l = #FS_REGULAR, iCharSet.l = 1)
  Protected tLOGFONT.LOGFONTEx 
  With tLOGFONT
    \lfCharSet = iCharSet
    PokeS(tLOGFONT+ OffsetOf(LOGFONT\lfFaceName) ,Left(sFaceName,32))
  EndWith
  Protected tFN.FN_GetFontName\iFlags =iStyle
  Protected hDC = CreateCompatibleDC_(#NUL)
  Protected aRet.l = EnumFontFamiliesEx_(hDC, tLOGFONT, @OLDFONTENUMPROC(), tFN, 0)
  Protected sRet.s
  If Not aRet : sRet = PeekS(@tFN\Fontname) : EndIf
  DeleteDC_(hDC)
  ProcedureReturn sRet
EndProcedure

Procedure.i CreateFontEx(sFaceName.s,iHeight.l, iQuality.l = #DEFAULT_QUALITY, iWeight.l = #FW_NORMAL, iStyle.l = #FS_REGULAR, iWidth.l = #False, iEscapement.l = #False, iOrientation.l = #False, bItalic.l = #False, bUnderline.l = #False, bStrikeOut.l = #False, iCharSet.l = #DEFAULT_CHARSET, iOutPrecision.l = #OUT_DEFAULT_PRECIS, iClipPrecision.l = #CLIP_DEFAULT_PRECIS, iPitchAndFamily.l = #DEFAULT_PITCH )
  Protected FontUname.s = GetFontNameEx(sFaceName, iStyle, iCharSet)
  If FontUname = "" :  FontUname = sFaceName : EndIf
  Protected lptf.LOGFONT
  With lptf
    \lfHeight                                               = iHeight
    \lfWeight                                              = iWeight
    \lfCharSet                                            = iCharSet
    \lfWidth                                                = iWidth
    \lfEscapement                                      = iEscapement
    \lfOrientation                                        = iOrientation
    \lfItalic                                                 = bItalic
    \lfUnderline                                          = bUnderline
    \lfStrikeOut                                          = bStrikeOut
    \lfOutPrecision                                     = iOutPrecision
    \lfClipPrecision                                     = iClipPrecision
    \lfQuality                                             = iQuality
    \lfPitchAndFamily                                 = iPitchAndFamily
    PokeS(lptf+ OffsetOf(LOGFONT\lfFaceName) ,Left(FontUname,32))
  EndWith
  ProcedureReturn CreateFontIndirect_(lptf)
EndProcedure

Procedure.l DeleteFontEx(hFont)
  ProcedureReturn DeleteObject_(hFont) 
EndProcedure

Macro SwapDataType(iValue,iReturn)
  Protected vSize.b = SizeOf(iReturn)-1,ii.b:For ii= 0 To vSize:PokeB(@iReturn+ii,PeekB(@iValue+(vSize-ii))):Next
EndMacro

Procedure.w SwapWord(iValue.w)
  Protected iReturn.w
  SwapDataType(iValue,iReturn)
  ProcedureReturn iReturn
EndProcedure

Procedure.l SwapLong(iValue.l)
  Protected iReturn.l
  SwapDataType(iValue,iReturn)
  ProcedureReturn iReturn
EndProcedure

Procedure.s GetFontFromMemoryInfo(*pMemory, iFlag.l = 1)
  Protected *tTTOffsetTable.TT_OFFSET_TABLE = *pMemory
  Protected iNumOfTables.w = SwapWord(*tTTOffsetTable\uNumOfTables)
  
  ;check is this is a true type font and the version is 1.0
  If Not (SwapWord(*tTTOffsetTable\uMajorVersion) = 1 And SwapWord(*tTTOffsetTable\uMinorVersion) = 0) : ProcedureReturn : EndIf
  
  Protected bFound.b = 0, iOffset.l, *tTblDir.TT_TABLE_DIRECTORY,sZName.s,i.w
  For i = 0 To iNumOfTables - 1
    *tTblDir = *pMemory + SizeOf(TT_OFFSET_TABLE) + (i * SizeOf(TT_TABLE_DIRECTORY))
    sZName = PeekS(@*tTblDir\szTag,-1,#PB_Ascii)
    
    If Left(sZName, 4) = "name"
      bFound = 1
      iOffset = SwapLong(*tTblDir\uOffset)
      Break
    EndIf
  Next
  
  If Not bFound : ProcedureReturn : EndIf
  
  Protected *tNTHeader.TT_NAME_TABLE_HEADER = *pMemory + iOffset
  
  Protected iNRCount.w = SwapWord(*tNTHeader\uNRCount)
  Protected iStorageOffset.w = SwapWord(*tNTHeader\uStorageOffset)
  
  Protected *tTTRecord.TT_NAME_RECORD
  
  For i = 0 To iNRCount - 1
    *tTTRecord = *pMemory + iOffset + SizeOf(TT_NAME_TABLE_HEADER) + (i * SizeOf(TT_NAME_RECORD))
    If SwapWord(*tTTRecord\uNameID) = iFlag
      Protected iStringLength.w = SwapWord(*tTTRecord\uStringLength)
      Protected	iStringOffset.w = SwapWord(*tTTRecord\uStringOffset)
      Protected	iEncodingID.w = SwapWord(*tTTRecord\uEncodingID)
      ProcedureReturn PeekS(*pMemory + iOffset + iStringOffset + iStorageOffset,iStringLength,#PB_Ascii)
    EndIf
    
  Next
  
EndProcedure

Procedure.l DeleteFontFromMemoiryEx(hFont)
  ProcedureReturn RemoveFontMemResourceEx_(hFont)
EndProcedure

Procedure.l DeleteFontFromFileEx(sFilePath.s)
  ProcedureReturn RemoveFontResourceEx_(@sFilePath, $20, 0)
EndProcedure

Procedure.s GetFontFromFileInfo(sFilePath.s, iFlag.l = 1,MaxLenBuffer.l = #MAX_PATH)
  Protected infofont.s=Space(MaxLenBuffer)
  If GetFontResourceInfo(@sFilePath,@MaxLenBuffer,@infofont,iFlag)  
    ProcedureReturn infofont
  EndIf
EndProcedure

;======= End Internal Procedure =================

Procedure.i LoadFontFromMemoiryEx(*pData, iSizepData.l,iHeight.l, iQuality.l = #DEFAULT_QUALITY, iWeight.l = #FW_NORMAL, iStyle.l = #FS_REGULAR, iWidth.l = #False, iEscapement.l = #False, iOrientation.l = #False, bItalic.l = #False, bUnderline.l = #False, bStrikeOut.l = #False, iCharSet.l = #DEFAULT_CHARSET, iOutPrecision.l = #OUT_DEFAULT_PRECIS, iClipPrecision.l = #CLIP_DEFAULT_PRECIS, iPitchAndFamily.l = #DEFAULT_PITCH )
  Protected pNumFonts.l,hFontReturn.i,*FontExInfo._FontExInfo,hfontmem=AddFontMemResourceEx_( *pData, iSizepData, 0, @pNumFonts)
  If hfontmem
    Protected  Fontname.s = GetFontFromMemoryInfo(*pData,1)
    If Fontname <> ""
      hFontReturn = CreateFontEx(Fontname,iHeight, iQuality, iWeight, iStyle, iWidth, iEscapement, iOrientation, bItalic, bUnderline, bStrikeOut, iCharSet, iOutPrecision, iClipPrecision, iPitchAndFamily)
      If hFontReturn
        *FontExInfo = AllocateMemory(SizeOf(_FontExInfo))
        *FontExInfo\HfontID = hFontReturn
        *FontExInfo\HFFMem = hfontmem
        *FontExInfo\IfType = 3
      EndIf  
    EndIf
  EndIf
  If Not  hFontReturn And hfontmem
    DeleteFontFromMemoiryEx(hfontmem)
  EndIf
  ProcedureReturn *FontExInfo
EndProcedure

Procedure.i LoadFontFromFileEx(sFilePath.s, iHeight.l, iQuality.l = #DEFAULT_QUALITY, iWeight.l = #FW_NORMAL, iStyle.l = #FS_REGULAR, iWidth.l = #False, iEscapement.l = #False, iOrientation.l = #False, bItalic.l = #False, bUnderline.l = #False, bStrikeOut.l = #False, iCharSet.l = #DEFAULT_CHARSET, iOutPrecision.l = #OUT_DEFAULT_PRECIS, iClipPrecision.l = #CLIP_DEFAULT_PRECIS, iPitchAndFamily.l = #DEFAULT_PITCH )
  Protected hFontReturn.i,*FontExInfo._FontExInfo,hfontmem  = AddFontResourceEx_(@sFilePath, $20, 0)
  If hfontmem
    Protected  Fontname.s = GetFontFromFileInfo(sFilePath,1)
    If Fontname <> ""
      hFontReturn = CreateFontEx(Fontname,iHeight, iQuality, iWeight, iStyle, iWidth, iEscapement, iOrientation, bItalic, bUnderline, bStrikeOut, iCharSet, iOutPrecision, iClipPrecision, iPitchAndFamily)
      If hFontReturn
        *FontExInfo = AllocateMemory(SizeOf(_FontExInfo))
        *FontExInfo\HfontID = hFontReturn
        *FontExInfo\FFFileS = sFilePath
        *FontExInfo\IfType = 2
      EndIf
    EndIf
  EndIf
  If Not  hFontReturn And hfontmem
    DeleteFontFromFileEx(sFilePath)
  EndIf
  ProcedureReturn *FontExInfo
EndProcedure

Procedure LoadFontEx(sFaceName.s,iHeight.l, iQuality.l = #DEFAULT_QUALITY, iWeight.l = #FW_NORMAL, iStyle.l = #FS_REGULAR, iWidth.l = #False, iEscapement.l = #False, iOrientation.l = #False, bItalic.l = #False, bUnderline.l = #False, bStrikeOut.l = #False, iCharSet.l = #DEFAULT_CHARSET, iOutPrecision.l = #OUT_DEFAULT_PRECIS, iClipPrecision.l = #CLIP_DEFAULT_PRECIS, iPitchAndFamily.l = #DEFAULT_PITCH )
  Protected *FontExInfo._FontExInfo,hFontReturn
  hFontReturn = CreateFontEx(sFaceName,iHeight, iQuality, iWeight, iStyle, iWidth, iEscapement, iOrientation, bItalic, bUnderline, bStrikeOut, iCharSet, iOutPrecision, iClipPrecision, iPitchAndFamily)
  If hFontReturn
    *FontExInfo = AllocateMemory(SizeOf(_FontExInfo))
    *FontExInfo\HfontID = hFontReturn
    *FontExInfo\IfType = 1
  EndIf  
  ProcedureReturn *FontExInfo
EndProcedure

Procedure GetFontIDEx(HFontInfo)
  Protected *FontExInfo._FontExInfo
  If Not HFontInfo : ProcedureReturn : EndIf
  *FontExInfo = HFontInfo
  ProcedureReturn *FontExInfo\HfontID
EndProcedure

Procedure.l FreeFontEx(HFontInfo)
  Protected *FontExInfo._FontExInfo, iReturn.l
  If Not HFontInfo : ProcedureReturn : EndIf
  *FontExInfo = HFontInfo
  Select *FontExInfo\IfType
    Case 1
      iReturn + 1
    Case 2
      iReturn + DeleteFontFromFileEx(*FontExInfo\FFFileS)
    Case 3
      iReturn + DeleteFontFromMemoiryEx(*FontExInfo\HFFMem)
  EndSelect
  iReturn + DeleteFontEx(*FontExInfo\HfontID)
  iReturn + FreeMemory(*FontExInfo)
  ProcedureReturn Bool(iReturn = 3)
EndProcedure  

Code : Tout sélectionner

IncludeFile "FontEX.PBI"

hfont = LoadFontFromFileEx("AlexBrush-Regular.ttf", 50)
Debug hfont

OpenWindow(0,0,0,500,250,"test font",#PB_Window_ScreenCentered |#PB_Window_SystemMenu)
EditorGadget(0,0,0,500,250,#PB_Editor_WordWrap)
SetGadgetText(0,"La vie est toujours trop cruelle. Tout ce que nous pouvons faire, c'est essayer de passer le ballon et laisser le soleil briller. En espérant qu'il brille pour tout le monde.")
SetGadgetFont(0,GetFontIDEx(hfont))

Repeat
  Event = WaitWindowEvent()
Until Event = #PB_Event_CloseWindow

Code : Tout sélectionner

LoadFontFromFileEx("FreePixel.ttf", 20)

Code : Tout sélectionner

 #Fenetre = 1
 #GadgetCanvas = 2

Procedure DrawTexte(Texte.s)
 Protected.d sx, sy, tw, th, ox, oy
  
 ResizeGadget(#GadgetCanvas, #PB_Ignore, #PB_Ignore, WindowWidth(#Fenetre), WindowHeight(#Fenetre))
 
 StartVectorDrawing(CanvasVectorOutput(#GadgetCanvas))
 VectorSourceColor(RGBA(0,0,0,255))
 FillVectorOutput()
 VectorFont(GetFontIDEx(font))
 VectorSourceColor(RGBA(255,0,0,255))
 
 ox = VectorTextWidth(Texte, #PB_VectorText_Visible|#PB_VectorText_Offset)
 oy = VectorTextHeight(Texte, #PB_VectorText_Visible|#PB_VectorText_Offset)
 tw = VectorTextWidth(Texte, #PB_VectorText_Visible)
 th = VectorTextHeight(Texte, #PB_VectorText_Visible)
 sx = 0.8 * VectorOutputWidth() / tw
 sy = 0.8 * VectorOutputHeight() / th
 TranslateCoordinates(0.5 * VectorOutputWidth(), 0.5 * VectorOutputHeight())
 ScaleCoordinates(sx, sy)
 ;MovePathCursor(-ox -0.5 * tw, -oy -0.5 * th)
 DrawVectorText(Texte)
 
 StopVectorDrawing()
  
EndProcedure

Procedure SizeWindowHandler()
  
 DrawTexte("Coucou, it's again KCC !!")
  
EndProcedure 

CompilerIf #PB_Compiler_IsMainFile

 
 Global w, y, i, t.s, img, font
 
 font.i = LoadFontFromFileEx("FreePixel.ttf", 10)
 
 OpenWindow(#Fenetre, x, y, 300, 100, "Try VectorDrawing", #PB_Window_SystemMenu|#PB_Window_SizeGadget|#PB_Window_ScreenCentered)
 CanvasGadget(#GadgetCanvas, 0,0,300,100)
 BindEvent(#PB_Event_SizeWindow, @SizeWindowHandler())
 
 DrawTexte("Coucou, it's again KCC !!")
 
 Repeat
   
   Evenement = WaitWindowEvent()
   
 Until Evenement = #PB_Event_CloseWindow
 
CompilerEndIf