-- 作者: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.
|