关于拉幕程序的讨论和源码
程序把一个文本文件在屏幕上缓慢输出,完全输出后再从头循环输出
修改后可以使用的程序源代码（还是不完善：还不能实现从一侧飞入的效果，容易出错）：
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ComCtrls, ColorGrd, RxCombos;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
OpenDialog1: TOpenDialog;
Button2: TButton;
Button3: TButton;
TrackBar1: TTrackBar;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Label1: TLabel;
Label2: TLabel;
Timer1: TTimer;
Button4: TButton;
ColorDialog1: TColorDialog;
FontDialog1: TFontDialog;
Button6: TButton;
Button7: TButton;
ComboBox1: TComboBox;
Panel4: TPanel;
Edit2: TEdit;
Edit3: TEdit;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Edit4: TEdit;
Edit5: TEdit;
Button8: TButton;
Button5: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button7Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
procedure Button8Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
private
procedure zShowText;
Procedure zBmpCreate;
procedure zSetBmp;
procedure zSetLineHeight;
procedure zShowLine(sender :TObject);
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
bWidth=200;
var
currline, LineHeight:integer;
sItem:TStringList;
bmp:TBitMap;
bRect,R1:TRect;
iDc:HDC;
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenDialog1.Execute;
Edit1.Text:=OpenDialog1.FileName;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.WindowState:=wsMaximized;
Panel1.Top:=80;
Panel1.Left:=96;
Panel1.Height:=385;
Panel1.Width:=433;
Timer1.Enabled:=False;
Label2.Caption:='100';
iDC:=GetDc(Panel1.handle);
Currline:=0;
end;
procedure TForm1.zShowLine(sender :TObject);
begin
zShowText;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
zShowLine(self);//显示字符串
//bitblt 转移矩形图 (目标句柄，LS x,y,宽，高，源句柄，LS x,y,光栅运算符）
BitBlt(iDc,0,0,Panel1.Width,Panel1.Height,
Bmp.Canvas.Handle,0,Currline,srcCopy);
Inc(Currline,1);
if Currline>=bRect.Bottom-panel1.Height+100 then//循环条件？
begin
Timer1.Enabled:=False;
Currline:=0;
end;
end;
procedure TForm1.zShowText;
var
i:integer;
ss:string;
ReadFile:TextFile;
begin
AssignFile(ReadFile,Edit1.Text);
Reset(ReadFile);
i:=1;
sItem:=TStringList.Create;
with sItem do
while not eof(ReadFile) do
begin
Readln(ReadFile,ss);
add(ss);
i:=i+1;
end;
CloseFile(ReadFile);
zBmpCreate;
sItem.Free;//释放串
end;
procedure TForm1.zBmpCreate; //创建图片
var
i,y:integer; //y
begin
if bmp<>nil then bmp.free;
bmp:=TBitMap.Create;
zSetBmp;
R1.Right:=bRect.Right;
R1.Bottom:=bRect.Bottom;
y:=Panel1.Height-100;
for i:=0 to sItem.Count-1 do // 从0到行数 循环显示图片
begin
R1.Top:=y;
R1.Bottom:=R1.Top+LineHeight;
if Combobox1.Text='中间对齐' then //显示图片
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_Center or Dt_Top)
else
if Combobox1.Text='左对齐' then
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_Left or Dt_Top)
else
if Combobox1.Text='右对齐'then
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_Right or Dt_Top)
else
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_Center or Dt_Top);
Inc(y,LineHeight);
end;
end;
procedure TForm1.zSetBmp;
begin
zSetLineHeight;
with bRect do //Rect 矩形坐标(左上x,左下y,右上x,右下y)
begin
Top:=0;
Left:=0;
Right:=Panel1.Width;
Bottom:=LineHeight*sItem.Count+Height;//行高*行数+form高度
end;
with Bmp do
begin
Height:=bRect.Bottom+100;//图片高度
Width:=bRect.Right;
with Canvas do //canvas 画布
begin
Font:=FontDialog1.Font;
//Font:=self.Font;//form所设置的字体
Brush.Color:=ColorDialog1.Color;
FillRect(bRect);
Brush.Style:=bsClear;
end;
end;
end;
procedure TForm1.zSetLineHeight;
{设置行间隔}
var
Metrics:TTextMetric; //设置字体 API
begin
GetTextMetrics(iDc,Metrics);
LineHeight:=Metrics.tmHeight+Metrics.tmInternalLeading-Bmp.Canvas.Font.Height;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if Edit1.Text='' then ShowMessage('请输入文件地址')
else
begin
if Button2.Caption='开始' then Button2.Caption:='暂停'
else Button2.Caption:='开始';
Timer1.Enabled:=not Timer1.Enabled;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
timer1.Enabled :=false;
Currline:=0;
Button2.Click;
Button2.Caption:='暂停';
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
Timer1.Interval:=TrackBar1.Position*5;
Label2.Caption:=inttostr(Timer1.Interval);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Bmp<>nil then Bmp.Free;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
close;
end;
procedure TForm1.Button7Click(Sender: TObject);
begin
FontDialog1.Execute;
end;
procedure TForm1.Button6Click(Sender: TObject);
begin
ColorDialog1.Execute;
end;
procedure TForm1.Button8Click(Sender: TObject);
begin
if ((strtoint(Edit2.Text)>=600) or (strtoint(Edit3.text)>=500) or ((strtoint(Edit5.Text)>=553) or (strtoint(Edit4.Text)>=630)))
then showmessage('范围超界')
else
begin
Panel1.Top:=strtoint(Edit2.text);
Panel1.Left:=strtoint(Edit3.text);
Panel1.Width:=strtoint(Edit4.text);
Panel1.Height:=strtoint(Edit5.text);
end;
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
Panel1.Top:=0;
Panel1.Left:=0;
Panel1.Width:=Panel3.Width;
Panel1.Height:=Panel3.Height;
end;
end.
详细讨论在：http://www.csdn.net/expert/topic/97/97371.shtm