屏保自己做

因需要根据不同星期自动调用不同屏保图片，自己动手做了一个

代码如下：

//主工程文件
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,bmpinteger;
  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;
    bmp=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,bmpinteger;
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;
    bmp=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,bmpinteger;
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;
    bmp=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,bmpinteger;
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;
    bmp=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