GraVis - eine 2D Grafikunit

Jack Falworth · Verfasst: So 12.09.04 01:48

Kurzbeschreibung:
GraVis ist eine 2D Grafikunit zum einfachen erstellen und verwalten diverser
geometrischer Figuren, (Rechtecke, Kreise, Dreiecke,..). Durch Verwendung von Klassen können die Eigenschaften (Farbe, Text,..) jedes Objektes mit einfachen Befehlen verändert und beispielsweise in Arrays verwaltet werden.

Hier zwei Screenshots, die zeigen was man damit z.b. machen kann:
user defined image

Die Unit zum Download gibts hier.

Ein OpenSource Demo Programm hier.

markieren

Delphi-Quelltext

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:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:
595:
596:
597:
598:
599:
600:
601:
602:
603:
604:
605:
606:
607:
608:
609:
610:
611:
612:
613:
614:
615:
616:
617:

{******************************************************************************}
{                                                                              }
{                   GraVis XT - Version 0.7 (2004-08-30)                       }
{                                                                              }
{                     Copyright (c) 2003-2004 Evocore                          }
{                                                                              }
{                          Programmer:  Erik Derr                              }
{                             Kontakt:  >> derr@evocore.de                     }
{                                                                              }
{                                                                              }
{      Unsere Codes sind wie moderne Kunst: Keiner kann sie einordnen,         }
{          und wenn man sie zu lange betrachtet, wird einem schlecht.  :-)     }
{                                                                              }
{                                                                              }
{******************************************************************************}

{*******************************************************************************
                               -=LICENSE=-

THIS Unit is OpenSource.

THIS SOURCE IS FREE OF CHARGE. THERE IS NO WARRANTY FOR IT.
THE PROGRAM IS PROVIDED 'AS IS' WITHOUT WARRANTY OF ANY KIND.

The source is provided under the above conditions. You are allowed to
change its origin, but then please send us a copy.
If there are any questions contact us.
*******************************************************************************}

unit GraVis;

interface

uses
   Classes, Graphics, Controls, ExtCtrls;

type
  TTriangle_Dir = (links, rechts);

  TCircle = class
  private
   { Private-Deklarationen }
   fx: Integer;
   fy: Integer;
   fWidth: Integer;
   fFarbe: TColor;
   fText: String;
   fImage: TImage;
    function get_int (index: integer): integer;
    procedure set_int (index: integer; value: integer);
    procedure set_col (value: tcolor);
    procedure set_str (value: string);
    procedure set_img (value: Timage);
    procedure paint; overload; virtual;
    procedure p_Circle;
  public
   { Public-Deklarationen }          
   constructor create;
   procedure paint (pImage: TImage); overload; virtual;
   procedure paint (px,py,pWidth: Integer; pImage: TImage); overload;
  published
   property x: integer index 0 read get_int write set_int;
   property y: integer index 1 read get_int write set_int;
   property width: integer index 2 read get_int write set_int;
   property farbe: tcolor read fFarbe write set_col;
   property text: string read fText write set_str;
   property image: TImage read fImage write set_img;
  end;


  TRectangle = class (TCircle)
  private
   { Private-Deklarationen }
   fHeight: Integer;
    procedure paint; overload; override;
    procedure set_HInt (value: integer);
    procedure p_Rectangle;
  public
   { Public-Deklarationen }
   constructor create;
   procedure paint (pImage: TImage); overload; override;
   procedure paint (px,py,pWidth,pHeight: Integer; pImage: TImage); overload;
  published
   { Published-Deklarationen }
   property height: integer read fHeight write set_HInt;
  end;


  TRRectangle = class (TRectangle)
  private
   { Private-Deklarationen }
   fRundung: cardinal;
    procedure set_card (value: cardinal);
    procedure paint; overload; override;
    procedure p_RRectangle;
  public
   { Public-Deklarationen }
   constructor create;
   procedure paint (pImage: TImage); overload; override;
   procedure paint (px,py,pWidth,pHeight: Integer; pImage: TImage); overload;
  published
   { Published-Deklarationen }
   property rundung: cardinal read fRundung write set_card;
  end;


  TLine = class
  private
   { Private-Deklarationen }
   fx: Integer;
   fy: Integer;
   fWidth: Integer;
   fHeight: Integer;
   fFarbe: TColor;
   fImage: TImage;
    function get_int (index: integer): integer;
    procedure set_int (index: integer; value: integer);
    procedure set_col (value: tcolor);
    procedure set_img (value: Timage);
    procedure paint; overload;
    procedure p_Line;
  public
   { Public-Deklarationen }
   constructor create;
   procedure paint (pImage: TImage); overload;
   procedure paint (px,py,pWidth,pHeight: Integer; pImage: TImage); overload;
  published
   property x: integer index 0 read get_int write set_int;
   property y: integer index 1 read get_int write set_int;
   property width: integer index 2 read get_int write set_int;
   property height: integer index 3 read get_int write set_int;
   property farbe: tcolor read fFarbe write set_col;
   property image: TImage read fImage write set_img;
  end;

  TTriangle = class
  private
   { Private-Deklarationen }
   fx: integer;
   fy: integer;
   fheight: integer;
   fwidth: integer;
   fcolor: TColor;
   frichtung: TTriangle_Dir;
   fImage: TImage;
    function get_int (index: integer): integer;
    procedure set_int (index: integer; value: integer);
    procedure set_col (value: tcolor);
    procedure set_img (value: Timage);
    procedure set_dir (value: TTriangle_Dir);
    procedure paint; overload;
    procedure p_Triangle;
  public
   { Public-Deklarationen }
   constructor create;
   procedure paint (pImage: TImage); overload;
   procedure paint (px,py: Integer); overload;
   procedure paint (px,py: Integer; pImage: TImage); overload;
  published
   property x: integer index 0 read get_int write set_int;
   property y: integer index 1 read get_int write set_int;
   property height: integer index 2 read get_int write set_int;
   property width: integer index 3 read get_int write set_int;
   property color: TColor read fcolor write set_col;
   property richtung: TTriangle_dir read frichtung write set_dir;
   property image: TImage read fimage write set_img;
  end;

procedure Refresh_Img (image: Timage);

implementation

{-----------------------------------------------------------------}
{-----  Class TCircle  -------------------------------------------}
{-----------------------------------------------------------------}

constructor TCircle.create;
begin
 fx:= 50;
 fy:= 50;
 fwidth:= 70;
 ffarbe:= clWhite;
 ftext:= '';
end;

function TCircle.get_int (index: integer): integer;
begin
 case index of
  0: result:= fx;
  1: result:= fy;
  2: result:= fWidth;
 else result:= 0;
 end;
end;

procedure TCircle.set_int (index: integer; value: integer);
begin
 case index of
  0: fx:= value;
  1: fy:= value;
  2: fWidth:= value;
 else ;
 end;
paint;
end;

procedure TCircle.set_col (value: tcolor);
begin
 fFarbe:= value;
 paint;
end;

procedure TCircle.set_str (value: string);
begin
 fText:= value;
 paint;
end;

procedure TCircle.set_img (value: Timage);
begin
 fImage:= value;
 paint;
end;

procedure TCircle.p_Circle;
var zen_x, zen_y: integer;
begin
 with fImage.Canvas do
 begin
  Pen.Width:= 1;
  Brush.Color:= fFarbe;
  Ellipse (fx,fy-(fWidth div 2),fx+fWidth,fy+(fWidth div 2));
 end;

 if fText <> '' then
 begin
  zen_x:= ((fWidth div 2) + fx) - (fImage.Canvas.Textwidth (fText) div 2);
  zen_y:= fy - (fImage.Canvas.Textheight (fText) div 2);
  fImage.Canvas.Textout (zen_x, zen_y, fText);
 end;
end;


procedure TCircle.paint;
begin
Refresh_img (fImage);
p_Circle;
end;

procedure TCircle.paint (pImage: TImage);
begin
 if image <> pImage then
  fImage:= pImage;
p_Circle;
end;

procedure TCircle.paint (px,py,pWidth: Integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if width <> pWidth then
  fWidth:= pWidth;
 if image <> pImage then
  fImage:= pImage;
p_Circle;
end;

{-----------------------------------------------------------------}
{-----  Class TRectangle  ----------------------------------------}
{-----------------------------------------------------------------}

constructor TRectangle.create;
begin
 fx:= 50;
 fy:= 50;
 fHeight:= 40;
 fWidth:= 50;
 fFarbe:= clWhite;
 fText:= '';
end;

procedure TRectangle.set_HInt (value: Integer);
begin
 fHeight:= value;
 paint;
end;

procedure TRectangle.p_Rectangle;
var zen_x, zen_y: integer;
begin
 with fImage.Canvas do
 begin
  Pen.Width:= 1;
  Brush.Color:= ffarbe;
  Rectangle (fx,fy -(fHeight div 2),fx+fWidth,fy + (fHeight div 2));
 end;

 if fText <> '' then
 begin
  zen_x:= ((fWidth div 2) + fx) - (fImage.Canvas.Textwidth (fText) div 2);
  zen_y:= fy - (fImage.Canvas.Textheight (fText) div 2);
  fImage.Canvas.Textout (zen_x, zen_y, fText);
 end;
end;

procedure TRectangle.paint (px,py,pWidth,pHeight: integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if width <> pWidth then
  fWidth:= pWidth;
 if height <> pHeight then
  fHeight:= pHeight;
 if image <> pImage then
  fImage:= pImage;
p_Rectangle;
end;

procedure TRectangle.paint (pImage: TImage);
begin
 if image <> pImage then
  fImage:= pImage;
p_Rectangle;
end;

procedure TRectangle.paint;
begin
Refresh_img (fImage);
p_Rectangle;
end;


{---------------------------------------------------------------}
{-----  Class TRRectangle  -------------------------------------}
{---------------------------------------------------------------}

constructor TRRectangle.create;
begin
 fx:= 50;
 fy:= 50;
 fHeight:= 35;
 fWidth:= 70;
 fFarbe:= clWhite;
 fText:= '';
 fRundung:= 35;
end;

procedure TRRectangle.set_card (value: cardinal);
begin
 fRundung:= value;
 paint;
end;

procedure TRRectangle.p_RRectangle;
var zen_x, zen_y: integer;
begin
 with fImage.Canvas do
 begin
  Pen.Width:= 1;
  Brush.Color:= fFarbe;
  RoundRect (fx,fy-(fHeight div 2),fx+fWidth,fy + (fHeight div 2),fRundung,fRundung);
 end;

 if fText <> '' then
 begin
  zen_x:= ((fWidth div 2) + fx) - (fImage.Canvas.Textwidth (fText) div 2);
  zen_y:= fy - (fImage.Canvas.Textheight (ftext) div 2);
  fImage.Canvas.Textout (zen_x, zen_y, fText);
 end;
end;

procedure TRRectangle.paint;
begin
Refresh_img (fImage);
p_RRectangle;
end;

procedure TRRectangle.paint (pImage: TImage);
begin
 if image <> pImage then
  fImage:= pImage;
p_RRectangle;
end;

procedure TRRectangle.paint (px,py,pWidth,pHeight: Integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if width <> pWidth then
  fWidth:= pWidth;
 if height <> pHeight then
  fHeight:= pHeight;
 if image <> pImage then
  fImage:= pImage;
p_RRectangle;
end;


{---------------------------------------------------------------}
{-----  Class TLine  -------------------------------------------}
{---------------------------------------------------------------}

constructor TLine.create;
begin
 fx:= 10;
 fy:= 10;
 fWidth:= 20;
 fHeight:= 0;
 fFarbe:= clBlack;
end;

function TLine.get_int (index: integer): integer;
begin
 case index of
  0: result:= fx;
  1: result:= fy;
  2: result:= fWidth;
  3: result:= fHeight;
 else result:= 0;
 end;
end;

procedure TLine.set_int (index: integer; value: integer);
begin
 case index of
  0: fx:= value;
  1: fy:= value;
  2: fWidth:= value;
  3: fHeight:= value;
 else ;
 end;
paint;
end;

procedure TLine.set_col (value: TColor);
begin
 fFarbe:= value;
 paint;
end;

procedure TLine.set_img (value: TImage);
begin
 fImage:= value;
 paint;
end;

procedure TLine.p_Line;
begin
 with fImage.Canvas do
 begin
  Pen.Color:= fFarbe;
  MoveTo (fx,fy);
  LineTo (fx+fWidth,fy+fHeight);
  Pen.Color:= clblack;
 end;
end;

procedure TLine.paint;
begin
Refresh_Img (fImage);
p_Line;
end;

procedure TLine.paint (pImage: TImage);
begin
 if Image <> pImage then
  fImage:= pImage;
p_Line;
end;

procedure TLine.paint (px,py,pWidth,pHeight: Integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if width <> pWidth then
  fWidth:= pWidth;
 if height <> pHeight then
  fHeight:= pHeight;
 if image <> pImage then
  fImage:= pImage;
p_Line;
end;


{---------------------------------------------------------------}
{-----  Class TTriangle  ---------------------------------------}
{---------------------------------------------------------------}

constructor TTriangle.create;
begin
 fx:= 50;
 fy:= 50;
 fheight:= 40;
 fwidth:= 24;
 fcolor:= clred;
 frichtung:= rechts;
 fImage:= nil;
end;

function TTriangle.get_int (index: integer): integer;
begin
 case index of
  0: result:= fx;
  1: result:= fy;
  2: result:= fHeight;
  3: result:= fWidth;
 else result:= 0;
 end;
end;

procedure TTriangle.set_int (index: integer; value: integer);
begin
 case index of
  0: fx:= value;
  1: fy:= value;
  2: fHeight:= value;
  3: fWidth:= value;
 else ;
 end;
paint;
end;

procedure TTriangle.set_col (value: tcolor);
begin
 fcolor:= value;
 paint;
end;

procedure TTriangle.set_img (value: Timage);
begin
 fImage:= value;
 paint;
end;

procedure TTriangle.set_dir (value: TTriangle_Dir);
begin
 frichtung:= value;
 paint;
end;

procedure TTriangle.paint;
begin
Refresh_img (fImage);
p_Triangle;
end;

procedure TTriangle.paint (pImage: TImage);
begin
 if image <> pImage then
  fImage:= pImage;
p_Triangle;
end;

procedure TTriangle.paint (px,py: Integer);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
p_Triangle;
end;

procedure TTriangle.paint (px,py: Integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if image <> pImage then
  fImage:= pImage;
p_Triangle;
end;

procedure TTriangle.p_Triangle;
begin
 with fImage.Canvas do
 begin
  Pen.Width:= 1;
  Brush.Color:= fcolor;

  if (richtung = rechts) then
   Polygon ([Point(fx,fy+(fheight div 2)), Point(fx,fy-(fheight div 2)), Point (fx+fwidth, fy)])
  else if (richtung = links) then
   Polygon ([Point(fx,fy+(fheight div 2)), Point(fx,fy-(fheight div 2)), Point (fx-fwidth, fy)]);
 end;
end;

{---------------------------------------------------------------}
{-----  General Procedures  ------------------------------------}
{---------------------------------------------------------------}

procedure Refresh_Img (image: Timage);
var Bitmap : TBitmap;
begin
  begin
    with Image do
     Bitmap := nil;
      try
        Bitmap:= TBitmap.Create;
        Bitmap.Width := image.width;
        Bitmap.Height := image.height;
        Image.Picture.Graphic := Bitmap;
      finally
        Bitmap.Free;
     end;
  end;
end;

end.

Die Unit hab ich ursprünglich für zwei andere Programme geschrieben. Daher ist das ein oder andere auf jene Programme angepasst.

MfG

Jack Falworth

Moderiert von Udontknow: Code- durch Delphi-Tags ersetzt.

_________________
Andere zu kritisieren ist mitunter eine Möglichkeit, sich selbst ins bessere Licht zu setzen.

PhilGo · Beiträge: 315 Win 98, Win Longhorn ;-)

Echt net schlecht!

_________________
Sie werden dich finden und töten... Söhne der großen Bärin!

Lhid · Beiträge: 831

Meinung und mich grundlegend geändert-> alte beiträge gelöscht

Jack Falworth · Verfasst: Do 16.09.04 23:32

@Lhid: Was ist das genau (omoprhia)? Normalerweise hätte ich nichts dagegen, wenn die Unit verbreitet oder weiterverwendet wird. Dafür hab ich sie ja hier reingestellt

_________________
Andere zu kritisieren ist mitunter eine Möglichkeit, sich selbst ins bessere Licht zu setzen.

BenBE · Verfasst: Fr 17.09.04 11:33

Omorphia ist ein Projekt zur ERstellung von Multimedia- und Spiele-Anwendungen unabhängig von der Grafik-Schnittstelle (d.h. Unabhängig von DX oder OGL), je nach Verfügbarkeit dieser.

Näheres unter
www.de-schneider.de/omorphia/
sowie
sf.net/projects/omorphia/

_________________

Anyone who is capable of being elected president should on no account be allowed to do the job.
Ich code EdgeMonkey - In dubio pro Setting.

Jack Falworth · Verfasst: Fr 17.09.04 13:02

Jo von mir aus könnt ihr die Unit benutzen.

Achja zur Page: Ich finde das Negativ der Tussi etwas gewöhnungsbedürftig und der HTML Code ist einfach nur grausam. Da fehlen wichtige Sachen und man sollte fürs Layout keine Tables mehr benutzen. Aber das nur so am Rande.

_________________
Andere zu kritisieren ist mitunter eine Möglichkeit, sich selbst ins bessere Licht zu setzen.

G'Kar · Hält's aus hier Beiträge: 2

Hi !

Zwei Fragen!

Im IMPLEMENTATION-Teil (Zeile 173 --> uses unit1; & Zeile 507 --> fImage:= form1.image1;) können wohl gelöscht werden? ODER?

MFG G'Kar

BenBE · Verfasst: Fr 21.01.05 14:13

Jip, kann weg ...
In Zeile 507 aber durch NIL esetzen!

_________________

Anyone who is capable of being elected president should on no account be allowed to do the job.
Ich code EdgeMonkey - In dubio pro Setting.

Jack Falworth · Verfasst: Fr 21.01.05 18:48

Jo das kann weg. Muss ich wohl übersehen haben.
Habs editiert.

MfG

Jack Falworth

_________________
Andere zu kritisieren ist mitunter eine Möglichkeit, sich selbst ins bessere Licht zu setzen.

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme