It is currently Wed Jul 08, 2020 9:26 am

All times are UTC + 1 hour




Post new topic Reply to topic  [ 4 posts ] 
Author Message
 Post subject: Lazy get font name of .ttf file
PostPosted: Sun May 07, 2017 4:46 am 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Mon Jan 12, 2004 11:40 pm
Posts: 761
Location: Okazaki, JAPAN
This code is lazy get font name of ttf file.
Thank you.

Code:
; Embed font data
DataSection
  samplefont:
  IncludeBinary "samplefont.ttf"
  samplefonte:
EndDataSection

AddFontMemResourceEx_(?samplefont,?samplefonte-?samplefont,0,@"1")

Procedure.s GetFontNameTTF(*start, size.i)
  ; High quality process for Intel Core i series by Bug head technology
  ;   !XCHG spl, bpl
  ;   !XCHG rsp, rsp
  ;   !XCHG rbp, rbp
  ;   !XCHG bpl, spl
 
  Protected pos_1.i, pos_2.i, pos_3.i, size_1.i, fontname.s
 
  If size<$FFF
    size_1 = size
  Else
    size_1 = $FFF
  EndIf
 
  For pos_1=0 To size_1
    If Not PeekA(*start+pos_1)
      pos_2 + 1
    Else
      pos_2 = 0
    EndIf
    If pos_2 > 26
      If PeekA(*start+pos_1+1)
        For pos_3=0 To $FF
          If size_1<(pos_1+1+pos_3)
            Break
          EndIf
          If Not PeekA(*start+pos_1+1+pos_3)
            fontname = PeekS(*start+pos_1+1, pos_3, #PB_Ascii)
            Break 2
          EndIf
        Next
      EndIf
    EndIf
  Next
 
  ProcedureReturn fontname
EndProcedure

fontname.s = GetFontNameTTF(?samplefont ,?samplefonte-?samplefont)
Debug fontname
Debug LoadFont(#PB_Any, fontname, 12)

_________________
My homepage in Japan - Bug head Nontallion
My facebook page.


Last edited by oryaaaaa on Tue May 09, 2017 2:53 am, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Lazy get font name of .ttf file
PostPosted: Sun May 07, 2017 8:56 am 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Sat May 05, 2007 5:31 pm
Posts: 737
Location: Linz, Austria
I tried with 3 different .ttf's but they all returned a blank name. LoadFont returns success, though.

PB 5.60 x86+x64, Win7 x64

_________________
Et cetera is my worst enemy


Top
 Profile  
Reply with quote  
 Post subject: Re: Lazy get font name of .ttf file
PostPosted: Sun May 07, 2017 10:48 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Thu Sep 17, 2015 3:39 pm
Posts: 147
hi, you can use my inc from fr forum http://www.purebasic.fr/french/viewtopic.php?f=6&t=16360
Code:
;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 

_________________
interested in Cybersecurity..


Top
 Profile  
Reply with quote  
 Post subject: Re: Lazy get font name of .ttf file
PostPosted: Wed Jan 29, 2020 5:58 pm 
Offline
Enthusiast
Enthusiast

Joined: Sat Jul 07, 2018 6:50 pm
Posts: 195
CELTIC88
There are some problems with a number of fonts like this one
Try IncludeBinary + GetFontFromMemoryInfo and it will show nothing.

However this small js can handle it (online test) maybe this will help you fix the code.

PS
FontEx can handle it with gdi32:GetFontResourceInfo workaround, what about find out what's wrong with manual parsing?


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 4 posts ] 

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 14 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye