Пример, когда "бегущая" строка не затирает фон формы, кокой бы он ни был (однородный, рисованный или картинка).
Код:
procedure TForm1.FormCreate(Sender: TObject);
begin
s := 'Это большой пример для маленькой компании.';
sam := TBitmap.Create;
buf := TBitmap.Create;
x := ClientWidth;
y := 60;
sam.Canvas.Font.Color := clRed;
sam.Canvas.Font.Name := 'Arial';
sam.Canvas.Font.Size := 15;
sam.Canvas.Font.Style := [fsBold];
sam.Width := sam.Canvas.TextWidth(s);
sam.Height := sam.Canvas.TextHeight('Wg');
buf.Assign(sam); //bmp для сохранения фона, по которому топает строка
BufRct := Rect(X, Y, sam.Width+X, Y + sam.Height);
//вначале спасаем кусок фона, на котором еще нет бегущей строки
//это лучше делать не здесь, а уже после создания формы и ее полной прорисовки
buf.Canvas.CopyRect(Rect(0, 0, sam.Width, sam.Height), Canvas, BufRct);
TW := sam.Canvas.TextWidth(s);
Timer1.Enabled:= True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
SetBkMode(sam.Canvas.Handle, TRANSPARENT);
SetBkMode(buf.Canvas.Handle, TRANSPARENT);
//прежний прямоугольник
BufRct := Rect(X, Y, sam.Width+X, Y + sam.Height);
//востановление фона из buf на форме и на "sam" (очистка)
Canvas.CopyRect(BufRct, buf.Canvas, Rect(0, 0, sam.Width, sam.Height));
sam.Canvas.CopyRect(Rect(0, 0, sam.Width, sam.Height), buf.Canvas,
Rect(0, 0, sam.Width, sam.Height));
X := X - 1;
If X <= -TW then
X := ClientWidth;
//новый прямоугольник после изменения координат
BufRct := Rect(X, Y, sam.Width+X, Y + sam.Height);
//сохраняем фон
buf.Canvas.CopyRect(Rect(0, 0, sam.Width, sam.Height), Canvas, BufRct);
//пишем текст в bmp
sam.Canvas.TextOut(0, 0, s);
//выводим на форму
Canvas.CopyRect(BufRct, sam.Canvas, Rect(0, 0, sam.Width, sam.Height));
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
sam.Free; buf.Free
end;
Код выполняется с небольшими огрехами, которые, при желании, не сложно задавить.
__________________
Не забывайте делать резервные копии
|