home *** CD-ROM | disk | FTP | other *** search
/ Dan Appleman's Visual Bas…s Guide to the Win32 API / Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD / VB5PG32.mdf / vbpg32 / samples5 / ch04 / fontinfo.bas < prev    next >
Encoding:
BASIC Source File  |  1996-11-25  |  7.9 KB  |  230 lines
  1. Attribute VB_Name = "FONTINFO1"
  2. Option Explicit
  3.  
  4. #If Win32 Then
  5. Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
  6. Declare Function GetVersion Lib "kernel32" () As Long
  7. #Else
  8. Declare Function GetVersion& Lib "Kernel" ()
  9. Declare Function GetWindowsDirectory% Lib "Kernel" (ByVal lpBuffer$, ByVal nSize%)
  10. #End If
  11.  
  12. Type OffsetTable
  13.     sfntVersionA As Integer
  14.     sfntVersionB As Integer
  15.     numTables As Integer
  16.     searchRange As Integer
  17.     entrySelector As Integer
  18.     rangeShift As Integer
  19. End Type
  20.  
  21. Type TableDirectoryEntry
  22.     tag(3) As Byte      ' Was String * 4 in VB 3.0 - But chars are 2 bytes in Win32, hence the change
  23.     checkSum As Long
  24.     offset As Long
  25.     length As Long
  26. End Type
  27.  
  28. Type NamingTable
  29.     FormatSelector As Integer
  30.     NameRecords As Integer
  31.     offsStrings As Integer
  32. End Type
  33.  
  34. Type NameRecord
  35.     PlatformID As Integer
  36.     PlatformSpecific As Integer
  37.     LanguageID As Integer
  38.     NameID As Integer
  39.     StringLength As Integer
  40.     StringOffset As Integer
  41. End Type
  42.  
  43. Global OT As OffsetTable
  44.  
  45.  
  46. Function GetNameForID(ByVal id As Long) As String
  47.     Dim s$
  48.     Select Case id
  49.         Case 0
  50.             s$ = "Copyright"
  51.         Case 1
  52.             s$ = "Font Family"
  53.         Case 2
  54.             s$ = "Font subfamily"
  55.         Case 3
  56.             s$ = "Font Identifier"
  57.         Case 4
  58.             s$ = "Full Font Name"
  59.         Case 5
  60.             s$ = "Version"
  61.         Case 6
  62.             s$ = "Postscript name"
  63.         Case 7
  64.             s$ = "Trademark"
  65.         Case Else
  66.             s$ = "Unknown"
  67.     End Select
  68.  
  69.     GetNameForID = s$
  70. End Function
  71.  
  72. Function GetPlatformForID(ByVal id As Long) As String
  73.     Dim s$
  74.     Select Case id
  75.         Case 0
  76.             s$ = "Apple Unicode"
  77.         Case 1
  78.             s$ = "Macintosh"
  79.         Case 2
  80.             s$ = "ISO"
  81.         Case 3
  82.             s$ = "Microsoft"
  83.     End Select
  84.     GetPlatformForID = s$
  85.  
  86. End Function
  87.  
  88. Sub LoadFontInfo(filename$, List1 As ListBox, mode%)
  89.     Dim fileid%
  90.     Dim TD As TableDirectoryEntry
  91.     Dim NT As NamingTable
  92.     Dim NR As NameRecord
  93.     Dim n&
  94.     Dim NTStart&    ' Start of naming table
  95.     Dim CurrentLoc& ' Current location in file
  96.     Dim nrnum&
  97.     Dim nameinfo() As Byte
  98.     Dim nPlatformID&
  99.     Dim stroffset&
  100.  
  101.     List1.Clear
  102.     fileid% = FreeFile  ' Get a file ID
  103.  
  104.     Open filename$ For Binary Access Read As #fileid%
  105.     Get #fileid%, , OT ' Retrieve the offset table
  106.     List1.AddItem "Version " & SwapInteger(OT.sfntVersionA) & "." & SwapInteger(OT.sfntVersionB)
  107.     List1.AddItem "Tables " & SwapInteger(OT.numTables)
  108.     
  109.     Select Case mode%
  110.         Case 0  ' List all tables
  111.                 For n& = 1 To SwapInteger(OT.numTables)
  112.                     Get #fileid%, , TD
  113.                     ' We used to be able to add the string directly (Win16), but
  114.                     ' Using a byte array requires a conversion
  115.                     List1.AddItem TagToString(TD)
  116.                 Next n&
  117.         Case 1  ' Name Information
  118.                 For n& = 1 To SwapInteger(OT.numTables)
  119.                     Get #fileid%, , TD
  120.                     If TagToString(TD) = "name" Then
  121.                         ' Seek to the specified location in the file
  122.                         NTStart& = SwapLong(TD.offset) + 1
  123.                         Seek #fileid%, NTStart&
  124.                         Get #fileid%, , NT
  125.                         List1.AddItem "NumRecords " & SwapInteger(NT.NameRecords)
  126.                         For nrnum& = 1 To SwapInteger(NT.NameRecords)
  127.                             Get #fileid%, , NR
  128.                             List1.AddItem "NameRecord # " & nrnum&
  129.                             List1.AddItem "  Platform ID: " & GetPlatformForID(SwapInteger(NR.PlatformID))
  130.                             List1.AddItem "  NameID: " & GetNameForID$(SwapInteger(NR.NameID))
  131.                             nPlatformID = SwapInteger(NR.PlatformID)
  132.                             If (nPlatformID = 1 Or nPlatformID = 3) And NR.StringLength <> 0 Then
  133.                                 ' Mark the current location in the file
  134.                                 CurrentLoc& = Seek(fileid%)
  135.                                 ' Calculate the length of the string
  136.                                 ReDim nameinfo(SwapInteger(NR.StringLength) - 1)
  137.                                 ' Calculate the location of the string
  138.                                 ' It should be possible to use the NT.offsStrings field to determine the
  139.                                 ' start location of the string table, but it turns out some fonts get this
  140.                                 ' wrong, so we calculate it based on the number of NameRecord structures
  141.                                 ' and the size of the structures.
  142.                                 stroffset = 6 + SwapInteger(NT.NameRecords) * 12
  143.                                 ' Get #fileid%, NTStart& + SwapInteger(NT.offsStrings) + SwapInteger(NR.StringOffset), nameinfo
  144.                                 Get #fileid%, NTStart& + stroffset + SwapInteger(NR.StringOffset), nameinfo
  145.                                 Select Case nPlatformID
  146.                                     Case 1  ' Macintosh (ANSI)
  147.                                         #If Win32 Then
  148.                                             List1.AddItem "  " & StrConv(nameinfo, vbUnicode)
  149.                                         #Else
  150.                                             List1.AddItem "  " & CStr(nameinfo)
  151.                                         #End If
  152.                                     Case 3  ' Microsoft (Unicode)
  153.                                        #If Win32 Then
  154.                                         SwapArray nameinfo()
  155.                                         List1.AddItem "  " & CStr(nameinfo)
  156.                                        #Else
  157.                                         List1.AddItem "  " & "Not supported in 16 bit environments"
  158.                                        #End If
  159.                                 End Select
  160.                                 ' Restore the previous location
  161.                                 Seek #fileid%, CurrentLoc&
  162.                             Else
  163.                                 List1.AddItem "  - This program only diplays Macintosh and Microsoft strings"
  164.                             End If
  165.                         Next nrnum&
  166.  
  167.                         Exit For
  168.                     End If
  169.                 Next n&
  170.     End Select
  171.  
  172.  
  173.     Close #fileid%
  174.  
  175. End Sub
  176.  
  177. '
  178. ' Note that we swap the low order bytes in a long so that
  179. ' we don't have to worry about overflow problems
  180. '
  181. Function SwapInteger(ByVal i As Long) As Long
  182.     SwapInteger = ((i \ &H100) And &HFF) Or ((i And &HFF) * &H100&)
  183.     
  184. End Function
  185.  
  186. '
  187. ' Swap a long value from Motorola to Intel format or vice versa
  188. '
  189. Function SwapLong(ByVal l As Long) As Long
  190.     Dim addbit%
  191.     Dim newlow&, newhigh&
  192.  
  193.     newlow& = l \ &H10000
  194.     newlow& = SwapInteger(newlow& And &HFFFF&)
  195.  
  196.     newhigh& = SwapInteger(l And &HFFFF&)
  197.     If newhigh& And &H8000& Then
  198.         ' This would overflow
  199.         newhigh& = newhigh And &H7FFF
  200.         addbit% = True
  201.     End If
  202.     newhigh& = (newhigh& * &H10000) Or newlow&
  203.     If addbit% Then newhigh = newhigh Or &H80000000
  204.     SwapLong = newhigh&
  205.  
  206. End Function
  207.  
  208. ' Swap every other byte in a Unicode string
  209. Sub SwapArray(namearray() As Byte)
  210.     Dim u%, p%
  211.     Dim b As Byte
  212.     u% = UBound(namearray)
  213.     For p = 0 To u - 1 Step 2
  214.         b = namearray(p)
  215.         namearray(p) = namearray(p + 1)
  216.         namearray(p + 1) = b
  217.     Next p
  218. End Sub
  219. '
  220. ' Converts the byte array to a 4 character tag name
  221. '
  222. Public Function TagToString(TD As TableDirectoryEntry)
  223.     Dim tagstr As String * 4
  224.     Dim x%
  225.     For x% = 1 To 4
  226.         Mid(tagstr, x%, 1) = Chr$(TD.tag(x% - 1))
  227.     Next x%
  228.     TagToString = tagstr
  229. End Function
  230.