1:
2:
3:
4:

procedure TForm1.FormCreate(Sender: TObject);
begin
  TWriter1 := TWriter.Create(Form1, DXDraw1);
end;					

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:

type
  TWriter = class(TComponent)
  private
    WAutoFill : boolean;
    WAutoFillClr : integer;
    WAutoFlip : boolean;
    WDXDraw : TDXDraw;
    WFont : string;
    WFontTable : integer;
    WOwner : TComponent;
    WPatternSkip : integer;
    WSize : integer;
    WWriterImagePath : string;
    WWriterImages : TDXImageList;
    Wx, Wy : integer;
    procedure SetFont(sFont : string);
    procedure SetSize(iSize : integer);
    procedure SetDXDraw(aDXDraw : TDXDraw);
    procedure SetAutoFill(bAutoFill : boolean);
    procedure SetAutoFillClr(iAutoFillClr : integer);
    procedure SetAutoFlip(bAutoFlip : boolean);
    function XDiff(CIdx : integer; Size : integer) : integer;
    function YDiff(CIdx : integer; Size : integer) : integer;
  protected
  public
    procedure Write(text : string; PosX, PosY : integer);
    constructor Create(aForm: TComponent; aDXDraw: TDXDraw);
    procedure SetWriterStyle(sFont : string; iSize : integer);
    destructor Destroy;
  published
    property AutoFill : boolean read WAutoFill write SetAutoFill;
    property AutoFillClr : integer read WAutoFillClr write SetAutoFillClr;
    property AutoFlip : boolean read WAutoFlip write SetAutoFlip;
    property DXDraw : TDXDraw read WDXDraw write SetDXDraw;
    property Font : string read WFont write SetFont;
    property Size : integer read WSize write SetSize;
  end;					

1:

constructor Create(AOwner: TComponent); override;					

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:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:

unit DXWriter;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DXDraws, DXClass;

type
  TDXWriterPattern         = (wp17,wp25,wp34);         // Verfügbare Pattern 17, 25, 34
  TDXWriterPatternSet      = set of TDXWriterPattern;
  TDXWriterFonts           = (RED_FLAT,RED_HIGH,BLUE_FLAT,BLUE_HIGH,BLACK);  // Schriftarten
  TDXWriterSizes           = (Size17,Size25,Size34);   // Verfügbare Schriftgrößen 17, 25, 34

  TDXWriter = class(TComponent)
  private
    FDXWriterPattern : TDXWriterPatternSet;
    Fwp17,
    Fwp25,
    Fwp34 : Boolean;

    FAutoFill : boolean;
    FAutoFillClr : integer;
    FAutoFlip : boolean;
    FDXDraw : TDXDraw;
    FDXWriterFont   : TDXWriterFonts;
    FFontTable : integer;
    FOwner : TComponent;
    FPatternAutoLoad : boolean;
    FPatternSkip : integer;
    FSize : integer;
    FDXWriterSize   : TDXWriterSizes;
    WWriterImagePath : string;
    FWriterImages : TDXImageList;
    procedure SetAutoFill(bAutoFill : boolean);
    procedure SetAutoFillClr(iAutoFillClr : integer);
    procedure SetDXDraw(aDXDraw : TDXDraw);
    procedure SetFont(FontValue : TDXWriterFonts);
    procedure SetSize(SizeValue : TDXWriterSizes);
    function XDiff(CIdx : integer; Size : integer) : integer;
    function YDiff(CIdx : integer; Size : integer) : integer;
  protected
  public
    procedure Write(text : string; PosX, PosY : integer);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetWriterStyle(sFont : string; iSize : integer);
    procedure LoadPattern(PatternValues: TDXWriterPatternSet);
  published
    property AutoFill : boolean read FAutoFill write SetAutoFill;
    property AutoFillClr : integer read FAutoFillClr write SetAutoFillClr;
    property AutoFlip : boolean read FAutoFlip write FAutoFlip;
    property AutoPattern : boolean read FPatternAutoLoad write FPatternAutoLoad;
    property DXDraw : TDXDraw read FDXDraw write SetDXDraw;
    property Font : TDXWriterFonts read FDXWriterFont write SetFont;
    property ImagePath : string read WWriterImagePath write WWriterImagePath;
    property Pattern : TDXWriterPatternSet read FDXWriterPattern write LoadPattern;
    property Size : TDXWriterSizes read FDXWriterSize write SetSize;
  end;

procedure Register;

implementation


constructor TDXWriter.Create(AOwner: TComponent);
var i : integer;
begin
  inherited create(AOwner);
  FOwner:=AOwner;
  FWriterImages := TDXImagelist.create(AOwner);
  WWriterImagePath:=ExtractFilePath(ParamStr(0));
  repeat FWriterImages.Items.Add;
  until FWriterImages.Items.count >=3;

  with FWriterImages do
  begin
    if FDXDraw<>nil then dxdraw:=FDXDraw;

    items[0].PatternHeight:=34;      // Erstellter Imagelist werden
    items[0].PatternWidth:=34;       // PatternEigenschaften hinzugefügt
    items[1].PatternHeight:=25;
    items[1].PatternWidth:=25;
    items[2].PatternHeight:=17;
    items[2].PatternWidth:=17;

    for i:=0 to 2 do
    begin
      items[i].TransparentColor:=clFuchsia;   // clFuchsia als Transparenz
      items[i].Transparent:=true;
    end;
  end;

  LoadPattern([wp25]);             // Standard Font 25 RED_FLAT laden
  SetWriterStyle('RED_FLAT',25);   //  "  "
end;

destructor TDXWriter.Destroy;
begin
  inherited destroy;
  FWriterImages.Free;
end;

procedure TDXWriter.SetAutoFill(bAutoFill : boolean);
begin
  FAutoFill:=bAutoFill;                      // Für ein Stand-alone des
  if (FAutoFillClr<0) then FAutoFillClr:=0;  // writers, zusammen mit Autoflip
end;

procedure TDXWriter.SetAutoFillClr(iAutoFillClr : integer);
begin
  if (FAutoFillClr<0) then FAutoFillClr:=0 else
    FAutoFillClr:=iAutoFillClr;
end;

procedure TDXWriter.SetDXDraw(aDXDraw : TDXDraw);
begin
  FDXDraw:=aDXDraw;                   // DXDraw zuweisen. Einmal für den writer
  FWriterImages.DXDraw:=FDXDraw;      // und einmal für die imagelist
end;

procedure TDXWriter.SetWriterStyle(sFont : string; iSize : integer);
{ SetWriterStyle definiert den Writer Style mittels Strings und Integern}

  function StrToDXWFont(s : string) : TDXWriterFonts;
  begin
    s:=uppercase(s);
    if s='RED_HIGH' then result:=RED_HIGH else
    if s='RED_FLAT' then result:=RED_FLAT else
    if s='BLUE_HIGH' then result:=BLUE_HIGH else
    if s='BLUE_FLAT' then result:=BLUE_FLAT else
    if s='BLACK' then result:=BLACK else result:=BLACK;
  end;
  function IntToDXWSize(i : integer) : TDXWriterSizes;
  begin
    if i=17 then result:=Size17 else
    if i=25 then result:=Size25 else
    if i=34 then result:=Size34 else result:=Size25;
  end;
begin
  SetFont(StrToDXWFont(sFont));     // Font und Size gleichzeitig einstellen
  SetSize(IntToDXWSize(iSize));
end;

procedure TDXWriter.SetFont(FontValue : TDXWriterFonts);
begin
  FDXWriterFont:=FontValue;
  if FDXWriterFont=RED_HIGH then FPatternSkip:=0 else
  if FDXWriterFont=BLUE_HIGH then FPatternSkip:=1 else
  if FDXWriterFont=RED_FLAT then FPatternSkip:=2 else
  if FDXWriterFont=BLUE_FLAT then FPatternSkip:=3 else
  if FDXWriterFont=BLACK then FPatternSkip:=0 else FPatternSkip:=0;
end;

procedure TDXWriter.SetSize(SizeValue : TDXWriterSizes);
var lwp17, lwp25, lwp34 : boolean;
begin
  FDXWriterSize:=SizeValue;
  if FDXWriterSize=Size34 then
  begin
    FFontTable:=0;
    FSize:=34;
  end else
  if FDXWriterSize=Size25 then
  begin
    FFontTable:=1;
    FSize:=25;
  end else
  if FDXWriterSize=Size17 then
  begin
    FFontTable:=2;
    FSize:=17;
  end else
  begin
    FFontTable:=1;
    FDXWriterSize:=Size25;
    FSize:=25;
  end;

  if FPatternAutoLoad then begin
  if SizeValue=Size17 then lwp17:=true else lwp17:=false;
  if SizeValue=Size25 then lwp25:=true else lwp25:=false;
  if SizeValue=Size34 then lwp34:=true else lwp34:=false;

  if ( (not lwp17) and (not lwp25) and (not lwp34) ) then LoadPattern([]) else
  if ( (lwp17) and (not lwp25) and (not lwp34) ) then LoadPattern([wp17]) else
  if ( (not lwp17) and (lwp25) and (not lwp34) ) then LoadPattern([wp25]) else
  if ( (lwp17) and (lwp25) and (not lwp34) ) then LoadPattern([wp17,wp25]) else
  if ( (lwp17) and (not lwp25) and (lwp34) ) then LoadPattern([wp17,wp34]) else
  if ( (lwp17) and (lwp25) and (lwp34) ) then LoadPattern([wp17,wp25,wp34]) else
  if ( (not lwp17) and (lwp25) and (lwp34) ) then LoadPattern([wp25,wp34]) else
  if ( (not lwp17) and (not lwp25) and (lwp34) ) then LoadPattern([wp34]);
  end;
end;


procedure TDXWriter.LoadPattern(PatternValues: TDXWriterPatternSet);
begin
  FDXWriterPattern:=PatternValues;
  Fwp17 := (wp17 in FDXWriterPattern);
  Fwp25 := (wp25 in FDXWriterPattern);
  Fwp34 := (wp34 in FDXWriterPattern);

  if Fwp17 then FWriterImages.Items[2].Picture.loadfromfile(WWriterImagePath+'font17.bmp')
      else FWriterImages.Items[2].Picture.Bitmap.FreeImage;
  if Fwp25 then FWriterImages.Items[1].Picture.loadfromfile(WWriterImagePath+'font25.bmp')
      else FWriterImages.Items[1].Picture.Bitmap.FreeImage;
  if Fwp34 then FWriterImages.Items[0].Picture.loadfromfile(WWriterImagePath+'font34.bmp')
      else FWriterImages.Items[0].Picture.Bitmap.FreeImage;

end;

function TDXWriter.YDiff(CIdx : integer; Size : integer) : integer;
var dify : integer;
begin
  if FSize=34 then
  begin
    case CIdx of
      26..51 : dify:=+3;
      52..61 : dify:=+2;
      62..64 : dify:=-2;
      65..67 : dify:=+2
    else dify:=0;
    end;
  end else

  if FSize=25 then
  begin
    case CIdx of
      26..51 : dify:=2;
      52..61 : dify:=+2;
      65..67 : dify:=+2;
    else dify:=0;
    end;
  end else

  if FSize=17 then
  begin
    case CIdx of
      0..25  : dify:=0;
      26..51 : dify:=+1;
      52..61 : dify:=0;
      62..64 : dify:=-2;
      65..67 : dify:=+1;
      68..69 : dify:=-1;
      70..103: dify:=0;
    else dify:=0;
    end;
  end else dify:=0;

  Result:=dify;
end;

function TDXWriter.XDiff(CIdx : integer; Size : integer) : integer;
var difx : integer;
begin
  if FSize = 34 then
  begin
    case cidx of
        0   : difx:=17;
        1   : difx:=14;
        2   : difx:=17;
        4   : difx:=15;
        5 : difx:=17;
        6 : difx:=18;
        8..11 : difx:=15;
        12 : difx:=22;
        15 : difx:=17;
        17 : difx:=17;
        18 : difx:=18;
        19..21 : difx:= 17;
        22 : difx:=22;
        23 : difx:=21;
        24 : difx:=15;
        25 : difx:=20;
        26..29 : difx:=15;
        30..31 : difx:=13;
        32 : difx:=16;
        33 : difx:=15;
        34 : difx:=7;
        35 : difx:=13;
        36 : difx:=15;
        37 : difx:=14;
        38 : difx:=18;
        39 : difx:=16;
        40 : difx:=14;
        41..44 : difx:=15;
        45 : difx:=13;
        46 : difx:=13;
        47 : difx:=16;
        48 : difx:=18;
        49..61 : difx:=16;
        63..64 : difx:=21;
        65..74 : difx:=17;
        75..76 : difx:=14;
        77 : difx:=16;
        78..80 : difx:=17;
        81..84 : difx:=14;
        85 : difx:=9;
        86 : difx:=17;
        87..88 : difx:=14;
        102 : difx:=15;
    else difx:=20;
    inc(difx,7);
    end;
  end else

  if FSize = 25 then
  begin
    case cidx of
        0   : difx:=17;
        1   : difx:=14;
        2   : difx:=17;
        4   : difx:=15;
        5 : difx:=17;
        6 : difx:=18;
        8..11 : difx:=15;
        12 : difx:=22;
        15 : difx:=17;
        17 : difx:=17;
        18 : difx:=18;
        19..21 : difx:= 17;
        22 : difx:=22;
        23 : difx:=21;
        24 : difx:=15;
        25 : difx:=20;
        26..29 : difx:=15;
        30..31 : difx:=13;
        32 : difx:=16;
        33 : difx:=15;
        34 : difx:=7;
        35 : difx:=13;
        36 : difx:=15;
        37 : difx:=9;
        38 : difx:=18;
        39 : difx:=16;
        40 : difx:=14;
        41..44 : difx:=15;
        45 : difx:=13;
        46 : difx:=13;
        47 : difx:=16;
        48 : difx:=18;
        49..61 : difx:=16;
        63..64 : difx:=21;
        65..74 : difx:=17;
        75..76 : difx:=14;
        77 : difx:=16;
        78..80 : difx:=17;
        81..84 : difx:=14;
        85 : difx:=9;
        86 : difx:=17;
        87..88 : difx:=14;
        102 : difx:=15;
    else difx:=20;
    end;
  end else

  if FSize = 17 then
  begin
    case cidx of
        0 : difx:=14;
        4  : difx:=12;
        5  : difx:=11;
        8  : difx:=5;
        11 : difx:=11;
        12 : difx:=15;
        14 : difx:=14;
        22 : difx:=16;
        24 : difx:=11;
        27..30 : difx:=11;
        31 : difx:=5;
        32..33 : difx:=12;
        34 : difx:=6;
        35..36 : difx:=12;
        37 : difx:=7;
        38 : difx:=14;
        39..41 : difx:=11;
        43..47 : difx:=10;
        48 : difx:=15;
        49 : difx:=11;
        53 : difx:=11;
        65..67 : difx:=11;
        75..77 : difx:=9;
        79..80 : difx:=10;
        81..85 : difx:=8;
        87..90 : difx:=8;

        102 : difx:=11;
    else difx:=13;
    end;
  end else difx:=20;
  Result:=difx;
end;

procedure TDXWriter.Write(text : string; PosX, PosY : integer);
var i, cidx : integer;
begin
  // IST DAS AKTUELLE PATTERN GELADEN?

  if ( ((FSize=34) and (not Fwp34)) or
       ((FSize=25) and (not Fwp25)) or
       ((FSize=17) and (not Fwp17)) ) then exit;

  // DXDRAW ?

  if FDXDraw = nil then exit;
     
  // GIBT ES EINEN TEXT?
  if length(text)<1 then exit;

  if FAutoFill then FDXDraw.surface.fill(FAutoFillClr);
 

  for i:=1 to length(text) do
  begin

    //ZEICHEN CHECKEN

    case text[i] of
     'A': cidx:=0;
     'B': cidx:=1;
     'C': cidx:=2;
     'D': cidx:=3;
     'E': cidx:=4;
     'F': cidx:=5;
     'G': cidx:=6;
     'H': cidx:=7;
     'I': cidx:=8;
     'J': cidx:=9;
     'K': cidx:=10;
     'L': cidx:=11;
     'M': cidx:=12;
     'N': cidx:=13;
     'O': cidx:=14;
     'P': cidx:=15;
     'Q': cidx:=16;
     'R': cidx:=17;
     'S': cidx:=18;
     'T': cidx:=19;
     'U': cidx:=20;
     'V': cidx:=21;
     'W': cidx:=22;
     'X': cidx:=23;
     'Y': cidx:=24;
     'Z': cidx:=25;

     'a': cidx:=26;
     'b': cidx:=27;
     'c': cidx:=28;
     'd': cidx:=29;
     'e': cidx:=30;
     'f': cidx:=31;
     'g': cidx:=32;
     'h': cidx:=33;
     'i': cidx:=34;
     'j': cidx:=35;
     'k': cidx:=36;
     'l': cidx:=37;
     'm': cidx:=38;
     'n': cidx:=39;
     'o': cidx:=40;
     'p': cidx:=41;
     'q': cidx:=42;
     'r': cidx:=43;
     's': cidx:=44;
     't': cidx:=45;
     'u': cidx:=46;
     'v': cidx:=47;
     'w': cidx:=48;
     'x': cidx:=49;
     'y': cidx:=50;
     'z': cidx:=51;

     '0': cidx:=52;
     '1': cidx:=53;
     '2': cidx:=54;
     '3': cidx:=55;
     '4': cidx:=56;
     '5': cidx:=57;
     '6': cidx:=58;
     '7': cidx:=59;
     '8': cidx:=60;
     '9': cidx:=61;

     'Ä': cidx:=62;
     'Ö': cidx:=63;
     'Ü': cidx:=64;

     'ä': cidx:=65;
     'ö': cidx:=66;
     'ü': cidx:=67;

     '(': cidx:=68;
     ')': cidx:=69;
     '[': cidx:=70;
     ']': cidx:=71;
     '<': cidx:=72;
     '>': cidx:=73;
     '=': cidx:=74;
     ':': cidx:=75;
     '!': cidx:=76;
     '?': cidx:=77;
     '+': cidx:=78;
     '-': cidx:=79;
     '_': cidx:=80;
     '.': cidx:=81;
     ',': cidx:=82;
     ';': cidx:=83;
     '"': cidx:=84;
     chr(39): cidx:=85;
     '´': cidx:=85;
     '`': cidx:=85;
     'ß': cidx:=86;
     '^': cidx:=87;
     '°': cidx:=88;
     '/': cidx:=89;
     '\': cidx:=90;
     '%': cidx:=91;
     '$': cidx:=92;
     '#': cidx:=93;
     '*': cidx:=94;
     '{': cidx:=95;
     '}': cidx:=96;
     '€': cidx:=97;
     '@': cidx:=98;
     '~': cidx:=99;
     '&': cidx:=100;
     '|': cidx:=101;
     ' ': cidx:=102;
    else cidx:=103;
    end;


    // AUSGABE DES AKTUELLEN ZEICHENS
    
    FWriterImages.items[FFontTable].draw(FDXDraw.Surface,posx, posy+YDiff(cidx, FSize), cidx+(FPatternSkip*104));

    // ZEICHENABSTAND

    Inc(Posx,XDiff(cidx, FSize));

  end;
  if FAutoFlip then FDXDraw.Flip;
end;

procedure Register;
begin
  RegisterComponents('Horschdware', [TDXWriter]);
end;

end.