Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
A Component that plots graphs Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
18-Oct-03
Category
VCL-General
Language
Delphi 3.x
Views
145
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			 Author: Vimil Saju

A component for creating graphs

Answer:

Here is a component that draws graphs. You can zoom in and out of the graph. The 
code is shown below. Copy the code to .pas file and install the component. I will 
add a demo to show how to use this component soon. 

1   unit UGraph;
2   
3   interface
4   
5   uses
6     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math;
7   
8   type
9     TOnMouseMove = procedure(Shift: TShiftState; x, y: integer) of object;
10    TOnMouseDown = procedure(Button: TMouseButton; Shift: TShiftState; x, y: integer) 
11  of
12      object;
13    TOnMouseUp = procedure(Button: TMouseButton; Shift: TShiftState; x, y: integer) of
14      object;
15  
16    TState = (fplotted, fjoined);
17    TGraph = class;
18    TPlots = class;
19  
20    TPoints = class(Tlist)
21    private
22      fplots: TPlots;
23      fptcolor, fcrvcolor: TColor;
24      fstate: set of Tstate;
25      procedure fPlot;
26      procedure fJoin;
27    protected
28      function Get(index: integer): PPoint;
29    public
30      procedure Plot;
31      procedure Join;
32      constructor Create(aplots: TPlots);
33      function Add(x, y: integer): PPoint;
34      procedure HideDots;
35      procedure HideJoins;
36      procedure Clear; override;
37      property CurveColor: Tcolor read fcrvcolor write fcrvColor;
38      property DotColor: Tcolor read fptcolor write fptColor;
39      property Items[index: integer]: PPoint read Get; default;
40    end;
41  
42    TPlots = class(Tlist)
43    private
44      fgraph: TGraph;
45    protected
46      function Get(index: integer): TPoints;
47    public
48      constructor Create(agraph: TGraph);
49      function Add: TPoints;
50      procedure Clear; override;
51      procedure PlotAllDots;
52      procedure PlotAllJoins;
53      procedure HideAllDots;
54      procedure HideAllJoins;
55      property Items[index: integer]: TPoints read Get; default;
56    end;
57  
58    TGraph = class(TGraphicControl)
59    private
60      faxcolor, fbkcolor, fgridcolor: Tcolor;
61      fMouseDown: TOnMouseDown;
62      fMouseMove: TOnMouseMove;
63      fMouseUp: TOnMouseUp;
64      fspc: extended;
65      ldiv, sdiv: integer;
66      xaxis, yaxis: integer;
67      xlc, ylc: integer;
68      fmag: integer;
69      fplots: TPlots;
70      function Translate(x, y: integer): Tpoint;
71      function GetScale: Extended;
72      procedure DrawGrid;
73      procedure DrawAxes;
74      procedure GetXLineRect(y: integer; var arect: trect);
75      procedure GetYLineRect(x: integer; var arect: trect);
76      procedure SetGridColor(acolor: Tcolor);
77      procedure SetBackColor(acolor: Tcolor);
78      procedure SetAxisColor(acolor: TColor);
79    protected
80      procedure loaded; override;
81      procedure Paint; override;
82      {procedure MsgHandler(var msg:TMessage);}
83      procedure MouseDown(Button: TMouseButton; shift: TShiftState; x, y: integer);
84        override;
85      procedure MouseMove(shift: TShiftState; x, y: integer); override;
86      procedure MouseUp(Button: TMouseButton; shift: TShiftState; x, y: integer);
87        override;
88    public
89      constructor Create(AComponent: TComponent); override;
90      destructor Destroy; override;
91      procedure OffSetAxes(x, y: integer);
92      procedure ResetAxes;
93      procedure Zoom(mag: integer);
94      property Plots: TPlots read fplots;
95    published
96      property OnMouseDown: TOnMouseDown read fMouseDown write fMouseDown;
97      property OnMouseMove: TOnMouseMove read fMouseMove write fMouseMove;
98      property OnMouseUp: TOnMouseUp read fMouseUp write fMouseUp;
99      property GridColor: Tcolor read fgridcolor write SetGridColor;
100     property BackColor: Tcolor read fbkcolor write SetBackColor;
101     property AxisColor: Tcolor read faxcolor write SetAxisColor;
102     property Scale: extended read GetScale;
103     property ZoomFactor: integer read fmag;
104   end;
105 
106 procedure register;
107 
108 implementation
109 
110 procedure TGraph.MouseDown(Button: TMouseButton; shift: TShiftState; x, y: integer);
111 var
112   tp: Tpoint;
113 begin
114   tp.x := x - left;
115   tp.y := y - top;
116   tp.x := trunc(tp.x / fspc - yaxis);
117   tp.y := trunc(xaxis - tp.y / fspc);
118   if (assigned(fMouseDown)) then
119     fMouseDown(button, shift, tp.x, tp.y);
120   inherited;
121 end;
122 
123 procedure TGraph.MouseMove(shift: TShiftState; x, y: integer);
124 var
125   tp: Tpoint;
126 begin
127   tp.x := x - left;
128   tp.y := y - top;
129   tp.x := trunc(tp.x / fspc - yaxis);
130   tp.y := trunc(xaxis - tp.y / fspc);
131   if (assigned(fMousemove)) then
132     fMousemove(shift, tp.x, tp.y);
133   inherited;
134 end;
135 
136 procedure TGraph.MouseUp(Button: TMouseButton; shift: TShiftState; x, y: integer);
137 var
138   tp: Tpoint;
139 begin
140   tp.x := x - left;
141   tp.y := y - top;
142   tp.x := trunc(tp.x / fspc - yaxis);
143   tp.y := trunc(xaxis - tp.y / fspc);
144   if (assigned(fMouseUp)) then
145     fMouseup(button, shift, tp.x, tp.y);
146   inherited;
147 end;
148 
149 constructor TPoints.Create(aplots: TPlots);
150 begin
151   if aplots = nil then
152     raise Exception.Create('Not a valid Graph object.');
153   fplots := aplots;
154 end;
155 
156 constructor TPlots.Create(agraph: Tgraph);
157 begin
158   if agraph = nil then
159     raise Exception.Create('Not a valid Graph object.');
160   fgraph := agraph;
161 end;
162 
163 procedure TPoints.HideDots;
164 begin
165   fstate := fstate - [fplotted];
166 end;
167 
168 procedure TPoints.HideJoins;
169 begin
170   fstate := fstate - [fjoined];
171 end;
172 
173 procedure TPoints.Plot;
174 begin
175   fstate := fstate + [fplotted];
176   fplots.fgraph.invalidate;
177 end;
178 
179 procedure TPoints.fPlot;
180 var
181   i: integer;
182   tmp: tpoint;
183 begin
184   if count <= 0 then
185     exit;
186   with fplots.fgraph do
187   begin
188     canvas.pen.color := fptcolor;
189     canvas.pen.width := 1;
190     for i := 0 to count - 1 do
191     begin
192       tmp := Translate(items[i].x, items[i].y);
193       canvas.Ellipse(rect(tmp.x - 1, tmp.y - 1, tmp.x + 1, tmp.y + 1));
194     end;
195   end;
196 end;
197 
198 procedure TPoints.Join;
199 begin
200   fstate := fstate + [fjoined];
201   fplots.fgraph.invalidate;
202 end;
203 
204 procedure TPoints.fJoin;
205 var
206   i: integer;
207   tmp: tpoint;
208 begin
209   if count <= 0 then
210     exit;
211   with fplots.fgraph do
212   begin
213     canvas.pen.color := fcrvcolor;
214     canvas.pen.width := 1;
215     tmp := Translate(items[0].x, items[0].y);
216     canvas.moveto(tmp.x, tmp.y);
217     for i := 1 to count - 1 do
218     begin
219       tmp := Translate(items[i].x, items[i].y);
220       canvas.lineto(tmp.x, tmp.y);
221     end;
222   end;
223 end;
224 
225 procedure TPlots.PlotAllDots;
226 var
227   i: integer;
228 begin
229   for i := 0 to count - 1 do
230     items[i].Plot;
231 end;
232 
233 procedure TPlots.PlotAllJoins;
234 var
235   i: integer;
236 begin
237   for i := 0 to count - 1 do
238     items[i].join
239 end;
240 
241 procedure TPlots.HideAllDots;
242 var
243   i: integer;
244   inv: boolean;
245 begin
246   inv := false;
247   for i := 0 to count - 1 do
248     if (fplotted in items[i].fstate) then
249     begin
250       items[i].fstate := items[i].fstate - [fplotted];
251       inv := true;
252     end;
253   if inv then
254     fgraph.invalidate;
255 end;
256 
257 procedure TPlots.HideAllJoins;
258 var
259   i: integer;
260   inv: boolean;
261 begin
262   inv := false;
263   for i := 0 to count - 1 do
264     if (fjoined in items[i].fstate) then
265     begin
266       items[i].fstate := items[i].fstate - [fjoined];
267       inv := true;
268     end;
269   if inv then
270     fgraph.invalidate;
271 end;
272 
273 function TPlots.Get(index: integer): TPoints;
274 begin
275   result := TPoints(inherited Get(index));
276 end;
277 
278 function TPlots.Add: TPoints;
279 begin
280   result := TPoints.create(self);
281   inherited Add(result);
282 end;
283 
284 procedure TPlots.Clear;
285 var
286   i: integer;
287   tmp: Tpoints;
288 begin
289   for i := 0 to count - 1 do
290   begin
291     tmp := items[i];
292     freeandnil(tmp);
293   end;
294   inherited;
295 end;
296 
297 procedure TPoints.Clear;
298 var
299   i: integer;
300 begin
301   for i := 0 to count - 1 do
302     dispose(items[i]);
303   inherited;
304 end;
305 
306 function TPoints.Get(index: integer): PPoint;
307 begin
308   result := PPoint(inherited Get(index));
309 end;
310 
311 function TPoints.Add(x, y: integer): PPoint;
312 begin
313   new(result);
314   result.x := x;
315   result.y := y;
316   inherited Add(result);
317 end;
318 
319 function TGraph.GetScale: extended;
320 begin
321   if fspc result := sdiv / fspc
322 else
323   result := 1;
324 end;
325 
326 destructor TGraph.Destroy;
327 begin
328   freeandnil(fplots);
329   inherited;
330 end;
331 
332 constructor TGraph.Create(AComponent: TComponent);
333 begin
334   fplots := TPlots.create(self);
335   fmag := 100;
336   fbkcolor := clwhite;
337   faxcolor := clnavy;
338   fgridcolor := RGB(214, 244, 254);
339   ldiv := 10;
340   sdiv := 5;
341   fspc := 1;
342   inherited;
343 end;
344 
345 procedure TGraph.GetXLineRect(y: integer; var arect: trect);
346 begin
347   arect.left := left;
348   arect.right := arect.left + width;
349   arect.top := top + trunc(y * fspc);
350   arect.bottom := arect.top + 2;
351 end;
352 
353 procedure TGraph.GetYLineRect(x: integer; var arect: trect);
354 begin
355   arect.top := top;
356   arect.bottom := arect.top + height;
357   arect.left := left + trunc(x * fspc);
358   arect.right := arect.left + 2;
359 end;
360 
361 procedure TGraph.SetGridColor(acolor: Tcolor);
362 begin
363   fgridcolor := acolor;
364   Invalidate;
365 end;
366 
367 procedure TGraph.SetBackColor(acolor: Tcolor);
368 begin
369   fbkcolor := acolor;
370   Invalidate;
371 end;
372 
373 procedure TGraph.SetAxisColor(acolor: TColor);
374 begin
375   faxcolor := acolor;
376   Invalidate;
377 end;
378 
379 procedure TGraph.Zoom(mag: integer);
380 begin
381   if mag <= 0 then
382     mag := 1;
383   if mag > 100000 then
384     mag := 100000;
385   fspc := (mag / 20);
386   if fspc > 1 then
387     fspc := trunc(fspc);
388   fmag := mag;
389   xlc := Trunc(width / fspc);
390   ylc := Trunc(height / fspc);
391   xaxis := Trunc(ylc / 2);
392   yaxis := Trunc(xlc / 2);
393   Invalidate;
394 end;
395 
396 function TGraph.Translate(x, y: integer): Tpoint;
397 begin
398   result.x := trunc((x + yaxis) * fspc);
399   result.y := trunc((xaxis - y) * fspc);
400 end;
401 
402 procedure TGraph.loaded;
403 begin
404   Zoom(fmag);
405 end;
406 
407 procedure TGraph.ResetAxes;
408 begin
409   Zoom(fmag);
410 end;
411 
412 procedure TGraph.OffSetAxes(x, y: integer);
413 var
414   tmp: trect;
415   tmpx, tmpy: integer;
416 begin
417   canvas.Pen.color := faxcolor;
418   canvas.Pen.Width := 1;
419   tmpx := xaxis;
420   tmpy := yaxis;
421   xaxis := xaxis - y;
422   yaxis := yaxis + x;
423   if (tmpx = xaxis) and (tmpy = yaxis) then
424     exit;
425   GetXlineRect(tmpx, tmp);
426   InvalidateRect(parent.handle, @tmp, false);
427   GetYlineRect(tmpy, tmp);
428   InvalidateRect(parent.handle, @tmp, false);
429 
430   GetXlineRect(xaxis, tmp);
431   InvalidateRect(parent.handle, @tmp, false);
432   GetYlineRect(yaxis, tmp);
433   InvalidateRect(parent.handle, @tmp, false);
434 end;
435 
436 procedure TGraph.DrawAxes;
437 begin
438   canvas.Pen.color := faxcolor;
439   canvas.Pen.Width := 1;
440   canvas.MoveTo(0, trunc(fspc * xaxis));
441   canvas.lineto(width, trunc(fspc * xaxis));
442   canvas.MoveTo(trunc(fspc * yaxis), 0);
443   canvas.lineto(trunc(fspc * yaxis), height);
444 end;
445 
446 procedure TGraph.DrawGrid;
447 var
448   i, t: integer;
449   t1, t2: Tpoint;
450 begin
451   i := 0;
452   t := 0;
453   canvas.pen.color := fbkcolor;
454   canvas.Brush.color := fbkcolor;
455   canvas.rectangle(0, 0, width, height);
456   canvas.Pen.color := fgridcolor;
457   canvas.Pen.Width := 1;
458   while i <= width do
459   begin
460     if (t mod ldiv) = 0 then
461       canvas.pen.width := 2
462     else
463       canvas.pen.width := 1;
464     t1.x := i;
465     t1.y := 0;
466     canvas.moveto(t1.x, t1.y);
467     t2.x := i;
468     t2.y := height;
469     canvas.lineto(t2.x, t2.y);
470     i := i + max(trunc(fspc), sdiv);
471     t := t + 1;
472   end;
473   i := 0;
474   t := 0;
475   while i <= height do
476   begin
477     if (t mod ldiv) = 0 then
478       canvas.pen.width := 2
479     else
480       canvas.pen.width := 1;
481     t1.x := 0;
482     t1.y := i;
483     canvas.moveto(t1.x, t1.y);
484     t2.x := width;
485     t2.y := i;
486     canvas.lineto(t2.x, t2.y);
487     i := i + max(trunc(fspc), sdiv);
488     t := t + 1;
489   end;
490 end;
491 
492 procedure TGraph.Paint;
493 var
494   i: integer;
495 begin
496   DrawGrid;
497   for i := 0 to fplots.count - 1 do
498   begin
499     if (fplotted in fplots[i].fstate) then
500       fplots[i].fplot;
501     if fjoined in fplots[i].fstate then
502       fplots[i].fjoin;
503   end;
504   DrawAxes;
505 end;
506 
507 procedure register;
508 begin
509   RegisterComponents('My Components', [TGraph]);
510 end;
511 
512 end.


			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC