有单位年会要用照片抽奖，上网搜了几个都不满意，且居然还要收费。自己写一个算了。只是有一点不爽，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.
时间： 2024-10-29 12:38:33