 // Es kann
eine sogenannte "Punktschrift" erstellt werden
type
Range = 3 .. 25;
const
Wide = 4; // 5 = 0..4
Altitude = 6; // 7 = 0..6
var
Bitmap: TBitmap;
arr: Array [0 .. Wide, 0 .. Altitude] of Boolean;
Actively, Inactive: TColor;
DiameterW, DiameterH: Range;
procedure Dots(Cnv: TCanvas; X, Y, B: Integer);
var
I, W, H, GW, GH, X1, X2, Y1, Y2: Integer;
begin
I := Succ((DiameterW + DiameterH) Div 20);
with Cnv do
begin
for H := 0 to Altitude do
for W := 0 to B do
begin
GW := DiameterW + I;
GH := DiameterH + I;
X1 := X + W * GW;
Y1 := Y + H * GH;
X2 := X1 + DiameterW;
Y2 := Y1 + DiameterH;
if arr[W, H] = False then
begin
Brush.Color := Inactive;
Fillrect(Rect(X1, Y1, X2, Y2));
end
else
Cnv.Draw(X1, Y1, Bitmap);
end;
end;
end;
procedure Horz(X, L, R: Integer; C: Boolean);
var
I: Integer;
begin
for I := L to R do
arr[I, X] := C;
end;
procedure Vert(X, T, B: Integer; C: Boolean);
var
I: Integer;
begin
for I := T to B do
arr[X, I] := C;
end;
function Letter(S: Integer): Integer;
procedure Blank(B: Integer);
var
I: Integer;
begin
for I := 0 to B do
Vert(I, 0, Altitude, False);
end;
procedure V1(I, J, K: Integer);
begin
Vert(I, J, K, true);
end;
procedure H2(I, J, K: Integer);
begin
Horz(I, J, K, true);
end;
var
I: Integer;
begin
Result := Succ(Wide);
case S of
40: // Klammer auf
begin
Blank(Wide - 3);
V1(0, 1, Altitude - 1);
arr[1, 0] := true;
arr[1, Altitude] := true;
Result := Wide - 2;
end;
41: // Klammer zu
begin
Blank(Wide - 3);
V1(1, 1, Altitude - 1);
arr[0, 0] := true;
arr[0, Altitude] := true;
Result := Wide - 2;
end;
43: // +
begin
Blank(Wide);
V1(2, 1, Altitude - 1);
H2(3, 0, Wide);
end;
45: // -
begin
Blank(Wide - 1);
H2(3, 0, Wide - 1);
Result := Wide;
end;
46: // Punkt
begin
Blank(Wide - 4);
arr[0, Altitude] := true;
Result := Wide - 3;
end;
58: // Doppelpunkt
begin
Blank(Wide - 4);
arr[0, 3] := true;
arr[0, 5] := true;
Result := Wide - 3;
end;
44: // Komma
begin
Blank(Wide - 3);
arr[0, Altitude] := true;
arr[1, Altitude - 1] := true;
Result := Wide - 2;
end;
48, 79: // 0, O
begin
Blank(Wide);
V1(0, 1, Altitude - 1);
V1(Wide, 1, Altitude - 1);
H2(0, 1, Wide - 1);
H2(Altitude, 1, Wide - 1);
if S = 48 then
Vert(2, 2, 4, true);
end;
49: // 1
begin
Blank(Wide - 2);
V1(1, 0, Altitude - 1);
H2(Altitude, 0, 2);
arr[0, 1] := true;
Result := Wide - 1;
end;
50: // 2
begin
Blank(Wide);
H2(0, 1, Wide - 1);
arr[0, 1] := true;
V1(Wide, 1, 2);
H2(Altitude, 0, Wide);
for I := 1 to Wide - 1 do
arr[I, Altitude - I] := true;
end;
51: // 3
begin
Blank(Wide);
H2(0, 1, Wide - 1);
arr[0, 1] := true;
V1(Wide, 1, 2);
H2(3, 2, 3);
H2(Altitude, 1, Wide - 1);
Vert(Wide, Altitude - 2, Altitude - 1, true);
arr[0, Altitude - 1] := true;
end;
52: // 4
begin
Blank(Wide);
H2(4, 0, Wide);
V1(2, 3, Altitude);
for I := 0 to 2 do
arr[I, 2 - I] := true;
arr[0, 3] := true;
end;
53: // 5
begin
Blank(Wide - 1);
H2(0, 0, Wide - 1);
V1(0, 1, 2);
arr[0, Altitude - 1] := true;
H2(Altitude, 1, Wide - 2);
V1(Wide - 1, Altitude - 3, Altitude - 1);
H2(2, 1, Wide - 2);
Result := Wide;
end;
54: // 6
begin
Blank(Wide);
V1(0, 1, Altitude - 1);
H2(0, 1, Wide - 1);
H2(Altitude, 1, Wide - 1);
V1(Wide, Altitude - 3, Altitude - 1);
H2(2, 1, Wide - 1);
end;
55: // 7
begin
Blank(Wide - 1);
H2(0, 0, Wide - 1);
for I := 0 to Wide - 1 do
arr[I, Altitude - I - 1] := true;
arr[Wide - 1, 1] := true;
arr[0, Altitude] := true;
arr[0, 1] := true;
Result := Wide;
end;
56: // 8
begin
Blank(Wide);
H2(0, 1, Wide - 1);
H2(3, 1, Wide - 1);
H2(Altitude, 1, Wide - 1);
Vert(0, 1, 2, true);
V1(0, Altitude - 2, Altitude - 1);
V1(Wide, 1, 2);
V1(Wide, Altitude - 2, Altitude - 1);
end;
57: // 9
begin
Blank(Wide);
H2(0, 1, Wide - 1);
H2(3, 1, Wide - 1);
V1(0, 1, 2);
V1(Wide, 1, Altitude - 1);
H2(Altitude, 1, Wide - 1);
end;
65: // A
begin
Blank(Wide);
V1(0, 1, Altitude);
V1(Wide, 1, Altitude);
H2(0, 1, Wide - 1);
H2(3, 1, Wide - 1);
end;
66: // B
begin
Blank(Wide);
V1(0, 0, Altitude);
H2(0, 0, Wide - 1);
H2(Altitude, 1, Wide - 1);
H2(3, 1, Wide - 1);
V1(Wide, 1, 2);
V1(Wide, 4, Altitude - 1);
end;
67: // C
begin
Blank(Wide);
V1(0, 1, Altitude - 1);
H2(0, 1, Wide - 1);
H2(Altitude, 1, Wide - 1);
arr[Wide, 1] := true;
arr[Wide, Altitude - 1] := true;
end;
68: // D
begin
Blank(Wide);
V1(0, 0, Altitude);
H2(0, 1, Wide - 2);
H2(Altitude, 1, Wide - 2);
arr[Wide - 1, 1] := true;
arr[Wide - 1, Altitude - 1] := true;
V1(Wide, 2, Altitude - 2);
end;
69: // E
begin
Blank(Wide - 1);
V1(0, 0, Altitude);
H2(0, 1, Wide - 1);
H2(3, 0, Wide - 2);
H2(Altitude, 1, Wide - 1);
Result := Wide;
end;
70: // F
begin
Blank(Wide - 1);
V1(0, 0, Altitude);
H2(0, 1, Wide - 1);
H2(3, 1, Wide - 2);
Result := Wide;
end;
71: // G
begin
Blank(Wide);
V1(0, 1, Altitude - 1);
H2(0, 1, Wide - 1);
H2(Altitude, 1, Wide - 1);
V1(Wide, Altitude - 3, Altitude - 1);
H2(3, 2, Wide - 1);
arr[Wide, 1] := true;
end;
72: // H
begin
Blank(Wide);
V1(0, 0, Altitude);
V1(Wide, 0, Altitude);
H2(3, 1, Wide - 1);
end;
73: // I
begin
Blank(Wide - 2);
V1(1, 1, Altitude - 1);
H2(0, 0, 3);
H2(Altitude, 0, 3);
Result := Wide - 1;
end;
74: // J
begin
Blank(Wide - 1);
V1(Wide - 1, 0, Altitude - 1);
H2(Altitude, 1, Wide - 2);
V1(0, Altitude - 2, Altitude - 1);
Result := Wide;
end;
75: // K
begin
Blank(Wide - 1);
V1(0, 0, Altitude);
for I := 1 to Wide - 1 do
arr[I, 3 - I] := true;
for I := 1 to Wide - 1 do
arr[I, I + 3] := true;
Result := Wide;
end;
76: // L
begin
Blank(Wide - 1);
V1(0, 0, Altitude);
H2(Altitude, 1, Wide - 1);
Result := Wide;
end;
77: // M
begin
Blank(Wide);
V1(0, 0, Altitude);
V1(Wide, 0, Altitude);
for I := 1 to 2 do
arr[I, I] := true;
arr[3, 1] := true;
end;
78: // N
begin
Blank(Wide);
V1(0, 0, Altitude);
V1(Wide, 0, Altitude);
for I := 1 to 2 do
begin
arr[I, I] := true;
arr[I + 1, I + 2] := true;
end;
end;
80, 82: // P, R
begin
Blank(Wide);
V1(0, 0, Altitude);
H2(0, 0, 3);
H2(3, 1, 3);
V1(Wide, 1, 2);
if S = 82 then
begin
for I := 2 to Wide do
arr[I, I + 2] := true;
end;
end;
81: // Q
begin
Blank(Wide);
V1(0, 1, Altitude - 1);
V1(Wide, 1, Altitude - 2);
H2(0, 1, Wide - 1);
for I := Wide - 2 to Wide do
arr[I, I + 2] := true;
H2(Altitude, 1, 2);
end;
83: // S
begin
Blank(Wide);
H2(0, 1, Wide - 1);
H2(3, 1, Wide - 1);
H2(Altitude, 1, Wide - 1);
V1(0, 1, 2);
V1(Wide, 4, Altitude - 1);
arr[0, Altitude - 1] := true;
arr[Wide, 1] := true;
end;
84: // T
begin
Blank(Wide);
H2(0, 0, Wide);
V1(2, 1, Altitude);
end;
85: // U
begin
Blank(Wide);
V1(0, 0, Altitude - 1);
V1(Wide, 0, Altitude - 1);
H2(Altitude, 1, Wide - 1);
end;
86: // V
begin
Blank(Wide);
V1(0, 0, 3);
V1(1, 4, 5);
V1(Wide, 0, 3);
V1(Wide - 1, 4, 5);
arr[2, Altitude] := true;
end;
87: // W
begin
Blank(Wide);
V1(0, 0, Altitude - 1);
V1(Wide, 0, Altitude - 1);
arr[1, Altitude] := true;
arr[Wide - 1, Altitude] := true;
V1(2, Altitude - 3, Altitude - 1);
end;
88: // X
begin
Blank(Wide);
V1(0, 0, 1);
V1(Wide, 0, 1);
V1(0, Altitude - 1, Altitude);
V1(Wide, Altitude - 1, Altitude);
for I := 1 to Wide - 1 do
arr[I, I + 1] := true;
arr[1, Altitude - 2] := true;
arr[3, 2] := true;
end;
89: // Y
begin
Blank(Wide);
V1(0, 0, 2);
V1(Wide, 0, 2);
arr[1, Altitude - 3] := true;
arr[3, Altitude - 3] := true;
V1(2, Altitude - 2, Altitude);
end;
90: // Z
begin
Blank(Wide);
H2(0, 0, Wide);
H2(Altitude, 0, Wide);
for I := 0 to Wide do
arr[I, Altitude - Succ(I)] := true;
end;
else // Space
begin
Blank(Wide - 1);
Result := Wide;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAndNil(Bitmap);
end;
procedure TForm1.Scripture(Txt: String; Cnv: TCanvas; X, Y: Integer);
var
I, D, DD, DDD, XX, YY: Integer;
begin
XX := X;
DDD := X;
I := Succ((DiameterW + DiameterH) Div 20);
YY := (DiameterH + I) * (Altitude + 2);
Txt := AnsiUppercase(StringReplace(Txt, 'ß', 'SS', [rfReplaceAll]));
Txt := StringReplace(Txt, 'Ä', 'AE', [rfReplaceAll]);
Txt := StringReplace(Txt, 'Ö', 'OE', [rfReplaceAll]);
Txt := StringReplace(Txt, 'Ü', 'UE', [rfReplaceAll]);
for I := 1 to length(Txt) do
begin
D := Letter(Ord(Txt[I]));
DD := DiameterW * D + Round(DiameterW * 1.5);
inc(DDD, DD);
if DDD > Cnv.cliprect.Right then // Zeilenumbruch
begin
X := XX;
DDD := XX;
inc(Y, YY);
end;
Dots(Cnv, X, Y, D - 1);
inc(X, DD);
end;
end;
// ------ Beispiel1 -------
procedure Load;
var
C: TColor;
function ChangeColor(bmp: TBitmap; oldc, newc: TColor): Boolean;
var
n: array [0 .. 2] of Byte;
R, g, B: Byte;
X, Y, z, b3: Integer;
p: PBytearray;
begin
Result := False;
newc := colortorgb(newc);
oldc := colortorgb(oldc);
n[2] := getrvalue(newc);
n[1] := getgvalue(newc);
n[0] := getbvalue(newc);
R := getrvalue(oldc);
g := getgvalue(oldc);
B := getbvalue(oldc);
bmp.pixelformat := pf24bit;
b3 := bmp.width * 3;
for Y := 0 to bmp.Height - 1 do
begin
p := bmp.scanline[Y];
X := 0;
while X < b3 do
begin
if (p[X] = B) and (p[X + 1] = g) and (p[X + 2] = R) then
begin
for z := 0 to 2 do
p[X + z] := n[z];
Result := true;
end;
inc(X, 3);
end;
end;
end;
begin
Bitmap.LoadFromFile('Herz.bmp');
C := Bitmap.Canvas.Pixels[0, 0]; // z.B.
ChangeColor(Bitmap, C, Form1.Color);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Actively := $D00000;
Inactive := Color;
Load;
DiameterW := Bitmap.width;
DiameterH := Bitmap.Height;
Scripture('Delphi', Canvas, 30, 10);
end;
// ------ Beispiel2 -------
procedure TForm1.Button2Click(Sender: TObject);
begin
Actively := $AF0000;
Inactive := $FFE0E0;
Bitmap.width := 5;
Bitmap.Height := 5;
DiameterW := Bitmap.width;
DiameterH := Bitmap.Height;
with Bitmap.Canvas do
begin
Brush.Color := Inactive;
Fillrect(cliprect);
Brush.Color := Actively;
Pen.Color := Actively;
Ellipse(0, 0, DiameterW, DiameterH);
end;
Scripture('Test 123', Canvas, 30, 100);
end;
// --- P.S. --- // Wer nicht nur Strings ausgeben will, sondern den Text // buchstabenweise eintippen möchte findet in Punkt.rtf // eine entsprechende Anregung.
|
||||
Zugriffe seit
6.9.2001 auf Delphi-Ecke |
