New topic: getfontfile info
<http://forums.realsoftware.com/viewtopic.php?t=47045> Page 1 of 1 [ 1 post ] Previous topic | Next topic Author Message pcmac1 Post subject: getfontfile infoPosted: Sat Feb 23, 2013 10:26 am 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 Display posts from previous: All posts1 day7 days2 weeks1 month3 months6 months1 year Sort by AuthorPost timeSubject AscendingDescending Page 1 of 1 [ 1 post ] -- Over 1500 classes with 29000 functions in one REALbasic plug-in collection. The Monkeybread Software Realbasic Plugin v9.3. http://www.monkeybreadsoftware.de/realbasic/plugins.shtml [email protected]
