在线等待（300分）如何做到卡拉OK中字幕滚动效果(300分)

卡拉OK中字幕滚动大家都熟悉但我如何在Delphi编程中实现?

找找有没有相关控件吧。

rxlib中有一个控件，没问题。。

rxtools中的
scretpanel

我估计你需要的不是简单的文字滚动吧？
否则应该很简单的。
你是不是希望颜色能够变化什么的？
一个思路：先用一种颜色生成左边的bitmap，再用另一种颜色生成右边的bitmap,
然后把两个一起显示。具体做法再想想，呵呵...

用缓冲做

关注

找个好点的填充算法！

unit KLOKPas;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls;

const OneSecond=0.0000001;//常量
type
TForm1 = class(TForm)
Panel2: TPanel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
image1: TImage;
image2: TImage;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
SaveDisPlayStr:String;//保存显示文字
Rect0,Rect1:TRect;
{限定文字显示的矩形数据结构变量}
StopFlag:boolean;
{控制循环显示的逻辑变量}
procedure DisplayText(WayFlag:Integer;DisPlayStr:String);//显示文字
procedure Delay(ltime:longint);//延时
end;


var
Form1: TForm1;

implementation

{$R *.DFM}

//延时
procedure TForm1.Delay(ltime:longint);
var
ltimebegin
:double;
ltimelong:double;
begin

ltimebegin
:=time;
ltimelong:=OneSecond*ltime;
repeat
until (time-ltimebegin
)>ltimelong;
end;


//文字显示处理
procedure TForm1.DisplayText(WayFlag:Integer;DisPlayStr:String);
var
i:integer;
begin

{设置下层画笔}
Image1.Canvas.Brush.Color:=clWhite;
Image1.canvas.brush.style:=bsclear;
Image1.Canvas.Font.Size:=24;
Image1.Canvas.Font.Color:=clBlue;

{设置上层画笔}
Image2.Canvas.Brush.Color:=clWhite;
Image2.canvas.brush.style:=bsclear;
Image2.Canvas.Font.Size:=24;
Image2.Canvas.Font.Color:=clRed;

{限定下层显示区域}
Rect0:=Rect(0,0,Image2.width,Image2.Height);
Image1.Canvas.FillRect(Rect0);

case WayFlag of
0://清除显示
begin

Image1.Canvas.Font.Color:=clBtnFace;
Image2.Canvas.Font.Color:=clBtnFace;
Image1.Canvas.Textout(0,0,DisplayStr);{显示下层文字}
Image2.Canvas.Textout(0,0,DisplayStr);{显示上层文字}
end;

1,2://文字显示,1是“卡拉OK字幕”,2是“招牌文字”
begin

StopFlag:=True;
SaveDisPlayStr:=DisPlayStr;
{循环移动}
i:=-20;
repeat
if i=Image2.width then
i:=-20;
i:=i+1;
Delay(1);{延时一秒}
if WayFlag=1 then
//是“卡拉OK字幕”
Rect1:=Rect(0,0,i+10,Image2.Height){改变上层显示区域大小}
else
//是“招牌文字”
Rect1:=Rect(i+10,0,i+50,Image2.Height);{改变上层显示区域位置}

Image1.Canvas.Textout(0,0,DisplayStr);{显示下层文字}
Image2.Canvas.FillRect(Rect1);{限定上层显示区域}
Image2.Canvas.TextRect(Rect1,0,0,DisplayStr);{显示上层文字}
Application.ProcessMessages;{响应其他消息}
until StopFlag=False;
end;

end;

end;


//窗体创建时，初始化程序
procedure TForm1.FormCreate(Sender: TObject);
begin

StopFlag:=False;
Image1.Transparent := true;
Image2.Transparent := true;
end;


// 卡拉“OK”字幕
procedure TForm1.Button1Click(Sender: TObject);
begin

DisplayText(0,SaveDisPlayStr);
DisplayText(1,'卡拉OK字幕');
end;


//程序退出
procedure TForm1.Button4Click(Sender: TObject);
begin

StopFlag:=False;
Close;
end;


// 招牌文字
procedure TForm1.Button2Click(Sender: TObject);
begin

DisplayText(0,SaveDisPlayStr);
DisplayText(2,'招牌文字');
end;


//停止移动
procedure TForm1.Button3Click(Sender: TObject);
begin

StopFlag:=False;
end;


end.

form上方一个button和一个timer，以下是代码：unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;


var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Timer1Timer(Sender: TObject);
var
Bmp :TBitmap;
S :String;
i,Wid,Len :Integer;
begin

S :='卷起千堆雪';
Bmp :=TBitmap.Create;
SetBKMode(Bmp.Canvas.Handle,TRANSPARENT);

Bmp.Canvas.Font.Size :=72;
Bmp.Canvas.Font.Color :=RGB(Random(255),Random(255),Random(255));
Wid :=Trunc(Canvas.TextWidth(S)*9.5);

Len :=Canvas.TextHeight(S)*9;
Bmp.Width :=Wid;
Bmp.Height :=Len;
Bmp.Canvas.Brush.Color :=clBtnFace;

Bmp.Canvas.Rectangle(0,0,Bmp.Width,Bmp.Height);
Bmp.Canvas.TextOut(0,0,S);
for i :=0 to Wid-1do

begin


Canvas.CopyRect(Rect(0,0,i,Bmp.Height-1),Bmp.Canvas,Rect(1,0,i,Bmp.Height-1));
Sleep(10);

end;

Bmp.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin

timer1.Enabled:=true;
end;


end.

给分不均还请大家多见谅

请问zw84611:
我将你给我程序用了,可以实现,近来又在透明窗体上用您的程序,发现Image的灰色背景
我不能消除,并且闪屏我一直没有解决,真的不好意思打扰你,无这几天老板催得紧,还望兄
弟指点一下,我的程序如下:
unit Unit2;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;

const OneSecond=0.0000001;//常量

type
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
FullRgn, lblRgn: THandle;
SaveDisPlayStr:String;//保存显示文字
Rect0,Rect1:TRect;
{限定文字显示的矩形数据结构变量}
StopFlag:boolean;
{控制循环显示的逻辑变量}
procedure DisplayText(WayFlag:Integer;DisPlayStr:String);//显示文字
procedure Delay(ltime:longint);//延时
procedure SetTransparent;
end;


var
Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.Delay(ltime: Integer);
var
ltimebegin
:double;
ltimelong:double;
begin

ltimebegin
:=time;
ltimelong:=OneSecond*ltime;
repeat
until (time-ltimebegin
)>ltimelong;
end;


procedure TForm1.DisplayText(WayFlag: Integer;
DisPlayStr: String);
var
i:integer;
begin

{设置下层画笔}
Image1.Canvas.Brush.Color:=clBtnFace;
Image1.canvas.brush.style:=bsclear;
Image1.Canvas.Font.Size:=48;
Image1.Canvas.Font.Color:=clBlue;
// Image1.Canvas.Textout(0,0,DisplayStr);{显示下层文字}

{设置上层画笔}
Image2.Canvas.Brush.Color:=clWhite;
Image2.canvas.brush.style:=bsclear;
Image2.Canvas.Font.Size:=48;
Image2.Canvas.Font.Color:=clRed;

{限定下层显示区域}
Rect0:=Rect(0,0,Image2.width,Image2.Height);
Image1.Canvas.FillRect(Rect0);

case WayFlag of
0://清除显示
begin

Image1.Canvas.Font.Color:=clBtnFace;
Image2.Canvas.Font.Color:=clBtnFace;
Image1.Canvas.Textout(0,0,DisplayStr);{显示下层文字}
Image2.Canvas.Textout(0,0,DisplayStr);{显示上层文字}
end;

1,2://文字显示,1是“卡拉OK字幕”,2是“招牌文字”
begin

StopFlag:=True;
SaveDisPlayStr:=DisPlayStr;
Image1.Canvas.Textout(0,0,DisplayStr);
{循环移动}
i:=-20;
repeat
if i=Image2.width then
i:=-20;
i:=i+1;
Delay(10);{延时一秒}
if WayFlag=1 then
//是“卡拉OK字幕”
Rect1:=Rect(0,0,i+10,Image2.Height){改变上层显示区域大小}
else
//是“招牌文字”
Rect1:=Rect(i+10,0,i+50,Image2.Height);{改变上层显示区域位置}

// Image1.Canvas.Textout(0,0,DisplayStr);{显示下层文字}
Image2.Canvas.FillRect(Rect1);{限定上层显示区域}
Image2.Canvas.TextRect(Rect1,0,0,DisplayStr);{显示上层文字}
Application.ProcessMessages;{响应其他消息}
until StopFlag=False;
end;

end;

end;


procedure TForm1.FormCreate(Sender: TObject);
begin

StopFlag:=False;
Image1.Transparent := true;
Image2.Transparent := true;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin

SetTransparent;
DisplayText(0,SaveDisPlayStr);
DisplayText(1,'卡拉OK字幕');
end;


procedure TForm1.Button4Click(Sender: TObject);
begin

StopFlag:=False;
Close;
end;


procedure TForm1.Button2Click(Sender: TObject);
begin

DisplayText(0,SaveDisPlayStr);
DisplayText(2,'招牌文字');
end;


procedure TForm1.Button3Click(Sender: TObject);
begin

StopFlag:=False;
end;


procedure TForm1.SetTransparent;
var
I: Integer;
ClientRgn, ControlRgn: THandle;
Margin, MarginX, MarginY, X, Y: Integer;
W,H :Integer;
bX,bY :Integer;
c: TColor;
lbl: TLabel;
begin

Margin := (Width - ClientWidth) div 2;
FullRgn := CreateRectRgn(0, 0, Width, Height);
MarginX := Margin;
MarginY := Height - ClientHeight - Margin;
ClientRgn := CreateRectRgn(MarginX, MarginY, MarginX + ClientWidth, MarginY + ClientHeight);
CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF);
DeleteObject(ClientRgn);
for I:=0 to ControlCount-1do

begin

X := MarginX + Controls.Left;
Y := MarginY + Controls.Top;
W:=Controls.Width;
H:=Controls.Height;
if controls is TLabel then

begin

lbl := controls as TLabel
lblRgn := CreateRectRgn(lbl.Left, lbl.Top, lbl.Width, lbl.Height);
begin

for bX:=0 to lbl.Width-1do
begin

for bY:=0 to lbl.Height-1do
begin

c := lbl.Canvas.Pixels[bX,bY];
if c=16777215 then
begin

ControlRgn := CreateRectRgn(X+bX, Y+bY, X + bX+1, Y + bY+1);
CombineRgn(FullRgn, FullRgn, ControlRgn, RGN_OR);
// DeleteObject(ControlRgn);
end;

end;

end;

end;

end else
begin

ControlRgn := CreateRectRgn(X, Y, X + W, Y + H);
CombineRgn(FullRgn, FullRgn, ControlRgn, RGN_OR);
DeleteObject(ControlRgn);
end;

end;

SetWindowRgn(Handle, FullRgn, True);
DeleteObject(FullRgn);
end;


end.

关注！·

我有一整套的东东，自主版权，可以出售

UP

用一个比较老的办法，照葫芦画瓢，用SLEEP（）延时，后时间相等在出现字幕，不知
这个方法，是否可行？

我有字幕文件的播放源码有意者可与我联系wtong2000@163.net

up!