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=64;              //缺省照片缓存大小
  CoverFileName='COVER.JPG';  //封面图片
  WinnerFileName='中奖.txt';  //抽奖结果文件
  
  TextColor=clRed;    //显示文字颜色
  TextSize=72;        //显示文字大小
  TextFont='华文行楷';//显示文字字体

var
  MainForm: TMainForm;
  PhotoIndex:integer=0;     //当前显示的图片索引
  PhotoCount:integer=0;     //图片总数
  Names : array of string;  //图片名称缓存
  Photos : array of TMemoryStream; //JPG文件流缓存
  Selected : array of integer;  //已中奖图片标志
  SelectedCount : integer=0;    //已中奖数量，如果全部中奖则停止抽奖
  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  
  bmp=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(0, 0, 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)>0 then
    begin
      bmpPaint.Canvas.Brush.Style := bsClear;
      bmpPaint.Canvas.TextOut(
        10,
        (bmpPaint.Height-bmpPaint.Canvas.textheight(name)) div 2,
        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:=0 to photocount-1 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 := 0;
  Self.Top := 0;
  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=0 do
    begin
      if (SearchRec.Name<>'.')  and (SearchRec.Name<>'..')
           and (SearchRec.Attr<>faDirectory) then
      begin
        if (PhotoCount>=length(Names)) then  //内存缓冲长度不足
        begin
          setlength(Names,length(Names)*2);
          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>0) then //标记已中奖者
  begin
    for i:=0 to photoCount-1 do
      if log.IndexOf(names[i])>=0 then
      begin
        Selected[i]:=1;
        inc(selectedCount);
      end;
  end;

end;

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

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

//清除中奖纪录
procedure TMainForm.MenuClearClick(Sender: TObject);
var
  i:integer;
begin
  if MessageDlg('真的要清除中奖记录么？',
    mtConfirmation, [mbYes, mbNo], 0) = mrYes then
  begin
    Log.Clear;
    SelectedCount:=0;
    for i:=0 to PhotoCount-1 do
      selected[i]:=0;
    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 2,   //左右居中
      (MainPaint.Height-bmpPaint.Height) div 2, //上下居中
      bmpPaint);
  end;
end;

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

end.

可执行程序下载