'Module Code ' Only allow declared variables Option Explicit ' Declare constants Public Const TMPF_TRUETYPE = &H4 Public Const LF_FACESIZE = 32 ' Declare types Public Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(1 To LF_FACESIZE) As Byte End Type Public Type TEXTMETRIC tmHeight As Long tmAscent As Long tmDescent As Long tmInternalLeading As Long tmExternalLeading As Long tmAveCharWidth As Long tmMaxCharWidth As Long tmWeight As Long tmOverhang As Long tmDigitizedAspectX As Long tmDigitizedAspectY As Long tmFirstChar As Byte tmLastChar As Byte tmDefaultChar As Byte tmBreakChar As Byte tmItalic As Byte tmUnderlined As Byte tmStruckOut As Byte tmPitchAndFamily As Byte tmCharSet As Byte End Type ' Declare Windows API functions Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Public Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long 'La fonction DeleteObject supprime un objet (logical pen, brush, font, bitmap, region, or palette), ce qui libère toutes les ressources système associé à l'objet. Après que l'objet soit supprimé, le handle spécifié n'est plus valide. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Public Function IsFontTrueType(sFontName As String, ByVal HdcSruface As Long) As Boolean Dim lf As LOGFONT Dim tm As TEXTMETRIC Dim oldfont As Long, newfont As Long Dim tmpArray() As Byte Dim dummy As Long Dim i As Integer 'need to convert font name to byte array... tmpArray = StrConv(sFontName & vbNullString, vbFromUnicode) For i = 0 To UBound(tmpArray) lf.lfFaceName(i + 1) = tmpArray(i) Next 'create the font object newfont = CreateFontIndirect(lf) 'save the current font object and use the new font object oldfont = SelectObject(HdcSruface, newfont) 'get the new font object's info dummy = GetTextMetrics(HdcSruface, tm) 'determine whether new font object is TrueType IsFontTrueType = CBool(tm.tmPitchAndFamily And TMPF_TRUETYPE) 'restore the original font object - !!!THIS IS IMPORTANT!!! dummy = SelectObject(HdcSruface, oldfont) 'Supprime la police crée DeleteObject newfont End Function