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

[yeyuzy]

如何实现与电视字幕广告一样的从左至右平滑移动效果？
具体说就是能够在显示屏的下方（和任务栏平齐的地方）生成一个水平的字母广告条，可以从左至右平滑移动显示广告文本，最好不要闪烁。
如果是使用Directx，能介绍一下如何实现？

[ZengXi]

textout

[dengzhen]

我写了一个完整的平滑滚屏示例程序，现在贴上来给你。

//main.pas

unit 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

[VSaber]

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

[yeyuzy]

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

[dana]

用flash太容易了。

[yeyuzy]

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

[VSaber]

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

[dengzhen]

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

[FatBoy]

我这里有个控件带原码
*****************************
unit ALScrollingText;

interface

uses
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;

implementation

procedure 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.

[綏子]

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

[lubing317]

h

[afeisky]

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