-- 作者：wangxinxin
-- 發布時間：2010-12-14 11:20:34
-- 關于拉幕程序的討論和源碼
修改后可以使用的程序源代碼（還是不完善：還不能實現從一側飛入的效果，輕易出錯）：
unitUnit1;
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;
procedureButton1Click(Sender:TObject);
procedureFormCreate(Sender:TObject);
procedureTimer1Timer(Sender:TObject);
procedureButton2Click(Sender:TObject);
procedureButton3Click(Sender:TObject);
procedureTrackBar1Change(Sender:TObject);
procedureFormDestroy(Sender:TObject);
procedureButton4Click(Sender:TObject);
procedureButton7Click(Sender:TObject);
procedureButton6Click(Sender:TObject);
procedureButton8Click(Sender:TObject);
procedureButton5Click(Sender:TObject);
private
procedurezShowText;
ProcedurezBmpCreate;
procedurezSetBmp;
procedurezSetLineHeight;
procedurezShowLine(sender:TObject);
{Privatedeclarations}
public
{Publicdeclarations}
end;
var
Form1:TForm1;
implementation
{$R*.DFM}
const
bWidth=200;
var
currline,LineHeight:integer;
sItem:TStringList;
bmp:TBitMap;
bRect,R1:TRect;
iDc:HDC;
procedureTForm1.Button1Click(Sender:TObject);
begin
OpenDialog1.Execute;
Edit1.Text:=OpenDialog1.FileName;
end;
procedureTForm1.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;
procedureTForm1.zShowLine(sender:TObject);
begin
zShowText;
end;
procedureTForm1.Timer1Timer(Sender:TObject);
begin
zShowLine(self);//顯示字符串
//bitblt轉移矩形圖(目標句柄，LSx,y,寬，高，源句柄，LSx,y,光柵運算符）
BitBlt(iDc,0,0,Panel1.Width,Panel1.Height,
Bmp.Canvas.Handle,0,Currline,srcCopy);
Inc(Currline,1);
ifCurrline>=bRect.Bottom-panel1.Height 100then//循環條件？
begin
Timer1.Enabled:=False;
Currline:=0;
end;
end;
procedureTForm1.zShowText;
var
i:integer;
ss:string;
ReadFile:TextFile;
begin
AssignFile(ReadFile,Edit1.Text);
Reset(ReadFile);
i:=1;
sItem:=TStringList.Create;
withsItemdo
whilenoteof(ReadFile)do
begin
Readln(ReadFile,ss);
add(ss);
i:=i 1;
end;
CloseFile(ReadFile);
zBmpCreate;
sItem.Free;//釋放串
end;
procedureTForm1.zBmpCreate;//創建圖片
var
i,y:integer;//y
begin
ifbmp<>nilthenbmp.free;
bmp:=TBitMap.Create;
zSetBmp;
R1.Right:=bRect.Right;
R1.Bottom:=bRect.Bottom;
y:=Panel1.Height-100;
fori:=0tosItem.Count-1do//從0到行數循環顯示圖片
begin
R1.Top:=y;
R1.Bottom:=R1.Top LineHeight;
ifCombobox1.Text=\'中間對齊\'then//顯示圖片
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_CenterorDt_Top)
else
ifCombobox1.Text=\'左對齊\'then
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_LeftorDt_Top)
else
ifCombobox1.Text=\'右對齊\'then
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_RightorDt_Top)
else
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_CenterorDt_Top);
Inc(y,LineHeight);
end;
end;
procedureTForm1.zSetBmp;
begin
zSetLineHeight;
withbRectdo//Rect矩形坐標(左上x,左下y,右上x,右下y)
begin
Top:=0;
Left:=0;
Right:=Panel1.Width;
Bottom:=LineHeight*sItem.Count Height;//行高*行數 form高度
end;
withBmpdo
begin
Height:=bRect.Bottom 100;//圖片高度
Width:=bRect.Right;
withCanvasdo//canvas畫布
begin
Font:=FontDialog1.Font;
//Font:=self.Font;//form所設置的字體
Brush.Color:=ColorDialog1.Color;
FillRect(bRect);
Brush.Style:=bsClear;
end;
end;
end;
procedureTForm1.zSetLineHeight;
{設置行間隔}
var
Metrics:TTextMetric;//設置字體API
begin
GetTextMetrics(iDc,Metrics);
LineHeight:=Metrics.tmHeight Metrics.tmInternalLeading-Bmp.Canvas.Font.Height;
end;
procedureTForm1.Button2Click(Sender:TObject);
begin
ifEdit1.Text=\'thenShowMessage(\'請輸入文件地址\')
else
begin
ifButton2.Caption=\'開始\'thenButton2.Caption:=\'暫停\'
elseButton2.Caption:=\'開始\';
Timer1.Enabled:=notTimer1.Enabled;
end;
end;
procedureTForm1.Button3Click(Sender:TObject);
begin
timer1.Enabled:=false;
Currline:=0;
Button2.Click;
Button2.Caption:=\'暫停\';
end;
procedureTForm1.TrackBar1Change(Sender:TObject);
begin
Timer1.Interval:=TrackBar1.Position*5;
Label2.Caption:=inttostr(Timer1.Interval);
end;
procedureTForm1.FormDestroy(Sender:TObject);
begin
ifBmp<>nilthenBmp.Free;
end;
procedureTForm1.Button4Click(Sender:TObject);
begin
close;
end;
procedureTForm1.Button7Click(Sender:TObject);
begin
FontDialog1.Execute;
end;
procedureTForm1.Button6Click(Sender:TObject);
begin
ColorDialog1.Execute;
end;
procedureTForm1.Button8Click(Sender:TObject);
begin
if((strtoint(Edit2.Text)>=600)or(strtoint(Edit3.text)>=500)or((strtoint(Edit5.Text)>=553)or(strtoint(Edit4.Text)>=630)))
thenshowmessage(\'范圍超界\')
else
begin
Panel1.Top:=strtoint(Edit2.text);
Panel1.Left:=strtoint(Edit3.text);
Panel1.Width:=strtoint(Edit4.text);
Panel1.Height:=strtoint(Edit5.text);
end;
end;
procedureTForm1.Button5Click(Sender:TObject);
begin
Panel1.Top:=0;
Panel1.Left:=0;
Panel1.Width:=Panel3.Width;
Panel1.Height:=Panel3.Height;
end;
end.
|