有單位年會要用照片抽獎，上網搜了幾個都不滿意，且居然還要收費。自己寫一個算了。只是有一點不爽，Delphi 7 在 Windows 7 64位下有問題，不能雙擊 dpr 文件直接打開項目！
關於性能：
廢話不說，上代碼。
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.
可執行程序下載
