Code: Select all
;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
