如何实现与电视字幕广告一样的从左至右平滑移动效果？

Question

我写了一个完整的平滑滚屏示例程序，现在贴上来给你。//main.pasunit main;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;
type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;var
  Form1: TForm1;
  Y:integer;
implementation{$R *.DFM}procedure TForm1.FormCreate(Sender: TObject);
begin
    y:=paintbox1.Height;
end;procedure TForm1.Timer1Timer(Sender: TObject);
begin
  PaintBox1.Canvas.Font.Color := clBlue;
  PaintBox1.Canvas.TextOut(50,y,'这是平滑滚屏示例');
  PaintBox1.Canvas.Font.Color := clBlack;
  PaintBox1.Canvas.TextOut(60,y+PaintBox1.Canvas.Font.Size+8,'效果还不错吧');
  dec(y);
  if y<-(PaintBox1.Canvas.Font.Size+8)*2 then y:=paintbox1.Height;
end;procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
    PaintBox1.Canvas.Font.Name:='宋体';
    PaintBox1.Canvas.Font.Size:=10;
    PaintBox1.Canvas.Brush.Color := clwhite;
    PaintBox1.Canvas.FillRect(Rect(0,0,PaintBox1.Width, PaintBox1.Height));
end;
end.
//main.dfm
object Form1: TForm1
  Left = 209
  Top = 142
  Width = 214
  Height = 202
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object PaintBox1: TPaintBox
    Left = 0
    Top = 0
    Width = 206
    Height = 175
    Align = alClient
    OnPaint = PaintBox1Paint
  end
  object Timer1: TTimer
    Interval = 50
    OnTimer = Timer1Timer
    Left = 152
    Top = 128
  end
end

Answer 1

很简单,用timer+label移动label的left就行了,要平滑,设置form.doublebuffer:=true;

Answer 2

但是闪烁感太强。有人用DirectX实现了这个问题？

Answer 3

form.doublebuffer:=true;设置以后就不闪烁了！！！

Answer 4

感谢VSaber(☆浪人☆)，加了Form1。doublebuffered：＝true确实不闪烁了，请问这是什么原因，Form1。doublebuffered：＝true的作用是什么？

Answer 5

Form1.Doublebuffered是Delphi6新增的功能，表示为Form1增加双缓冲，防止闪烁。

Answer 6

我这里有个控件带原码
*****************************
unit ALScrollingText;interfaceuses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;type
  TTextLayout = (tlTop, tlCenter, tlBottom);
  TTextDirection = (tdLeftToRight, tdRightToLeft);  TALScrollingText = class(TGraphicControl)
  private
    fText: String;
    Timer: TTimer;
    fSpeed: Integer;
    fBackgroundColor: TColor;
    BackBitmap: TBitmap;
    DrawnBitmap: TBitmap;
    WholeBitmap: TBitmap;
    Position: Integer;
    fEdgeFade: Boolean;
    fEdgeFadeWidth: Integer;
    fLayout: TTextLayout;
    fTextDirection: TTextDirection;
    fPixelJump: Integer;
    procedure SetText(const Value: String);
    procedure SetSpeed(const Value: Integer);
    procedure OnTimer(Sender: TObject);
    procedure SetBackgroundColor(const Value: TColor);
    procedure CMFontChanged(var Msg: TMessage); message CM_FontChanged;
    procedure InvalidateEverything;
    procedure SetEdgeFadeWidth(const Value: Integer);
    function CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
    procedure SetLayout(const Value: TTextLayout);
    procedure SetTextDirection(const Value: TTextDirection);
  protected
    procedure Paint; override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Resize; override;
  published
    property Text: String                   read fText              write SetText;
    property Speed: Integer                 read fSpeed             write SetSpeed              default 50;
    property BackgroundColor: TColor        read fBackgroundColor   write SetBackgroundColor    default clBtnFace;
    property EdgeFadeWidth: Integer         read fEdgeFadeWidth     write SetEdgeFadeWidth      default 15;
    property Layout: TTextLayout            read fLayout            write SetLayout             default tlCenter;
    property TextDirection: TTextDirection  read fTextDirection     write SetTextDirection      default tdLeftToRight;
    property PixelJump: Integer             read fPixelJump         write fPixelJump            default 1;
    property Font;
    property Enabled;
    property ParentFont;
    property Visible;
    property OnMouseDown;
    property OnMouseUp;
    property OnClick;
  end;procedure Register;implementationprocedure Register;
begin
  RegisterComponents('ChoiceSoft', [TALScrollingText]);
end;{ TALScrollingText }constructor TALScrollingText.Create(AOwner: TComponent);
begin
  inherited;  BackBitmap := TBitmap.Create;
  DrawnBitmap := tBitmap.Create;
  WholeBitmap := TBitmap.Create;
  WholeBitmap.Transparent := True;  Timer := TTimer.Create(nil);
  Timer.OnTimer := OnTimer;  Width := 50;
  Height := 18;  ParentFont := True;  fText := 'Text';
  Speed := 50;
  fEdgeFade := True;
  fEdgeFadeWidth := 15;
  fBackgroundColor := clBtnFace;
  fLayout := tlCenter;
  fTextDirection := tdLeftToRight;
  fPixelJump := 1;
  Position := -Width;
  Font.Color := clWindowText;
end;destructor TALScrollingText.Destroy;
begin
  Timer.Free;
  BackBitmap.Free;
  DrawnBitmap.Free;
  WholeBitmap.Free;  inherited;
end;procedure TALScrollingText.Loaded;
begin
  inherited;  InvalidateEverything;
  if fTextDirection = tdLeftToRight then
    Position := -(WholeBitmap.Width - Width)
  else
    Position := 0;
end;procedure TALScrollingText.OnTimer(Sender: TObject);
begin
  if Enabled then
  begin
    if fTextDirection = tdLeftToRight then
    begin
      Inc(Position, fPixelJump);
      if Position >= 0 then
        Position := -WholeBitmap.Width + Width;
    end
    else
    begin
      Dec(Position, fPixelJump);
      if Position <= -(WholeBitmap.Width - Width) then
        Position := 0;
    end;
  end;
  Paint;
end;procedure TALScrollingText.Paint;
begin
  inherited;  BitBlt(DrawnBitmap.Canvas.Handle, 0, 0, Width, Height, BackBitmap.Canvas.Handle, 0, 0, SrcCopy);
  DrawnBitmap.Canvas.Draw(Position, 0, WholeBitmap);  BitBlt(Canvas.Handle, 0, 0, Width, Height, DrawnBitmap.Canvas.Handle, 0, 0, SrcCopy);
end;procedure TALScrollingText.InvalidateEverything;
var
  i: Integer;
begin
  with WholeBitmap do
  begin
    Canvas.Brush.Color := fBackgroundColor;
    Canvas.FillRect(Rect(0, 0, Width, Height));
    Canvas.Font := Self.Font;
    Width := WholeBitmap.Canvas.TextWidth(fText) + (2 * Self.Width);
    Height := Self.Height;
    if (Self.Font.Color = clGreen) or (fBackgroundColor = clGreen) then
    begin
      TransparentColor := clRed;
      Canvas.Font.Color := clRed;
    end
    else
    begin
      TransparentColor := clGreen;
      Canvas.Font.Color := clGreen;
    end;
    if fLayout = tlTop then
      Canvas.TextOut(Self.Width, 0, fText)
    else if fLayout = tlCenter then
      Canvas.TextOut(Self.Width, (Self.Height div 2) - (Canvas.TextHeight(fText) div 2), fText)
    else
      Canvas.TextOut(Self.Width, Self.Height - Canvas.TextHeight(fText), fText);
  end;  with BackBitmap do
  begin
    Width := Self.Width;
    Height := Self.Height;
    Canvas.Brush.Color := Self.Font.Color;
    Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));
    if fEdgeFadeWidth > 0 then
    begin
      for i := 0 to fEdgeFadeWidth-1 do
      begin
        Canvas.Pen.Color := CalcColorIndex(fBackgroundColor, Self.Font.Color, fEdgeFadeWidth, i+1);
        Canvas.MoveTo(i, 0);
        Canvas.LineTo(i, Self.Height);
        Canvas.MoveTo(Width-i-1, 0);
        Canvas.LineTo(Width-i-1, Self.Height);
      end;
    end;
  end;  DrawnBitmap.Width := Width;
  DrawnBitmap.Height := Height;
end;procedure TALScrollingText.CMFontChanged(var Msg: TMessage);
begin
  inherited;  InvalidateEverything;
  Msg.Result := 1;
end;procedure TALScrollingText.Resize;
begin
  inherited;  InvalidateEverything;
end;procedure TALScrollingText.SetBackgroundColor(const Value: TColor);
begin
  if fBackgroundColor <> Value then
  begin
    fBackgroundColor := Value;
    InvalidateEverything;
  end;
end;procedure TALScrollingText.SetSpeed(const Value: Integer);
begin
  if fSpeed <> Value then
  begin
    fSpeed := Value;
    Timer.Interval := Value;
  end;
end;procedure TALScrollingText.SetText(const Value: String);
begin
  if fText <> Value then
  begin
    fText := Value;
    InvalidateEverything;
  end;
end;procedure TALScrollingText.SetEdgeFadeWidth(const Value: Integer);
begin
  if fEdgeFadeWidth <> Value then
  begin
    fEdgeFadeWidth := Value;
    InvalidateEverything;
  end;
end;procedure TALScrollingText.SetLayout(const Value: TTextLayout);
begin
  if fLayout <> Value then
  begin
    fLayout := Value;
    InvalidateEverything;
  end;
end;procedure TALScrollingText.SetTextDirection(const Value: TTextDirection);
begin
  if fTextDirection <> Value then
  begin
    fTextDirection := Value;
    if Value = tdLeftToRight then
      Position := -(WholeBitmap.Width - Width)
    else
      Position := 0;
    InvalidateEverything;
  end;
end;function TALScrollingText.CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
var
  BeginRGBValue: Array[0..2] of Byte;
  RGBDifference: Array[0..2] of Integer;
  Red, Green, Blue: Byte;
  NumColors: Integer;
begin
  if (ColorIndex < 1) or (ColorIndex > Steps) then
    raise ERangeError.Create('ColorIndex can''t be less than 1 or greater than ' + IntToStr(Steps));
  NumColors := Steps;
  Dec(ColorIndex);
  BeginRGBValue[0] := GetRValue(ColorToRGB(StartColor));
  BeginRGBValue[1] := GetGValue(ColorToRGB(StartColor));
  BeginRGBValue[2] := GetBValue(ColorToRGB(StartColor));
  RGBDifference[0] := GetRValue(ColorToRGB(EndColor)) - BeginRGBValue[0];
  RGBDifference[1] := GetGValue(ColorToRGB(EndColor)) - BeginRGBValue[1];
  RGBDifference[2] := GetBValue(ColorToRGB(EndColor)) - BeginRGBValue[2];  // Calculate the bands color
  Red := BeginRGBValue[0] + MulDiv(ColorIndex, RGBDifference[0], NumColors - 1);
  Green := BeginRGBValue[1] + MulDiv(ColorIndex, RGBDifference[1], NumColors - 1);
  Blue := BeginRGBValue[2] + MulDiv(ColorIndex, RGBDifference[2], NumColors - 1);
  Result := RGB(Red, Green, Blue);
end;end.

Answer 7

何必这么费径， 下载一个lmd for d6的控件， 里面有个你需要的控件

Answer 8

faint,有没有搞错为，MS出了Directx的函数，就可以直接产生这样的效果，sigh,我忘了什么函数，以前在这个论坛中见过。搜一下吧。
不要说从左到右，就是反过来也有，还有....