Real Software Forums

The forum for Real Studio and other Real Software products.
[ REAL Software Website | Board Index ]
It is currently Sat Aug 19, 2017 5:14 pm
xojo

All times are UTC - 5 hours




Post new topic Reply to topic  [ 1 post ] 
Author Message
 Post subject: getfontfile info
PostPosted: Sat Feb 23, 2013 10:26 am 
Offline

Joined: Tue Mar 25, 2008 12:53 pm
Posts: 16
Location: ChongQin China
The following is a ( VB ) code, I would like to ask how to convert Realbasic??


Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Type tag_TT_OFFSET_TABLE
uMajorVersion As Integer
uMinorVersion As Integer
uNumOfTables As Integer
uSearchRange As Integer
uEntrySelector As Integer
uRangeShift As Integer
End Type

Type tag_TT_TABLE_DIRECTORY
szTag As String * 4
uCheckSum As Long
uOffset As Long
uLength As Long
End Type

Type tag_TT_NAME_TABLE_HEADER
uFSelector As Integer
uNRCount As Integer
uStorageOffset As Integer
End Type

Type tag_TT_NAME_RECORD
uPlatformID As Integer
uEncodingID As Integer
uLanguageID As Integer
uNameID As Integer
uStringLength As Integer
uStringOffset As Integer
End Type

Type FONT_PROPERTIES
csName As String
csNameUni As String
csCopyright As String
csTrademark As String
csFamily As String
csVersion As String
csAuthor As String
csUrl As String
csType As String
End Type

Public Function IsFile(ByVal fPath As String) As Boolean
Dim rc As Long

rc = GetFileAttributes(fPath)
If rc <> -1 Then
IsFile = True
Else
IsFile = False
End If
End Function

Public Function SwapInteger(ByVal value As Integer) As Long
Dim byt(1) As Byte

CopyMemory byt(0), value, 2

SwapInteger = CLng(byt(0)) * 256 + CLng(byt(1))

If SwapInteger > 32767 Then SwapInteger = 32767
End Function

Public Function SwapLong(ByVal value As Long) As Long
Dim byt(3) As Byte

CopyMemory byt(0), value, 4

SwapLong = CLng(byt(0)) * 16777216 + CLng(byt(1)) * 65536 + CLng(byt(2)) * 256 + CLng(byt(3))
End Function


Function GetFontProperties(ByVal lpszFilePath As String, ByRef lpFontProps As FONT_PROPERTIES) As Long
Dim fn As Integer, bFound As Boolean, csTemp As String, nPos As Long
Dim ttOffsetTable As tag_TT_OFFSET_TABLE
Dim tblDir As tag_TT_TABLE_DIRECTORY
Dim ttNTHeader As tag_TT_NAME_TABLE_HEADER
Dim ttRecord As tag_TT_NAME_RECORD

If IsFile(lpszFilePath) Then

fn = FreeFile
Open lpszFilePath For Binary As fn

Get fn, , ttOffsetTable

ttOffsetTable.uNumOfTables = SwapInteger(ttOffsetTable.uNumOfTables)
ttOffsetTable.uMajorVersion = SwapInteger(ttOffsetTable.uMajorVersion)
ttOffsetTable.uMinorVersion = SwapInteger(ttOffsetTable.uMinorVersion)

If ttOffsetTable.uMajorVersion = 1 And ttOffsetTable.uMinorVersion = 0 Then

bFound = False

For i = 0 To ttOffsetTable.uNumOfTables
Get fn, , tblDir

If InStr(1, tblDir.szTag, "name") > 0 Then
bFound = True
tblDir.uLength = SwapLong(tblDir.uLength)
tblDir.uOffset = SwapLong(tblDir.uOffset)
Exit For
End If
Next

If bFound Then
Seek fn, tblDir.uOffset + 1
Get fn, , ttNTHeader
ttNTHeader.uNRCount = SwapInteger(ttNTHeader.uNRCount)
ttNTHeader.uStorageOffset = SwapInteger(ttNTHeader.uStorageOffset)
bFound = False

For ii = 0 To ttNTHeader.uNRCount

Get fn, , ttRecord

ttRecord.uNameID = SwapInteger(ttRecord.uNameID)
ttRecord.uStringLength = SwapInteger(ttRecord.uStringLength)
ttRecord.uStringOffset = SwapInteger(ttRecord.uStringOffset)
ttRecord.uPlatformID = SwapInteger(ttRecord.uPlatformID)

If ttRecord.uNameID >= 0 And ttRecord.uNameID <= 14 Then

nPos = Seek(fn)
Seek fn, tblDir.uOffset + ttRecord.uStringOffset + ttNTHeader.uStorageOffset + 1

csTemp = String(ttRecord.uStringLength, 0)
Get fn, , csTemp

If Len(csTemp) > 0 Then
If ttRecord.uPlatformID = 1 Or ttRecord.uPlatformID = 2 Then

Select Case ttRecord.uNameID
Case 1
If Len(lpFontProps.csFamily) = 0 Then lpFontProps.csFamily = csTemp

Case 0
If Len(lpFontProps.csCopyright) = 0 Then lpFontProps.csCopyright = csTemp

Case 7
If Len(lpFontProps.csTrademark) = 0 Then lpFontProps.csTrademark = csTemp

Case 4
If Len(lpFontProps.csName) = 0 Then lpFontProps.csName = csTemp

Case 5
If Len(lpFontProps.csVersion) = 0 Then lpFontProps.csVersion = csTemp

Case 9
If Len(lpFontProps.csAuthor) = 0 Then lpFontProps.csAuthor = csTemp

Case 12
If Len(lpFontProps.csUrl) = 0 Then lpFontProps.csUrl = csTemp

Case 2
If Len(lpFontProps.csType) = 0 Then lpFontProps.csType = csTemp

End Select
Else
If ttRecord.uPlatformID = 3 And ttRecord.uNameID = 4 Then
If Len(lpFontProps.csNameUni) = 0 Then lpFontProps.csNameUni = Replace(csTemp, Chr$(0), "")
End If
End If
End If

Seek fn, nPos
End If

Next

If Len(lpFontProps.csName) = 0 Then lpFontProps.csName = lpFontProps.csFamily

End If

Close fn

End If

End If
End Function

_________________
http://pcmac1.blog.163.com


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

All times are UTC - 5 hours


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:  
cron
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group