今天在网上发现的,贴下来,希望对大家有些帮助!
------------------------------------------------------------------
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, ExtCtrls, Buttons, StdCtrls,registry,shellapi;
type
TMainForm = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
MainMenu1: TMainMenu;
game: TMenuItem;
start: TMenuItem;
N3: TMenuItem;
level1: TMenuItem;
level2: TMenuItem;
level3: TMenuItem;
N7: TMenuItem;
oldrec: TMenuItem;
N9: TMenuItem;
_exit: TMenuItem;
help: TMenuItem;
content: TMenuItem;
About: TMenuItem;
Image1: TImage;
Panel3: TPanel;
Panel4: TPanel;
Image2: TImage;
Image5: TImage;
Image7: TImage;
Image6: TImage;
Image3: TImage;
Image4: TImage;
Timer1: TTimer;
Edit1: TEdit;
Image8: TImage;
Image9: TImage;
Image10: TImage;
Image11: TImage;
Image12: TImage;
Panel5: TPanel;
Image13: TImage;
N1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure startClick(Sender: TObject);
procedure levelClick(bm,bn,bp:byte;s1,s2:string);
procedure level1Click(Sender: TObject);
procedure level2Click(Sender: TObject);
procedure level3Click(Sender: TObject);
procedure oldrecClick(Sender: TObject);
procedure _exitClick(Sender: TObject);
procedure contentClick(Sender: TObject);
procedure AboutClick(Sender: TObject);
procedure Image1Click(Sender: TObject);
procedure Image1MouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
procedure Image1MouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
procedure Image1MouseMove(Sender: TObject;
Shift: TShiftState;
X,
Y: Integer);
procedure Panel1MouseMove(Sender: TObject;
Shift: TShiftState;
X,
Y: Integer);
procedure Timer1Timer(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure N1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure InitForm(x,y:byte);//窗体初始化
procedure DrawBlocks(x,y:byte);//画方块阵列
procedure RndMine(sender:Tobject);//随机布雷
procedure DrawX(x,y:byte);//在错的标记上打上红色的‘X’
procedure DrawMineFlag(x,y:byte);//画一个地雷标记
procedure ClearFlag(x,y:byte);//清除标记
procedure do
tLineDrawBlock(x,y:byte);//用虚线画块
procedure DrawAllMine(sender:Tobject);//显示所有地雷
procedure line(x1,y1,x2,y2:integer);//画一般线
procedure do
tLine(x1,y1,x2,y2:integer);//画虚线
procedure DrawaMine(x,y:integer);//画一个地 雷
procedure search(x,y:byte);//搜索安全块
procedure OpenBlocks(x,y: byte);//揭开一片相连无雷区
procedure PressSafeBlock(x,y:byte);//在安全块上按一下
procedure PressDangerBlock(nn,x,y:byte);//在周围有雷的方块上按下
procedure Nun_Clock_Change;
//当地雷计数或计时变化时
end;
var
MainForm: TMainForm;
//t游戏时间,link相连空白块数目
t,link:integer;
//m行,n列,p个雷,oldp:上次玩时的地雷数,NumFlagMine 已标记地雷数
m,n,p,oldp,NumFlagMine:byte;
//记录地雷在几号方块 0..98为地雷编号,0..1之0为行,1为列
mine:array[0..98,0..1] of integer;
//每个方块周围有多少地雷
MineNumAroundBlock:array[0..480] of byte;
//为true表示在上面标记有数字
FlagNoMine:array[0..479] of Boolean;
//连成一片的空白块位置,估计很难超过100个
linkblock:array[0..99] of integer;
//searched为true表示搜索过了,避免重复搜索
searched:array[0..479] of boolean;
//TStart为true则可启动计时并开始游戏
TStart:boolean;
//FlagAsMine为true表示上面有地雷标记
FlagAsMine:array[0..479] of byte;
//errflag为标记错的数目
errflag:byte;
//写注册表时用
regrec:string;
regname:string;
//mineflagerr为true表示该地雷标记是错误的,下面无雷
mineflagerr:array[0..479] of boolean;
//使用脱屏位图
offscreen:tbitmap;
source:trect;
//时钟和地雷数
Clock_MineNum:array[0..4] of integer=(4,0,0,0,0);
OldClock_MineNum:array[0..4]of integer=(4,0,0,0,0);
const
//定义数字颜色
NumColor:array[1..8] of tcolor=(clblue,clgreen,clred,clolive, clteal, clnavy,clblack,clyellow);
implementation
{$R bmp10.res}
uses rec;
{$R *.DFM}
procedure TMainForm.Formcreate(Sender: TObject);
var rk:tregistry;
s:string;
i:byte;
begin
s:=ExtractFileDir(Application.Exename);
application.HelpFile:=s+'/'+'mine.hlp';
regrec:='中级成绩';
regname:='中级人名';
rk:=TRegistry.Create;
try
if not rk.KeyExists('挖雷') then
begin
with rk do
begin
CreateKey('挖雷');
Openkey('挖雷',False);
Writestring ('初级人名', '无名');
WriteInteger('初级成绩',999);
Writestring ('中级人名', '无名');
WriteInteger('中级成绩',999);
Writestring ('高级人名', '无名');
WriteInteger('高级成绩',999);
end;
end;
finally
end;
rk.Free;
offscreen:=tbitmap.Create;
source:=rect(0,0,16,16);
try
offscreen.Width:=16;
offscreen.height:=16;
with offscreen.Canvas do
begin
brush.color:=clbtnface;
brush.Style:=bssolid;
pen.Style:=pssolid;
pen.color:=clbtnface;
rectangle(0,0,16,16);
for i:=0 to 7 do
begin
pixels[0,i*2]:=$808080;
end;
for i:=0 to 7 do
begin
pixels[i*2,0]:=$808080;
end;
pen.color:=0;
brush.Color:=0;
rectangle(6,6,11,11);
pixels[4,8]:=0;
pixels[5,8]:=0;
pixels[11,8]:=0;
pixels[12,8]:=0;
pixels[8,4]:=0;
pixels[8,5]:=0;
pixels[8,11]:=0;
pixels[8,12]:=0;
pixels[5,5]:=0;
pixels[11,11]:=0;
pixels[5,11]:=0;
pixels[11,5]:=0;
pixels[7,7]:=$ffffff;
end;
finally
end;
TStart:=false;
NumFlagMine:=0;
t:=0;
n:=16;
m:=16;
p:=40;
oldp:=40;
InitForm(n,m);
TStart:=true;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
offscreen.Free;
end;
procedure TMainForm.startClick(Sender: TObject);
begin
image5.hide;
DrawBlocks(n,m);
RndMine(MainForm);
t:=0;
NumFlagMine:=0;
edit1.text:=inttostr(p);
timer1.Enabled:=False;
image2.Picture:=image7.Picture;
image1.Enabled:=true;
Nun_Clock_Change;
end;
procedure TMainForm.levelClick(bm, bn, bp: byte;
s1, s2: string);
begin
m:=bm;
n:=bn;
p:=bp;
regrec:=s1;
regname:=s2;
initform(n,m);
oldp:=bp;
end;
procedure TMainForm.level1Click(Sender: TObject);
begin
levelclick(8,8,10,'初级成绩','初级人名');
end;
procedure TMainForm.level2Click(Sender: TObject);
begin
levelclick(16,16,40,'中级成绩','中级人名');
end;
procedure TMainForm.level3Click(Sender: TObject);
begin
levelclick(16,30,99,'高级成绩','高级人名');
end;
procedure TMainForm.oldrecClick(Sender: TObject);
begin
RecForm.show;
end;
procedure TMainForm._exitClick(Sender: TObject);
begin
close;
end;
procedure TMainForm.contentClick(Sender: TObject);
begin
Application.HelpCommand(HELP_FINDER,0);
end;
procedure TMainForm.AboutClick(Sender: TObject);
var thetext,thecaption:string;
begin
thetext:='作者:官本和 Copyright (c) 1999-2000';
thecaption:='扫雷';
application.MessageBox(pchar(thetext),pchar(thecaption),MB_OK);
end;
procedure TMainForm.Image1Click(Sender: TObject);
begin
TStart:= True;
end;
procedure TMainForm.Image1MouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
var k, ll,l:integer;
i,mx,my,j,cc:byte;
lr:integer;
begin
image2.Picture:=image3.Picture;
If TStart = True then
Timer1.Enabled:= True;
mx:= x div 16;
my:= y div 16;
k:= mx + my * n;
i:= MineNumAroundBlock[k];
if (button=mbleft) and (FlagAsMine[k]=1) then
exit;
If (i > 0) And (i < 9) And (FlagNoMine[k] = True) then
begin
lr:=0;
For ll:= -1 To 1 do
begin
For l:= -1 To 1 do
begin
if ((mx+ll)>=0) and ((mx+ll)<=n-1) and ((my+l)>=0) and ((my+l)<=m-1) then
lr:= lr + FlagAsMine[k + ll + l * n];
end;
end;
If lr = i then
begin
For ll:= -1 To 1 do
begin
For l:= -1 To 1 do
begin
if ((mx+ll)>=0) and ((mx+ll)<=n-1) and ((my+l)>=0) and ((my+l)<=m-1) then
begin
cc:= MineNumAroundBlock[k + ll + l * n];
If (cc = 0) And (FlagAsMine[k + ll + l * n] <> 1) then
OpenBlocks(mx+ll,my+l);
If (cc > 0) And (cc < 9) And (FlagAsMine[k + ll + l * n] <> 1) then
PressDangerBlock(cc,mx+ll,my+l);
If (cc = 9) And (FlagAsMine[k + ll + l * n] <> 1) then
begin
TStart:=false;
DrawAllMine(sender);
image2.Picture:= image6.Picture;
Timer1.Enabled:= False;
image1.Enabled:=false;
end;
end;
end;
end;
end;
end;
If (i < 9) And (i > 0) And (Button = mbleft) then
PressDangerBlock(i, mx, my);
If (i = 0) And (Button = mbleft) then
OpenBlocks(mx,my);
If (i = 9) And (Button = mbleft) then
begin
TStart:=false;
DrawAllMine(sender);
timer1.Enabled:=false;
image5.left:=mx*16+4;
image5.top:=my*16+4;
image5.show;
image2.Picture:= image6.Picture;
image1.Enabled:=false;
end;
if (button=mbright) and (FlagNoMine[k]=false) and (FlagAsMine[k]=0) and (NumFlagMine<p) then
begin
if MineNumAroundBlock[k]<>9 then
begin
errflag:=errflag+1;
mineflagerr[k]:=true;
end;
DrawMineFlag(mx,my);
FlagAsMine[k]:=1;
NumFlagMine:=NumFlagMine+1;
edit1.text:=inttostr(p-NumFlagMine);
exit;
end;
if (button=mbright) and (FlagAsMine[k]=1) then
begin
if MineNumAroundBlock[k]<>9 then
dec(errflag);
NumFlagMine:=NumFlagMine-1;
edit1.text:=inttostr(p-NumFlagMine);
FlagAsMine[k]:=0;
ClearFlag(mx,my);
end;
end;
procedure TMainForm.Image1MouseMove(Sender: TObject;
Shift: TShiftState;
X,
Y: Integer);
begin
edit1.Enabled:=true;
end;
procedure TMainForm.Image1MouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
begin
if image1.Enabled=true then
image2.Picture:=image7.Picture;
end;
procedure TMainForm.Panel1MouseMove(Sender: TObject;
Shift: TShiftState;
X,
Y: Integer);
begin
if timer1.Enabled=false then
startclick(self);
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
begin
t:=t+1;
if TStart=true then
Nun_Clock_Change;
end;
procedure TMainForm.Edit1Change(Sender: TObject);
var rr:tregistry;
s:string;
rec:integer;
nowtime:integer;
begin
Nun_Clock_Change;
nowtime:=t;
rr:=tregistry.Create;
if (edit1.text='0') and (errflag=0) then
begin
timer1.Enabled:=false;
image2.picture:=image4.picture;
rr.OpenKey('挖雷', false);
rec:=rr.ReadInteger(regrec);
if (nowtime<rec) then
begin
s:=inputbox('挖雷','你创造了新记录,请键入你的名字','');
if length(s)>0 then
begin
rr.WriteString(regname,s);
rr.WriteInteger(regrec,nowtime);
startclick(sender);
end;
if length(s)=0 then
startclick(sender);
rr.free;
end;
if (rec<=nowtime) then
if (application.messagebox('你赢了!','挖雷',MB_ok)=idok) then
startclick(sender);
end;
end;
procedure TMainForm.InitForm(x,y:byte);
begin
image5.hide;
DrawBlocks(n,m);
image1.width:=n*16;
image1.height:=m*16;
panel2.Width:=n*16+8;
panel2.Height:=m*16+8;
panel1.Width:=n*16+8;
MainForm.width:=n*16+34;
MainForm.Height:=m*16+119;
panel4.left:=n*16-37;
image2.left:=n*8-8;
MainForm.Position:=poscreencenter;
RndMine(MainForm);
t:=0;
NumFlagMine:=0;
edit1.text:=inttostr(p);
timer1.Enabled:=False;
image2.Picture:=image7.Picture;
image1.Enabled:=true;
end;
procedure TMainForm.DrawBlocks(x,y:byte);
var i:byte;
begin
image1.Canvas.Brush.color:=clbtnface;
image1.Canvas.Rectangle(0,0,x*16-1,y*16-1);
with image1.Canvas do
begin
pen.style:=pssolid;
pen.mode:=pmcopy;
for i:=0 to x-1 do
begin
pen.color:=$888888;
moveto(i*16+14,1);
lineto(i*16+14,y*16-2);
end;
for i:=0 to y-1 do
begin
moveto(1,i*16+14);
lineto(x*16-2,i*16+14);
end;
for i:=0 to x-1 do
begin
pen.color:=$ffffff;
moveto(i*16,0);
lineto(i*16,y*16-2);
end;
for i:=0 to y-1 do
begin
moveto(1,i*16);
lineto(x*16-2,i*16);
end;
for i:=0 to x-1 do
begin
pen.color:=0;
moveto(i*16+15,0);
lineto(i*16+15,y*16-1);
end;
for i:=0 to y-1 do
begin
moveto(0,i*16+15);
lineto(x*16-1,i*16+15);
end;
end;
end;
procedure TMainForm.RndMine(sender:Tobject);
var i,j,k,l,num:integer;
mine01:array of boolean;
label again;
begin
setlength(mine01,m*n);
errflag:=0;
Randomize;
for i:=0 to m*n-1 do
begin
mine01
:=false;
MineNumAroundBlock:=0;
searched:=false;
mineflagerr:=false;
end;
for i:=0 to p-1 do
begin
mine[i,0]:=random;
again:
mine[i,1]:=random(m);
if mine01[mine[i,0]+n*mine[i,1]]=true then
goto again;
mine01[mine[i,0]+n*mine[i,1]]:=true;
MineNumAroundBlock[mine[i,0]+n*mine[i,1]]:=9;
end;
setlength(mine01,0);
For i:= 0 To n - 1 do
begin
For j:= 0 To m - 1 do
begin
For k:= -1 To 1 do
begin
For l:= -1 To 1 do
begin
if ((i+k)>=0) and ((i+k)<=n-1) and ((j+l)>=0) and ((j+l)<=m-1) then
begin
num:= i + k + (j + l) * n;
If MineNumAroundBlock[i + j * n] <> 9 then
MineNumAroundBlock[i + j * n]:= MineNumAroundBlock[i + j * n] +(MineNumAroundBlock[num]) div 9;
end;
end;
end;
end;
end;
for i:=0 to m*n-1 do
begin
FlagNoMine:=false;
FlagAsMine:=0;
end;
end;
procedure TMainForm.DrawX(x,y:byte);
begin
with image1.canvas do
begin
brush.color:=clbtnface;
brush.Style:=bssolid;
pen.Style:=pssolid;
pen.color:=clbtnface;
rectangle(16*x,16*y,16*x+16,16*y+16);
do
tLine(x*16,y*16,x*16,y*16+15);
do
tLine(x*16,y*16,x*16+15,y*16);
Font.Color:=$ff;
TextOut(x*16+4,y*16+2,'X');
end;
end;
procedure TMainForm.DrawMineFlag(x,y:byte);
begin
with image1.canvas do
begin
pen.style:=pssolid;
pen.color:=0;
line(16*x+4,16*y+11,16*x+11,16*y+11);
line(16*x+6,16*y+10,16*x+9,16*y+10);
line(16*x+7,16*y+9,16*x+7,16*y+5);
pen.Color:=$ff;
line(16*x+4,16*y+5,16*x+8,16*y+5);
line(16*x+4,16*y+4,16*x+8,16*y+4);
line(16*x+4,16*y+3,16*x+8,16*y+3)
end;
end;
procedure TMainForm.ClearFlag(x,y:byte);
begin
with image1.Canvas do
begin
brush.color:=clbtnface;
brush.Style:=bssolid;
pen.Style:=pssolid;
pen.color:=clbtnface;
rectangle(16*x+3,16*y+3,16*x+12,16*y+13);
end;
end;
procedure TMainForm.DotLineDrawBlock(x,y:byte);
begin
with image1.canvas do
begin
pen.Color:=clbtnface;
Brush.color:=clbtnface;
Brush.Style:=bssolid;
Rectangle(16*x,16*y,16+16*x,16+16*y);
do
tLine(16*x ,y*16,16*x+15,y*16);
do
tLine(16*x,y*16,16*x,15+y*16);
end;
end;
procedure TMainForm.DrawAllMine(sender:tobject);
var i,j:integer;
x,y:byte;
begin
for i:=0 to m*n-1 do
begin
x:=(i mod n);
y:=(i div n);
if (FlagAsMine=1) and (mineflagerr=true) then
DrawX(x,y);
end;
for i:=0 to p-1 do
begin
j:= mine[i,0] +n*mine[i,1];
if (FlagAsMine[j]=0) then
image1.Canvas.CopyRect(rect(16*mine[i,0],16*mine[i,1],16*mine[i,0]+16,16*mine[i,1]+16),offscreen.canvas,source);
// 用DrawaMine(...)和 image1.Canvas.CopyRect(...)画出所有地雷,
// 效果相同。较早时用地雷图象数组画所有地雷,速度太慢
end;
end;
procedure TMainForm.line(x1,y1,x2,y2:integer);
begin
with image1.Canvas do
begin
moveto(x1,y1);
lineto(x2,y2);
end;
end;
//注意:一定要x2>x1或y2>y1
//由于每个方块只有16象素,所以
// 有以下的i:=0 to 7
procedure TMainForm.DotLine(x1,y1,x2,y2:integer);
var i:integer;
begin
if x1=x2 then
begin
for i:=0 to 7 do
begin
image1.canvas.pixels[x1,y1+i*2]:=$808080;
end;
end;
if y1=y2 then
begin
for i:=0 to 7 do
begin
image1.canvas.pixels[x1+i*2,y1]:=$808080;
end;
end;
end;
procedure TMainForm.DrawaMine(x,y:integer);
begin
with image1.Canvas do
begin
brush.color:=clbtnface;
brush.Style:=bssolid;
pen.Style:=pssolid;
pen.color:=clbtnface;
rectangle(16*x,16*y,16*x+16,16*y+16);
do
tLine(x*16,y*16,x*16,y*16+15);
do
tLine(x*16,y*16,x*16+15,y*16);
pen.color:=0;
brush.Color:=0;
rectangle(16*x+6,16*y+6,16*x+11,16*y+11);
line(16*x+4,16*y+8,16*x+13,16*y+8);
line(16*x+8,16*y+4,16*x+8,16*y+13);
pixels[16*x+5,16*y+5]:=0;
pixels[16*x+11,16*y+11]:=0;
pixels[16*x+5,16*y+11]:=0;
pixels[16*x+11,16*y+5]:=0;
pixels[16*x+7,16*y+7]:=$ffffff;
end;
end;
procedure TMainForm.search(x,y:byte);
var aaa,k,l:integer;
x1,y1:byte;
begin
linkblock[link]:= x + y * n;
searched[x + y * n]:= True;
For k:= -1 To 1 do
begin
For l:= -1 To 1 do
begin
if ((x+k)>=0) and ((x+k)<=n-1) and ((y+l)>=0) and ((y+l)<=m-1) then
begin
aaa:= x + k + (l + y) * n;
//超出范围则退出搜索
If (aaa < 0) Or (aaa >= m * n) then
exit;
If (MineNumAroundBlock[aaa] = 0) And (searched[aaa]=False) then
begin
link:=link + 1;
linkblock[link]:= aaa;
searched[aaa]:= True;
//递归
x1:=x+k;y1:=y+l;
search(x1, y1);
end;
end;
end;
end;
end;
procedure TMainForm.OpenBlocks(x,y: byte);
var j:integer;
xx,yy:byte;
begin
search(x, y);
For j:= 0 To link do
begin
xx:=(linkblock[j]) mod n;
yy:=(linkblock[j]) div n;
PressSafeBlock(xx,yy);
end;
link:= 0;
end;
procedure TMainForm.PressSafeBlock(x,y:byte);
var index,k,l:integer;
x1,y1,a,b,c:byte;
begin
x1:=x;
y1:=y;
Index:= x + y * n;
if FlagAsMine[index]<>1 then
begin
FlagNoMine[Index]:= True;
do
tLineDrawBlock(x1, y1);
For k:= -1 To 1 do
begin
For l:= -1 To 1 do
begin
if ((x1+k)>=0) and ((x1+k)<=n-1) and ((y1+l)>=0) and ((y1+l)<=m-1) then
begin
a:=MineNumAroundBlock[x1 + k + (l + y1) * n];
b:=x1+k;
c:=y1+l;
If a>0 then
begin
PressDangerBlock(a,b,c);
end;
end;
end;
end;
end;
end;
procedure TMainForm.PressDangerBlock(nn,x,y:byte);
begin
if FlagAsMine[x+y*n]<>1 then
begin
DotLineDrawBlock(x, y);
FlagNoMine[x + y * n]:= True;
image1.canvas.pen.Color:=rgb(0,0,200);
image1.canvas.Font.Color:=NumColor[nn];
image1.canvas.Font.size:=8;
image1.Canvas.Font.style:=[fsBold];
image1.canvas.textout(16*x+4,2+y*16,inttostr(nn));
end;
end;
procedure TMainForm.Nun_Clock_Change;
var nbmp:tbitmap;
ncs:string;
nci:byte;
begin
nbmp:=tbitmap.Create;
Clock_MineNum[0]:=strtoint(edit1.text) div 10;
Clock_MineNum[1]:=strtoint(edit1.text) mod 10;
Clock_MineNum[4]:=t mod 10;
Clock_MineNum[2]:=t div 100;
Clock_MineNum[3]:=(t div 10)mod 10;
for nci:=0 to 4 do
begin
if Clock_MineNum[nci]<>OldClock_MineNum[nci] then
begin
ncs:='N'+inttostr(Clock_MineNum[nci]);
nbmp.Handle:=loadbitmap(hinstance,pchar(ncs));
case nci of
0:image8.Canvas.Draw(0,0,nbmp);
1:image9.Canvas.Draw(0,0,nbmp);
2:image10.Canvas.Draw(0,0,nbmp);
3:image11.Canvas.Draw(0,0,nbmp);
4:image12.Canvas.Draw(0,0,nbmp);
end;
end;
end;
nbmp.Free;
OldClock_MineNum[0]:=Clock_MineNum[0];
OldClock_MineNum[1]:=Clock_MineNum[1];
OldClock_MineNum[2]:=Clock_MineNum[2];
OldClock_MineNum[3]:=Clock_MineNum[3];
OldClock_MineNum[4]:=Clock_MineNum[4];
end;
procedure TMainForm.N1Click(Sender: TObject);
Var St:Array[0..255] of char;
begin
ShellExecute(Handle,'open',StrPCopy(St,'http://personal.hb.cninfo.net/~gbh/'),nil,nil,SW_SHOW);
end;
end.