Visual Basic Helper Routines
CreateScalableFontResource: Friendly TrueType Font File Name
     
Posted:   Thursday December 26, 1996
Updated:   Monday December 26, 2011
     
Applies to:   VB3, VB4-16, VB4-32, VB5, VB6
Developed with:   VB4-32, Windows 95
OS restrictions:   None
Author:   Karl E. Peterson
     
 Prerequisites
None.

Code from a newsgroup post by Karl E. Peterson.
 BAS Module Code
None.

 Form Code
To a new form add a command button and a label, along with the following code:

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright 1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function CreateScalableFontResource Lib "gdi32" _ 
   Alias "CreateScalableFontResourceA" _
  (ByVal fHidden As Long, _
   ByVal lpszResourceFile As String, _
   ByVal lpszFontFile As String, _
   ByVal lpszCurrentPath As String) As Long


Private Sub Command1_Click()

   Dim TTFontFile As String
  
  'get the font name for Arial Bold
  'be sure to verify that this font exists on your system
   TTFontFile = "C:\Windows\Fonts\anb_____.TTF"   

   Label1.Caption = GetFontName(TTFontFile)

End Sub


Public Function GetFontName(FileNameTTF As String) As String

   Dim hFile As Integer
   Dim Buffer As String
   Dim FontName As String
   Dim TempName As String
   Dim iPos As Integer
   
  'Build name for new resource file in
  'a temporary file, and call the API.
   TempName = App.Path & "\~TEMP.FOT"

   If CreateScalableFontResource(1, _
                                 TempName, _
                                 FileNameTTF, _
                                 vbNullString) Then
      
     'The name sits behind the text "FONTRES:"
      hFile = FreeFile

      Open TempName For Binary Access Read As hFile

         Buffer = Space(LOF(hFile))
         Get hFile, , Buffer
         iPos = InStr(Buffer, "FONTRES:") + 8
         FontName = Mid(Buffer, iPos, _
                        InStr(iPos, Buffer, vbNullChar) - iPos)

      Close hFile

      Kill TempName

    End If
   
  'Return the font name
   GetFontName = FontName

End Function
 Comments

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter