Delphi 实现照片抽奖-原创

有单位年会要用照片抽奖，上网搜了几个都不满意，且居然还要收费。自己写一个算了。只是有一点不爽，Delphi 7 在 Windows 7 64位下有问题，不能双击 dpr 文件直接打开项目！

关于性能：

• 因为总数不大（没超过100个），所以一次性全部载入内存保存，启动速度也不慢，秒开。以流的形式保存，因为可直接使用 TJPEGImage 的 LoadFromStream 方法。如果照片很多，那就要掂量掂量内存占用情况了。实时读取文件的话，同时还要考虑磁盘读写的延时。
• 图片分辨率对 JPG 的解压、显示的速度影响较大（i3 CPU、B75主板、8G内存）：
  4288*2848——耗时 260ms
  1440*956——耗时 109ms
  1156*768——耗时 63ms
  因此，必须限制原始图片的分辨率，宁可放大显示。如果对显示性能要求较高，比如图片切换间隔要求小于100ms（不过短于视觉暂留时间的话就看不见了），必须别想他法。

废话不说，上代码。

 unit main;

 interface

 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, ExtCtrls, ComCtrls, Menus, Jpeg;

 type
   TMainForm = class(TForm)
     MainTimer: TTimer;
     PopMenu: TPopupMenu;
     MenuClear: TMenuItem;
     MainPaint: TPaintBox;
     ExitMenu: TMenuItem;
     procedure MainTimerTimer(Sender: TObject);
     procedure FormKeyPress(Sender: TObject; var Key: Char);
     procedure FormClose(Sender: TObject; var Action: TCloseAction);
     procedure FormCreate(Sender: TObject);
     procedure MenuClearClick(Sender: TObject);
     procedure MainPaintPaint(Sender: TObject);
     procedure ExitMenuClick(Sender: TObject);
   private
     { Private declarations }
     procedure ShowPhoto(paint:TPaintBox; src:TGraphic; const name:string);
   public
     { Public declarations }
   end;

 const
   BufferSize=;              //缺省照片缓存大小
   CoverFileName='COVER.JPG';  //封面图片
   WinnerFileName='中奖.txt';  //抽奖结果文件

   TextColor=clRed;    //显示文字颜色
   TextSize=;        //显示文字大小
   TextFont='华文行楷';//显示文字字体

 var
   MainForm: TMainForm;
   PhotoIndex:integer=;     //当前显示的图片索引
   PhotoCount:integer=;     //图片总数
   Names : array of string;  //图片名称缓存
   Photos : array of TMemoryStream; //JPG文件流缓存
   Selected : array of integer;  //已中奖图片标志
   SelectedCount : integer=;    //已中奖数量，如果全部中奖则停止抽奖
   Log : TStringList;  //中奖记录，存入文本文件

   jpg:TJpegImage;   //解压JPG用的公用变量
   Times:Cardinal;   //定时器事件的执行次数

   bmpPaint:TBitmap; //作为PaintBox的显示缓存

 implementation

 {$R *.dfm}

 {
 procedure Mosaic(dest:TBitmap; src:TBitmap);
 var
   i,x,y:Integer;
   from:TRect;
   bmpwidth,bmpheight:Integer;
 const
   squ=20;
 begin
   bmpwidth:=src.Width;
   bmpheight:=src.Height;

   dest.Width:=bmpwidth;
   dest.Height:=bmpHeight; 

   for i:=0 to 400 do
   begin
     Randomize;
     x:=Random(bmpwidth div squ);
     y:=Random(bmpheight div squ);
     from:=Rect(x*squ,y*squ,(x+1)*squ,(y+1)*squ);
     dest.Canvas.CopyRect(from,Src.Canvas,from);
   end;
 end;

 procedure Alpha(bitmap:TBitmap; jpg:TJPEGImage);
 var
   BlendFunc: TBlendFunction;
   bit:TBitmap;
 begin
   bit := TBitMap.Create;
   try
     jpg.DIBNeeded;
     bit.Assign(jpg);
     BlendFunc.BlendOp := AC_SRC_OVER;
     BlendFunc.BlendFlags := 0;
     BlendFunc.AlphaFormat := 0;
     BlendFunc.SourceConstantAlpha := 127;
     windows.AlphaBlend(bitmap.Canvas.Handle, 0, 0, bit.Width, bit.Height,
                        bit.Canvas.Handle,  0, 0, bit.Width, bit.Height,
                        BlendFunc);
   finally
     bit.Free;
   end;
 end;
 }

 //源图等比缩放后填充目标图片，width、height指定可用显示区域的大小
 procedure ZoomFill(dest:TBitMap; src:TGraphic; width,Height:integer);
 var
   ZoomX,ZoomY,Zoom:double;
 begin
   zoomY:= Height / src.Height;
   zoomX:= Width / src.Width;
   // zoom 为 min(zoomX,zoomY)
   if (ZoomX<ZoomY) then
     zoom:= zoomX
   else
     zoom:=zoomY;
   dest.Width:= trunc(src.width*zoom);
   dest.Height:= trunc(src.Height*zoom);
   dest.Canvas.StretchDraw(rect(, , dest.Width, dest.Height), src);
 end;

 // 显示图片，name指定了文本（固定居左、上下居中位置）
 procedure TMainForm.ShowPhoto(paint:TPaintBox; src:TGraphic; const name:string);
 begin
   if not src.Empty then
   begin
     ZoomFill(bmpPaint,src,screen.Width,screen.Height);
     if length(name)> then
     begin
       bmpPaint.Canvas.Brush.Style := bsClear;
       bmpPaint.Canvas.TextOut(
         ,
         (bmpPaint.Height-bmpPaint.Canvas.textheight(name)) div ,
         name);
     end;
     paint.Repaint;
   end;
 end;

 //关闭 Form 时释放资源
 procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
 var
   i:integer;
 begin
   if MainTimer.Enabled then
     MainTimer.Enabled:=false;

   bmpPaint.Free;

   Log.SaveToFile(WinnerFileName);
   Log.Free;
   jpg.Free;

   for i:= to photocount- do
     Photos[i].Free;
 end;

 //创建 Form 时初始化资源
 procedure TMainForm.FormCreate(Sender: TObject);
 var
   SearchRec:TSearchRec;
   found:integer;
   i:integer;
 begin
   // 开启双缓冲，减少屏幕闪烁
   if not Self.doubleBuffered then
     Self.doubleBuffered:=true;

   //初始化缓冲区
   setlength(Names,BufferSize);
   setlength(Photos,BufferSize);
   setlength(Selected,BufferSize);

   Log:=TStringList.Create;
   jpg:=TJpegImage.Create;

   bmpPaint:=tBitmap.create;
   BmpPaint.pixelformat := pf24bit;
   bmpPaint.Canvas.Font.Size:=textSize;
   bmpPaint.Canvas.Font.Color:=textColor;
   bmpPaint.Canvas.Font.Name:=TextFont;

   // 窗口全屏
   Self.BorderStyle := bsNone;
   Self.Left := ;
   Self.Top := ;
   Self.Width := Screen.Width;
   Self.Height := Screen.Height;

   // 载入封面图片
   try
     jpg.LoadFromFile(coverfilename);
     jpg.DIBNeeded;
   except
   end;
   ShowPhoto(MainPaint, jpg, '');

   // 载入 data 目录下的所有JPG文件
   found:=FindFirst('data\*.jpg',faAnyFile,SearchRec);
   try
     while found= do
     begin
       if (SearchRec.Name<>'.')  and (SearchRec.Name<>'..')
            and (SearchRec.Attr<>faDirectory) then
       begin
         if (PhotoCount>=length(Names)) then  //内存缓冲长度不足
         begin
           setlength(Names,length(Names)*);
           setlength(Photos,length(Names));
           setlength(Selected,length(Names));
         end;
         Names[PhotoCount]:= ChangeFileExt(SearchRec.Name,'');
         Photos[PhotoCount]:=TMemoryStream.Create;
         Photos[PhotoCount].LoadFromFile('data\'+ SearchRec.Name);
         inc(PhotoCount);
       end;
       found:=FindNext(SearchRec);
     end;
   finally
     FindClose(SearchRec);
   end;

   //载入中奖纪录
   if fileexists(WinnerFileName) then
     log.LoadFromFile(WinnerFileName);
   if (log.Count>) then //标记已中奖者
   begin
     for i:= to photoCount- do
       if log.IndexOf(names[i])>= then
       begin
         Selected[i]:=;
         inc(selectedCount);
       end;
   end;

 end;

 //计时器事件
 procedure TMainForm.MainTimerTimer(Sender: TObject);
 var
   s:TMemoryStream;
 begin
   repeat
     Randomize;
     PhotoIndex:=random(photocount);
   until (Selected[photoIndex]<=); //跳过已中奖的图片
   s:= Photos[PhotoIndex];
   jpg.LoadFromStream(s);
   s.Position:=;  //这句必不可少。否则再读时不会报错，jpg.Empty不为空，但长度宽度均为0。
   showPhoto(MainPaint,jpg,Names[PhotoIndex]);
   inc(times);
   //逐渐加快图片滚动速度
   if (times>) then
   begin
     if MainTimer.Interval> then
       MainTimer.Interval:=;
   end
   else if times> then
     maintimer.Interval:=
   else if times> then
     Maintimer.Interval:=
   else
     MainTimer.Interval:=;
 end;

 //按键处理
 procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char);
 begin
   if (Key=#) then //Esc
   begin
     MainTimer.Enabled:=false;
     showmessage(Log.Text);
     close;
   end
   else  if (Key=' ') or (Key=#) then
   begin
     if MainTimer.Enabled then //要停止滚动
     begin
       MainTimer.Enabled:=false;
       inc(SelectedCount);
       Selected[PhotoIndex]:=;  //设置中奖标记
       Log.Append(Names[PhotoIndex]);
       Log.SaveToFile(WinnerFileName);
     end
     else
     begin //要开始滚动
       if SelectedCount<PhotoCount then  //还有未中奖
       begin
         times:=;
         MainTimer.Enabled:=true;
       end
       else
         showmessage('全部人员均已抽中！');
     end;
   end;
 end;

 //清除中奖纪录
 procedure TMainForm.MenuClearClick(Sender: TObject);
 var
   i:integer;
 begin
   if MessageDlg('真的要清除中奖记录么？',
     mtConfirmation, [mbYes, mbNo], ) = mrYes then
   begin
     Log.Clear;
     SelectedCount:=;
     for i:= to PhotoCount- do
       selected[i]:=;
     if fileexists(WinnerFileName) then
       deletefile(WinnerFileName);
   end;
 end;

 //重绘 TPaintBox 事件
 procedure TMainForm.MainPaintPaint(Sender: TObject);
 begin
   with MainPaint.Canvas do
   begin
     pen.mode := pmcopy;
     brush.style := bssolid;
     copymode := srccopy;
     draw(
       (MainPaint.Width-bmpPaint.Width) div ,   //左右居中
       (MainPaint.Height-bmpPaint.Height) div , //上下居中
       bmpPaint);
   end;
 end;

 procedure TMainForm.ExitMenuClick(Sender: TObject);
 begin
   close;
 end;

 end.

可执行程序下载