關於拉幕程式的討論和原始碼 (轉)

關於拉幕程式的討論和原始碼 (轉)[@more@]

把一個文字在螢幕上緩慢輸出,完全輸出後再從頭迴圈輸出

修改後可以使用的程式（還是不完善：還不能實現從一側飛入的效果，容易出錯）：
unit Unit1;

interface

uses
  , 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: T);
    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;  //設定字型
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.

詳細討論在：