Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
FBVectorFont.bi
| Uploader: |  ThePuppetMaster |
| Datum/Zeit: | 15.03.2010 21:50:44 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts FBVectorFont, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
'####################################################################################################################################
'####################################################################################################################################
' FBVectorFont - FreeBasic Vector Font Modul
'####################################################################################################################################
'####################################################################################################################################
' 2009 By.: /_\ DeltaLab's Germany - Experimental Computing
' Autor: Martin Wiemann
' Idee: 1.00.0 - 03.09.2009 - 13:54:57
' Version: 1.00.0 - 03.09.2009 - 13:54:57
'####################################################################################################################################
' Licence: "Do What The Fuck U Want"
'####################################################################################################################################
'####################################################################################################################################
'####################################################################################################################################
Const FBVF_INT_FontMaxWidth = 36
'####################################################################################################################################
Enum FBVF_GuruCode_Enum
FBVF_GURU_NoError = 1
FBVF_GURU_UnknownError = 0
FBVF_GURU_InternalAllocationError = -1
FBVF_GURU_FileNotFound = -2
FBVF_GURU_FileAlreadyExist = -3
FBVF_GURU_FileNameError = -4
FBVF_GURU_FileDamage = -5
FBVF_GURU_CantOpenFile = -6
FBVF_GURU_FontIDNotFound = -7
FBVF_GURU_PointListIDNotFound = -8
FBVF_GURU_PointIDNotFound = -9
End Enum
'####################################################################################################################################
Type FBVF_INT_XPoint_Type
V_X as Single
V_Y as Single
End Type
'####################################################################################################################################
Type FBVF_INT_Point_Type
V_Next as FBVF_INT_Point_Type Ptr
V_Prev as FBVF_INT_Point_Type Ptr
V_PosX as Single
V_PosY as Single
End Type
'------------------------------------------------------------------------------------------------------------------------------------
Type FBVF_INT_PointList_Type
V_Next as FBVF_INT_PointList_Type Ptr
V_Prev as FBVF_INT_PointList_Type Ptr
V_PointF as FBVF_INT_Point_Type Ptr
V_PointL as FBVF_INT_Point_Type Ptr
V_FillPointX as Single
V_FillPointY as Single
V_PointC as UInteger
End Type
'------------------------------------------------------------------------------------------------------------------------------------
Type FBVF_INT_Font_Type
V_PointListF as FBVF_INT_PointList_Type Ptr
V_PointListL as FBVF_INT_PointList_Type Ptr
V_PointListC as UInteger
V_FastDrawImage as Any Ptr
End Type
'------------------------------------------------------------------------------------------------------------------------------------
Type FBVF_INT_Type
V_Next as FBVF_INT_Type Ptr
V_Prev as FBVF_INT_Type Ptr
V_Font(255) as FBVF_INT_Font_Type
V_FontID as UInteger
V_Autor as String
V_Version as UInteger
V_Revision as UInteger
V_EditCount as UInteger
V_FDTReady as UByte
V_FDTSize as UInteger
End Type
'------------------------------------------------------------------------------------------------------------------------------------
Dim Shared FBVF_INT_F as FBVF_INT_Type Ptr
Dim Shared FBVF_INT_L as FBVF_INT_Type Ptr
Dim Shared FBVF_INT_Mutex as Any Ptr
Dim Shared FBVF_INT_FontIDC as UInteger
Dim shared PX as UInteger
'####################################################################################################################################
Sub FBVF_INT_Construct() Constructor
FBVF_INT_Mutex = MutexCreate()
End Sub
'------------------------------------------------------------------------------------------------------------------------------------
Sub FBVF_INT_Destruct() Destructor
'Destroy_FontTable's
MutexDestroy(FBVF_INT_Mutex)
FBVF_INT_Mutex = 0
End Sub
'####################################################################################################################################
Sub FBVF_INT_FillPolygon(V_ImagePtr as Any Ptr = 0, V_PointListD() as FBVF_INT_XPoint_Type, V_PointListC as UInteger, V_FillColor as UInteger)
If UBound(V_PointListD) < V_PointListC Then Exit Sub
If V_PointListC <= 2 Then Exit Sub
Dim XTop as Single = 2147483647
Dim XBottom as Single = -2147483648
Dim XLeft as Single = 2147483647
Dim XRight as Single = -2147483648
Dim X as Integer
Dim Y as Single
Dim Z as UInteger
For X = 0 to V_PointListC
If XBottom < V_PointListD(X).V_Y Then XBottom = V_PointListD(X).V_Y
If XTop > V_PointListD(X).V_Y Then XTop = V_PointListD(X).V_Y
If XLeft > V_PointListD(X).V_X Then XLeft = V_PointListD(X).V_X
If XRight < V_PointListD(X).V_X Then XRight = V_PointListD(X).V_X
If X < V_PointListC Then Line V_ImagePtr, (V_PointListD(X).V_X, V_PointListD(X).V_Y)-(V_PointListD(X + 1).V_X, V_PointListD(X + 1).V_Y), V_FillColor
Next
Line V_ImagePtr, (V_PointListD(V_PointListC).V_X, V_PointListD(V_PointListC).V_Y)-(V_PointListD(0).V_X, V_PointListD(0).V_Y), V_FillColor
If (XRight - XLeft) = 0 Then Exit Sub
If (XBottom - XTop) = 0 Then Exit Sub
Dim PV as Single
Dim PL(V_PointListC) as Single
Dim PC as UInteger
Dim PCL as UInteger
Dim X2 as UInteger
Dim POK as UByte
For Y = XTop To XBottom
PC = 0
PCL = 0
For X = 0 to V_PointListC
X2 = X + 1
If X2 > V_PointListC Then X2 = 0
PV = V_PointListD(X2).V_X - (V_PointListD(X2).V_X - V_PointListD(X).V_X) * (V_PointListD(X2).V_Y - (Y - 0.5)) / (V_PointListD(X2).V_Y - V_PointListD(X).V_Y)
POK = 0
If V_PointListD(X).V_Y <= V_PointListD(X2).V_Y Then
If (V_PointListD(X).V_Y <= Y) and (V_PointListD(X2).V_Y >= Y) Then POK = 1
Else: If (V_PointListD(X2).V_Y <= Y) and (V_PointListD(X).V_Y >= Y) Then POK = 1
End If
If POK = 1 Then
If V_PointListD(X).V_X <= V_PointListD(X2).V_X Then
If (PV >= V_PointListD(X).V_X) and (PV <= V_PointListD(X2).V_X) Then PC += 1
Else: If (PV >= V_PointListD(X2).V_X) and (PV <= V_PointListD(X).V_X) Then PC += 1
End If
If PC <> PCL Then
PCL = PC
PL(PC) = PV
End If
End If
Next
X = 1
Do Until X > PC - 1
If PL(X) > PL(X + 1) Then
Swap PL(X), PL(X + 1)
If X > 1 Then X -= 1
Else: X += 1
End If
Loop
If (PC mod 2) <> 0 Then PC -= 1
For X = 1 to PC - 1 step 2
Line V_ImagePtr, (PL(X), Y)-(PL(X + 1), Y), V_FillColor
Next
Next
End Sub
'####################################################################################################################################
Function FBVF_INT_FTGet(V_FontID as UInteger) as FBVF_INT_Type Ptr
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_F
Do Until TPtr = 0
If TPtr->V_FontID = V_FontID Then Return TPtr
Loop
Return TPtr
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_INT_FTAdd(V_FontID as UInteger) as FBVF_INT_Type Ptr
If FBVF_INT_L <> 0 Then
FBVF_INT_L->V_Next = CAllocate(SizeOf(FBVF_INT_Type))
FBVF_INT_L->V_Next->V_Prev = FBVF_INT_L
FBVF_INT_L = FBVF_INT_L->V_Next
Else
FBVF_INT_L = CAllocate(SizeOf(FBVF_INT_Type))
FBVF_INT_F = FBVF_INT_L
End If
With *FBVF_INT_L
.V_FontID = V_FontID
End With
Return FBVF_INT_L
End Function
'####################################################################################################################################
Function FBVF_New(ByRef R_FontID as UInteger, V_Autor as String, V_Version as UInteger) as FBVF_GuruCode_Enum
MutexLock(FBVF_INT_Mutex)
FBVF_INT_FontIDC += 1
Do Until FBVF_INT_FTGet(FBVF_INT_FontIDC) = 0
FBVF_INT_FontIDC += 1
Loop
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTAdd(FBVF_INT_FontIDC)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_InternalAllocationError
With *TPtr
.V_Autor = V_Autor
.V_Version = V_Version
End With
R_FontID = FBVF_INT_FontIDC
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_Unload(V_FontID as UInteger) as FBVF_GuruCode_Enum
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
For X as UInteger = 0 to 255
With TPtr->V_Font(X)
If .V_FastDrawImage <> 0 Then ImageDestroy(.V_FastDrawImage): .V_FastDrawImage = 0
Do Until .V_PointListF = 0
.V_PointListL = .V_PointListF->V_Next
With *.V_PointListF
Do Until .V_PointF = 0
.V_PointL = .V_PointF->V_Next
DeAllocate(.V_PointF)
.V_PointF = .V_PointL
Loop
End With
DeAllocate(.V_PointListF)
.V_PointListF = .V_PointListL
Loop
End With
Next
If TPtr->V_Next <> 0 Then TPtr->V_Next->V_Prev = TPtr->V_Prev
If TPtr->V_Prev <> 0 Then TPtr->V_Prev->V_Next = TPtr->V_Next
If FBVF_INT_F = TPtr Then FBVF_INT_F = TPtr->V_Next
If FBVF_INT_L = TPtr Then FBVF_INT_L = TPtr->V_Prev
DeAllocate(TPtr)
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'====================================================================================================================================
Function FBVF_SaveFile(V_FilePathName as String, V_FontID as UInteger) as FBVF_GuruCode_Enum
If ((Right(V_FilePathName, 1) = "/") or (Right(V_FilePathName, 1) = "\")) Then Return FBVF_GURU_FileNameError
If Dir(V_FilePathName, -1) <> "" Then Return FBVF_GURU_FileAlreadyExist
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim XFN as Integer = FreeFile
If Open(V_FilePathName for Binary as #XFN) <> 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_CantOpenFile
With *TPtr
Dim MX as UInteger
MX = Len(.V_Autor)
Print #XFN, Chr((MX shr 24) and 255); Chr((MX shr 16) and 255); Chr((MX shr 8) and 255); Chr(MX and 255); .V_Autor;
Print #XFN, Chr((.V_Version shr 24) and 255); Chr((.V_Version shr 16) and 255); Chr((.V_Version shr 8) and 255); Chr(.V_Version and 255);
Print #XFN, Chr((.V_Revision shr 24) and 255); Chr((.V_Revision shr 16) and 255); Chr((.V_Revision shr 8) and 255); Chr(.V_Revision and 255);
Print #XFN, Chr((.V_EditCount shr 24) and 255); Chr((.V_EditCount shr 16) and 255); Chr((.V_EditCount shr 8) and 255); Chr(.V_EditCount and 255);
Dim TPLPtr as FBVF_INT_PointList_Type Ptr
Dim TPPtr as FBVF_INT_Point_Type Ptr
For X as UInteger = 0 to 255
TPLPtr = .V_Font(X).V_PointListF
If TPLPtr <> 0 Then
Print #XFN, Chr((X shr 24) and 255); Chr((X shr 16) and 255); Chr((X shr 8) and 255); Chr(X and 255);
Print #XFN, Chr((.V_Font(X).V_PointListC shr 24) and 255); Chr((.V_Font(X).V_PointListC shr 16) and 255); Chr((.V_Font(X).V_PointListC shr 8) and 255); Chr(.V_Font(X).V_PointListC and 255);
Do Until TPLPtr = 0
TPPtr = TPLPtr->V_PointF
If TPPtr <> 0 Then
With *TPLPtr
Print #XFN, Chr((.V_FillPointX shr 24) and 255); Chr((.V_FillPointX shr 16) and 255); Chr((.V_FillPointX shr 8) and 255); Chr(.V_FillPointX and 255);
Print #XFN, Chr((.V_FillPointY shr 24) and 255); Chr((.V_FillPointY shr 16) and 255); Chr((.V_FillPointY shr 8) and 255); Chr(.V_FillPointY and 255);
Print #XFN, Chr((.V_PointC shr 24) and 255); Chr((.V_PointC shr 16) and 255); Chr((.V_PointC shr 8) and 255); Chr(.V_PointC and 255);
End With
Do Until TPPtr = 0
With *TPPtr
Print #XFN, Chr((.V_PosX shr 24) and 255); Chr((.V_PosX shr 16) and 255); Chr((.V_PosX shr 8) and 255); Chr(.V_PosX and 255);
Print #XFN, Chr((.V_PosY shr 24) and 255); Chr((.V_PosY shr 16) and 255); Chr((.V_PosY shr 8) and 255); Chr(.V_PosY and 255);
End With
TPPtr = TPPtr->V_Next
Loop
End If
TPLPtr = TPLPtr->V_Next
Loop
End If
Next
End With
MutexUnLock(FBVF_INT_Mutex)
Close #XFN
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_SaveStream(ByRef R_Data as String, V_FontID as UInteger) as FBVF_GuruCode_Enum
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
With *TPtr
Dim MX as UInteger
MX = Len(.V_Autor)
R_Data += Chr((MX shr 24) and 255) & Chr((MX shr 16) and 255) & Chr((MX shr 8) and 255) & Chr(MX and 255) & .V_Autor
R_Data += Chr((.V_Version shr 24) and 255) & Chr((.V_Version shr 16) and 255) & Chr((.V_Version shr 8) and 255) & Chr(.V_Version and 255)
R_Data += Chr((.V_Revision shr 24) and 255) & Chr((.V_Revision shr 16) and 255) & Chr((.V_Revision shr 8) and 255) & Chr(.V_Revision and 255)
R_Data += Chr((.V_EditCount shr 24) and 255) & Chr((.V_EditCount shr 16) and 255) & Chr((.V_EditCount shr 8) and 255) & Chr(.V_EditCount and 255)
Dim TPLPtr as FBVF_INT_PointList_Type Ptr
Dim TPPtr as FBVF_INT_Point_Type Ptr
For X as UInteger = 0 to 255
TPLPtr = .V_Font(X).V_PointListF
If TPLPtr <> 0 Then
R_Data += Chr((X shr 24) and 255) & Chr((X shr 16) and 255) & Chr((X shr 8) and 255) & Chr(X and 255)
R_Data += Chr((.V_Font(X).V_PointListC shr 24) and 255) & Chr((.V_Font(X).V_PointListC shr 16) and 255) & Chr((.V_Font(X).V_PointListC shr 8) and 255) & Chr(.V_Font(X).V_PointListC and 255)
Do Until TPLPtr = 0
TPPtr = TPLPtr->V_PointF
If TPPtr <> 0 Then
With *TPLPtr
R_Data += Chr((.V_FillPointX shr 24) and 255) & Chr((.V_FillPointX shr 16) and 255) & Chr((.V_FillPointX shr 8) and 255) & Chr(.V_FillPointX and 255)
R_Data += Chr((.V_FillPointY shr 24) and 255) & Chr((.V_FillPointY shr 16) and 255) & Chr((.V_FillPointY shr 8) and 255) & Chr(.V_FillPointY and 255)
R_Data += Chr((.V_PointC shr 24) and 255) & Chr((.V_PointC shr 16) and 255) & Chr((.V_PointC shr 8) and 255) & Chr(.V_PointC and 255)
End With
Do Until TPPtr = 0
With *TPPtr
R_Data += Chr((.V_PosX shr 24) and 255) & Chr((.V_PosX shr 16) and 255) & Chr((.V_PosX shr 8) and 255) & Chr(.V_PosX and 255)
R_Data += Chr((.V_PosY shr 24) and 255) & Chr((.V_PosY shr 16) and 255) & Chr((.V_PosY shr 8) and 255) & Chr(.V_PosY and 255)
End With
TPPtr = TPPtr->V_Next
Loop
End If
TPLPtr = TPLPtr->V_Next
Loop
End If
Next
End With
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_SaveFileHuman(V_FilePathName as String, V_FontID as UInteger) as FBVF_GuruCode_Enum
If ((Right(V_FilePathName, 1) = "/") or (Right(V_FilePathName, 1) = "\")) Then Return FBVF_GURU_FileNameError
If Dir(V_FilePathName, -1) <> "" Then Return FBVF_GURU_FileAlreadyExist
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim XFN as Integer = FreeFile
If Open(V_FilePathName for Binary as #XFN) <> 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_CantOpenFile
With *TPtr
.V_EditCount += 1
Print #XFN, "Autor="; .V_Autor; Chr(13, 10);
Print #XFN, "Version="; Str(.V_Version); Chr(13, 10);
Print #XFN, "Revision="; Str(.V_Revision); Chr(13, 10);
Print #XFN, "Editcount="; Str(.V_EditCount); Chr(13, 10);
Dim TPLPtr as FBVF_INT_PointList_Type Ptr
Dim TPPtr as FBVF_INT_Point_Type Ptr
For X as UInteger = 0 to 255
TPLPtr = .V_Font(X).V_PointListF
If TPLPtr <> 0 Then
Print #XFN, "NewChar="; Str(X); Chr(13, 10);
Do Until TPLPtr = 0
TPPtr = TPLPtr->V_PointF
If TPPtr <> 0 Then
Print #XFN, "NewPointList"; Chr(13, 10);
If (TPLPtr->V_FillPointX > 0) and (TPLPtr->V_FillPointY > 0) Then
Print #XFN, "SetFillPoint="; Str(TPLPtr->V_FillPointX); "x"; Str(TPLPtr->V_FillPointY); Chr(13, 10);
End If
Print #XFN, "AddPoints=";
Do Until TPPtr = 0
Print #XFN, Str(TPPtr->V_PosX); "x"; Str(TPPtr->V_PosY); " ";
TPPtr = TPPtr->V_Next
Loop
Print #XFN, Chr(13, 10);
End If
TPLPtr = TPLPtr->V_Next
Loop
End If
Next
End With
MutexUnLock(FBVF_INT_Mutex)
Close #XFN
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_SaveStreamHuman(ByRef R_Data as String, V_FontID as UInteger) as FBVF_GuruCode_Enum
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
With *TPtr
.V_EditCount += 1
R_Data += "Autor=" & .V_Autor & Chr(13, 10)
R_Data += "Version=" & Str(.V_Version) & Chr(13, 10)
R_Data += "Revision=" & Str(.V_Revision) & Chr(13, 10)
R_Data += "Editcount=" & Str(.V_EditCount) & Chr(13, 10)
Dim TPLPtr as FBVF_INT_PointList_Type Ptr
Dim TPPtr as FBVF_INT_Point_Type Ptr
For X as UInteger = 0 to 255
TPLPtr = .V_Font(X).V_PointListF
If TPLPtr <> 0 Then
R_Data += "NewChar=" & Str(X) & Chr(13, 10)
Do Until TPLPtr = 0
TPPtr = TPLPtr->V_PointF
If TPPtr <> 0 Then
R_Data += "NewPointList" & Chr(13, 10)
If (TPLPtr->V_FillPointX > 0) and (TPLPtr->V_FillPointY > 0) Then
R_Data += "SetFillPoint=" & Str(TPLPtr->V_FillPointX) & "x" & Str(TPLPtr->V_FillPointY) & Chr(13, 10)
End If
R_Data += "AddPoints="
Do Until TPPtr = 0
R_Data += Str(TPPtr->V_PosX) & "x" & Str(TPPtr->V_PosY) & " "
TPPtr = TPPtr->V_Next
Loop
R_Data += Chr(13, 10)
End If
TPLPtr = TPLPtr->V_Next
Loop
End If
Next
End With
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'====================================================================================================================================
Function FBVF_LoadFile(V_FilePathName as String, ByRef R_FontID as UInteger) as FBVF_GuruCode_Enum
R_FontID = 0
If ((Right(V_FilePathName, 1) = "/") or (Right(V_FilePathName, 1) = "\")) Then Return FBVF_GURU_FileNameError
If Dir(V_FilePathName, -1) = "" Then Return FBVF_GURU_FileNotFound
MutexLock(FBVF_INT_Mutex)
Dim XFN as Integer = FreeFile
If Open(V_FilePathName for Binary as #XFN) <> 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_CantOpenFile
MutexUnLock(FBVF_INT_Mutex)
Dim RV as FBVF_GuruCode_Enum = FBVF_New(R_FontID, "", 0)
If RV <> FBVF_GURU_NoError Then Close #XFN: R_FontID = 0: Return RV
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(R_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): R_FontID = 0: Close #XFN: Return FBVF_GURU_InternalAllocationError
Dim T as String
Dim XLen as UInteger = Lof(XFN)
Dim MX as UInteger
Dim TOffSet as UInteger
If XLen < 4 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Close #XFN: Return FBVF_GURU_FileDamage
T = Space(4)
Get #XFN, 1, T
MX = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
If (XLen - 4) < MX Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Close #XFN: Return FBVF_GURU_FileDamage
With *TPtr
.V_Autor = Space(MX): Get #XFN, 5, .V_Autor
If (XLen - 4 - MX) < 12 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Close #XFN: Return FBVF_GURU_FileDamage
T = Space(12)
Get #XFN, 5 + MX, T
.V_Version = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
.V_Revision = (T[4] shl 24) or (T[5] shl 16) or (T[6] shl 8) or T[7]
.V_EditCount = (T[8] shl 24) or (T[9] shl 16) or (T[10] shl 8) or T[11]
TOffSet = 4 + MX + 12
Dim TChrID as UByte
Dim XPLC as UInteger
Dim X as UInteger
Do
If (XLen - TOffSet) = 0 Then Exit Do
If (XLen - TOffSet) < 8 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Close #XFN: Return FBVF_GURU_FileDamage
T = Space(8)
Get #XFN, 1 + TOffSet, T
TOffSet += 8
TChrID = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
XPLC = (T[4] shl 24) or (T[5] shl 16) or (T[6] shl 8) or T[7]
If (XLen - TOffSet) < (XPLC * 8) Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Close #XFN: Return FBVF_GURU_FileDamage
With .V_Font(TChrID)
.V_PointListC = XPLC
For X as UInteger = 1 to .V_PointListC
If (XLen - TOffSet) < 12 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Close #XFN: Return FBVF_GURU_FileDamage
If .V_PointListL <> 0 Then
.V_PointListL->V_Next = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListL->V_Next->V_Prev = .V_PointListL
.V_PointListL = .V_PointListL->V_Next
Else
.V_PointListL = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListF = .V_PointListL
End If
T = Space(12)
Get #XFN, 1 + TOffSet, T
TOffSet += 12
With *.V_PointListL
.V_FillPointX = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
.V_FillPointY = (T[4] shl 24) or (T[5] shl 16) or (T[6] shl 8) or T[7]
.V_PointC = (T[8] shl 24) or (T[9] shl 16) or (T[10] shl 8) or T[11]
For Y as UInteger = 1 to .V_PointC
If (XLen - TOffSet) < 8 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Close #XFN: Return FBVF_GURU_FileDamage
T = Space(8)
Get #XFN, 1 + TOffSet, T
TOffSet += 8
If .V_PointL <> 0 Then
.V_PointL->V_Next = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointL->V_Next->V_Prev = .V_PointL
.V_PointL = .V_PointL->V_Next
Else
.V_PointL = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointF = .V_PointL
End If
With *.V_PointL
.V_PosX = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
.V_PosY = (T[4] shl 24) or (T[5] shl 16) or (T[6] shl 8) or T[7]
End With
Next
End With
Next
End With
Loop
End With
MutexUnLock(FBVF_INT_Mutex)
Close #XFN
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_LoadStream(V_Data as String, ByRef R_FontID as UInteger) as FBVF_GuruCode_Enum
R_FontID = 0
Dim RV as FBVF_GuruCode_Enum = FBVF_New(R_FontID, "", 0)
If RV <> FBVF_GURU_NoError Then R_FontID = 0: Return RV
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(R_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): R_FontID = 0: Return FBVF_GURU_InternalAllocationError
Dim T as String
Dim XLen as UInteger = Len(V_Data)
Dim MX as UInteger
Dim TOffSet as UInteger
If XLen < 4 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Return FBVF_GURU_FileDamage
T = Mid(V_Data, 1, 4)
MX = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
If (XLen - 4) < MX Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Return FBVF_GURU_FileDamage
With *TPtr
.V_Autor = Mid(V_Data, 5, MX)
If (XLen - 4 - MX) < 12 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Return FBVF_GURU_FileDamage
T = Mid(V_Data, 5 + MX, 12)
.V_Version = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
.V_Revision = (T[4] shl 24) or (T[5] shl 16) or (T[6] shl 8) or T[7]
.V_EditCount = (T[8] shl 24) or (T[9] shl 16) or (T[10] shl 8) or T[11]
TOffSet = 4 + MX + 12
Dim TChrID as UByte
Dim XPLC as UInteger
Dim X as UInteger
Do
If (XLen - TOffSet) = 0 Then Exit Do
If (XLen - TOffSet) < 8 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Return FBVF_GURU_FileDamage
T = Mid(V_Data, 1 + TOffSet, 8)
TOffSet += 8
TChrID = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
XPLC = (T[4] shl 24) or (T[5] shl 16) or (T[6] shl 8) or T[7]
If (XLen - TOffSet) < (XPLC * 8) Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Return FBVF_GURU_FileDamage
With .V_Font(TChrID)
.V_PointListC = XPLC
For X as UInteger = 1 to .V_PointListC
If (XLen - TOffSet) < 12 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Return FBVF_GURU_FileDamage
If .V_PointListL <> 0 Then
.V_PointListL->V_Next = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListL->V_Next->V_Prev = .V_PointListL
.V_PointListL = .V_PointListL->V_Next
Else
.V_PointListL = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListF = .V_PointListL
End If
T = Mid(V_Data, 1 + TOffSet, 12)
TOffSet += 12
With *.V_PointListL
.V_FillPointX = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
.V_FillPointY = (T[4] shl 24) or (T[5] shl 16) or (T[6] shl 8) or T[7]
.V_PointC = (T[8] shl 24) or (T[9] shl 16) or (T[10] shl 8) or T[11]
For Y as UInteger = 1 to .V_PointC
If (XLen - TOffSet) < 8 Then MutexUnLock(FBVF_INT_Mutex): FBVF_Unload(R_FontID): R_FontID = 0: Return FBVF_GURU_FileDamage
T = Mid(V_Data, 1 + TOffSet, 8)
TOffSet += 8
If .V_PointL <> 0 Then
.V_PointL->V_Next = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointL->V_Next->V_Prev = .V_PointL
.V_PointL = .V_PointL->V_Next
Else
.V_PointL = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointF = .V_PointL
End If
With *.V_PointL
.V_PosX = (T[0] shl 24) or (T[1] shl 16) or (T[2] shl 8) or T[3]
.V_PosY = (T[4] shl 24) or (T[5] shl 16) or (T[6] shl 8) or T[7]
End With
Next
End With
Next
End With
Loop
End With
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_LoadFileHuman(V_FilePathName as String, ByRef R_FontID as UInteger) as FBVF_GuruCode_Enum
R_FontID = 0
If ((Right(V_FilePathName, 1) = "/") or (Right(V_FilePathName, 1) = "\")) Then Return FBVF_GURU_FileNameError
If Dir(V_FilePathName, -1) = "" Then Return FBVF_GURU_FileNotFound
MutexLock(FBVF_INT_Mutex)
Dim XFN as Integer = FreeFile
If Open(V_FilePathName for Binary as #XFN) <> 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_CantOpenFile
MutexUnLock(FBVF_INT_Mutex)
Dim RV as FBVF_GuruCode_Enum = FBVF_New(R_FontID, "", 0)
If RV <> FBVF_GURU_NoError Then Close #XFN: R_FontID = 0: Return RV
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(R_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): R_FontID = 0: Close #XFN: Return FBVF_GURU_InternalAllocationError
Dim T as String
Dim XPos as UInteger
Dim T1 as String
Dim T2 as String
Dim TChrID as UByte
Do Until EOF(XFN)
Line Input #XFN, T
XPos = InStr(1, T, "=")
If XPos > 0 Then
T1 = Mid(T, XPos + 1)
T = LCase(Left(T, XPos - 1))
Else: T1 = "": T = LCase(T)
End If
With *TPtr
Select Case T
Case "autor": .V_Autor = T1
Case "version": .V_Version = ValUInt(T1)
Case "revision": .V_Revision = ValUInt(T1)
Case "editcount": .V_EditCount = ValUInt(T1)
Case "newchar": TChrID = CUByte(ValUInt(T1))
Case "newpointlist"
With .V_Font(TChrID)
.V_PointListC += 1
If .V_PointListL <> 0 Then
.V_PointListL->V_Next = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListL->V_Next->V_Prev = .V_PointListL
.V_PointListL = .V_PointListL->V_Next
Else
.V_PointListL = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListF = .V_PointListL
End If
End With
Case "setfillpoint"
If .V_Font(TChrID).V_PointListL <> 0 Then
T1 = LCase(T1)
XPos = InStr(1, T1, "x")
If XPos > 0 Then
With *.V_Font(TChrID).V_PointListL
.V_FillPointX = ValUInt(Left(T1, XPos - 1))
.V_FillPointY = ValUInt(Mid(T1, XPos + 1))
End With
End If
End If
Case "addpoints"
If .V_Font(TChrID).V_PointListL <> 0 Then
T1 = LCase(T1)
Do
XPos = InStr(1, T1, " ")
If XPos = 0 Then Exit Do
T2 = LCase(Left(T1, XPos - 1))
T1 = Mid(T1, XPos + 1)
XPos = InStr(1, T2, "x")
If XPos > 0 Then
With *.V_Font(TChrID).V_PointListL
.V_PointC += 1
If .V_PointL <> 0 Then
.V_PointL->V_Next = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointL->V_Next->V_Prev = .V_PointL
.V_PointL = .V_PointL->V_Next
Else
.V_PointL = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointF = .V_PointL
End If
With *.V_PointL
.V_PosX = ValUInt(Left(T2, XPos - 1))
.V_PosY = ValUInt(Mid(T2, XPos + 1))
End With
End With
End If
Loop
End If
End Select
End With
Loop
MutexUnLock(FBVF_INT_Mutex)
Close #XFN
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_LoadStreamHuman(ByVal V_Data as String, ByRef R_FontID as UInteger) as FBVF_GuruCode_Enum
R_FontID = 0
Dim RV as FBVF_GuruCode_Enum = FBVF_New(R_FontID, "", 0)
If RV <> FBVF_GURU_NoError Then R_FontID = 0: Return RV
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(R_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): R_FontID = 0: Return FBVF_GURU_InternalAllocationError
Dim T as String
Dim XPos as UInteger
Dim T1 as String
Dim T2 as String
Dim TChrID as UByte
Do
XPos = InStr(1, V_Data, Chr(13, 10))
If XPos = 0 Then Exit Do
T = Left(V_Data, XPos - 1)
V_Data = Mid(V_Data, XPos + 1)
XPos = InStr(1, T, "=")
If XPos > 0 Then
T1 = Mid(T, XPos + 1)
T = LCase(Left(T, XPos - 1))
Else: T1 = "": T = LCase(T)
End If
With *TPtr
Select Case T
Case "autor": .V_Autor = T1
Case "version": .V_Version = ValUInt(T1)
Case "revision": .V_Revision = ValUInt(T1)
Case "editcount": .V_EditCount = ValUInt(T1)
Case "newchar": TChrID = CUByte(ValUInt(T1))
Case "newpointlist"
With .V_Font(TChrID)
.V_PointListC += 1
If .V_PointListL <> 0 Then
.V_PointListL->V_Next = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListL->V_Next->V_Prev = .V_PointListL
.V_PointListL = .V_PointListL->V_Next
Else
.V_PointListL = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListF = .V_PointListL
End If
End With
Case "setfillpoint"
If .V_Font(TChrID).V_PointListL <> 0 Then
T1 = LCase(T1)
XPos = InStr(1, T1, "x")
If XPos > 0 Then
With *.V_Font(TChrID).V_PointListL
.V_FillPointX = ValUInt(Left(T1, XPos - 1))
.V_FillPointY = ValUInt(Mid(T1, XPos + 1))
End With
End If
End If
Case "addpoints"
If .V_Font(TChrID).V_PointListL <> 0 Then
T1 = LCase(T1)
Do
XPos = InStr(1, T1, " ")
If XPos = 0 Then Exit Do
T2 = LCase(Left(T1, XPos - 1))
T1 = Mid(T1, XPos + 1)
XPos = InStr(1, T2, "x")
If XPos > 0 Then
With *.V_Font(TChrID).V_PointListL
.V_PointC += 1
If .V_PointL <> 0 Then
.V_PointL->V_Next = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointL->V_Next->V_Prev = .V_PointL
.V_PointL = .V_PointL->V_Next
Else
.V_PointL = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointF = .V_PointL
End If
With *.V_PointL
.V_PosX = ValUInt(Left(T2, XPos - 1))
.V_PosY = ValUInt(Mid(T2, XPos + 1))
End With
End With
End If
Loop
End If
End Select
End With
Loop
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'####################################################################################################################################
Function FBVF_CreateFastDrawTable(V_FontID as UInteger) as FBVF_GuruCode_Enum
Return FBVF_GURU_NoError
End Function
'####################################################################################################################################
Function FBVF_Chr_Dimension(V_FontID as UInteger, V_ChrID as UInteger, V_Size as UInteger = 10, ByRef R_Width as UInteger, ByRef R_Height as UInteger, V_SizeWidth as UInteger = 0, V_SizeHeight as UInteger = 0, V_SizeMultiple as Double = 0, ByRef R_TopOffset as UInteger = 0, ByRef R_LeftOffset as UInteger = 0) as FBVF_GuruCode_Enum
R_Width = 0
R_Height = 0
R_TopOffset = 0
R_LeftOffset = 0
If (V_SizeWidth > 0) and (V_SizeHeight > 0) Then
R_Width = V_SizeWidth
R_Height = V_SizeHeight
Return FBVF_GURU_NoError
End If
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim TPLPtr as FBVF_INT_PointList_Type Ptr = TPtr->V_Font(V_ChrID).V_PointListF
Dim TPPtr as FBVF_INT_Point_Type Ptr
Dim XL as UInteger = 0
Dim XR as UInteger = -1
Dim XT as UInteger = 0
Dim XB as UInteger = -1
Dim TX as UInteger
Dim TY as UInteger
If TPLPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_NoError
Do Until TPLPtr = 0
With *TPLPtr
TPPtr = .V_PointF
Do Until TPPtr = 0
If V_SizeMultiple = 0 Then
Else
TX = TPPtr->V_PosX * V_SizeMultiple
TY = TPPtr->V_PosY * V_SizeMultiple
End If
If TX > XL Then XL = TX
If TX < XR Then XR = TX
If TY > XT Then XT = TY
If TY < XB THen XB = TY
TPPtr = TPPtr->V_Next
Loop
End With
TPLPtr = TPLPtr->V_Next
Loop
MutexUnLock(FBVF_INT_Mutex)
'PX += 10: Draw String (50, PX), "DIM:" & XR & " - " & XL & " --- " & XB & " - " & XT, &HFFFF00
R_Width = XL - XR
R_Height = XT - XB
R_TopOffset = XR
R_LeftOffset = XB
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_GetStringDimension(V_FontID as UInteger, V_Text as String, V_Size as UInteger = 10, V_SizeWidth as UInteger = 0, V_SizeHeight as UInteger = 0, V_SizeMultiple as Double = 0, V_ChrSpace as UInteger = 8, ByRef R_Width as UInteger, ByRef R_Height as UInteger, ByRef R_TopOffset as UInteger = 0, ByRef R_LeftOffset as UInteger = 0, V_Monospace as UByte = 1) as FBVF_GuruCode_Enum
Dim XPX as UInteger
Dim XPY as UInteger
Dim XOX as UInteger
Dim XOY as UInteger
Dim TPX as UInteger
Dim TPY as UInteger
Dim TOX as UInteger
Dim TOY as UInteger
For X as UInteger = 1 to Len(V_Text)
FBVF_Chr_Dimension(V_FontID, V_Text[X - 1], V_Size, TPX, TPY, V_SizeWidth, V_SizeHeight, V_SizeMultiple, TOX, TOY)
If V_Monospace = 0 Then
If TPX > 0 Then XPX += TPX + (V_ChrSpace * V_SizeMultiple)' - TOX
Else: If TPX > 0 Then XPX += FBVF_INT_FontMaxWidth + (V_ChrSpace * V_SizeMultiple)
End If
If XPY < TPY Then XPY = TPY
If XOX < TOX Then XOX = TOX
If XOY < TOY Then XOY = TOY
Next
If Len(V_Text) > 0 Then XPX -= (V_ChrSpace * V_SizeMultiple)
R_Width = XPX
R_Height = XPY
R_TopOffset = XOX
R_LeftOffset = XOY
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_GetFontInfo(V_FontID as UInteger, ByRef R_Autor as String = "", ByRef R_Version as UInteger = 0, ByRef R_Revision as UInteger = 0, ByRef R_Editcount as UInteger = 0) as FBVF_GuruCode_Enum
R_Autor = ""
R_Version = 0
R_Revision = 0
R_Editcount = 0
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
With *TPtr
R_Autor = .V_Autor
R_Version = .V_Version
R_Revision = .V_Revision
R_Editcount = .V_Editcount
End With
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'####################################################################################################################################
Function FBVF_PointList_Add(V_FontID as UInteger, V_ChrID as UInteger, ByRef R_PointListID as UInteger) as FBVF_GuruCode_Enum
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
With TPtr->V_Font(V_ChrID)
.V_PointListC += 1
R_PointListID = .V_PointListC
If .V_PointListL <> 0 Then
.V_PointListL->V_Next = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListL->V_Next->V_Prev = .V_PointListL
.V_PointListL = .V_PointListL->V_Next
Else
.V_PointListL = CAllocate(SizeOf(FBVF_INT_PointList_Type))
.V_PointListF = .V_PointListL
End If
End With
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_PointList_Del(V_FontID as UInteger, V_ChrID as UInteger, V_PointListID as UInteger) as FBVF_GuruCode_Enum
Return FBVF_GURU_NoError
End Function
'####################################################################################################################################
Function FBVF_Point_Add(V_FontID as UInteger, V_ChrID as UInteger, V_PointListID as UInteger, V_PosX as UInteger, V_PosY as UInteger, ByRef R_PointID as UInteger) as FBVF_GuruCode_Enum
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim TPLPtr as FBVF_INT_PointList_Type Ptr = TPtr->V_Font(V_ChrID).V_PointListF
Dim XLC as UInteger
Do Until TPLPtr = 0
XLC += 1
If XLC = V_PointListID Then Exit Do
TPLPtr = TPLPtr->V_Next
Loop
If TPLPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_PointListIDNotFound
With *TPLPtr
.V_PointC += 1
R_PointID = .V_PointC
If .V_PointL <> 0 Then
.V_PointL->V_Next = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointL->V_Next->V_Prev = .V_PointL
.V_PointL = .V_PointL->V_Next
Else
.V_PointL = CAllocate(SizeOf(FBVF_INT_Point_Type))
.V_PointF = .V_PointL
End If
With *.V_PointL
.V_PosX = V_PosX
.V_PosY = V_PosY
End With
End With
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_Point_Edit(V_FontID as UInteger, V_ChrID as UInteger, V_PointListID as UInteger, V_PointID as UInteger, V_NewPosX as UInteger, V_NewPosY as UInteger) as FBVF_GuruCode_Enum
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim TPLPtr as FBVF_INT_PointList_Type Ptr = TPtr->V_Font(V_ChrID).V_PointListF
Dim XLC as UInteger
Do Until TPLPtr = 0
XLC += 1
If XLC = V_PointListID Then Exit Do
TPLPtr = TPLPtr->V_Next
Loop
If TPLPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_PointListIDNotFound
Dim TPPtr as FBVF_INT_Point_Type Ptr = TPLPtr->V_PointF
XLC = 0
Do Until TPPtr = 0
XLC += 1
If XLC = V_PointID Then
With *TPPtr
.V_PosX = V_NewPosX
.V_PosY = V_NewPosY
End With
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End If
TPPtr = TPPtr->V_Next
Loop
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_PointIDNotFound
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_Point_Del(V_FontID as UInteger, V_ChrID as UInteger, V_PointListID as UInteger, V_PointID as UInteger) as FBVF_GuruCode_Enum
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_Point_FillPointSet(V_FontID as UInteger, V_ChrID as UInteger, V_PointListID as UInteger, V_FillPointPosX as UInteger, V_FillPointPosY as UInteger) as FBVF_GuruCode_Enum
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim TPLPtr as FBVF_INT_PointList_Type Ptr = TPtr->V_Font(V_ChrID).V_PointListF
Dim XLC as UInteger
Do Until TPLPtr = 0
XLC += 1
If XLC = V_PointListID Then Exit Do
TPLPtr = TPLPtr->V_Next
Loop
If TPLPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_PointListIDNotFound
With *TPLPtr
.V_FillPointX = V_FillPointPosX
.V_FillPointY = V_FillPointPosY
End With
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_Point_FillPointGet(V_FontID as UInteger, V_ChrID as UInteger, V_PointListID as UInteger, ByRef R_FillPointPosX as UInteger, ByRef R_FillPointPosY as UInteger) as FBVF_GuruCode_Enum
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim TPLPtr as FBVF_INT_PointList_Type Ptr = TPtr->V_Font(V_ChrID).V_PointListF
Dim XLC as UInteger
Do Until TPLPtr = 0
XLC += 1
If XLC = V_PointListID Then Exit Do
TPLPtr = TPLPtr->V_Next
Loop
If TPLPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_PointListIDNotFound
With *TPLPtr
R_FillPointPosX = .V_FillPointX
R_FillPointPosY = .V_FillPointY
End With
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_Point_GetPLPID(V_FontID as UInteger, V_ChrID as UInteger, V_PosX as UInteger, V_PosY as UInteger, ByRef R_PointListID as UInteger, ByRef R_PointID as UInteger) as FBVF_GuruCode_Enum
R_PointListID = 0
R_PointID = 0
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim TPLPtr as FBVF_INT_PointList_Type Ptr = TPtr->V_Font(V_ChrID).V_PointListF
Dim TPPtr as FBVF_INT_Point_Type Ptr
Dim XLC as UInteger
Dim XPC as UInteger
Do Until TPLPtr = 0
XLC += 1
XPC = 0
TPPtr = TPLPtr->V_PointF
Do Until TPPtr = 0
XPC += 1
With *TPPtr
If (.V_PosX = V_PosX) and (.V_PosY = V_PosY) Then
R_PointListID = XLC
R_PointID = XPC
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End If
End With
TPPtr = TPPtr->V_Next
Loop
TPLPtr = TPLPtr->V_Next
Loop
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_PointIDNotFound
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_Point_GetList(V_FontID as UInteger, V_ChrID as UInteger, R_PointListDX() as UInteger, R_PointListDY() as UInteger, ByRef R_PointListC as UInteger) as FBVF_GuruCode_Enum
R_PointListC = 0
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim TPLPtr as FBVF_INT_PointList_Type Ptr = TPtr->V_Font(V_ChrID).V_PointListF
Dim TPPtr as FBVF_INT_Point_Type Ptr
Dim TAC as UInteger
Do Until TPLPtr = 0
TPPtr = TPLPtr->V_PointF
Do Until TPPtr = 0
With *TPPtr
R_PointListC += 1
If TAC < R_PointListC Then
TAC += 10
ReDim Preserve R_PointListDX(TAC) as UInteger
ReDim Preserve R_PointListDY(TAC) as UInteger
End If
R_PointListDX(R_PointListC) = .V_PosX
R_PointListDY(R_PointListC) = .V_PosY
End With
TPPtr = TPPtr->V_Next
Loop
TPLPtr = TPLPtr->V_Next
Loop
MutexUnLock(FBVF_INT_Mutex)
ReDim Preserve R_PointListDX(R_PointListC) as UInteger
ReDim Preserve R_PointListDY(R_PointListC) as UInteger
Return FBVF_GURU_NoError
End Function
'####################################################################################################################################
Function FBVF_DrawChr(V_FontID as UInteger, V_ChrID as UByte, V_ToPosX as Integer, V_ToPosY as Integer, V_ImagePtr as Any Ptr = 0, V_Size as UInteger = 10, V_SizeWidth as UInteger = 0, V_SizeHeight as UInteger = 0, V_BorderColor as UInteger = &HFFFFFF, V_FillColor as UInteger = &HFFFFFF, V_SizeMultiple as Double = 0, V_Monospace as UByte = 1) as FBVF_GuruCode_Enum
'V_SizeWidth / V_SizeHeight überschreibt (wenn beide grösser 0), die V_Size Angabe
'V_SizeMultiple überschreibt V_Width / V_Height und V_Size, wenn wert grösser 0
Dim TPX as UInteger
Dim TPY as UInteger
Dim TOX as UInteger
Dim TOY as UInteger
If V_Monospace = 0 Then FBVF_Chr_Dimension(V_FontID, V_ChrID, V_Size, TPX, TPY, V_SizeWidth, V_SizeHeight, V_SizeMultiple, TOX, TOY)
MutexLock(FBVF_INT_Mutex)
Dim TPtr as FBVF_INT_Type Ptr = FBVF_INT_FTGet(V_FontID)
If TPtr = 0 Then MutexUnLock(FBVF_INT_Mutex): Return FBVF_GURU_FontIDNotFound
Dim TPLPtr as FBVF_INT_PointList_Type Ptr = TPtr->V_Font(V_ChrID).V_PointListF
Dim TPPtr as FBVF_INT_Point_Type Ptr
Dim XC as UInteger = 1
Dim XFPX as UInteger
Dim XFPY as UInteger
Dim DD() as FBVF_INT_XPoint_Type
Do Until TPLPtr = 0
With *TPLPtr
TPPtr = .V_PointF
If TPPtr > 0 Then
XC = 1
XFPX = TPPtr->V_PosX
XFPY = TPPtr->V_PosY
TPPtr = TPPtr->V_Next
Do Until TPPtr = 0
XC += 1
If V_SizeMultiple = 0 Then
Else
Line V_ImagePtr, (V_ToPosX - TOX + Fix(XFPX * V_SizeMultiple), V_ToPosY - TOY + Fix(XFPY * V_SizeMultiple))-(V_ToPosX - TOX + Fix(TPPtr->V_PosX * V_SizeMultiple), V_ToPosY - TOY + Fix(TPPtr->V_PosY * V_SizeMultiple)), V_BorderColor
End If
XFPX = TPPtr->V_PosX
XFPY = TPPtr->V_PosY
TPPtr = TPPtr->V_Next
Loop
If XC >= 3 Then
' If (.V_FillPointX > 0) and (.V_FillPointY > 0) Then
If V_SizeMultiple = 0 Then
Else
Redim DD(XC) as FBVF_INT_XPoint_Type
XC = 0
TPPtr = .V_PointF
Do Until TPPtr = 0
If V_SizeMultiple = 0 Then
Else
DD(XC).V_X = V_ToPosX - TOX + Fix(TPPtr->V_PosX * V_SizeMultiple)
DD(XC).V_Y = V_ToPosY - TOY + Fix(TPPtr->V_PosY * V_SizeMultiple)
End If
XC += 1
TPPtr = TPPtr->V_Next
Loop
FBVF_INT_FillPolygon(V_ImagePtr, DD(), XC - 1, V_FillColor)
' Paint V_ImagePtr, (V_ToPosX - TOX + Fix(.V_FillPointX * V_SizeMultiple), V_ToPosY - TOY + Fix(.V_FillPointY * V_SizeMultiple)), V_FillColor, V_BorderColor
End If
' End If
End If
End If
End With
TPLPtr = TPLPtr->V_Next
Loop
MutexUnLock(FBVF_INT_Mutex)
Return FBVF_GURU_NoError
End Function
'------------------------------------------------------------------------------------------------------------------------------------
Function FBVF_DrawString(V_FontID as UInteger, V_Text as String, V_ToPosX as Integer, V_ToPosY as Integer, V_ImagePtr as Any Ptr = 0, V_Size as UInteger = 10, V_SizeWidth as UInteger = 0, V_SizeHeight as UInteger = 0, V_BorderColor as UInteger = &HFFFFFF, V_FillColor as UInteger = &HFFFFFF, V_SizeMultiple as Double = 0, V_ChrSpace as UInteger = 8, V_Monospace as UByte = 1) as FBVF_GuruCode_Enum
Dim XPX as UInteger = V_ToPosX
Dim XPY as UInteger = V_ToPosY
Dim TPX as UInteger
Dim TPY as UInteger
Dim TOX as UInteger
Dim TOY as UInteger
For X as UInteger = 1 to Len(V_Text)
FBVF_DrawChr(V_FontID, V_Text[X - 1], XPX, XPY, V_ImagePtr, V_Size, V_SizeWidth, V_SizeHeight, V_BorderColor, V_FillColor, V_SizeMultiple, V_Monospace)
FBVF_Chr_Dimension(V_FontID, V_Text[X - 1], V_Size, TPX, TPY, V_SizeWidth, V_SizeHeight, V_SizeMultiple, TOX, TOY)
If V_Monospace = 0 Then
If TPX > 0 Then
If V_SizeMultiple = 0 Then
Else: XPX += TPX + (V_ChrSpace * V_SizeMultiple)
End If
End If
Else
If TPX > 0 Then
If V_SizeMultiple = 0 Then
Else: XPX += (FBVF_INT_FontMaxWidth * V_SizeMultiple) + (V_ChrSpace * V_SizeMultiple)
End If
End If
End If
Next
Return FBVF_GURU_NoError
End Function