,FontEx : C 'Est Une mise à jour personnelle de la Bibliothèque "font" cette mise a jour contient plus d 'option pour charger une police .
*Mise a jour de code pour que ce soit compatible avec la dernière version Purebasic 5.50
les procédures:
LoadFontFromMemoiryEx : Charger une fonte à partir de sa zone mémoire
LoadFontFromFileEx : Charger une fonte à partir de son emplacement sur disque dur
LoadFontEx : Charger une fonte par son nom
GetFontIDEx : Renvoie l'identifiant d'une police dans le système d'exploitation
FreeFontEx : Libère une police
Le Code
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
Test Code :
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
