Try out this solitaire game. This solitaire game is fun and addictive. For rules of this game, click here. It also saves games, tells you when there are no more moves,when aces are covering each piles and custom card decks. Just run the exe file to play

unit acesupUnit1; //Main unit interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, mmsystem, ExtCtrls, Menus,shellapi,dialogs, StdCtrls,math; {$RESOURCE acesup32.res} const ticktocksound='TICKTOCK'; CARD_RESERVED_SIZE=Sizeof(pointer)-2; gamename='Aces Up'; DELPHIJUSTIN_KEY='Software\Justin'; GAMESPATH='GamesPath'; GameStats='ScoreStats'; NoHintsDescription='Delete this vaue to enable move hints.'; nohints='NoHints'; ShellFoldersName='SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders'; bad_game_data_error='Saved game is invalid.'; GAME_KEY_NAME='Software\Justin\AcesUp'; CurrentVersion='CurrentVersion'; gamever=$01000000; savename='Settings\AcesUp.sav'; valid_save_size=4+6+(2*52); CardValues:array[0..12]of byte=(13,1,2,3,4,5,6,7,8,9,10,11,12); Faces:array[0..12]of string=('Ace','Two','Three','Four','Five','Six','Seven', 'Eight','Nine','Ten','Jack','Queen','King'); Suits:array[1..4]of string=('Clubs','Diamonds','Hearts','Spades'); WinnerScore=52-4; type TAcesUpTable = class(TForm) PaintBox1: TPaintBox; PaintBox2: TPaintBox; PaintBox3: TPaintBox; PaintBox4: TPaintBox; PaintBox5: TPaintBox; PaintBox6: TPaintBox; Timer1: TTimer; MainMenu1: TMainMenu; Game1: TMenuItem; NewGame1: TMenuItem; EnterGameNumber1: TMenuItem; Exit1: TMenuItem; ChangeCardDeck1: TMenuItem; Help1: TMenuItem; About1: TMenuItem; HowToPlay1: TMenuItem; Label1: TLabel; NoHints1: TMenuItem; HowToUseThisGame1: TMenuItem; HighScores1: TMenuItem; procedure FormCreate(Sender: TObject); procedure FormPaint(Sender: TObject); procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure PaintBox5Click(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure About1Click(Sender: TObject); procedure HowToPlay1Click(Sender: TObject); procedure NewGame1Click(Sender: TObject); procedure EnterGameNumber1Click(Sender: TObject); procedure ChangeCardDeck1Click(Sender: TObject); procedure FormKeyPress(Sender: TObject; var Key: Char); procedure Exit1Click(Sender: TObject); procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure NoHints1Click(Sender: TObject); procedure HowToUseThisGame1Click(Sender: TObject); procedure HighScores1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; TPlayingCard=record face,suit:byte; reserved:array[1..CARD_RESERVED_SIZE]of byte; end; TScoreStats=record GamesPlayed,Gameswon:extended; end; {$RESOURCE D:\CARDDECK.RES} var gamenum:integer; hdeck:hmodule; back:dword; bBack,EmptyPile,EmptyDrawPile:tbitmap; deck_pics:array[0..12,1..4]of tbitmap; AcesUpTable: TAcesUpTable; piles:array[0..5]of tlist; used:array[0..12,1..4]of boolean; implementation uses acesupunit2; {$R *.DFM} function VersionStr:string; begin result:=format('%x.%x.%x.%x',[hibyte(hiword(gamever)),lobyte(hiword(gamever)), Hibyte(loword(gamever)),lobyte(loword(gamever))]); end; function acesUnder(index:byte):byte; var i:integer; pcar:pointer; card:tplayingcard; begin result:=0;zeromemory(@card,sizeof(card)); for i:=1to 4do begin card.suit:=i;copymemory(@pcar,@card,sizeof(card));if piles[ index].indexof(pcar)>-1then inc(result);end; end; function acesCovering:boolean; var i,j:integer; pcar:pointer; card:tplayingcard; pilecount:array[0..6]of byte; begin zeromemory(@pilecount,sizeof(pilecount)); pcar:=nil;zeromemory(@Card,Sizeof(card));for i:=1to 4do for j:=0to 3do begin card.suit:=i;copymemory(@pcar,@card,sizeof(card)); if(piles[j].indexof(pcar)>0)then begin inc(pilecount[j]);inc(pilecount[4]); end else begin if(piles[j].indexof(pcar)=0)and(acesunder(j)=1)then inc(pilecount[5]); pilecount[6]:=max(pilecount[6],acesunder(j)); end;end; result:=(pilecount[4]=4); for i:=0to 3 do result:=result and(pilecount[i]=1); if not result then result:=((pilecount[4]=1)and(pilecount[5]=3))or((pilecount[4]=2)and(pilecount[5] =2)and(pilecount[6]=1)); end; function CardBack:byte; var rs,rtyp:Dword; hk:hkey; begin RegCreateKey(hkey_current_user,GAME_KEY_NAME,hk); back:=255; rs:=4; regqueryvalueex(hk,'CardBack',nil,@rtyp,@back,@rs); result:=back; regclosekey(hk); if back>11then back:=strtointdef(paramstr(5),random(12)); end; function HasMoves(index:byte):boolean; var i:integer; pc:pointer; car1,car2:tplayingcard; begin result:=false; if piles[index].count=0then exit; pc:=piles[index].last;copymemory(@car1,@pc,sizeof(pc)); for i:=0to 3do if piles[i].count>0then begin pc:=piles[i].last;copymemory(@car2, @Pc,sizeof(pc));result:=result or((cardvalues[car1.face]<cardvalues[car2.face]) and(car1.suit=car2.suit));end; end; function movesleft:boolean; var i:integer; suitcount:array[1..4]of byte; pcar:pointer; car:tplayingcard; begin zeromemory(@suitcount,4); result:=false; for i:=0to 3do if piles[i].count>0then begin pcar:=piles[i].last;copymemory(@car, @pcar,sizeof(car));inc(suitcount[car.suit]);end; for i:=1to 4do result:=result or(suitcount[i]>1); acesuptable.Label1.Visible:=result; end; function EmptyPiles:boolean; var i:integer; begin result:=false; for i:=0to 3do result:=result or(piles[i].count=0); end; function CustomMsgBox(hw:hwnd;text,caption:pchar;flags,iconint:integer):integer; var mbparams:msgboxparams; begin zeromemory(@mbparams,sizeof(mbparams)); mbparams.cbSize:=sizeof(mbparams); mbparams.hwndOwner:=hw; mbparams.hInstance:=hinstance; mbparams.lpszText:=text; mbparams.lpszCaption:=caption; mbparams.dwStyle:=flags or mb_usericon; mbparams.lpszIcon:=makeintresource(iconint); result:=integer(messageboxindirect(mbparams)); end; function checkForLost:boolean; var mbtext:array[0..1024]of char; hk:hkey; rs:dword; i:integer; stats:tscorestats; begin result:=(not movesleft)and(piles[4].count=0)and(piles[5].count<winnerscore)and (not emptypiles); if result then begin deletefile(savename);regcreatekey(hkey_current_user, game_key_name,hk);zeromemory(@stats,sizeof(stats));rs:=sizeof(stats); regqueryvalueex(hk,GameStats,nil,nil,@stats,@rs);stats.GamesPlayed:= stats.GamesPlayed+1; regsetvalueex(hk,gamestats,0,reg_binary,@stats,sizeof(stats)); regclosekey(hk); playsound('LOSE',hinstance,snd_resource or snd_sync);playsound(ticktocksound, hinstance,snd_resource or snd_async or snd_loop); if custommsgbox(acesuptable.Handle,strfmt(mbtext, 'Sorry, there are no more moves.'#13#10'Score: %d/%d'#13#10'Play again?',[piles[ 5].count,winnerscore]),'Game Over',mb_yesno,253)=idyes then acesuptable.NewGame1.Click;playsound(nil,0,0); end; acesuptable.PaintBox1.Enabled:=not result; acesuptable.PaintBox2.Enabled:=not result; acesuptable.PaintBox3.Enabled:=not result; acesuptable.PaintBox4.Enabled:=not result; end; function drawcard:tplayingcard; label newcard; begin zeromemory(@result,sizeof(result)); newcard: result.suit:=Random(4)+1; result.face:=random(13); if used[result.face,result.suit] then goto newcard; used[result.face,result.suit]:=true; end; procedure NewGame(game:integer); var i:integer; begin acesuptable.Caption:='Aces Up Solitaire #'+inttostr(game);application.Title:= acesuptable.Caption; randseed:=game; gamenum:=game; for i:=0to 5 do piles[i].clear; zeromemory(@used,sizeof(@used)); for i:=0to 51do piles[4].Add(pointer(drawcard)); for i:=0to 3 do begin piles[i].add(piles[4].last);piles[4].remove(piles[4].last); end; acesuptable.FormPaint(nil); end; function pccard(i,j:integer):string; begin result:=format('CARD%d%x',[j,i]); end; function pcback(index:integer):string; begin result:=format('BACK%d',[index]); end; procedure savegame; var cardcount:byte; card:pointer; i,j:integer; hsavfile:thandle; bWritten:dword; begin hsavfile:=createfile(savename,generic_write,file_share_read,nil,create_Always, file_attribute_normal,0); writefile(hsavfile,gamenum,sizeof(gamenum),bwritten,nil); for i:=0to 5 do begin cardcount:=piles[i].count;writefile(hsavfile,cardcount,1,bwritten,nil); for j:=0to cardcount-1do begin card:=piles[i][j];writefile(hsavfile,card,2, bwritten,nil); end; end; closehandle(hsavfile); end; function opensavedgame:boolean; var cardcount:byte; card:pointer; noload:boolean; i,j,k:integer; hsavfile:thandle; bRead:dword; car:tplayingcard; begin hsavfile:=createfile(savename,generic_read,file_share_read,nil,open_existing, file_attribute_normal,0); noload:=false; result:=(hsavfile<>invalid_handle_value); if result then begin if(not noload)and(valid_save_size<>getfilesize(hsavfile,nil)) then begin closehandle(hsavfile); result:=false;messagebox(acesuptable.Handle,bad_game_data_error,gamename, mb_iconerror);for i:=0to 5do piles[i].Clear;end;end; if not result then begin closehandle(hsavfile);exit;end; readfile(hsavfile,gamenum,sizeof(gamenum),bread,nil); acesuptable.Caption := 'Aces Up Solitaire #'+inttostr(gamenum); application.Title:=acesuptable.Caption; for i:=0to 5 do begin readfile(hsavfile,cardcount,1,bread,nil); for j:=1to cardcount do begin card:=nil;readfile(hsavfile,card,2,bread,nil); piles[i].add(card);copymemory(@car,@card,sizeof(car));if(car.suit=0)or(car.Face>12)or( cardcount>52)or(car.suit>4)then begin result:=false;for k:=0to 5do piles[k].clear;closehandle(hsavfile);messagebox(acesuptable.handle, bad_game_data_error,gamename,mb_iconerror);exit;end;end;end; result:=result and(piles[5].count<=Winnerscore); if not result then begin messagebox(acesuptable.handle,bad_game_data_error, gamename,mb_iconerror);for i:=0to 5do piles[i].clear;end; closehandle(hsavfile); end; function IsLastestVersion(Ver:dword):boolean; begin result:=(ver<=gamever)and(ver>0); end; procedure displayHelp; var mbText:array[0..1024]of char; begin messagebox(acesuptable.Handle,strpcopy(mbtext, 'To discard a card use the left mouse button.'#13#10+ 'To move a card to an empty pile use the right mouse button.'#13#10+ 'To see a covered card hold down the Ctrl key while clicking on the card.'#13#10+ 'You can use the space key to draw.'#13#10+ 'You can use lowercase a through d keys to discard from pile a through d'#13#10+ 'You can use uppercase A through D keys to move a card to an empty pile' ),gamename,0); end; procedure TAcesUpTable.FormCreate(Sender: TObject); var i,j:integer; hkdj,hk,hkdirs:hkey; rs,regver:dword; deckdll,desktop,iconpath:array[0..max_path]of char; begin paintbox1.Canvas.Brush.Color:=clgreen; paintbox2.Canvas.Brush.Color:=clgreen; paintbox3.Canvas.Brush.Color:=clgreen; paintbox4.Canvas.Brush.Color:=clgreen; paintbox5.Canvas.Brush.Color:=clgreen; paintbox6.Canvas.Brush.Color:=clgreen; for i:=0to 12do for j:=1to 4do deck_pics[i,j]:=tbitmap.create; for i:=0to 5do piles[i]:=tlist.Create; randomize; regcreatekey(hkey_current_User,GAME_KEY_NAME,hk); nohints1.Checked:=(regqueryvalueex(hk,nohints,nil,nil,nil,nil)=error_success); regver:=0;rs:=4; regqueryvalueex(hk,CurrentVersion,nil,nil,@rs,@regver); regcreatekey(hkey_current_user,delphijustin_key,hkdj); if not islastestversion(regver) then begin regver:=gamever; displayhelp; regsetvalueex(hk,CurrentVersion,0,reg_dword,@regver,4); if messagebox(handle,'Create a icon onto the desktop?',gamename,mb_iconquestion or mb_yesno)=idyes then begin regopenkey(hkey_current_user,shellfoldersname, hkdirs);rs:=sizeof(desktop);regqueryvalueex(hkdirs,'Desktop',nil,nil,@desktop, @rs);regclosekey(hkdirs);createdirectory(strfmt(iconpath,'%s\Delphijustin Games', [desktop]),nil);regsetvalueex(hkdj,GamesPath,0,reg_sz,@iconpath,(1+strlen( iconpath))*sizeof(char)); if copyfile(pchar(paramstr(0)),strfmt(iconpath,'%s\Delphijustin Games\AcesUp.exe', [desktop]),false)then messagebox(handle, 'Program is under the "Delphijustin Games" folder on the Desktop.',gamename, mb_iconinformation) else messagebox(handle,'Failed to create icon on Desktop', gamename,mb_iconwarning); end; end; rs:=sizeof(iconpath); if regqueryvalueex(hkdj,gamespath,nil,nil,@iconpath,@rs)=error_success then setcurrentdirectory(iconpath); createdirectory('Settings',nil); if regqueryvalueex(hk,'DeckDLL',nil,nil,@deckdll,@rs)=error_success then hdeck:=loadlibrary(deckdll)else hdeck:=hinstance;cardback; if(paramcount=0)or(paramstr(1)='/')then if not opensavedgame then newgame(random(maxint)); if(paramcount=1)and(paramstr(1)<>'/')then newgame(strtoint(paramstr(1))); label1.Visible:=movesleft; emptypile:=tbitmap.Create; emptypile.LoadFromResourceName(hdeck,'CARD02');bBack:=tbitmap.Create; bback.LoadFromResourceName(hdeck,pcback(back)); emptyDRAWpile:=tbitmap.Create;emptydrawpile.LoadFromResourceName(hdeck,'CARD01'); for i:=0to 12do for j:=1to 4do deck_pics[i,j].loadfromresourcename(hdeck,pccard( i,j)); regclosekey(hkdj); regclosekey(hk); if fileexists(custom_card_back)then bback.LoadFromFile(custom_card_back); end; procedure TAcesUpTable.FormPaint(Sender: TObject); var i,j:integer; paintbox:tpaintbox; car:tplayingcard; pcar:pointer; begin paintbox1.Canvas.FillRect(rect(0,0,paintbox1.width,paintbox1.height)); paintbox2.Canvas.FillRect(rect(0,0,paintbox2.width,paintbox2.height)); paintbox3.Canvas.FillRect(rect(0,0,paintbox3.width,paintbox3.height)); paintbox4.Canvas.FillRect(rect(0,0,paintbox4.width,paintbox4.height)); paintbox5.Canvas.FillRect(rect(0,0,paintbox5.width,paintbox5.height)); paintbox6.Canvas.FillRect(rect(0,0,paintbox6.width,paintbox6.height)); paintbox1.Canvas.Draw(0,0,emptypile); paintbox2.Canvas.Draw(0,0,emptypile); paintbox3.Canvas.Draw(0,0,emptypile); paintbox4.Canvas.Draw(0,0,emptypile); for i:=0to 3 do begin case i of 0:paintbox:=paintbox1; 1:paintbox:=paintbox2; 2:paintbox:=paintbox3; 3:paintbox:=paintbox4; end; for j:=0to piles[i].count-1do begin pcar:=piles[i][j];copymemory(@car,@pcar, sizeof(car)); paintbox.Canvas.Draw(0,j*16,deck_pics[car.face,car.suit]);end; end; paintbox5.Canvas.Draw(0,0,emptydrawpile);for i:=0to piles[4].count-1do paintbox5.Canvas.Draw(0,i*8,bback); for i:=0to piles[5].count-1do begin pcar:=piles[5][i];copymemory(@car,@pcar, sizeof(car)); paintbox6.Canvas.Draw(i*16,0,deck_pics[car.face,car.suit]); end; end; procedure Discard(PB:TPaintbox); var b:boolean; i:integer; pcar:pointer; car1,car2:tplayingcard; begin b:=false; if piles[pb.Tag].count=0then exit; pcar:=piles[pb.tag].last;copymemory(@car2,@pcar,sizeof(car1)); for i:=0to 3do if piles[i].count>0then begin pcar:=piles[i].last;copymemory(@car1, @pcar,sizeof(car1));b:=b or((cardvalues[car1.face]>cardvalues[car2.face])and (car1.suit=car2.suit));end; if b then begin copymemory(@pcar,@car2,sizeof(car2));piles[pb.tag].remove(piles[ pb.tag].last); piles[5].add(pcar);end; end; procedure MoveToEmpty(pb:tpaintbox); var car:tplayingcard; pcar:pointer; i:integer; begin if piles[pb.tag].count=0then exit; pcar:=piles[pb.tag].last;copymemory(@car,@pcar,sizeof(car)); for i:=pb.tag to 3 do if piles[i].count=0 then begin piles[i].add(pcar);piles[pb.tag].remove(piles[pb.tag].last);exit; end; for i:=0 to 3do if piles[i].count=0 then begin piles[i].add(pcar);piles[pb.tag].remove(piles[pb.tag].last);exit;end; end; procedure TAcesUpTable.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var car:tplayingcard; pcar:pointer; hk:hkey; mbtext:array[0..255]of char; gameover:boolean; rs:dword; stats:tscorestats; begin if piles[tpaintbox(sender).tag].count=0then exit; if ssCtrl in shift then begin if (y div 16)>=piles[TPaintbox(sender).tag].count then pcar:=piles[tpaintbox( sender).tag].last else pcar:=piles[tpaintbox(sender).tag][y div 16];copymemory( @car,@pcar,sizeof(car)); messagebox(handle,strfmt(mbtext,'That card is The %s Of %s',[faces[car.face], suits[car.suit]]),gamename,mb_iconinformation);exit; end; label1.Visible:=movesleft; if not paintbox1.Enabled then exit; case button of mbLeft:discard(tpaintbox(sender)); mbRight:MoveToEmpty(tpaintbox(sender)); end; paintbox1mousemove(sender,[],0,0); formpaint(nil); gameover:=checkforlost or(piles[5].count=winnerscore); acesuptable.PaintBox1.Enabled:=not gameover; acesuptable.PaintBox2.Enabled:=not gameover; acesuptable.PaintBox3.Enabled:=not gameover; acesuptable.PaintBox4.Enabled:=not gameover; if piles[5].count=WinnerScore then begin zeromemory(@stats,sizeof(stats)); regcreatekey(hkey_current_user,game_key_name,hk);rs:=sizeof(stats); regqueryvalueex(hk,gamestats,nil,nil,@stats,@rs); stats.GamesPlayed:=stats.GamesPlayed+1; stats.Gameswon:=int(stats.Gameswon)+1;regsetvalueex(hk,gamestats,0,reg_binary, @stats,sizeof(stats)); playsound('WINNER',hinstance,snd_sync or snd_resource); playsound(TickTockSound,hinstance,snd_resource or snd_async or snd_loop); if custommsgbox(handle,strpcopy(mbtext, 'Congradulations, you won!'#13#10+ 'Play Again?'),gamename,mb_yesno,254)=idyes then newgame1.Click;playsound(nil,0,0); timer1.enabled:=true;exit;end; if gameover then begin deletefile(savename);exit;end; savegame; end; procedure TAcesUpTable.PaintBox5Click(Sender: TObject); var i:integer; hk:hkey; rs:dword; stats:tscorestats; mbtext:array[0..1024]of char; begin if piles[4].count=0then exit; for i:=0to 3 do begin piles[i].add(piles[4].last);piles[4].remove(piles[4].last); end; formpaint(nil); if acescovering then begin playsound(ticktocksound,hinstance,snd_resource or snd_async or snd_loop);if custommsgbox(handle,strfmt(mbtext, 'Aces are covering all piles making it impossible to win.'#13#10'Score %d/%d'#13#10'Continue playing?', [piles[5].count,winnerscore]),gamename,mb_yesno,253)=idno then begin deletefile( savename);zeromemory(@stats,sizeof(stats));regcreatekey(hkey_current_user, game_key_name,hk);regqueryvalueex(hk,gamestats,nil,nil, @stats,@rs);stats.GamesPlayed:=stats.GamesPlayed+1;regsetvalueex(hk,gamestats,0, reg_binary,@stats,sizeof(stats));regclosekey(hk); newgame1.Click;end;playsound(nil,0,0); end; if checkforlost then begin deletefile(savename);exit;end; savegame; end; procedure TAcesUpTable.Timer1Timer(Sender: TObject); begin canvas.Draw(random(width),random(height),deck_pics[random(13),random(4)+1]); end; procedure TAcesUpTable.About1Click(Sender: TObject); var mbdata:msgboxparams; begin zeromemory(@mbdata,sizeof(mbdata)); mbdata.cbSize:=sizeof(mbdata); mbdata.hwndOwner:=handle; mbdata.hInstance:=hinstance; mbdata.lpszText:=Strlfmt(stralloc(1024),1024,pchar( 'delphijustin Aces Up Solitaire v%s'#13#10+ 'By Justin Roeder'#13#10+ 'https://delphijustin.biz/'),[VersionStr]); mbdata.lpszCaption:='About Aces Up'; mbdata.dwStyle:=mb_usericon; mbdata.lpszIcon:=makeintresource(255); messageboxindirect(mbdata); strdispose(mbdata.lpszText); end; procedure TAcesUpTable.HowToPlay1Click(Sender: TObject); begin shellexecute(0,nil,'https://www.wikihow.com/Play-Aces-Up',nil,nil,sw_show); end; procedure TAcesUpTable.NewGame1Click(Sender: TObject); begin randomize; shellexecute(0,nil,pchar(paramstr(0)),strpcopy(stralloc(15),inttostr(random(maxint))), nil,sw_show); exitprocess(0); end; procedure TAcesUpTable.EnterGameNumber1Click(Sender: TObject); var gamenum:string; i:integer; begin randomize; gamenum:=inttostr(random(maxint)); if not inputquery('New Game','Enter game#',gamenum)then exit; gamenum:=trim(gamenum);for i:=1to length(gamenum)do if not(gamenum[i] in ['0'..'9'])then begin Messagebox(handle,'You must use whole numbers and positive',gamename, mb_iconinformation);entergamenumber1click(nil);exit; end; shellexecute(0,nil,pchar(paramstr(0)),pchar(gamenum),nil,sw_show);exitprocess(0); end; procedure TAcesUpTable.ChangeCardDeck1Click(Sender: TObject); begin changedeckwnd.Visible:=true; end; procedure TAcesUpTable.FormKeyPress(Sender: TObject; var Key: Char); begin case key of 'a':paintbox1mousedown(paintbox1,mbleft,[],0,0); 'A':paintbox1mousedown(paintbox1,mbright,[],0,0); 'b':paintbox1mousedown(paintbox2,mbleft,[],0,0); 'B':paintbox1mousedown(paintbox2,mbright,[],0,0); 'c':paintbox1mousedown(paintbox3,mbleft,[],0,0); 'C':paintbox1mousedown(paintbox3,mbright,[],0,0); 'd':paintbox1mousedown(paintbox4,mbleft,[],0,0); 'D':paintbox1mousedown(paintbox4,mbright,[],0,0); #32:paintbox5click(nil); end; end; procedure TAcesUpTable.Exit1Click(Sender: TObject); begin close; end; procedure TAcesUpTable.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var hk:hkey; b:boolean; begin regcreatekey(hkey_current_user,GAME_KEY_NAME,hk); b:=(regqueryvalueex(hk,NoHints,nil,nil,nil,nil)=error_success);regclosekey(hk); if b then exit; if hasmoves(tpaintbox(sender).tag)then tpaintbox(sender).cursor :=crhandpoint else tpaintbox(sender).cursor:=crdefault; end; procedure TAcesUpTable.NoHints1Click(Sender: TObject); var hk:hkey; begin nohints1.checked:=not nohints1.Checked; regcreatekey(hkey_current_user,game_key_name,hk); if nohints1.Checked then regsetvalueex(hk,nohints,0,reg_sz,@nohintsdescription[1], (1+length(nohintsdescription))*sizeof(char))else regdeletevalue(hk,nohints); regclosekey(hk); end; procedure TAcesUpTable.HowToUseThisGame1Click(Sender: TObject); begin displayhelp; end; function divide(n,d:extended):extended; begin result:=0; if d=0then exit; result:=n/d; end; procedure TAcesUpTable.HighScores1Click(Sender: TObject); var mbtext:array[0..1024]of char; hk:hkey; rs:dword; stats:tscorestats; begin zeromemory(@stats,sizeof(Stats)); rs:=sizeof(stats); regopenkey(hkey_current_user,game_key_name,hk); regqueryvalueex(hk,gamestats,nil,nil,@stats,@rs); regclosekey(hk); messagebox(handle,strfmt(mbtext,pchar( 'Games Played: %u'#13#10+ 'Games won: %u'#13#10+ 'Games lost: %u'#13#10+ 'Winning percentage: %f%%'#13#10+ 'Losing percentage: %f%%'), [trunc(stats.GamesPlayed),trunc(stats.gameswon),trunc(stats.gamesplayed- stats.gameswon),divide(stats.gameswon,stats.gamesplayed)*100,100-(divide( stats.gameswon,stats.gamesplayed)*100)]), 'Aces Up Statistics',0); end; end. unit acesupUnit2; //Change card deck unit interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,shellapi, ExtDlgs; const card_width=71; card_height=96; CUSTOM_CARD_BACK='Settings\AcesUp.bac'; type TChangeDeckWND = class(TForm) Button1: TButton; CheckBox1: TCheckBox; ScrollBar1: TScrollBar; Button2: TButton; OpenDialog1: TOpenDialog; Button3: TButton; Button4: TButton; Button5: TButton; Button6: TButton; OpenPictureDialog1: TOpenPictureDialog; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); procedure Button4Click(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure Button5Click(Sender: TObject); procedure FormPaint(Sender: TObject); procedure ScrollBar1Change(Sender: TObject); procedure Button6Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var ChangeDeckWND: TChangeDeckWND; implementation uses acesupunit1; {$R *.DFM} procedure TChangeDeckWND.Button1Click(Sender: TObject); var hk:hkey; ba:dword; begin regcreatekey(hkey_current_user,GAME_KEY_NAME,hk); if checkbox1.checked then ba:=255 else ba:=scrollbar1.Position; Regsetvalueex(hk,'CardBack',0,reg_dword,@ba,4); regclosekey(hk); if ba=255then back:=random(12)else back:=ba; shellexecute(0,nil,pchar(paramstr(0)),'/',nil,sw_show);exitprocess(0); end; procedure TChangeDeckWND.Button2Click(Sender: TObject); var hk:hkey; begin regcreatekey(hkey_current_user,GAME_KEY_NAME,hk); regdeletevalue(hk,'DeckDLL'); Regdeletevalue(hk,'CardBack'); regclosekey(hk); shellexecute(0,nil,pchar(paramstr(0)),'/',nil,sw_show);exitprocess(0); end; procedure TChangeDeckWND.Button3Click(Sender: TObject); var hk:hkey; hdec:hmodule; buff:array[0..max_path]of char; begin if not opendialog1.Execute then exit; hdec:=loadlibrary(pchar(opendialog1.filename)); if hdec=0 then begin messagebox(handle,pchar(syserrormessage(getlasterror)), 'delphijustin Card Deck',mb_iconerror);exit;end; hdeck:=hdec; regcreatekey(hkey_current_user,game_key_name,hk); regsetvalueex(hk,'DeckDLL',0,reg_sz,strpcopy(buff,opendialog1.filename),length( opendialog1.filename)+1); Regclosekey(hk); end; procedure TChangeDeckWND.Button4Click(Sender: TObject); begin shellexecute(0,nil,'https://delphijustin.biz/bin/carddecks',nil,nil,sw_show); end; procedure TChangeDeckWND.FormClose(Sender: TObject; var Action: TCloseAction); begin acesuptable.FormPaint(nil); end; procedure TChangeDeckWND.Button5Click(Sender: TObject); begin close; end; procedure TChangeDeckWND.FormPaint(Sender: TObject); var bmp:tbitmap; backst:array[0..8]of char; i:integer; begin bmp:=tbitmap.Create; bmp.Handle:=loadbitmap(hdeck,strfmt(backst,'BACK%d',[scrollbar1.position])); canvas.Draw(0,0,bmp); bmp.FreeImage; bmp.Free; if fileexists(custom_card_back)then canvas.Draw(0,0,bback); end; procedure TChangeDeckWND.ScrollBar1Change(Sender: TObject); begin formpaint(nil); end; procedure TChangeDeckWND.Button6Click(Sender: TObject); var uncropped,cropped:tbitmap; begin if not openpicturedialog1.Execute then exit; uncropped:=tbitmap.Create; uncropped.LoadFromFile(openpicturedialog1.FileName); cropped:=tbitmap.Create; cropped.Height:=card_height; cropped.width:=card_width; cropped.Canvas.StretchDraw(rect(0,0,card_width,card_height),uncropped); cropped.SaveToFile(custom_card_back); bback.Free; bback:=cropped; formpaint(nil); end; end.