因需要根据不同星期自动调用不同屏保图片,自己动手做了一个
代码如下:
//主工程文件
program scrsave;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.Title := '横店屏保一';
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
//单元文件
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, JPEG;
type
TForm1 = class(TForm)
Timer1: TTimer;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure LoadImage(img: TBitmap; cFile: String);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
procedure FindFiles(sPath: string);
procedure Detect(var Msg: TMsg; var Handled: Boolean);
procedure BackClear;//清屏
procedure HundredLeaf(cFile: string); //百叶窗
procedure PushDrag(cFile: string);//推拉
procedure HorizonCross(cFile: string);//水平交错
procedure VericalCross(cFile: string);//垂直交错
procedure PutStick(cFile: string); //积木
procedure CenToAll(cFile: string);//中间到四周
procedure AllToCen(cFile: string);
procedure LUpToRDown(cFile: string);//左上到右下
procedure RDownToLUp(cFile: string);//右下到左上
procedure LDownToRUp(cFile: string);//左下到右上
procedure RUpToLDown(cFile: string);//右上到左下
procedure MidToBoth(cFile: string);//中间到两边
procedure BothToMid(cFile: string);//两边到中间
procedure FlowSand(cFile: string);//流沙
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
FilesList: TStringList;
sFilePath: string;
Stop: boolean;
implementation
//{$D ScreenSave 我的屏幕保护}
{$R *.dfm}
procedure TForm1.FormDestroy(Sender: TObject);
begin
FilesList.Free;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
week: Integer;
begin
self.Color := clBlack;
Stop := False;
//按星期选择相应的文件夹
week := DayOfWeek(Date());
case week of
1,2: sFilePath := ExtractFilePath(Application.ExeName)+'Hdds\monday';
3: sFilePath := ExtractFilePath(Application.ExeName)+'Hdds\tuesday';
4: sFilePath := ExtractFilePath(Application.ExeName)+'Hdds\wendsday';
5: sFilePath := ExtractFilePath(Application.ExeName)+'Hdds\thursday';
6,7: sFilePath := ExtractFilePath(Application.ExeName)+'Hdds\friday';
end;
FindFiles(sFilePath);
//Self.FormStyle := fsStayOnTop;
end;
procedure Tform1.FindFiles(sPath: string);
function FType(cFile: String): boolean;
var
k :integer;
ext: string;
begin
result := false;
if Length(cFile) > 2 then
begin
k := pos('.',cFile);
ext := UpperCase(copy(cFile,k,length(cFile)-k+1));
if (ext= '.JPEG') or (ext= '.JPG') or (ext= '.BMP') then
result := true;
end;
end;
var
SearchRec: TSearchRec;
begin
if not Assigned(FilesList) then FilesList:= TStringList.Create;
FilesList.Clear;
if FindFirst(sPath+'\*.*', 0, SearchRec)=0 then
begin
try
repeat
if FType(SearchRec.Name) then
begin
FilesList.Add(sPath+'\'+SearchRec.Name);
end;
until FindNext(SearchRec)<>0;
except
FindClose(SearchRec);
raise;
end;
FindClose(SearchRec);
end;
end;
procedure TForm1.Detect(var Msg: TMsg; var Handled: Boolean);
begin
if (Msg.message = wm_keydown) or (Msg.message = wm_lbuttondown) or
(Msg.message = wm_rbuttondown)then
begin
stop := true;
Timer1.Enabled := True;
close;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
WindowState := wsMaximized;
Self.BringToFront;
ShowCursor(False);
Application.OnMessage := Detect;
end;
//百叶窗效果
procedure TForm1.HundredLeaf(cFile: string);
var
BitTemp1,BitTemp2,Bitmap:TBitmap;
i,j,bmpheight,bmpwidth:integer;
xgroup,xcount:integer;
begin
BitTemp1:= TBitmap.Create;//过渡位图
BitTemp2:= TBitmap.Create;
Bitmap := TBitmap.Create;
BackClear;
try
LoadImage(BitTemp1, cFile);
BitTemp2.Width := self.Width;
BitTemp2.Height := self.Height;
BitTemp2.Canvas.StretchDraw(ClientRect, BitTemp1);
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
bmpheight:=Height;
bmpwidth:=Width;
xgroup:=10;
xcount:=bmpheight div xgroup;
for i:=0 to xcount do
for j:=0 to xgroup do
begin
sleep(10);
Bitmap.Canvas.CopyRect(Rect(0,xcount*j+i-1,bmpwidth,xcount*j+i),
BitTemp2.Canvas,Rect(0,xcount*j+i-1,bmpwidth,xcount*j+i));
self.Canvas.Draw(0,0,Bitmap);
Application.ProcessMessages;
if Stop then Exit;
end;
finally
Bitmap.Free;
BitTemp1.Free;
BitTemp2.Free;
end;
end;
//=========================================================
//推拉效果
//==========================================================
procedure TForm1.PushDrag(cFile: string);
var
BitTemp1,BitTemp2:TBitmap;
//Bitmap:TBitmap;
i,bmpheight,bmpwidth:integer;
begin
BackClear; //清屏
BitTemp1:= TBitmap.Create;//过渡位图
BitTemp2:= TBitmap.Create;
//Bitmap := TBitmap.Create;
try
LoadImage(BitTemp1, cFile);
BitTemp2.Width := self.Width;
BitTemp2.Height := self.Height;
BitTemp2.Canvas.StretchDraw(ClientRect, BitTemp1);
//Bitmap.Width := self.Width;
// Bitmap.Height := self.Height;
bmpheight:=Height;
bmpwidth:=Width;
for i:=0 to bmpheight do
begin
{Bitmap.Canvas.CopyRect(Rect(0,bmpheight-i,bmpwidth,bmpheight),BitTemp2.Canvas,Rect(0,0,bmpwidth,i));
self.Canvas.Draw(0,0,Bitmap,); }
BitBlt(Self.Canvas.Handle,0,bmpheight-i,bmpwidth,bmpheight,
BitTemp2.Canvas.Handle,
0,0,srcCopy);
Application.ProcessMessages;
if Stop then Exit;
end;
finally
// Bitmap.Free;
BitTemp1.Free;
BitTemp2.Free;
end;
end;
//==============================================================
//水平交错
//==============================================================
procedure TForm1.HorizonCross(cFile: string);
var
BitTemp1,BitTemp2,Bitmap:TBitmap;
i,j,bmpheight,bmpwidth:integer;
begin
//BackClear(cFile); //清屏
BitTemp1:= TBitmap.Create;//过渡位图
BitTemp2:= TBitmap.Create;
Bitmap := TBitmap.Create;
try
LoadImage(BitTemp1, cFile);
BitTemp2.Width := self.Width;
BitTemp2.Height := self.Height;
BitTemp2.Canvas.StretchDraw(ClientRect, BitTemp1);
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
bmpheight:=Height;
bmpwidth:=Width;
i:=0;
while i<=bmpwidth do
begin
j:=i;
while j >0 do
begin
Bitmap.Canvas.CopyRect(Rect(j-1,0,j,bmpheight),BitTemp2.Canvas,
Rect(bmpwidth-i+j-1,0,bmpwidth-i+j,bmpheight));
Bitmap.Canvas.CopyRect(Rect(bmpwidth-j-1,0,bmpwidth-j,bmpheight),
BitTemp2.Canvas,Rect(i-j,0,i-j+1,bmpheight));
j:=j-3;
Application.ProcessMessages;
if Stop then Exit;
end;
Application.ProcessMessages;
if Stop then Exit;
self.Canvas.Draw(0,0,Bitmap);
inc(i,3);
end;
Bitmap.Canvas.CopyRect(rect(0,0,Width,Height),BitTemp2.Canvas,rect(0,0,Width,Height));
self.Canvas.Draw(0,0,Bitmap);
sleep(500);
finally
Bitmap.Free;
BitTemp1.Free;
BitTemp2.Free;
end;
end;
//=======================================================================
//垂直交错
//========================================================================
procedure TForm1.VericalCross(cFile: string);
var
BitTemp1,BitTemp2,Bitmap:TBitmap;
i,j,bmpheight,bmpwidth:integer;
begin
BackClear; //清屏
BitTemp1:= TBitmap.Create;//过渡位图
BitTemp2:= TBitmap.Create;
Bitmap := TBitmap.Create;
try
LoadImage(BitTemp1, cFile);
BitTemp2.Width := self.Width;
BitTemp2.Height := self.Height;
BitTemp2.Canvas.StretchDraw(ClientRect, BitTemp1);
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
bmpheight:=Height;
bmpwidth:=Width;
i:=0;
while i<=bmpheight do
begin
j:=i;
while j >0 do
begin
Bitmap.Canvas.CopyRect(Rect(0,j-1,bmpwidth,j),BitTemp2.Canvas,Rect(0,bmpheight-i+j-1,bmpwidth,bmpheight-i+j));
Bitmap.Canvas.CopyRect(Rect(0,bmpheight-j-1,bmpwidth,bmpheight-j),BitTemp2.Canvas,Rect(0,i-j,bmpwidth,i-j+1));
j:=j-3;
Application.ProcessMessages;
if Stop then Exit;
end;
Application.ProcessMessages;
if Stop then Exit;
self.Canvas.Draw(0,0,Bitmap);
i:=i+3;
end;
Bitmap.Canvas.CopyRect(rect(0,0,Width,Height),BitTemp2.Canvas,rect(0,0,Width,Height));
self.Canvas.Draw(0,0,Bitmap);
sleep(500);
finally
Bitmap.Free;
BitTemp1.Free;
BitTemp2.Free;
end;
end;
//===========================================================================
//积木效果
//===========================================================================
procedure TForm1.PutStick(cFile: string);
var
BitTemp1,BitTemp2,Bitmap:TBitmap;
i,j,x,y:integer;
begin
BitTemp1:= TBitmap.Create;//过渡位图
BitTemp2:= TBitmap.Create;
Bitmap := TBitmap.Create;
try
LoadImage(BitTemp1, cFile);
BitTemp2.Width := self.Width;
BitTemp2.Height := self.Height;
BitTemp2.Canvas.StretchDraw(ClientRect, BitTemp1);
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
self.Color := clBlack;
i := 0;
j := 0;
for x:=0 to 20 do
begin
for y:=0 to 15 do
begin
Bitmap.Canvas.CopyRect(rect(i*50,j*50,(i+1)*50,(j+1)*50),BitTemp2.Canvas,rect(i*50,j*50,(i+1)*50,(j+1)*50));
self.Canvas.Draw(0,0,Bitmap);
i:=i+2;
Application.ProcessMessages;
if Stop then Exit;
end;
j:=j+2;
i:=0;
end;
j:=1;
i:=1;
for x:=0 to 20 do
begin
for y:=0 to 15 do
begin
Bitmap.Canvas.CopyRect(rect(i*50,j*50,(i+1)*50,(j+1)*50),BitTemp2.Canvas,rect(i*50,j*50,(i+1)*50,(j+1)*50));
self.Canvas.Draw(0,0,Bitmap);
i:=i+2;
Application.ProcessMessages;
if Stop then Exit;
end;
j:=j+2;
i:=1;
end;
i := 0;
j := 0;
for x:=0 to 20 do
begin
for y:=0 to 15 do
begin
Bitmap.Canvas.CopyRect(rect(i*50,(j+1)*50,(i+1)*50,(j+2)*50),BitTemp2.Canvas,rect(i*50,(j+1)*50,(i+1)*50,(j+2)*50));
self.Canvas.Draw(0,0,Bitmap);
i:=i+2;
Application.ProcessMessages;
if Stop then Exit;
end;
j:=j+2;
i:=0;
end;
j:=1;
i:=1;
for x:=0 to 20 do
begin
for y:=0 to 15 do
begin
Bitmap.Canvas.CopyRect(rect(i*50,(j-1)*50,(i+1)*50,j*50),BitTemp2.Canvas,rect(i*50,(j-1)*50,(i+1)*50,j*50));
self.Canvas.Draw(0,0,Bitmap);
i:=i+2;
Application.ProcessMessages;
if Stop then Exit;
end;
j:=j+2;
i:=1;
end;
finally
Bitmap.Free;
BitTemp1.Free;
BitTemp2.Free;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
i,j : Integer;
begin
Timer1.Enabled := False;
Randomize;
i := 0;
while not stop do
begin
j := 1+Random(13);
case j of
1: HundredLeaf(FilesList.Strings[i]);
2: PushDrag(FilesList.Strings[i]);//推拉
3: HorizonCross(FilesList.Strings[i]);//水平交错
4: VericalCross(FilesList.Strings[i]);//垂直交错
5: PutStick(FilesList.Strings[i]); //积木
6: CenToAll(FilesList.Strings[i]); //中心到四周
7: AllToCen(FilesList.Strings[i]);
8: LUpToRDown(FilesList.Strings[i]);//左上到右下
9: RDownToLUp(FilesList.Strings[i]);//右下到左上
10: LDownToRUp(FilesList.Strings[i]);//左下到右上
11: RUpToLDown(FilesList.Strings[i]);//右上到左下
12: MidToBoth(FilesList.Strings[i]);//中间到两边
13: BothToMid(FilesList.Strings[i]);//两边到中间
14: FlowSand(FilesList.Strings[i]);//流沙
end;
Sleep(2000);
if stop then
begin
Timer1.Enabled := True;
exit;
end;
inc(i);
if i >= FilesList.Count then i := 0;
end; //while
end;
procedure TForm1.LoadImage(img: TBitmap; cFile: String);
var
ext: String;
jpgimg: TJpegImage;
begin
ext := ExtractFileExt(cFile);
if (UpperCase(ext) = '.JPG') or (UpperCase(ext) = '.JPEG') then
begin
jpgimg := TJpegImage.Create;
try
jpgimg.LoadFromFile(cFile);
img.Assign(jpgimg);
finally
jpgimg.Free;
end;
end
else img.LoadFromFile(cFile);
end;
procedure TForm1.BackClear;//清黑屏
const
step = 100;
var
BitTemp, Bitmap : TBitmap;
i : integer;
begin
// self.color := clBlack;
// repaint;
BitTemp := TBitmap.Create;
Bitmap:=TBitmap.Create;
LoadImage(BitTemp, ExtractFilePath(Application.ExeName) + 'Hdds\Monday\Back.bmp');//载入图片
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
//Bitmap.Canvas.Brush.Color := clBlack;
Bitmap.Canvas.StretchDraw(ClientRect, BitTemp);
for i := 1 to step do
BitBlt(self.Canvas.Handle,0,step-i,Width,Height,
Bitmap.Canvas.Handle,0,0,blackness);
Bitmap.Free; //释放位图
BitTemp.Free;
end;
procedure TForm1.CenToAll(cFile: string);//中间到四周
const
Step=1600; //循环的次数,用以调整图象变动的快慢
var
Bitmap, BitTemp:TBitmap;
X0,Y0:integer;
i,MidX,MidY:integer;
RatioX,RatioY:real;
begin
BitTemp := TBitmap.Create;
Bitmap:=TBitmap.Create;
try
LoadImage(BitTemp, cFile);//载入图片
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
Bitmap.Canvas.StretchDraw(self.ClientRect, BitTemp);
x0:=width div 2;
y0:=height div 2;
ratiox:=Bitmap.width/step; //step每加1,图片变化的宽度
ratioy:=Bitmap.height/step;
for i:=0 to step do
begin
midx:=round(ratiox*i*0.5);
midy:=round(ratioy*i*0.5);
bitblt(self.canvas.handle,x0-midx,y0-midy,
round(ratiox*i),round(ratioy*i),
bitmap.canvas.handle,x0-midx,y0-midy,srccopy);
//循环拷贝一定区域的图象显示,区域不断变化实现特效显示
Application.ProcessMessages;
if Stop then Exit;
end;
finally
bitmap.free; //释放位图
BitTemp.Free;
end;
end;
procedure TForm1.AllToCen(cFile: string);//四周到中间
const
Step=1600; //循环的次数,用以调整图象变动的快慢
var
Bitmap, BitTemp:TBitmap;
i :integer;
RatioX,RatioY:real;
begin
BitTemp := TBitmap.Create;
Bitmap:=TBitmap.Create;
try
LoadImage(BitTemp, cFile);//载入图片
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
Bitmap.Canvas.StretchDraw(self.ClientRect, BitTemp);
ratiox:=width/step;
ratioy:=height/step;
for i:= 0 to step do
begin //由于bitblt每次只能拷贝一个矩形,故要实现
//从四周到中间的渐变显示特效,需要每次拷贝周边的
//四个矩形,组成一个矩形框,
bitblt(self.canvas.handle,0,0,
round(ratiox*i*0.5),height,
bitmap.canvas.handle,0,0,srccopy);
//拷贝左边的矩形
bitblt(self.canvas.handle,0,0,
width,round(ratioy*i*0.5),
bitmap.canvas.handle,0,0,srccopy);
//拷贝上方的矩形
bitblt(self.canvas.handle,width-round(ratiox*i*0.5),0,
width,height,
bitmap.canvas.handle,width-round(ratiox*i*0.5),0,srccopy);
//拷贝右边的矩形
bitblt(self.canvas.handle,0,
height-round(ratioy*i*0.5),width,height,
bitmap.canvas.handle,0,
height-round(ratioy*i*0.5),srccopy);
//拷贝下面的矩形
Application.ProcessMessages;
if Stop then Exit;
end;
finally
bitmap.free; //释放位图
BitTemp.Free;
end;
end;
procedure TForm1.LUpToRDown(cFile: string);//左上到右下
const
Step=1600; //循环的次数,用以调整图象变动的快慢
var
Bitmap, BitTemp:TBitmap;
i:integer;
RatioX,RatioY:real;
begin
BitTemp := TBitmap.Create;
Bitmap:=TBitmap.Create;
try
LoadImage(BitTemp, cFile);//载入图片
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
Bitmap.Canvas.StretchDraw(self.ClientRect, BitTemp);
ratiox:=width/step;
ratioy:=height/step;
for i:= 0 to step do
begin
bitblt(self.canvas.handle,0,0,
round(ratiox*i),round(ratioy*i),
bitmap.canvas.handle,0,0,srccopy);
//拷贝左上角的一个矩形,要求右下角的坐标
//按(round(ratiox*i),round(ratioy*i))变化,
//注意,由于宽和高不等,所以它们的变化幅度
//也应该有所不同。
Application.ProcessMessages;
if Stop then Exit;
end;
finally
bitmap.free; //释放位图
BitTemp.Free;
end;
end;
procedure TForm1.RDownToLUp(cFile: string);//右下到左上
const
Step=1600; //循环的次数,用以调整图象变动的快慢
var
Bitmap, BitTemp:TBitmap;
i:integer;
RatioX,RatioY:real;
begin
BitTemp := TBitmap.Create;
Bitmap:=TBitmap.Create;
try
LoadImage(BitTemp, cFile);//载入图片
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
Bitmap.Canvas.StretchDraw(self.ClientRect, BitTemp);
ratiox:=width/step;
ratioy:=height/step;
for i:= 0 to step do
begin
bitblt(self.canvas.handle,width-round(ratiox*i),
height-round(ratioy*i),width,height,
bitmap.canvas.handle,width-round(ratiox*i),
height-round(ratioy*i),srccopy);
Application.ProcessMessages;
if Stop then Exit;
end;
finally
bitmap.free; //释放位图
BitTemp.Free;
end;
end;
procedure TForm1.LDownToRUp(cFile: string);//左下到右上
const
Step=1600; //循环的次数,用以调整图象变动的快慢
var
Bitmap, BitTemp:TBitmap;
i:integer;
RatioX,RatioY:real;
begin
BitTemp := TBitmap.Create;
Bitmap:=TBitmap.Create;
try
LoadImage(BitTemp, cFile);//载入图片
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
Bitmap.Canvas.StretchDraw(self.ClientRect, BitTemp);
ratiox:=width/step;
ratioy:=height/step;
for i:= 0 to step do
begin
bitblt(self.canvas.handle,0,height-round(ratioy*i),
round(ratiox*i),height,bitmap.canvas.handle,
0,height-round(ratioy*i),srccopy);
Application.ProcessMessages;
if Stop then Exit;
end;
finally
bitmap.free; //释放位图
BitTemp.Free;
end;
end;
procedure TForm1.RUpToLDown(cFile: string);//右上到左下
const
Step=1600; //循环的次数,用以调整图象变动的快慢
var
Bitmap, BitTemp:TBitmap;
i:integer;
RatioX,RatioY:real;
begin
BitTemp := TBitmap.Create;
Bitmap:=TBitmap.Create;
try
LoadImage(BitTemp, cFile);//载入图片
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
Bitmap.Canvas.StretchDraw(self.ClientRect, BitTemp);
ratiox:=width/step;
ratioy:=height/step;
for i:= 0 to step do
begin
bitblt(self.canvas.handle,width-round(ratiox*i),0,
width,round(ratioy*i),bitmap.canvas.handle,
width-round(ratiox*i),0,srccopy);
Application.ProcessMessages;
if Stop then Exit;
end;
finally
bitmap.free; //释放位图
BitTemp.Free;
end;
end;
procedure TForm1.MidToBoth(cFile: string);//中间到两边
const
Step=1600; //循环的次数,用以调整图象变动的快慢
var
Bitmap, BitTemp:TBitmap;
i:integer;
RatioX:real;
begin
BitTemp := TBitmap.Create;
Bitmap:=TBitmap.Create;
try
LoadImage(BitTemp, cFile);//载入图片
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
Bitmap.Canvas.StretchDraw(self.ClientRect, BitTemp);
RatioX:=width/step;
for i:= 0 to step do
begin
//注意此时左上角的x坐标朝左变化,而右下角的x坐标朝右变化
bitblt(self.canvas.handle,round(width/2)-round(ratiox*i*0.5),0,
round(ratiox*i),height,bitmap.canvas.handle,
round(width/2)-round(ratiox*i*0.5),0,srccopy);
Application.ProcessMessages;
if Stop then Exit;
end;
finally
bitmap.free; //释放位图
BitTemp.Free;
end;
end;
procedure TForm1.BothToMid(cFile: string);//两边到中间
const
Step=1600; //循环的次数,用以调整图象变动的快慢
var
Bitmap, BitTemp:TBitmap;
i:integer;
RatioX:real;
begin
BitTemp := TBitmap.Create;
Bitmap:=TBitmap.Create;
try
LoadImage(BitTemp, cFile);//载入图片
Bitmap.Width := self.Width;
Bitmap.Height := self.Height;
Bitmap.Canvas.StretchDraw(self.ClientRect, BitTemp);
ratiox:=width/step;
for i:= 0 to step do
begin
//实际是从四周到中心变化的简化。
bitblt(self.canvas.handle,0,0,
round(ratiox*i*0.5),height,
bitmap.canvas.handle,0,0,srccopy);
bitblt(self.canvas.handle,width-round(ratiox*i*0.5),0,width,height,
bitmap.canvas.handle,width-round(ratiox*i*0.5),0,srccopy);
Application.ProcessMessages;
if Stop then Exit;
end;
finally
bitmap.free; //释放位图
BitTemp.Free;
end;
end;
procedure TForm1.FlowSand(cFile: string);//流沙
var
Bitmap, BitTemp1, BitTemp2:TBitmap;
i,j:integer;
begin
BitTemp1 := TBitmap.Create;
BitTemp2 := TBitMap.Create;
Bitmap:=TBitmap.Create;
try
LoadImage(BitTemp1, cFile);//载入图片
BitTemp2.Width := self.Width;
BitTemp2.Height := self.Height;
BitTemp2.Canvas.StretchDraw(self.ClientRect, BitTemp1);
BitMap.width := Self.width;
BitMap.height := Self.height;
i:=BitMap.Height;
for j:= 1 to i do
begin
BitMap.Canvas.CopyRect(Rect(0,j-1,BitMap.Width,j),
BitTemp2.Canvas,
Rect(0,i-1,BitMap.Width,i));
Self.Canvas.Draw(0,j-1,BitMap);
Application.ProcessMessages;
if Stop then Exit;
end;
for i:=BitMap.Height downto 1 do
begin
BitMap.Canvas.CopyRect(Rect(0,i-1,BitMap.Width,i),
BitTemp2.Canvas,
Rect(0,i-1,BitMap.Width,i));
Self.Canvas.Draw(0,i-1,BitMap);
Application.ProcessMessages;
if Stop then Exit;
end;
finally
Bitmap.free; //释放位图
BitTemp1.free;
BitTemp2.Free;
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
close;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
close;
end;
end.
//窗体文件
object Form1: TForm1
Left = 237
Top = 206
Align = alCustom
BorderStyle = bsNone
Caption = 'Form1'
ClientHeight = 487
ClientWidth = 613
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
OnKeyDown = FormKeyDown
OnMouseDown = FormMouseDown
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Timer1: TTimer
Interval = 2000
OnTimer = Timer1Timer
Left = 15
Top = 26
end
end