[volod3000]

Здравствуйте !
Хочу освоить Двойную буферизацию, но что то не получаеться,
не могу понять в чем проблема.

Ниже представлен код программы, подскажите где ошибка ?

Код:

....

var
  Form1: TForm1;
  sam, buf:TBitmap;
  BufRct: TRect;
  x, y, TW: Integer;
  w, h: Integer;
  s: String;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
    s:= 'Это большой пример для маленькой компании.';

    sam:= TBitmap.Create;
    buf:= TBitmap.Create;

   sam.Width:=  ClientWidth;
   sam.Height:= (ClientHeight - sam.Canvas.TextHeight(s)) div 2;

   w:= sam.Width;
   h:= sam.Height;

   buf.Width:= w;
   buf.Height:=h;

   x:= ClientWidth;
   y:= 0;
   X := X - 100;
   sam.Canvas.Font.Color:= clRed;
   sam.Canvas.Font.Name := 'Georgia';
   sam.Canvas.Font.Size := 15;
   sam.Canvas.Font.Style:= [fsBold];
   sam.Transparent:= True;
   TW := sam.Canvas.TextWidth(s);

   sam.Canvas.TextOut(x,y,s);

   BufRct := Bounds(round(x + sin(1)), y, w, h);
   Buf.Canvas.CopyRect(Buf.Canvas.ClipRect,Form1.Canvas,BufRct);

   Form1.Canvas.Draw(0,20,sam);

   Timer1.Enabled:= True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Form1.Canvas.Draw(0,20,sam);

X := X - 1;
If X <= -TW  then
X := ClientWidth;

 BufRct := Bounds(x + 1, y, w, h);
 Buf.Canvas.CopyRect(Buf.Canvas.ClipRect,Form1.Canvas,BufRct);
 sam.Canvas.TextOut(x,y,s);
 Form1.Canvas.Draw(0,20,sam);
end;

end.

Программа выводит бегущую строку на форму, при sam.Transparent:= True
она размазана, при sam.Transparent:= False идет нормально.
Конечно можно подобрать цвет sam.Canvas.Brush.Color:= clBtnFace , но
это на простом фоне, а если сложный фон (картинка).Подскажите где ошибка и
как ее исправить.

[san-46]

Пример, когда "бегущая" строка не затирает фон формы, кокой бы он ни был (однородный, рисованный или картинка).

Код:

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;

Код выполняется с небольшими огрехами, которые, при желании, не сложно задавить.

[volod3000]

Спасибо san-46.
Буду разбираться, но вроде ни чего сложного.