Author: Jorge Abel Ayala Marentes
If you need to Scroll Text like those led advertising things you can use this
component.
Answer:
1
2 //
3 // Scroll Text Component
4 // Author: Jorge Abel Ayala Marentes
5 // Created: 25/01/2001
6 //
7 unit ScrollText;
8
9 interface
10
11 uses
12 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
13 ExtCtrls;
14
15 type
16 TColorType = (ctGreen, ctRed, ctBlue);
17
18 TScrollText = class(TComponent)
19 private
20 FText: string;
21 FTimer: TTimer;
22 FTextColor: TColorType;
23 vi_Mv, vi_St: Integer;
24 procedure SetText(const Value: string);
25 procedure CustomOnTimer(Sender: TObject);
26 procedure SetTextColor(const Value: TColorType);
27 protected
28 public
29 procedure ScrollText;
30 constructor Create(AOwner: TComponent); override;
31 destructor Destroy; override;
32 published
33 property Text: string read FText write SetText;
34 property TextColor: TColorType read FTextColor write SetTextColor;
35 end;
36
37 procedure register;
38
39 implementation
40
41 procedure register;
42 begin
43 RegisterComponents('prueba', [TScrollText]);
44 end;
45
46 { TScrollText }
47
48 constructor TScrollText.Create(AOwner: TComponent);
49 begin
50 inherited;
51 vi_Mv := 0;
52 vi_St := 1;
53
54 FTimer := TTimer.Create(Self);
55 with FTimer do
56 begin
57 Enabled := True;
58 Interval := 5;
59 OnTimer := CustomOnTimer;
60 end;
61
62 if not (AOwner.InheritsFrom(TForm)) then
63 raise Exception.Create('This Component can only be dropped on Forms!');
64
65 //Set the Forms Height
66 with (Owner as TForm) do
67 begin
68 Height := 90;
69 Color := clBlack;
70 BorderStyle := bsDialog;
71 Caption := '';
72 end;
73
74 ScrollText;
75 end; //end of TScrollText.Create
76
77 procedure TScrollText.CustomOnTimer(Sender: TObject);
78 begin
79 ScrollText;
80
81 //Move text
82 Inc(vi_Mv, vi_St);
83 end; //end of TScrollText.CustomOnTimer
84
85 destructor TScrollText.Destroy;
86 begin
87 FTimer.Free;
88 inherited;
89 end; //end of TScrollText.Destroy
90
91 procedure TScrollText.ScrollText;
92 var
93 Bitmap: TBitmap;
94 Rect: TRect;
95 vi_Counter: Integer;
96 begin
97 if not (csDesigning in Self.ComponentState) then
98 begin
99 //Create a Bitmap to draw the text
100 Bitmap := TBitmap.Create;
101 try
102 //set Bitmapīs Height to equal the Messageīs Height
103 Bitmap.Height := Bitmap.Canvas.TextHeight(Text);
104
105 //If the text has reaced the end then rewind
106 if vi_Mv >= Bitmap.Canvas.Textwidth(Text) then
107 vi_St := -16;
108
109 //if its at the beginning, go forward
110 if vi_Mv <= 0 then
111 vi_St := 1;
112
113 //Set Bitmapīs Width
114 Bitmap.Width := (Owner as TForm).Width div 4;
115
116 with Bitmap.Canvas do
117 begin
118 //We are Filling it with Solid Dark Green
119 Brush.Style := bssolid;
120 //The colour goes BBGGRR in hex - look up TColor
121 case TextColor of
122 ctGreen:
123 begin
124 Brush.Color := $005000;
125 Fillrect(ClipRect);
126 Font.Color := $00FF00;
127 end;
128 ctRed:
129 begin
130 Brush.Color := $000050;
131 Fillrect(ClipRect);
132 Font.color := $0000FF;
133 end;
134 ctBlue:
135 begin
136 Brush.Color := $500000;
137 Fillrect(ClipRect);
138 Font.color := $FF0000;
139 end;
140 end;
141 Textout(-vi_Mv, 0, Text);
142 Rect := Cliprect;
143 //Enlarge the image to twice its original size
144 Bitmap.Height := Bitmap.Height * 2;
145 Bitmap.Width := Bitmap.Width * 2;
146
147 CopyRect(ClipRect, Bitmap.canvas, Rect);
148 //Set up pen for solid black
149 Pen.Style := pssolid;
150 Pen.Color := clblack;
151
152 //Draw a grid of lines across the bitmap in X+Y
153 for vi_Counter := 0 to Bitmap.Height div 2 do
154 begin
155 MoveTo(0, vi_Counter * 2);
156 LineTo(Bitmap.width, vi_Counter * 2);
157 end;
158
159 for vi_Counter := 0 to Bitmap.width div 2 do
160 begin
161 MoveTo(vi_Counter * 2, 0);
162 LineTo(vi_counter * 2, Bitmap.height);
163 end;
164
165 //Stretch bitmap again and draw twice its size on the form
166 Rect := Bitmap.Canvas.ClipRect;
167 Rect.Bottom := Rect.Bottom * 2;
168 Rect.Right := Rect.Right * 2;
169 (Owner as TForm).Canvas.StretchDraw(Rect, Bitmap);
170
171 end;
172 finally
173 Bitmap.Free;
174 end;
175 end;
176 end; //end of TScrollText.ScrollText
177
178 procedure TScrollText.SetText(const Value: string);
179 begin
180 if Value <> FText then
181 FText := Value;
182
183 ScrollText;
184 end; //end of TScrollText.SetText
185
186 procedure TScrollText.SetTextColor(const Value: TColorType);
187 begin
188 if FTextColor <> Value then
189 FTextColor := Value;
190 end; //end of TScrollText.SetTextColor
191
192 end.
|
