98 lines
2.4 KiB
Plaintext
98 lines
2.4 KiB
Plaintext
Type TFont
|
|
As String nam,imgpath
|
|
As Integer height,charlength(93)
|
|
As Any Ptr img,char(93)
|
|
End Type
|
|
|
|
Dim Shared As TFont Font(4)
|
|
Dim Shared As UByte num_fonts
|
|
|
|
Sub LoadFont(nam As String, height As UByte, path As String)
|
|
Dim As String length
|
|
Dim As Integer count,fontlength
|
|
|
|
With Font(num_fonts)
|
|
.nam=nam
|
|
.height=height
|
|
.img=ImageCreate(93*8,height)
|
|
Var ff=FreeFile
|
|
Open path For Input As #ff
|
|
Line Input #ff,.imgpath
|
|
Line Input #ff,length
|
|
For i As Integer=1 To 93
|
|
.charlength(i)=Val(Mid(length,5))
|
|
Next
|
|
Do
|
|
Line Input #ff,Length
|
|
count+=1
|
|
.charlength(count)=Val(Length)
|
|
Loop Until Eof(ff)
|
|
Close #ff
|
|
Bload .imgpath,.img
|
|
For i As Integer=1 To 93
|
|
.char(i)=ImageCreate(.charlength(i),height)
|
|
Get .img,(fontlength,0)-(fontlength+.charlength(i)-1,height-1),.char(i)
|
|
fontlength+=.charlength(i)
|
|
Next
|
|
ImageDestroy .img
|
|
End With
|
|
num_fonts+=1
|
|
End Sub
|
|
|
|
Const VGA14=0
|
|
Const VGA16=1
|
|
Const VGA8=2
|
|
Const SANS=3
|
|
Const MONO=4
|
|
|
|
LoadFont("VGA_14",14,"font1.fon")
|
|
LoadFont("VGA_16",16,"font2.fon")
|
|
LoadFont("VGA_8",8,"font3.fon")
|
|
LoadFont("Sans Serif 11",11,"sans11.fon")
|
|
LoadFont("Monospace 14",15,"mono14.fon")
|
|
|
|
function replace(byval src as uinteger, byval dest as uinteger, byval p as any ptr) as uinteger
|
|
dim c as uinteger = *cptr(uinteger ptr, p)
|
|
if src = RGB(255,255,255) then
|
|
return c
|
|
elseif src = 0 then
|
|
return dest
|
|
else
|
|
return src
|
|
end if
|
|
end function
|
|
|
|
Sub ColorRGB(R As UByte, G As UByte, B As Ubyte, fontid As UByte=0)
|
|
Dim As ULong C
|
|
C=RGB(R,G,B)
|
|
For i As Integer=1 To 93
|
|
Put Font(fontid).char(i),(0,0),Font(fontid).char(i),Custom,@replace,@c
|
|
Next
|
|
End Sub
|
|
|
|
Sub DrawString(text As String, x As Short, y As Short, fontid As UByte=0)
|
|
Dim As Integer fontlength
|
|
For i As Integer=1 To Len(text)
|
|
'Put (x+(i-2)*8+(8-Font(fontid).Charlength(Asc(Mid(text,i,1))-32)),y),Font(fontid).Char(Asc(Mid(text,i,1))-32),Trans
|
|
If Mid(text,i,1)<>" " Then
|
|
Put (x+fontlength,y),Font(fontid).Char(Asc(Mid(text,i,1))-32),Trans
|
|
fontlength+=Font(fontid).Charlength(Asc(Mid(text,i,1))-32)
|
|
Else
|
|
fontlength+=6
|
|
End If
|
|
Next
|
|
End Sub
|
|
|
|
Function FontWidth(text As String, fontid As UByte=0)As Integer
|
|
Dim As Integer fontlength
|
|
For i As Integer=1 To Len(text)
|
|
If Mid(text,i,1)<>" " Then
|
|
fontlength+=Font(fontid).Charlength(Asc(Mid(text,i,1))-32)
|
|
Else
|
|
fontlength+=6
|
|
End If
|
|
Next
|
|
Return fontlength
|
|
End Function
|
|
|