Delphi 实现照片抽奖-原创

原作者: [db:作者] 来自: [db:来源] 收藏邀请

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

关于性能：

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

废话不说，上代码。

  1 unit main;
  2 
  3 interface
  4 
  5 uses
  6   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7   Dialogs, StdCtrls, ExtCtrls, ComCtrls, Menus, Jpeg;
  8 
  9 type
 10   TMainForm = class(TForm)
 11     MainTimer: TTimer;
 12     PopMenu: TPopupMenu;
 13     MenuClear: TMenuItem;
 14     MainPaint: TPaintBox;
 15     ExitMenu: TMenuItem;
 16     procedure MainTimerTimer(Sender: TObject);
 17     procedure FormKeyPress(Sender: TObject; var Key: Char);
 18     procedure FormClose(Sender: TObject; var Action: TCloseAction);
 19     procedure FormCreate(Sender: TObject);
 20     procedure MenuClearClick(Sender: TObject);
 21     procedure MainPaintPaint(Sender: TObject);
 22     procedure ExitMenuClick(Sender: TObject);
 23   private
 24     { Private declarations }
 25     procedure ShowPhoto(paint:TPaintBox; src:TGraphic; const name:string);
 26   public
 27     { Public declarations }
 28   end;
 29 
 30 const
 31   BufferSize=64;              //缺省照片缓存大小
 32   CoverFileName='COVER.JPG';  //封面图片
 33   WinnerFileName='中奖.txt';  //抽奖结果文件
 34   
 35   TextColor=clRed;    //显示文字颜色
 36   TextSize=72;        //显示文字大小
 37   TextFont='华文行楷';//显示文字字体
 38 
 39 var
 40   MainForm: TMainForm;
 41   PhotoIndex:integer=0;     //当前显示的图片索引
 42   PhotoCount:integer=0;     //图片总数
 43   Names : array of string;  //图片名称缓存
 44   Photos : array of TMemoryStream; //JPG文件流缓存
 45   Selected : array of integer;  //已中奖图片标志
 46   SelectedCount : integer=0;    //已中奖数量，如果全部中奖则停止抽奖
 47   Log : TStringList;  //中奖记录，存入文本文件
 48 
 49   jpg:TJpegImage;   //解压JPG用的公用变量
 50   Times:Cardinal;   //定时器事件的执行次数
 51 
 52   bmpPaint:TBitmap; //作为PaintBox的显示缓存
 53 
 54 implementation
 55 
 56 {$R *.dfm}
 57 
 58 {
 59 procedure Mosaic(dest:TBitmap; src:TBitmap);
 60 var
 61   i,x,y:Integer;  
 62   from:TRect;
 63   bmpwidth,bmpheight:Integer;
 64 const  
 65   squ=20;
 66 begin  
 67   bmpwidth:=src.Width;
 68   bmpheight:=src.Height;
 69 
 70   dest.Width:=bmpwidth;
 71   dest.Height:=bmpHeight; 
 72 
 73   for i:=0 to 400 do
 74   begin
 75     Randomize;
 76     x:=Random(bmpwidth div squ);  
 77     y:=Random(bmpheight div squ);  
 78     from:=Rect(x*squ,y*squ,(x+1)*squ,(y+1)*squ);
 79     dest.Canvas.CopyRect(from,Src.Canvas,from);
 80   end;  
 81 end;
 82 
 83 procedure Alpha(bitmap:TBitmap; jpg:TJPEGImage);
 84 var
 85   BlendFunc: TBlendFunction;
 86   bit:TBitmap;
 87 begin
 88   bit := TBitMap.Create;
 89   try
 90     jpg.DIBNeeded;
 91     bit.Assign(jpg);
 92     BlendFunc.BlendOp := AC_SRC_OVER;
 93     BlendFunc.BlendFlags := 0;
 94     BlendFunc.AlphaFormat := 0;
 95     BlendFunc.SourceConstantAlpha := 127;
 96     windows.AlphaBlend(bitmap.Canvas.Handle, 0, 0, bit.Width, bit.Height,
 97                        bit.Canvas.Handle,  0, 0, bit.Width, bit.Height,
 98                        BlendFunc);
 99   finally
100     bit.Free;
101   end;
102 end;
103 }
104 
105 //源图等比缩放后填充目标图片，width、height指定可用显示区域的大小
106 procedure ZoomFill(dest:TBitMap; src:TGraphic; width,Height:integer);
107 var
108   ZoomX,ZoomY,Zoom:double;
109 begin
110   zoomY:= Height / src.Height;
111   zoomX:= Width / src.Width;
112   // zoom 为 min(zoomX,zoomY)
113   if (ZoomX<ZoomY) then
114     zoom:= zoomX
115   else
116     zoom:=zoomY;
117   dest.Width:= trunc(src.width*zoom);
118   dest.Height:= trunc(src.Height*zoom);
119   dest.Canvas.StretchDraw(rect(0, 0, dest.Width, dest.Height), src);
120 end;
121 
122 // 显示图片，name指定了文本（固定居左、上下居中位置）
123 procedure TMainForm.ShowPhoto(paint:TPaintBox; src:TGraphic; const name:string);
124 begin
125   if not src.Empty then
126   begin
127     ZoomFill(bmpPaint,src,screen.Width,screen.Height);
128     if length(name)>0 then
129     begin
130       bmpPaint.Canvas.Brush.Style := bsClear;
131       bmpPaint.Canvas.TextOut(
132         10,
133         (bmpPaint.Height-bmpPaint.Canvas.textheight(name)) div 2,
134         name);
135     end;
136     paint.Repaint;
137   end;
138 end;
139 
140 //关闭 Form 时释放资源
141 procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
142 var
143   i:integer;
144 begin
145   if MainTimer.Enabled then
146     MainTimer.Enabled:=false;
147 
148   bmpPaint.Free;
149   
150   Log.SaveToFile(WinnerFileName);
151   Log.Free;
152   jpg.Free;
153 
154   for i:=0 to photocount-1 do
155     Photos[i].Free;
156 end;
157 
158 //创建 Form 时初始化资源
159 procedure TMainForm.FormCreate(Sender: TObject);
160 var   
161   SearchRec:TSearchRec;
162   found:integer;
163   i:integer;
164 begin
165   // 开启双缓冲，减少屏幕闪烁
166   if not Self.doubleBuffered then
167     Self.doubleBuffered:=true;
168 
169   //初始化缓冲区
170   setlength(Names,BufferSize);
171   setlength(Photos,BufferSize);
172   setlength(Selected,BufferSize);
173 
174   Log:=TStringList.Create;
175   jpg:=TJpegImage.Create;
176   
177   bmpPaint:=tBitmap.create;
178   BmpPaint.pixelformat := pf24bit;
179   bmpPaint.Canvas.Font.Size:=textSize;
180   bmpPaint.Canvas.Font.Color:=textColor;
181   bmpPaint.Canvas.Font.Name:=TextFont;
182 
183   // 窗口全屏
184   Self.BorderStyle := bsNone;
185   Self.Left := 0;
186   Self.Top := 0;
187   Self.Width := Screen.Width;
188   Self.Height := Screen.Height;
189 
190   // 载入封面图片
191   try
192     jpg.LoadFromFile(coverfilename);
193     jpg.DIBNeeded;
194   except
195   end;
196   ShowPhoto(MainPaint, jpg, '');
197 
198   // 载入 data 目录下的所有JPG文件
199   found:=FindFirst('data\*.jpg',faAnyFile,SearchRec);
200   try
201     while found=0 do
202     begin
203       if (SearchRec.Name<>'.')  and (SearchRec.Name<>'..')
204            and (SearchRec.Attr<>faDirectory) then
205       begin
206         if (PhotoCount>=length(Names)) then  //内存缓冲长度不足
207         begin
208           setlength(Names,length(Names)*2);
209           setlength(Photos,length(Names));
210           setlength(Selected,length(Names));
211         end;
212         Names[PhotoCount]:= ChangeFileExt(SearchRec.Name,'');
213         Photos[PhotoCount]:=TMemoryStream.Create;
214         Photos[PhotoCount].LoadFromFile('data\'+ SearchRec.Name);
215         inc(PhotoCount);
216       end;
217       found:=FindNext(SearchRec);
218     end;
219   finally
220     FindClose(SearchRec);
221   end;
222 
223   //载入中奖纪录
224   if fileexists(WinnerFileName) then
225     log.LoadFromFile(WinnerFileName);
226   if (log.Count>0) then //标记已中奖者
227   begin
228     for i:=0 to photoCount-1 do
229       if log.IndexOf(names[i])>=0 then
230       begin
231         Selected[i]:=1;
232         inc(selectedCount);
233       end;
234   end;
235 
236 end;
237 
238 //计时器事件
239 procedure TMainForm.MainTimerTimer(Sender: TObject);
240 var
241   s:TMemoryStream;
242 begin
243   repeat
244     Randomize;
245     PhotoIndex:=random(photocount);
246   until (Selected[photoIndex]<=0); //跳过已中奖的图片
247   s:= Photos[PhotoIndex];
248   jpg.LoadFromStream(s);
249   s.Position:=0;  //这句必不可少。否则再读时不会报错，jpg.Empty不为空，但长度宽度均为0。
250   showPhoto(MainPaint,jpg,Names[PhotoIndex]);
251   inc(times);
252   //逐渐加快图片滚动速度
253   if (times>16) then
254   begin
255     if MainTimer.Interval>125 then
256       MainTimer.Interval:=125;
257   end
258   else if times>8 then
259     maintimer.Interval:=250
260   else if times>3 then
261     Maintimer.Interval:=500
262   else
263     MainTimer.Interval:=800;
264 end;
265 
266 //按键处理
267 procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char);
268 begin
269   if (Key=#27) then //Esc
270   begin
271     MainTimer.Enabled:=false;
272     showmessage(Log.Text);
273     close;
274   end
275   else  if (Key=' ') or (Key=#13) then
276   begin
277     if MainTimer.Enabled then //要停止滚动
278     begin
279       MainTimer.Enabled:=false;
280       inc(SelectedCount);
281       Selected[PhotoIndex]:=1;  //设置中奖标记
282       Log.Append(Names[PhotoIndex]);
283       Log.SaveToFile(WinnerFileName);
284     end
285     else
286     begin //要开始滚动
287       if SelectedCount<PhotoCount then  //还有未中奖
288       begin
289         times:=0;
290         MainTimer.Enabled:=true;
291       end
292       else
293         showmessage('全部人员均已抽中！');  
294     end;
295   end;
296 end;
297 
298 //清除中奖纪录
299 procedure TMainForm.MenuClearClick(Sender: TObject);
300 var
301   i:integer;
302 begin
303   if MessageDlg('真的要清除中奖记录么？',
304     mtConfirmation, [mbYes, mbNo], 0) = mrYes then
305   begin
306     Log.Clear;
307     SelectedCount:=0;
308     for i:=0 to PhotoCount-1 do
309       selected[i]:=0;
310     if fileexists(WinnerFileName) then
311       deletefile(WinnerFileName);
312   end;
313 end;
314 
315 //重绘 TPaintBox 事件
316 procedure TMainForm.MainPaintPaint(Sender: TObject);
317 begin
318   with MainPaint.Canvas do
319   begin
320     pen.mode := pmcopy;
321     brush.style := bssolid;
322     copymode := srccopy;
323     draw(
324       (MainPaint.Width-bmpPaint.Width) div 2,   //左右居中
325       (MainPaint.Height-bmpPaint.Height) div 2, //上下居中
326       bmpPaint);
327   end;
328 end;
329 
330 procedure TMainForm.ExitMenuClick(Sender: TObject);
331 begin
332   close;
333 end;
334 
335 end.