1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
Uses
Dos, Crt, Graph;
Type
TCharType = Array[1..16] Of Byte;
TVesaFont = Array[0..255] Of TCharType;
TVesaAscii = Array[0..255 * 16] Of Byte;
TFontSize = 0..1;
Function GetCharSpace: Byte; forward;
Procedure WriteXY(X, Y : Integer; Text : String); forward;
Procedure SetCharSpace(Spc : Byte); forward;
Procedure SetTextSize(Size : TFontSize); forward;
Function TextHeight(Text : String): Integer; forward;
Function TextWidth(Text : String): Integer; forward;
Const
FFontSize : TFontSize = 0;
FSpace : Byte = 8;
FHeight : Byte = 16;
Var
PFont : Pointer;
LgFont : ^TVesaAscii;
SlFont : ^TVesaAscii;
Procedure LoadFonts;
Var
Regs : Registers;
Begin
New(LgFont);
New(SlFont);
Regs.Ax := $1130;
Regs.Bh := 6;
Intr($10, Regs);
PFont := Ptr(Regs.Es, Regs.Bp);
Move(PFont^, LgFont^, SizeOf(TVesaAscii));
Regs.Ax := $1130;
Regs.Bh := 3;
Intr($10, Regs);
PFont := Ptr(Regs.Es, Regs.Bp);
Move(PFont^, SlFont^, SizeOf(TVesaAscii));
End;
Procedure FreeFonts;
Begin
If LgFont <> Nil Then Dispose(LgFont);
If SlFont <> Nil Then Dispose(SlFont);
End;
Procedure SetCharSpace(Spc : Byte);
Begin
FSpace := Spc;
End;
Function GetCharSpace: Byte;
Begin
GetCharSpace := FSpace;
End;
Function TextHeight(Text : String): Integer;
Begin
TextHeight := FHeight;
End;
Function TextWidth(Text : String): Integer;
Begin
TextWidth := Ord(Text[0]) * FSpace;
End;
Procedure SetTextSize(Size : TFontSize);
Begin
FFontSize := Size;
End;
Procedure WriteXY(X, Y : Integer; Text : String);
Const
Mask : Array [0..7] Of Byte = (128, 64, 32, 16, 8, 4, 2, 1);
Var
XCh, YCh, i : Integer;
Ch, Height : Byte;
Begin
For i := 1 To Length(Text) Do
Begin
Ch := Mem[Seg(Text[i]):Ofs(Text[i])];
If FFontSize = 0 Then Height := 15
Else Height := 7;
For YCh := 0 To Height Do
For XCh := 0 To 7 Do
Begin
If FFontSize = 0 Then
Begin
If (LgFont^[(Ch * 16) + YCh] And Mask [XCh]) <> 0 Then
PutPixel (X + ((i - 1) * 8) + XCh, Y + YCh, GetColor);
End
Else
Begin
If (SlFont^[(Ch * 8) + YCh] And Mask [XCh]) <> 0 Then
PutPixel (X + ((i - 1) * 8) + XCh, Y + YCh, GetColor);
End;
End;
End;
End;
var
Gd, Gm: Integer;
begin
Gd:= Detect;
InitGraph(Gd, Gm, 'D:\BP7\BGI');
LoadFonts;
SetTextSize(0);
WriteXY(100, 100, 'Test police 8x16');
SetTextSize(1);
WriteXY(100, 150, 'Test police 8x8');
ReadKey;
FreeFonts;
CloseGraph;
end. |
[TP]Pb de police de caractère...
Répondre avec citation
Envoyé par wormful_sickfoot
Partager