program ipcalc;
//IPv4 Calculator
{$APPTYPE Console}
{$RESOURCE ipcalc32.res}
uses
SysUtils,
windows,
winsock,
math,
Classes;
var ip,subnet:string;
dummy1:twsadata;
aip,asubnet,wildcard,sip,eip,cip:dword;
nip1,nip2:array[1..4]of byte;
i:integer;
label TryAgain,validmask;
begin
if wsastartup($101,dummy1)<>0 then begin
writeln('Error initializing winsock');
exitprocess(1);
end;
TryAgain:
write('Enter IP Address:');readln(ip);
aip := inet_addr(pchar(ip));
write('Enter subnet mask or prefix:');
readln(subnet);
asubnet:=inet_addr(pchar(subnet));
//write('Enter prefix or leave blank:');
//readln(range);
if strscan(Pchar(subnet),'.')=nil then begin
copymemory(@nip1,@asubnet,4);
asubnet:=Trunc(IntPower(2,nip1[4])-1);
end else begin
for i:= 7 to 31 do if intpower(2,i)-1=asubnet then goto validmask;
write('Invalid Subnet mask! Try again(Yes/No)?');
readln(ip);
if strscan(pchar(uppercase(ip)),'Y')<>nil then goto tryagain;
end;
validmask:
writeln('Subnet Mask:',inet_ntoa(in_addr(asubnet)));
wildcard:=not asubnet;
copymemory(@nip1,@wildcard,4);
nip2[4]:=nip1[1];
nip2[3]:=nip1[2];
nip2[2]:=nip1[3];
nip2[1]:=nip1[4];
copymemory(@cip,@nip2,4);
sip:=aip and asubnet;
eip:=sip+wildcard;
writeln('Wildcard Mask:',inet_ntoa(in_addr(wildcard)));
writeln('Starting Address:',inet_ntoa(in_addr(sip)));
writeln('Ending Address:',inet_ntoa(in_addr(eip)));
writeln('Max. Hosts:',cip);
//writeln('Class: ',getipclass(sip));
write('Try again(Yes/No)?');
readln(ip);
if strscan(PChar(Uppercase(ip)),'Y')<>nil then goto TryAgain;
wsacleanup;
end.
program ipcalc6;
//IPv6 Calculator
{$APPTYPE Console}
{$RESOURCE ipcalc632.res}
uses
SysUtils,
windows,
Classes;
type TIN6_ADDR=array[0..15]of byte;
function RtlIpv6StringToAddressExA(astr:pchar;var address:tin6_addr;scope,
port:pointer):longint;stdcall;external 'ntdll.dll';
function RtlIpv6AddressToStringExA(var address:tin6_addr;scope,port:integer;
astr:pchar;len:PDWord):longint;stdcall;external 'ntdll.dll';
var ip,swcint:string;
aip,subnet,sip,eip,wildcard:tin6_addr;
bip,sSubnet,sSip,sEip,sWildcard:array[0..255] of char;
scope,cb,sum:dword;
i,prefix:integer;
port:word;
ce:byte;
wcint:int64;
function AddWithCarry(a,b:byte;var c:byte):byte;
begin
result:=(a xor b)xor c;
c:=(a and b)or(c and(a xor b));
end;
begin
ce:=0;
write('Enter IPv6 Address:'); //ask for a ip address
readln(ip);
write('Enter Subnet Prefix:'); //ask for the subnet prefix
readln(prefix);
zeromemory(@subnet,16);
if prefix>0 then subnet[0]:=subnet[0] or 128;//1 //bit setting on subnet mask
if prefix>1 then subnet[0]:=subnet[0] or 64;//2
if prefix>2 then subnet[0]:=subnet[0] or 32;//3
if prefix>3 then subnet[0]:=subnet[0] or 16;//4
if prefix>4 then subnet[0]:=subnet[0] or 8;//5
if prefix>5 then subnet[0]:=subnet[0] or 4;//6
if prefix>6 then subnet[0]:=subnet[0] or 2;//7
if prefix>7 then subnet[0]:=subnet[0] or 1;//8
if prefix>8 then subnet[1]:=subnet[1] or 128;//1
if prefix>9 then subnet[1]:=subnet[1] or 64;//2
if prefix>10 then subnet[1]:=subnet[1] or 32;//3
if prefix>11 then subnet[1]:=subnet[1] or 16;//4
if prefix>12 then subnet[1]:=subnet[1] or 8;//5
if prefix>13 then subnet[1]:=subnet[1] or 4;//6
if prefix>14 then subnet[1]:=subnet[1] or 2;//7
if prefix>15 then subnet[1]:=subnet[1] or 1;//8
if prefix>16 then subnet[2]:=subnet[2] or 128;//1
if prefix>17 then subnet[2]:=subnet[2] or 64;//2
if prefix>18 then subnet[2]:=subnet[2] or 32;//3
if prefix>19 then subnet[2]:=subnet[2] or 16;//4
if prefix>20 then subnet[2]:=subnet[2] or 8;//5
if prefix>21 then subnet[2]:=subnet[2] or 4;//6
if prefix>22 then subnet[2]:=subnet[2] or 2;//7
if prefix>23 then subnet[2]:=subnet[2] or 1;//8
if prefix>24 then subnet[3]:=subnet[3] or 128;//1
if prefix>25 then subnet[3]:=subnet[3] or 64;//2
if prefix>26 then subnet[3]:=subnet[3] or 32;//3
if prefix>27 then subnet[3]:=subnet[3] or 16;//4
if prefix>28 then subnet[3]:=subnet[3] or 8;//5
if prefix>29 then subnet[3]:=subnet[3] or 4;//6
if prefix>30 then subnet[3]:=subnet[3] or 2;//7
if prefix>31 then subnet[3]:=subnet[3] or 1;//8
if prefix>32 then subnet[4]:=subnet[4] or 128;//1
if prefix>33 then subnet[4]:=subnet[4] or 64;//2
if prefix>34 then subnet[4]:=subnet[4] or 32;//3
if prefix>35 then subnet[4]:=subnet[4] or 16;//4
if prefix>36 then subnet[4]:=subnet[4] or 8;//5
if prefix>37 then subnet[4]:=subnet[4] or 4;//6
if prefix>38 then subnet[4]:=subnet[4] or 2;//7
if prefix>39 then subnet[4]:=subnet[4] or 1;//8
if prefix>40 then subnet[5]:=subnet[5] or 128;//1
if prefix>41 then subnet[5]:=subnet[5] or 64;//2
if prefix>42 then subnet[5]:=subnet[5] or 32;//3
if prefix>43 then subnet[5]:=subnet[5] or 16;//4
if prefix>44 then subnet[5]:=subnet[5] or 8;//5
if prefix>45 then subnet[5]:=subnet[5] or 4;//6
if prefix>46 then subnet[5]:=subnet[5] or 2;//7
if prefix>47 then subnet[5]:=subnet[5] or 1;//8
if prefix>48 then subnet[6]:=subnet[6] or 128;//1
if prefix>49 then subnet[6]:=subnet[6] or 64;//2
if prefix>50 then subnet[6]:=subnet[6] or 32;//3
if prefix>51 then subnet[6]:=subnet[6] or 16;//4
if prefix>52 then subnet[6]:=subnet[6] or 8;//5
if prefix>53 then subnet[6]:=subnet[6] or 4;//6
if prefix>54 then subnet[6]:=subnet[6] or 2;//7
if prefix>55 then subnet[6]:=subnet[6] or 1;//8
if prefix>56 then subnet[7]:=subnet[7] or 128;//1
if prefix>57 then subnet[7]:=subnet[7] or 64;//2
if prefix>58 then subnet[7]:=subnet[7] or 32;//3
if prefix>59 then subnet[7]:=subnet[7] or 16;//4
if prefix>60 then subnet[7]:=subnet[7] or 8;//5
if prefix>61 then subnet[7]:=subnet[7] or 4;//6
if prefix>62 then subnet[7]:=subnet[7] or 2;//7
if prefix>63 then subnet[7]:=subnet[7] or 1;//8
if prefix>64 then subnet[8]:=subnet[8] or 128;//1
if prefix>65 then subnet[8]:=subnet[8] or 64;//2
if prefix>66 then subnet[8]:=subnet[8] or 32;//3
if prefix>67 then subnet[8]:=subnet[8] or 16;//4
if prefix>68 then subnet[8]:=subnet[8] or 8;//5
if prefix>69 then subnet[8]:=subnet[8] or 4;//6
if prefix>70 then subnet[8]:=subnet[8] or 2;//7
if prefix>71 then subnet[8]:=subnet[8] or 1;//8
if prefix>72 then subnet[9]:=subnet[9] or 128;//1
if prefix>73 then subnet[9]:=subnet[9] or 64;//2
if prefix>74 then subnet[9]:=subnet[9] or 32;//3
if prefix>75 then subnet[9]:=subnet[9] or 16;//4
if prefix>76 then subnet[9]:=subnet[9] or 8;//5
if prefix>77 then subnet[9]:=subnet[9] or 4;//6
if prefix>78 then subnet[9]:=subnet[9] or 2;//7
if prefix>79 then subnet[9]:=subnet[9] or 1;//8
if prefix>80 then subnet[10]:=subnet[10] or 128;//1
if prefix>81 then subnet[10]:=subnet[10] or 64;//2
if prefix>82 then subnet[10]:=subnet[10] or 32;//3
if prefix>83 then subnet[10]:=subnet[10] or 16;//4
if prefix>84 then subnet[10]:=subnet[10] or 8;//5
if prefix>85 then subnet[10]:=subnet[10] or 4;//6
if prefix>86 then subnet[10]:=subnet[10] or 2;//7
if prefix>87 then subnet[10]:=subnet[10] or 1;//8
if prefix>88 then subnet[11]:=subnet[11] or 128;//1
if prefix>89 then subnet[11]:=subnet[11] or 64;//2
if prefix>90 then subnet[11]:=subnet[11] or 32;//3
if prefix>91 then subnet[11]:=subnet[11] or 16;//4
if prefix>92 then subnet[11]:=subnet[11] or 8;//5
if prefix>93 then subnet[11]:=subnet[11] or 4;//6
if prefix>94 then subnet[11]:=subnet[11] or 2;//7
if prefix>95 then subnet[11]:=subnet[11] or 1;//8
if prefix>96 then subnet[12]:=subnet[12] or 128;//1
if prefix>97 then subnet[12]:=subnet[12] or 64;//2
if prefix>98 then subnet[12]:=subnet[12] or 32;//3
if prefix>99 then subnet[12]:=subnet[12] or 16;//4
if prefix>100 then subnet[12]:=subnet[12] or 8;//5
if prefix>101 then subnet[12]:=subnet[12] or 4;//6
if prefix>102 then subnet[12]:=subnet[12] or 2;//7
if prefix>103 then subnet[12]:=subnet[12] or 1;//8
if prefix>104 then subnet[13]:=subnet[13] or 128;//1
if prefix>105 then subnet[13]:=subnet[13] or 64;//2
if prefix>106 then subnet[13]:=subnet[13] or 32;//3
if prefix>107 then subnet[13]:=subnet[13] or 16;//4
if prefix>108 then subnet[13]:=subnet[13] or 8;//5
if prefix>109 then subnet[13]:=subnet[13] or 4;//6
if prefix>110 then subnet[13]:=subnet[13] or 2;//7
if prefix>111 then subnet[13]:=subnet[13] or 1;//8
if prefix>112 then subnet[14]:=subnet[14] or 128;//1
if prefix>113 then subnet[14]:=subnet[14] or 64;//2
if prefix>114 then subnet[14]:=subnet[14] or 32;//3
if prefix>115 then subnet[14]:=subnet[14] or 16;//4
if prefix>116 then subnet[14]:=subnet[14] or 8;//5
if prefix>117 then subnet[14]:=subnet[14] or 4;//6
if prefix>118 then subnet[14]:=subnet[14] or 2;//7
if prefix>119 then subnet[14]:=subnet[14] or 1;//8
if prefix>120 then subnet[15]:=subnet[15] or 128;//1
if prefix>121 then subnet[15]:=subnet[15] or 64;//2
if prefix>122 then subnet[15]:=subnet[15] or 32;//3
if prefix>123 then subnet[15]:=subnet[15] or 16;//4
if prefix>124 then subnet[15]:=subnet[15] or 8;//5
if prefix>125 then subnet[15]:=subnet[15] or 4;//6
if prefix>126 then subnet[15]:=subnet[15] or 2;//7
if prefix>127 then subnet[15]:=subnet[15] or 1;//8
rtlipv6stringtoaddressexa(pchar(ip),aip,@scope,@port);
//Convert a IP adresss in the string to a binary
for i:=0to 15 do begin//generates the wildcard mask and start and end addresses
wildcard[i]:=not subnet[i];
sip[i]:=aip[i] and subnet[i];
eip[i]:=addwithcarry(sip[i],wildcard[i],ce);
end;
cb:=256;
rtlipv6addresstostringexa(subnet,0,0,sSubnet,@cb);//convert subnet to string
cb:=256;
rtlipv6addresstostringexa(aip,0,0,bip,@cb);//convert ending address to string
writeln('IPv6 Address(short): ',bip);
writeln('IPv6 Address(long): ',inttohex(aip[0],2),inttohex(aip[1],2),':',
inttohex(aip[2],2),inttohex(aip[3],2),':',inttohex(aip[4],2),inttohex(aip[5],2)
,':',inttohex(aip[6],2),inttohex(aip[7],2),':',inttohex(aip[8],2),
inttohex(aip[9],2),':',inttohex(aip[10],2),inttohex(aip[11],2),':',
inttohex(aip[12],2),inttohex(aip[13],2),':',
inttohex(aip[14],2),inttohex(aip[15],2));
writeln('ScopeID:',scope);
writeln('Port:',port);
writeln('Microsoft Address: ',stringreplace(bip,':','-',[rfReplaceAll])+
'.ipv6-literal.net');
sum:=0;
for i:=0to 15 do sum:=sum+aip[i];
if sum*aip[15]=1 then Writeln('This is a loopback address');
write('Is part of a Local Unicast Network:');
if (aip[0]>$fb)and(aip[0]<$fe)then write('Yes')else
write('No');
writeln('');
write('Is link-local address:');
if (aip[0]=$fe)and(aip[1]=$80)then write('Yes')else write('No');
writeln('');
write('Prefix L bit:');
if aip[0] and 128>0 then Write('Yes')else write('No');
writeln('');
write('GlobalID:$');
for i:=1to 5 do write(inttohex(aip[i],2));
writeln('');
write('Subnet ID:$');
for i:=6to 7 do write(Inttohex(aip[i],2));
writeln('');
write('Interface ID:$');
for i:=8 to 15 do write(inttohex(aip[i],2));
writeln('');
cb:=256;
rtlipv6addresstostringexa(wildcard,0,0,sWildcard,@cb);
writeln('Subnet Mask: ',sSubnet);
if strscan(sWildCard,'.')=nil then swcint:=strpas(sWildCard)else
begin
swcint:=inttohex(wildcard[0],2)+inttohex(wildcard[1],2)+':'+
inttohex(wildcard[2],2)+inttohex(wildcard[3],2)+':'+
inttohex(wildcard[4],2)+inttohex(wildcard[5],2)+':'+
inttohex(wildcard[6],2)+inttohex(wildcard[7],2)+':'+
inttohex(wildcard[8],2)+inttohex(wildcard[9],2)+':'+
inttohex(wildcard[10],2)+inttohex(wildcard[11],2)+':'+
inttohex(wildcard[12],2)+inttohex(wildcard[13],2)+':'+
inttohex(wildcard[14],2)+inttohex(wildcard[15],2);
end;
writeln('Wildcard Mask: ',swcint);
swcint:=stringreplace(swildcard,':','',[rfReplaceAll]);
cb:=256;
rtlipv6addresstostringexa(sip,0,0,ssip,@cb);
writeln('Starting Address: ',ssip);
cb:=256;
rtlipv6addresstostringexa(eip,0,0,seip,@cb);
writeln('Ending Address: ',seip);
wcint:=StrToInt64Def('$'+swcint,-1);
if wcint>-1 then writeln('Max. Hosts: ',wcint)else
writeln('Max. Hosts: Overflow');
writeln('Press enter to exit...');
readln(ip);
end.
This tool is a
great tool to have for network administrators and people
who use domain
controllers or active directory. It allows you to lookup
the SID to and
from users accounts,computers,groups and more. It will
tell you if that
object has been deleted. You can use it on computers
when the computer
is having problems accessing the domain. It will give
you a nice error
message about accessing(if any error occurs). Try our
example batch
file that opens the tool up to get the SID from the
SYSTEM account.
This tool I believe should work on non-administrator
accounts. This
tool is an OK tool for anyone at your working place can
use. This tool
doesnt hack, it just gives information on the account
being looked up.
for example lets
say you want to lookup the account dmack from the
domain PTHS. To
do so you can call the following commands
findsid null
PTHS\dmack
findsid null
dmack
The first one
tells it to always use the domain PTHS and the second one
checks the
computer running findsid for it, and if it can’t find it, it
will check the
domain that the computer is part of. And by having the
first parameter
set to the word null it will have the systemname
pointer(memory
address in programming) set to nil on the lookup API
commands so it will
search for it the default way otherwise the first
parameter is a IP
address or hostname of a domain controller.
How to find a
certain user registry key under HKEY_USERS?
In registry
editor under the HKEY_USERS there is subkeys named by their
SID just replace
SID_HERE with the SID you would like to lookup.
findsid null
SID_HERE /SID
By adding /SID as
the last parameter will tell the object name isn’t a
name it’s a SID
of a object you want to lookup.
What to do when a
computer is having problems accessing the domain
controller?
You would open
findsid from the command prompt, using the follow command
where PTHSDC is
the server name of the domain controller and akrause is
a user account,
it doesnt have to be a user account, it can be a user
account,usergroup
or computername that is part of that domain.
So the command in
this example will look like
findsid PTHSDC
PTHS\akrause
if the domain
controller is working it should give you information about
the object
akrause. Otherwise you may get an error like this:
LookupErr:The RPC
server is unavailable
ConvertSidToStr:The
security ID structure is invalid
program findsid;
{$APPTYPE Console}
{$RESOURCE findsid32.res}
uses
SysUtils,
windows,
Classes;
function ConvertSidToStringSidA(sid:pointer;var lpStr:pchar):bool;stdcall;
external 'advapi32.dll';
function ConvertStringSidToSidA(lpStr:pchar;var sid:pointer):bool;stdcall;
external 'advapi32.dll';
var sidarray:array[0..2048]of byte;
lookuperror,cbSid,cbDomain,cbaccount,siduse:dword;
sidtype:string;
b:boolean;
sid:pointer;
domain,account:array[0..255]of char;
i:integer;
paccount:pchar;
begin
cbsid:=2049;
cbaccount:=256;
cbdomain:=256;
sid:=@sidarray;
if paramcount=0then
begin
writeln('This tool looks up a SID from a server and account name');
writeln('Usage: ',ExtractFilename(paramstr(0)),' servername account [/SID]');
writeln('Commandline switch /SID means that the account is a SID instead of a account name');
writeln('You can type NULL for the default servername');
exitprocess(0);
end;
if stricomp(pchar(paramstr(3)),'/SID')=0 then begin
if not convertstringsidtosidA(pchar(Paramstr(2)),sid)then begin
writeln('ConvertStrToSid:',Syserrormessage(getlasterror));
exitprocess(getlasterror);
end;
if stricomp(pchar(paramstr(1)),'NULL')=0 then
b:=lookupaccountsid(nil,sid,account,cbaccount,domain,cbdomain,siduse) else
b:=lookupaccountsid(pchar(paramstr(1)),sid,account,cbaccount,domain,cbdomain,siduse);
lookuperror:=getlasterror;
convertsidtostringsida(sid,paccount);
end else begin
if stricomp(pchar(paramstr(1)),'NULL')=0then
b:=lookupaccountname(nil,pchar(paramstr(2)),@sidarray,cbSid,domain,cbdomain,siduse)else
b:=lookupaccountname(pchar(paramstr(1)),pchar(paramstr(2)),@sidarray,cbSid,
domain,cbdomain,siduse);
lookuperror:=getlasterror;
if not ConvertSidToStringSidA(@sidarray,paccount) then begin
writeln('LookupErr:',syserrormessage(lookuperror));
writeln('ConvertSidToStr:',SysErrorMessage(getlasterror));
exitprocess(getlasterror);
end;
end;
if not b then begin
writeln('LookupErr:',syserrormessage(getlasterror));
exitprocess(getlasterror);
end;
case siduse of
SidTypeUser:sidtype:='User';
sidtypegroup:sidtype:='Group';
sidtypealias:sidtype:='Alias';
sidtypewellknowngroup:sidtype:='Well Known Group';
sidtypedeletedaccount:Sidtype:='Deleted Account';
sidtypeinvalid:sidtype:='Invalid Object';
sidtypeunknown:sidtype:='Unknown Object';
9:sidtype:='Computer';
10:sidtype:='Label';
else sidtype:='Unknown '+inttostr(siduse);
end;
if strpas(account)<>''then
writeln('Object Name:',account);
writeln('Object SID:',paccount);
writeln('Object Type:',sidtype);
Writeln('Domain:',domain);
writeln('SID Size:',GetLengthSid(sid),' bytes');
copymemory(@sidarray,sid,getlengthsid(sid));
write('SID data(in hex):');
for i:=0 to getlengthsid(sid)-1 do write(Inttohex(sidarray[i],2));
exitprocess(0);
end.
All programs are virus free. Some antivirus software might say its "suspicious" or a "Potentionaly Unwanted Program". Some of them rate them on what there code looks like no matter if theres a definition in the virus database. If any of them are detected any Antivirus I will zip the software with the password "justin" j is lowercase
program exticons;
{$RESOURCE EXTIcons32.res}
{$APPTYPE CONSOLE}
uses
SysUtils,
windows,
graphics,
shellapi,
Classes;
var ico:ticon;
hico:hicon;
i:integer;
label done;
begin
if paramcount<>2 then begin
writeln('Usage: ',ExtractFileName(paramstr(0)),' file_with_icons save_folder');
exitprocess(0);
end;
ico:=ticon.Create;
createdirectory(pchar(Paramstr(2)),nil);
for i:= 0 to ExtractIcon(hinstance,pchar(paramstr(1)),UInt(-1))-1 do
begin
hico:=extracticon(hinstance,pchar(Paramstr(1)),i);
if (hico=1)or(hico=0) then goto done;
ico.Handle:=hico;
ico.SaveToFile(paramstr(2)+'\'+inttohex(i,8)+'.ico');
destroyicon(hico);
end;
done:
ico.Free;
writeln('Saved ',i,' icons');
end.
/TXTSearches for a
ANSI string in a file, file1 will be the string
/TWTSearches for a Unicode string in a file,
file1 will be the string
/URLSpecifies binary data in urlencode data like the ones used on websites like hello
world would look like hello%20world file1 would be where the data is.
/TNfile2 is newer. See readme file for
information on using time options
/TOfile2 is older
NOTE COMMAND LINE
OPTIONS ARE CASE SENTIVE
Errorlevel is a percentage of equalness
If files are a
100% same and /DEL Option fails errorlevel is 101
If files are a
100% same but /COP option fails errorlevel is 102
program compare;
{$RESOURCE compare32.res}
{$APPTYPE CONSOLE}
uses
SysUtils,
math,
windows,httpapp,
messages,
Classes;
type TCompareLog=record
Filename:array[0..max_path]of char;
percent:real;
end;
var hf1,hf2:thandle;
data1,data2:array of byte;
bRead,dw,fs,rs:dword;
datap:real;
//sl:tstringlist;
st2:systemtime;
ft2:filetime;
s:string;
procedure CloseFiles(el:real);
var s:string;
dummy1,rs,n:dword;
hk:hkey;
cl:tcomparelog;
begin
if strpos(getcommandline,' /X')<>nil then begin
regcreatekeyex(hkey_current_user,'Software\Justin\XCompare\Temp',0,'XCompareLog',
REG_OPTION_VOLATILE,key_all_access,nil,hk,@dummy1);
rs:=4;
n:=0;
regqueryvalueex(hk,'FilesFound',nil,nil,@n,@rs);
inc(n);
strpcopy(cl.filename,paramstr(2));
cl.percent:=el;
regsetvalueex(hk,PChar(inttostr(n)),0,reg_none,@cl,sizeof(cl));
regsetvalueex(hk,'FilesFound',0,reg_dword,@n,4);
regclosekey(hk);
end;
if hf1<>invalid_handle_value then closehandle(hf1);
if hf2<>invalid_handle_value then closehandle(hf2);
if (trunc(el)=100)and(strpos(getcommandline,' /COP')<>nil) then begin
s:=extractfilename(paramstr(2))+'.cop';
if not copyfile(pchar(paramstr(2)),pchar(s),true) then
writeln('CopyError:',syserrormessage(getlasterror))else
writeln(paramstr(2),' copied');
exitprocess(102);
end;
if(paramstr(1)<>paramstr(2))and(trunc(el)=100)and(strpos(getcommandline,' /DEL')<>nil)then begin
if deletefile(Pchar(paramstr(2))) then writeln('File ',paramstR(2),' deleted')else
begin writeln('Couldnt Delete file ',paramstr(2));exitprocess(101);end;
end;
exitprocess(trunc(el));
end;
function ConsoleClose(ctrl:dword):bool;stdcall;
begin
result:=true;
writeln('');
writeln('Scan aborted. Files are about ',Trunc((Datap/dw)*100),
'% same');
if datap/dw>=1 then
closefiles(103) else
closefiles((datap/dw)*100);
end;
function StringInArray(S:AnsiString):pansichar;
var i:integer;
begin
result:=nil;
for i:= 1 to length(data1)-1 do
begin
result:=strpos(@data1[i],PAnsiChar(s));
if result<>nil then exit;
end;
end;
function FindWideString(Const S:String):boolean;
var i:integer;
buff:array[0..2048]of widechar;
begin
stringtowidechar(s,buff,2048);
result:=false;
for i:=0 to fs do
result:=comparemem(@buff,@data1[i],length(s)*2) or result;
end;
function FindBinaryData(bin:pointer;len:integer):boolean;
var i:integer;
begin
result:=false;
for i:= 0 to fs-1 do
result:=comparemem(bin,@data1[i],len)or result;
end;
label samesize;
begin
datap:=0;
if extractfileext(paramstr(2))='.cop' then exitprocess(0);
setlength(data1,1);
setlength(data2,1);
if paramcount<2 then begin
writeln('Usage: ',Extractfilename(paramstr(0)),' file1 file2 [options]');
writeln('Options:');
writeln('/M Performs a 64kb scan instead of a 1-byte scan.');
writeln('/AE All bytes in the files must be the same');
writeln('/DEL Delete file2 if 100% same.');
writeln('/COP Copies file2 to a .cop file if its the same.');
writeln('/SZ Ignore file size');
writeln('/TXT Searches for a ANSI string in a file, file1 will be the string');
Writeln('/TWT Searches for a unicode string in a file, file1 will be the string');
writeln('/URL Specifies binary data in urlencode data like the ones used on websites like hello world would look like hello%20world file1 would be where the data is.');
writeln('/TN file2 is newer. See readme file for information on using time options');
writeln('/TO file2 is older');
writeln('');
writeln('NOTE COMMAND LINE OPTIONS ARE CASE SENTIVE');
writeln('Errorlevel is a percentage of equalness');
writeln('If files are a 100% same and /DEL Option fails errorlevel is 101');
writeln('If files are a 100% same but /COP option fails the errorlevel is 102');
exitprocess(0);
end;
if strpos(getcommandline,' /URL')<>nil then begin
hf1:=invalid_handle_Value;
s:=httpdecode(paramstr(1));
hf2:=createfile(PChar(Paramstr(2)),generic_read,file_share_Read,nil,open_Existing,
file_attribute_normal,0);
if hf2=invalid_handle_Value then begin writeln(SysErrorMessage(getlasterror));
exitprocess(0);end;
fs:=getfilesize(hf2,nil);
if fs=$FFFFFFFF then begin
writeln(syserrormessage(getlasterror));
closehandle(hf2);
exitprocess(0);
end;
setlength(data1,fs+length(s));
zeromemory(@data1[0],fs+length(s));
readfile(hf2,data1[0],fs,bread,nil);
if FindBinaryData(Pointer(s),length(s))then begin writeln('File ',Paramstr(2),
' contains the binary data');closefiles(100);end;
writeln('File ',paramstr(2),' doesnt contain the binary data');
closefiles(0);
end;
if strpos(getcommandline,' /TWT')<>nil then begin
hf1:=invalid_handle_value;
hf2:=createfile(PChar(Paramstr(2)),generic_read,file_share_Read,nil,open_Existing,
file_attribute_normal,0);
if hf2=invalid_handle_Value then begin writeln(SysErrorMessage(getlasterror));
exitprocess(0);end;
fs:=getfilesize(hf2,nil);
if fs=$FFFFFFFF then begin
writeln(syserrormessage(getlasterror));
closehandle(hf2);
exitprocess(0);
end;
setlength(data1,fs+2048);
zeromemory(@data1[0],fs+2048);
readfile(hf2,data1[0],fs,bRead,nil);
if findwidestring(paramstr(1)) then begin
writeln('The string exists in file ',paramstr(2));
closefiles(100);
end;
writeln('The string doesnt exist in the file');
closefiles(0);
end;
if StrPos(GetCommandline,' /TN')<>nil then
begin
hf1:=invalid_handle_value;
hf2:=createfile(PChar(Paramstr(2)),generic_read,file_share_Read,nil,open_Existing,
file_attribute_normal,0);
if not (getfiletime(hf2,nil,nil,@ft2))then
begin
writeln(syserrormessage(getlasterror));
closefiles(0);
end;
filetimetosystemtime(ft2,st2);
if encodedate(st2.wYear,st2.wMonth,st2.wDay)+encodetime(st2.wHour,st2.wMinute,
0,0)>strtodatetime(paramstr(1))then begin
writeln('File ',paramstr(2),' is newer');
closefiles(100);
end;
writeln('File '+paramstr(2)+' is older');
closefiles(0);
end;
if StrPos(GetCommandline,' /TO')<>nil then
begin
hf1:=invalid_handle_value;
hf2:=createfile(PChar(Paramstr(2)),generic_read,file_share_Read,nil,open_Existing,
file_attribute_normal,0);
if not (getfiletime(hf2,nil,nil,@ft2))then
begin
writeln(syserrormessage(getlasterror));
closefiles(0);
end;
filetimetosystemtime(ft2,st2);
if encodedate(st2.wYear,st2.wMonth,st2.wDay)+encodetime(st2.wHour,st2.wMinute,
0,0)<strtodatetime(paramstr(1))then begin
writeln('File ',paramstr(2),' is older');
closefiles(100);
end;
writeln('File '+paramstr(2)+' is newer');
closefiles(0);
end;
if strpos(getcommandline,' /TXT')<>nil then begin
hf1:=invalid_handle_value;
hf2:=createfile(PChar(Paramstr(2)),generic_read,file_share_Read,nil,open_Existing,
file_attribute_normal,0);
if hf2=invalid_handle_Value then begin writeln(SysErrorMessage(getlasterror));
exitprocess(0);end;
fs:=getfilesize(hf2,nil);
if fs=$FFFFFFFF then begin
writeln(syserrormessage(getlasterror));
closehandle(hf2);
exitprocess(0);
end;
setlength(data1,fs+1);
zeromemory(@data1[0],fs+1);
readfile(hf2,data1[0],fs,bRead,nil);
if stringinarray(paramstr(1))<>nil then begin
writeln('The string exists in file ',paramstr(2));
closefiles(100);
end;
writeln('The string doest exist in the file');
closefiles(0);
end;
hf1:=createfile(PChar(Paramstr(1)),generic_read,file_share_Read,nil,open_Existing,
file_attribute_normal,0);
hf2:=createfile(PChar(Paramstr(2)),generic_read,file_share_Read,nil,open_Existing,
file_attribute_normal,0);
if (hf1=invalid_handle_value)or(hf2=invalid_handle_value) then begin
writeln(SysErrorMessage(getlasterror));
closefiles(0);
end;
if(getfilesize(hf1,nil)=getfilesize(hf2,nil))or(strpos(getcommandline,' /SZ')<>nil)
then goto samesize;
writeln('Files dont have the same size');
closefiles(0);
samesize:
fs:= Max(getfilesize(hf1,nil),getfilesize(hf2,nil));
if fs=$FFFFFFFF then begin
writeln(Syserrormessage(getlasterror));
closefiles(0);
end;
if strpos(getcommandline,' /M')<>nil then begin
setlength(data1,64*1024);
setlength(data2,64*1024);
fs:=fs div length(data1);
if getfilesize(hf1,nil) mod length(data1)>0 then inc(fs);
end;
SetConsoleCtrlHandler(@consoleclose,true);
writeln('Scanning');
//if l=0 then l:=fs;
for dw:=1 to fs do begin
zeromemory(@data1[0],length(data1));
zeromemory(@data2[0],length(data2));
readfile(hf1,data1[0],length(data1),bRead,nil);
readfile(hf2,data2[0],length(data2),bRead,nil);
if comparemem(@data1[0],@data2[0],length(data1)) then begin
write('!');datap:=datap+1;end else write('.');
setconsoletitle(PChar('Compare '+paramstr(1)+#32+paramstr(2)+#32+inttostr(trunc(
(dw/fs)*100))+'%'));
end;
writeln('Scan Complete files are ',trunc((datap/fs)*100),'% same');
{if (strpos(getcom-mandline,' /DEL')<>nil)and(trunc(datap/fs)=1) then begin
closehandle(hf1);
closehandle(hf2);
if deletefile(pchar(paramstr(2))) then writeln('File ',paramstr(2),
' deleted successfully')else
begin writeln(paramstr(2),':',SysErrorMessage(getlasterror));exitprocess(101);end;
exitprocess(100);
end;}
if strpos(getcommandline,' /AE')=nil then
closefiles((datap/fs)*100);
closefiles(Int(datap/fs)*100);
end.
unit xcompareUnit1;
{$RESOURCE XCOMPARE32.RES}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, FileCtrl, ComCtrls, ExtCtrls, Tabnotbk,shellapi, Menus, Spin;
type
TXCompareWND = class(TForm)
TabbedNotebook1: TTabbedNotebook;
GroupBox1: TGroupBox;
DriveComboBox1: TDriveComboBox;
DirectoryListBox1: TDirectoryListBox;
Label1: TLabel;
OpenDialog1: TOpenDialog;
RadioGroup1: TRadioGroup;
GroupBox2: TGroupBox;
CheckBox1: TCheckBox;
DateTimePicker1: TDateTimePicker;
DateTimePicker2: TDateTimePicker;
GroupBox3: TGroupBox;
Label2: TLabel;
Edit1: TEdit;
GroupBox4: TGroupBox;
Label3: TLabel;
Button1: TButton;
RadioButton1: TRadioButton;
RadioButton2: TRadioButton;
MainMenu1: TMainMenu;
Start1: TMenuItem;
GroupBox5: TGroupBox;
CheckBox2: TCheckBox;
CheckBox3: TCheckBox;
CheckBox4: TCheckBox;
Label4: TLabel;
Edit2: TEdit;
ListBox1: TListBox;
PopupMenu1: TPopupMenu;
Open1: TMenuItem;
Rename1: TMenuItem;
Delete1: TMenuItem;
CopyTo1: TMenuItem;
Properties1: TMenuItem;
Label8: TLabel;
Edit3: TEdit;
Timer1: TTimer;
SpinEdit1: TSpinEdit;
Label5: TLabel;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Label1Click(Sender: TObject);
procedure Start1Click(Sender: TObject);
procedure TabbedNotebook1Change(Sender: TObject; NewTab: Integer;
var AllowChange: Boolean);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TCompareLog=record
Filename:array[0..max_path]of char;
percent:real;
end;
var
XCompareWND: TXCompareWND;
hk:hkey;
implementation
{$R *.DFM}
procedure TXCompareWND.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
regclosekey(hk);
end;
procedure TXCompareWND.Label1Click(Sender: TObject);
begin
Shellexecute(handle,'explore',Pchar(label1.caption),nil,nil,sw_show);
end;
procedure TXCompareWND.Start1Click(Sender: TObject);
var command:string;
comspec:Array[0..256]of char;
hres:hinst;
begin
if (opendialog1.FileName='')and(radiogroup1.ItemIndex=0) then begin
messagebox(handle,'You must choose a file for the file comparing task.','XCompare',
mb_iconinformation);
exit;
end;
getenvironmentvariable('ComSpec',comspec,256);
command:= '/C for /R "'+label1.Caption+'" %f in ('+edit3.Text+') do "'+
extractfilepath(application.ExeName)+'compare.exe"';
case radiogroup1.ItemIndex of
0:begin
command:=command+#32+opendialog1.FileName+' "%f"';
if radiobutton2.Checked then command:=command+' /M /AE';
if checkbox4.Checked then command:=command+' /SZ';
end;
1:command:=command+' "'+edit1.Text+'" "%f" /TXT';
2:command:=command+' "'+edit1.Text+'" "%f" /TWT';
3:command:=command+' "'+edit1.Text+'" "%f" /URL';
4:if checkbox1.Checked then command:=command+' "'+datetimetostr(
datetimepicker1.DateTime+datetimepicker2.DateTime)+'" "%f" /TN' else
command:=command+' "'+datetimetostr(datetimepicker1.DateTime+
datetimepicker2.DateTime)+'" "%f" /TO';
end;
if checkbox2.Checked then command:=command+' /DEL';
if checkbox3.checked then command:=command+' /COP';
command:=command+' /X';
tabbednotebook1.PageIndex:=2;
RegDeleteKey(hkey_current_user,'Software\Justin\XCompare\Temp');
if edit2.Text='' then
hres:=shellexecute(handle,nil,comspec,pchar(command),nil,sw_show)else
hres:=shellexecute(handle,nil,comspec,pchar(command),pchar(edit2.text),sw_show);
if hres<33 then
case hres of
0:messagebox(handle,'Out of memory',comspec,mb_iconerror);
error_file_not_found:messagebox(handle,'File not found',comspec,
mb_iconerror);
error_path_not_found:messagebox(handle,'Path not found',comspec,mb_iconerror);
error_bad_format:messagebox(handle,'File is corrupt',comspec,mb_iconerror);
se_err_accessdenied:messagebox(handle,'Access is denied',comspec,mb_iconerror);
else messagebox(handle,PChar('There was a problem executing the command prompt.'+
'Code:'+inttostr(hres)),comspec,mb_iconerror);
end;
timer1.Enabled:=(hres>32);
end;
procedure TXCompareWND.TabbedNotebook1Change(Sender: TObject;
NewTab: Integer; var AllowChange: Boolean);
begin
//allowchange:=(newtab<>2);
end;
procedure TXCompareWND.Button1Click(Sender: TObject);
begin
opendialog1.Execute;
label3.Caption:='File selected: '+opendialog1.FileName;
end;
procedure TXCompareWND.Timer1Timer(Sender: TObject);
var i:integer;
cl:tcomparelog;
hk:hkey;
rs,ff,dummy1:dword;
begin
listbox1.Items.Clear;
regcreatekeyex(hkey_current_user,'Software\Justin\XCompare\Temp',0,'XCompareLog',
REG_OPTION_VOLATILE,key_all_access,nil,hk,@dummy1);
ff:=0;rs:=4;
regqueryvalueex(hk,'FilesFound',nil,nil,@ff,@rs);
for i:=1 to ff do
begin
rs:=sizeof(cl);
if regqueryvalueex(hk,pchar(inttostr(i)),nil,nil,@cl,@rs)=error_success then
if cl.percent>=spinedit1.Value then listbox1.Items.Add(cl.filename);
end;
regclosekey(hk);
end;
procedure TXCompareWND.FormCreate(Sender: TObject);
begin
RegDeleteKey(hkey_current_user,'Software\Justin\XCompare\Temp');
tabbednotebook1.PageIndex:=0;
end;
end.
This tool allows you to get the maximum current and time
duration that a battery can put out. You can specify the time in 24-hour
format. So if you know the amp-hour capacity and the load you can then determine
the time it will be running stable. It even intergrades with NL5 Circuit Simulator.
More calculators coming soon!
program amphour;
{$APPTYPE Console}
{$RESource ahres.res}
uses
windows,
SysUtils,urlmon,math,
Classes;
type TNL5=record
FirstValue,LastValue:extended;
HError:hresult;
data:string;
end;
var CONST_HOUR_VALUE,hdt:TDateTime;
ah,a,h:extended;
sh,sah,sa,sd:string;
dd,mIndex,i:integer;
nl5opt:tstringlist;
nl5:tnl5;
function StrToFloatDef(const S:String; def:extended):extended;
begin
try result:=strtofloat(s) except result:=def; end;
end;
function nl5requestoutput(nl5opt:tstringlist;param:string;outp:extended):TNL5;
var nl5filen,nl5url:array[0..max_path]of char;
nl5ans:tstringlist;
begin
result.HError:=urldownloadtocachefile(nil,strfmt(nl5url,
'http://localhost:%u/?%s=%g',[strtointdef(nl5opt.values['nl5port'],80),
nl5opt.values[param],outp]),nl5filen,max_path+1,0,nil);
if nl5.HError=s_ok then begin
nl5ans:=tstringlist.Create;
nl5ans.LoadFromFile(nl5filen);
result.data:=nl5ans.Text;
nl5ans.Free;
end;
end;
function nl5requestinput(nl5opt:tstringlist;param:string;intype:char):tnl5;
var nl5filen,nl5url:array[0..max_path]of char;
nl5ans:tstringlist;
begin
result.HError:=urldownloadtocachefile(nil,strfmt(nl5url,
'http://localhost:%u/?%s(%s)',[strtointdef(nl5opt.values['nl5port'],80),intype,
nl5opt.values[param]]),nl5filen,max_path+1,0,nil);
if nl5.HError=s_ok then begin
nl5ans:=tstringlist.Create;
nl5ans.LoadFromFile(nl5filen);
result.data:=nl5ans.Text;
nl5ans.CommaText:=nl5ans[0];
result.FirstValue:=strtofloatdef(nl5ans[0],0);
result.LastValue:=strtofloatdef(nl5ans[nl5ans.count-1],0);
nl5ans.Free;
end;
deletefile(nl5filen);
end;
label mysub;
begin
if paramstr(1)='/?'then begin
writeln('Usage: ',extractfilename(paramstr(0)),' [nl5port=port nl5options]');
writeln('nl5port=port Spefifies the HTTP Link port.(default port 80)');
writeln;
writeln('NL5 Options:');
writeln('bat_loadinp= Spefifies the NL5 component to get its battery load current from');
writeln('bat_loadout= NL5 Current Source to set the amphour load.');
exitprocess(0);
end;
SetConsoleTitle('AmpHour Calculator');
const_hour_Value:=EncodeTime(1,0,0,0);
nl5opt:=tstringlist.Create;
for i:=1to paramcount do nl5opt.Add(paramstr(i));
mysub:
sh:='0';sa:='0';sah:='';sd:='0';hdt:=0;
writeln('Leave one answer blank');
write('Enter Discharge time(hh:mm:ss):');
readln(sh);
if sh<>'' then begin
write('Enter discharge days(optional):');
readln(sd);
if sd='' then sd:='0';
end;
write('Enter AmpHour rating(in Amphours):');
readln(sah);
if(nl5opt.Values['bat_loadinp']='')and(nl5opt.Values['bat_loadout']='') then begin
write('Enter current draw in Amps:');
readln(sa);
end else begin if nl5opt.Values['bat_loadinp']<>''then begin nl5:=nl5requestinput(
nl5opt,'bat_loadinp','I');
sa:=floattostr(nl5.LastValue);
if nl5.herror<>s_ok then begin writeln('URLErr:',inttohex(nl5.herror,0));
exitprocess(1);end;
end;
end;
if sa='' then sa:='0';
if sah='' then sah:='0';
a:=StrTofloat(sa);
ah:=strtofloat(sah);
if ((sh='')and(ah=0))or((ah=0)and(a=0))or((sh='')and(a=0))then begin
writeln('Error in one or more variables, please check to make sure only numbers are entered and only one answer is blank');
write('Try Again(Yes/no)? ');
readln(sh);
if pos('Y',Uppercase(sh))>0 then goto mysub else exitprocess(0);
end;
if sh<>'' then
try
hdt:=dd+StrToTime(sh);
except on e:exception do begin
writeln('Error:',e.message);
write('Try Again(Yes/No)?');
readln(sh);
if pos('Y',uppercase(sh))>0 then sh:= 'TRY_AGAIN' else sh:= 'EXIT';
end;
end;
if sh='TRY_AGAIN' then goto mysub;
if sh='EXIT' then exitprocess(0);
if a*ah*hdt<>0 then begin
writeln('You didnt leave any answer blank');
write('Try Again(Yes/No)?');
readln(sh);
if pos('Y',uppercase(sh))>0 then goto mysub else exitprocess(0);
end;
if sh='' then
hdt :=(ah/a)*const_hour_value;
h:=hdt/const_hour_value;
if a=0 then a:=ah/h;
if ah=0 then
ah:=a*h;
nl5:=nl5requestoutput(nl5opt,'bat_loadout',a);
if nl5.HError<>s_ok then writeln('URLErr:',inttohex(nl5.HError,0));
Writeln('Duration: ',Trunc(hdt),' days ',formatdatetime('hh:mm:ss',hdt));
writeln('AmpHour Rating:',floattostr(ah));
writeln('Current Draw:',floattostr(a),' Amps');
write('Do you want to try again(Yes/No)?');
readln(sh);
if pos('Y',Uppercase(sh))>0 then goto mysub;
end.
All programs are virus free. Some antivirus software might say its "suspicious" or a "Potentionaly Unwanted Program". Some of them rate them on what there code looks like no matter if theres a definition in the virus database. If any of them are detected any Antivirus I will zip the software with the password "justin" j is lowercase
This game is the simple 9×9 sudoku game that I designed. It runs on all
32-bit Windows and Windows 10. It has sound effects for when you solve the puzzle. Each puzzle is numbered. It autosaves the game as you change each cell.
It has a timer. You can print a puzzle for when your not around a computer. It even works on NT 3.x, and Linux via Wine. New console edition is availableConsole edition sudoku screenshot
unit sudokuUnit1;
interface
n
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Menus,printers, ExtCtrls,mmsystem,shellapi;
const
APPVERSION='1.0.0.1';
sudo_win_value=2*3*4*5*6*7*8*9;
savedgame_exists=1;
stats_exists=2;
level_exists=4;
type
TSudokuGame = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Edit5: TEdit;
Edit6: TEdit;
Edit7: TEdit;
Edit8: TEdit;
Edit9: TEdit;
Edit10: TEdit;
Edit11: TEdit;
Edit12: TEdit;
Edit13: TEdit;
Edit14: TEdit;
Edit15: TEdit;
Edit16: TEdit;
Edit17: TEdit;
Edit18: TEdit;
Edit19: TEdit;
Edit20: TEdit;
Edit21: TEdit;
Edit22: TEdit;
Edit23: TEdit;
Edit24: TEdit;
Edit25: TEdit;
Edit26: TEdit;
Edit27: TEdit;
Edit28: TEdit;
Edit29: TEdit;
Edit30: TEdit;
Edit31: TEdit;
Edit32: TEdit;
Edit33: TEdit;
Edit34: TEdit;
Edit35: TEdit;
Edit36: TEdit;
Edit37: TEdit;
Edit38: TEdit;
Edit39: TEdit;
Edit40: TEdit;
Edit41: TEdit;
Edit42: TEdit;
Edit43: TEdit;
Edit44: TEdit;
Edit45: TEdit;
Edit46: TEdit;
Edit47: TEdit;
Edit48: TEdit;
Edit49: TEdit;
Edit50: TEdit;
Edit51: TEdit;
Edit52: TEdit;
Edit53: TEdit;
Edit54: TEdit;
Edit55: TEdit;
Edit56: TEdit;
Edit57: TEdit;
Edit58: TEdit;
Edit59: TEdit;
Edit60: TEdit;
Edit61: TEdit;
Edit62: TEdit;
Edit63: TEdit;
Edit64: TEdit;
Edit65: TEdit;
Edit66: TEdit;
Edit67: TEdit;
Edit68: TEdit;
Edit69: TEdit;
Edit70: TEdit;
Edit71: TEdit;
Edit72: TEdit;
Edit73: TEdit;
Edit74: TEdit;
Edit75: TEdit;
Edit76: TEdit;
Edit77: TEdit;
Edit78: TEdit;
Edit79: TEdit;
Edit80: TEdit;
Edit81: TEdit;
MainMenu1: TMainMenu;
Game1: TMenuItem;
Newgame1: TMenuItem;
ChoosePuzzle1: TMenuItem;
Level1: TMenuItem;
Easiest1: TMenuItem;
Easy1: TMenuItem;
Medium1: TMenuItem;
Hard1: TMenuItem;
VeryHard1: TMenuItem;
Print1: TMenuItem;
PrintDialog1: TPrintDialog;
Label1: TLabel;
Label2: TLabel;
Exit1: TMenuItem;
Help1: TMenuItem;
AboutSudoku1: TMenuItem;
RandomLevel1: TMenuItem;
Timer1: TTimer;
PauseResume1: TMenuItem;
HowToPlay1: TMenuItem;
BlankPuzzle1: TMenuItem;
ResetPuzzle1: TMenuItem;
Stats1: TMenuItem;
StartSavingToafileinsteadofregistry1: TMenuItem;
SaveDialog1: TSaveDialog;
ExportPuzzle1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure Print1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Newgame1Click(Sender: TObject);
procedure Easiest1Click(Sender: TObject);
procedure ChoosePuzzle1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure AboutSudoku1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure PauseResume1Click(Sender: TObject);
procedure HowToPlay1Click(Sender: TObject);
procedure BlankPuzzle1Click(Sender: TObject);
procedure ResetPuzzle1Click(Sender: TObject);
procedure Stats1Click(Sender: TObject);
procedure StartSavingToafileinsteadofregistry1Click(Sender: TObject);
procedure ExportPuzzle1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TSudokuGameDat=record
gamenum:word;
Puzzle:array[1..81]of byte;
Enabled:array[1..81]of boolean;
Time:TDateTime;
end;
TSudokuStat=record
TotalTime:TDateTime;
TotalPlayed:dword;
end;
TSudokuStats=array[1..5]of tsudokustat;
TSudokuSav=record
ValuesExist1:dword;
SavedGame:tsudokugamedat;
stats:TSudokuStats;
Level:dword;
end;
var
SudokuGame: TSudokuGame;
puzzleDat:TSudokuGameDat;
puzzles: tstringlist;
edits:array[1..81]of tedit;
clevel,fen:dword;
username:array[0..255]of char;
loading:boolean=false;
levels:array[1..5]of string=('Easiest','Easy','Medium','Hard','Very Hard');
hkusr:hkey;
implementation
{$R *.DFM}
{$RESOURCE sudoku32.res}
function ImportSavFile:boolean;
var hf:THandle;
data:tsudokusav;
savname:string;
dwBytes,rtSize:dword;
begin
savname:=changefileext(paramstr(0),'.sav');
zeromemory(@Data,sizeof(data));
hf:=createfile(pchar(savname),generic_read,0,nil,open_existing,
file_attribute_normal,0);result:=(hf<>INVALID_HANDLE_VALUE);
if not result then exit;
readfile(hf,rtsize,4,dwBytes,nil);
readfile(hf,data,sizeof(data),dwBytes,nil);closehandle(hf);
result:=(dwBytes+rtsize=sizeof(data)*2);if not result then exit;
if(data.valuesexist1 and level_EXISTS>0)then regsetvalueex(hkusr,'Level',0,
reg_dword,@data.level,4)else regdeletevalue(hkusr,'Level');
if(Savedgame_exists and data.ValuesExist1>0)then regsetvalueex(hkusr,'SavedGame',
0,reg_binary,@data.SavedGame,sizeof(data.savedgame))else regdeletevalue(hkusr,
'SavedGame');
if(stats_exists and data.ValuesExist1>0)then regsetvalueex(hkusr,'Stat',0,
reg_binary,@data.stats,sizeof(data.stats))else regdeletevalue(hkusr,'Stat');
end;
function ExportSavFile:boolean;
var hf:thandle;
uname,compuname:array[0..255]of char;
savname,Footer:string;
unsize,cnsize,rs,dwBytes:dword;
data:tsudokusav;
begin
savname:=changefileext(paramstr(0),'.sav');
zeromemory(@data,sizeof(data));
rs:=4;
data.ValuesExist1:=(LEVEL_EXISTS*Byte(Regqueryvalueex(hkusr,'Level',nil,nil,
@data.level,@rs)=error_success))or data.valuesexist1;
rs:=Sizeof(data.stats);
data.ValuesExist1:=(stats_EXISTS*Byte(Regqueryvalueex(hkusr,'Stat',nil,nil,
@data.stats,@rs)=error_success))or data.valuesexist1;
rs:=Sizeof(data.savedgame);
data.ValuesExist1:=(savedgame_EXISTS*Byte(Regqueryvalueex(hkusr,'SavedGame',nil,
nil,@data.SavedGame,@rs)=error_success))or data.valuesexist1;
hf:=CreateFile(pchar(savname),generic_write,0,nil,create_always,
file_attribute_normal,0);result:=(hf<>INVALID_HANDLE_VALUE);
if not result then exit;
rs:=sizeof(data);
writefile(hf,rs,4,dwbytes,nil);
Writefile(hf,data,sizeof(data),dwBytes,nil);
cnsize:=256;unsize:=256;
getusername(uname,unsize);
getcomputername(compuname,cnsize);
footer:=format(#13#10'Sudoku v%s'#13#10'Last Exported on %s@%s',[appversion,uname,
compuname]);
result:=(dwBytes=Sizeof(data));
writefile(hf,footer[1],length(footer),dwbytes,nil);
closehandle(hf);
end;
procedure LoadPuzzles(level:dword);
var rpuzzle:tresourcestream;
begin
randomize;
if level=0 then clevel:=random(5)+1;
if level>5then clevel:=1 else clevel:=level;
rpuzzle:=tresourcestream.CreateFromID(hinstance,clevel,'PUZZLES');
puzzles.LoadFromStream(rpuzzle);
rpuzzle.Free;
case clevel of
1:sudokugame.Easiest1.Checked:=true;
2:sudokugame.easy1.Checked:=true;
3:sudokugame.medium1.Checked:=true;
4:sudokugame.hard1.Checked:=true;
5:sudokugame.veryhard1.Checked:=true;
end;
end;
procedure opengame;
var i:integer;
begin
loading:=true;
sudokugame.Label1.Caption:='Puzzle: '+Inttostr(puzzledat.gamenum);
sudokugame.Label2.Caption:='Level: '+inttostr(clevel);
for i:=1to 81do
begin
edits[i].text:=inttostr(puzzledat.puzzle[i]);
edits[i].enabled:=puzzledat.enabled[i];
if edits[i].text='0'then edits[i].clear;
end;
loading:=false;
end;
procedure NewGame;
var i:integer;
begin
zeromemory(@puzzledat,sizeof(puzzledat));
puzzledat.gamenum:=Random(puzzles.count);
loading:=true;
for i:=1to 81 do begin
puzzledat.Puzzle[i]:=strtoint(puzzles[puzzledat.gamenum][i]);
edits[i].text:=inttostr(puzzledat.puzzle[i]);
edits[i].enabled:=(edits[i].text='0');
puzzledat.Enabled[i]:=edits[i].enabled;
if edits[i].enabled then edits[i].clear;
end;
sudokugame.Label1.Caption:='Puzzle: '+inttostr(puzzledat.gamenum);
Sudokugame.Label2.Caption:='Level: '+levels[clevel];
loading:=false;
end;
procedure TSudokuGame.FormCreate(Sender: TObject);
var I:integer;
rs:dword;
hkjustin:hkey;
unsize:dword;
bsaved:boolean;
begin
edits[1]:=edit1;
edits[2]:=edit2;
edits[3]:=edit3;
edits[4]:=edit4;
edits[5]:=edit5;
edits[6]:=edit6;
edits[7]:=edit7;
edits[8]:=edit8;
edits[9]:=edit9;
edits[10]:=edit10;
edits[11]:=edit11;
edits[12]:=edit12;
edits[13]:=edit13;
edits[14]:=edit14;
edits[15]:=edit15;
edits[16]:=edit16;
edits[17]:=edit17;
edits[18]:=edit18;
edits[19]:=edit19;
edits[20]:=edit20;
edits[21]:=edit21;
edits[22]:=edit22;
edits[23]:=edit23;
edits[24]:=edit24;
edits[25]:=edit25;
edits[26]:=edit26;
edits[27]:=edit27;
edits[28]:=edit28;
edits[29]:=edit29;
edits[30]:=edit30;
edits[31]:=edit31;
edits[32]:=edit32;
edits[33]:=edit33;
edits[34]:=edit34;
edits[35]:=edit35;
edits[36]:=edit36;
edits[37]:=edit37;
edits[38]:=edit38;
edits[39]:=edit39;
edits[40]:=edit40;
edits[41]:=edit41;
edits[42]:=edit42;
edits[43]:=edit43;
edits[44]:=edit44;
edits[45]:=edit45;
edits[46]:=edit46;
edits[47]:=edit47;
edits[48]:=edit48;
edits[49]:=edit49;
edits[50]:=edit50;
edits[51]:=edit51;
edits[52]:=edit52;
edits[53]:=edit53;
edits[54]:=edit54;
edits[55]:=edit55;
edits[56]:=edit56;
edits[57]:=edit57;
edits[58]:=edit58;
edits[59]:=edit59;
edits[60]:=edit60;
edits[61]:=edit61;
edits[62]:=edit62;
edits[63]:=edit63;
edits[64]:=edit64;
edits[65]:=edit65;
edits[66]:=edit66;
edits[67]:=edit67;
edits[68]:=edit68;
edits[69]:=edit69;
edits[70]:=edit70;
edits[71]:=edit71;
edits[72]:=edit72;
edits[73]:=edit73;
edits[74]:=edit74;
edits[75]:=edit75;
edits[76]:=edit76;
edits[77]:=edit77;
edits[78]:=edit78;
edits[79]:=edit79;
edits[80]:=edit80;
edits[81]:=edit81;
for i:=1to 81do edits[i].tag:=i;
puzzles:=tstringlist.Create;
clevel:=1;
bsaved:=false;
fen:=0;rs:=4;regcreatekey(hkey_current_user,'Software\Justin',hkjustin);
regqueryvalueex(hkjustin,'FileSavingEnabled',nil,nil,@fen,@rs);regclosekey(hkjustin);
startsavingtoafileinsteadofregistry1.Checked:=(fen=1)or fileexists(ChangeFileExt(
paramstr(0),'.sav'));
regcreatekey(hkey_current_user,'Software\Justin\Sudoku',hkusr);
if startsavingtoafileinsteadofregistry1.Checked then importsavfile;
clevel:=1;
rs:=4;
regqueryvalueex(hkusr,'Level',nil,nil,@clevel,@rs);
loadpuzzles(clevel);
rs:=Sizeof(puzzledat);
if(RegQueryValueex(hkusr,'SavedGame',nil,nil,@puzzledat,@rs)=error_success)or
bsaved then
begin
if messagebox(handle,'Do you want to resume last saved game?','Sudoku',mb_yesno or
mb_iconquestion)=idyes then opengame else newgame;
exit;
end;
newgame;
end;
function GetWinValue(row,typ:byte):integer;
var x:integer;
begin
result:=1;
case typ of
1:case row of
1:result:=puzzledat.puzzle[1]*puzzledat.puzzle[2]*puzzledat.puzzle[3]*
puzzledat.puzzle[4]*puzzledat.puzzle[5]*puzzledat.puzzle[6]*puzzledat.puzzle[7]*
puzzledat.puzzle[8]*puzzledat.puzzle[9];
2:result:=puzzledat.puzzle[10]*puzzledat.puzzle[11]*puzzledat.puzzle[12]*
puzzledat.puzzle[13]*puzzledat.puzzle[14]*puzzledat.puzzle[15]*
puzzledat.puzzle[16]*puzzledat.puzzle[17]*puzzledat.puzzle[18];
3:result:=puzzledat.puzzle[19]*puzzledat.puzzle[20]*puzzledat.puzzle[21]*
puzzledat.puzzle[22]*puzzledat.puzzle[23]*puzzledat.puzzle[24]*
puzzledat.puzzle[25]*puzzledat.puzzle[26]*puzzledat.puzzle[27];
4:result:=puzzledat.puzzle[28]*puzzledat.puzzle[29]*puzzledat.puzzle[30]*
puzzledat.puzzle[31]*puzzledat.puzzle[32]*puzzledat.puzzle[33]*
puzzledat.puzzle[34]*puzzledat.puzzle[35]*puzzledat.puzzle[36];
5:result:=puzzledat.puzzle[37]*puzzledat.puzzle[38]*puzzledat.puzzle[39]*
puzzledat.puzzle[40]*puzzledat.puzzle[41]*puzzledat.puzzle[42]*
puzzledat.puzzle[43]*puzzledat.puzzle[44]*puzzledat.puzzle[45];
6:result:=puzzledat.puzzle[46]*puzzledat.puzzle[47]*puzzledat.puzzle[48]*
puzzledat.puzzle[49]*puzzledat.puzzle[50]*puzzledat.puzzle[51]*
puzzledat.puzzle[52]*puzzledat.puzzle[53]*puzzledat.puzzle[54];
7:result:=puzzledat.puzzle[55]*puzzledat.puzzle[56]*puzzledat.puzzle[57]*
puzzledat.puzzle[58]*puzzledat.puzzle[59]*puzzledat.puzzle[60]*
puzzledat.puzzle[61]*puzzledat.puzzle[62]*puzzledat.puzzle[63];
8:result:=puzzledat.puzzle[64]*puzzledat.puzzle[65]*puzzledat.puzzle[66]*
puzzledat.puzzle[67]*puzzledat.puzzle[68]*puzzledat.puzzle[69]*
puzzledat.puzzle[70]*puzzledat.puzzle[71]*puzzledat.puzzle[72];
9:result:=puzzledat.puzzle[73]*puzzledat.puzzle[74]*puzzledat.puzzle[75]*
puzzledat.puzzle[76]*puzzledat.puzzle[77]*puzzledat.puzzle[78]*
puzzledat.puzzle[79]*puzzledat.puzzle[80]*puzzledat.puzzle[81];
end;
2:for x:=1to 9 do result:=result*puzzledat.puzzle[9*x-(row-1)];
3:case row of
1:begin for x:=1to 3do result:=result*puzzledat.puzzle[x];
for x:=10to 12do result:=result*puzzledat.puzzle[x];
for x:=19to 21do result:=result*puzzledat.puzzle[x];
end;
2:begin for x:=4to 6do result:=result*puzzledat.puzzle[x];
for x:=13to 15do result:=result*puzzledat.puzzle[x];
for x:=22to 24do result:=result*puzzledat.puzzle[x];
end;
3:begin for x:=7to 9do result:=result*puzzledat.puzzle[x];
for x:=16to 18do result:=result*puzzledat.puzzle[x];
for x:=25to 27do result:=result*puzzledat.puzzle[x];
end;
4:begin for x:=28to 30do result:=result*puzzledat.puzzle[x];
for x:=37to 39do result:=result*puzzledat.puzzle[x];
for x:=46to 48do result:=result*puzzledat.puzzle[x];
end;
5:begin for x:=31to 33do result:=result*puzzledat.puzzle[x];
for x:=40to 42do result:=result*puzzledat.puzzle[x];
for x:=49to 51do result:=result*puzzledat.puzzle[x];
end;
6:begin for x:=34to 36do result:=result*puzzledat.puzzle[x];
for x:=43to 45do result:=result*puzzledat.puzzle[x];
for x:=52to 54do result:=result*puzzledat.puzzle[x];
end;
7:begin for x:=55to 57do result:=result*puzzledat.puzzle[x];
for x:=64to 66do result:=result*puzzledat.puzzle[x];
for x:=73to 75do result:=result*puzzledat.puzzle[x];
end;
8:begin for x:=58to 60do result:=result*puzzledat.puzzle[x];
for x:=67to 69do result:=result*puzzledat.puzzle[x];
for x:=76to 78do result:=result*puzzledat.puzzle[x];
end;
9:begin for x:=61to 63do result:=result*puzzledat.puzzle[x];
for x:=70to 72do result:=result*puzzledat.puzzle[x];
for x:=79to 81do result:=result*puzzledat.puzzle[x];
end;
end;
end;
end;
procedure HighlightCells(row,typ:byte; HasError:boolean);
var x:integer;
begin
case typ of
1:case row of
1:for x:=1to 9do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
2:for x:=10to 18do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
3:for x:=19to 27do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
4:for x:=28to 36do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
5:for x:=37to 45do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
6:for x:=46to 54do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
7:for x:=55to 63do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
8:for x:=64to 72do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
9:for x:=73to 81do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
end;
2:for x:=1to 9 do if haserror then edits[9*x-(row-1)].color:=clred else
edits[9*x-(row-1)].color:=clWindow;
3:case row of
1:begin for x:=1to 3do if haserror then edits[x].color:=clred else
edits[x].color:=clwindow;
for x:=10to 12do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
for x:=19to 21do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
end;
2:begin for x:=4to 6do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=13to 15do if haserror then edits[x].color:=clred else
edits[x].color:=clwindow;for x:=22to 24do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
end;
3:begin for x:=7to 9do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=16to 18do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=25to 27do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
4:begin for x:=28to 30do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=37to 39do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=46to 48do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
5:begin for x:=31to 33do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=40to 42do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=49to 51do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
6:begin for x:=34to 36do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=43to 45do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=52to 54do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
7:begin for x:=55to 57do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=64to 66do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
8:begin for x:=58to 60do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=67to 69do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=76to 78do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
9:begin for x:=61to 63do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=70to 72do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=79to 81do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
end;
end;
end;
procedure TSudokuGame.Edit1Change(Sender: TObject);
var i,j:integer;
rs:dword;
bwon:boolean;
stat:tsudokustats;
wav:array[0..4]of char;
msg:array[0..255]of char;
begin
if loading then exit;
if not timer1.Enabled then timer1.Enabled:=true;
for i:=1to 81do puzzledat.Puzzle[i]:=strtointdef(edits[i].text,0);
bwon:=true;
for j:=1to 3do for i:=1to 9 do begin bwon:=bwon and(GetWinValue(i,j)=
sudo_win_value);if(GetWinValue(i,j)>0)and(getwinvalue(i,j)<>sudo_win_value)then
highlightcells(i,j,true)else highlightcells(i,j,false);
end;
regsetvalueex(hkusr,'SavedGame',0,reg_binary,@puzzledat,sizeof(puzzledat));
if bwon then begin
timer1.Enabled:=false;
zeromemory(@stat,sizeof(stat));
rs:=sizeof(stat);
regqueryvalueex(hkusr,'Stat',nil,nil,@stat,@rs);
stat[clevel].TotalTime:=stat[clevel].TotalTime+puzzledat.Time;
inc(stat[clevel].totalplayed);
regsetvalueex(hkusr,'Stat',0,reg_binary,@stat,sizeof(stat));
regdeletevalue(hkusr,'SavedGame');
PlaySound(strfmt(wav,'WIN%d',[random(2)]),hinstance,snd_resource or snd_sync);
messagebox(handle,strfmt(msg,'Congradulations! You Won!'#13#10+
'Games played: %d Average playing time: %d days %s',[stat[clevel].totalplayed,
trunc(stat[clevel].totaltime/stat[clevel].TotalPlayed),FormatDateTime('hh:nn:ss',
stat[clevel].totaltime/stat[clevel].totalplayed)]),'Sudoku',0);
for i:=1to 81 do edits[i].enabled:=false;
end;
end;
procedure printAnotherPuzzle;
var bmp:tbitmap;
begin
newgame;
printer.NewPage;
bmp:=sudokugame.GetFormImage;
printer.Canvas.StretchDraw(Rect(0,0,printer.PageWidth,printer.PageHeight),bmp);
end;
procedure TSudokuGame.Print1Click(Sender: TObject);
var bmp:tbitmap;
n,i:integer;
begin
n:=Strtointdef(inputbox('Number of puzzle','Number of puzzles to print','1'),1);
if not printdialog1.Execute then exit;
bmp:=GetFormImage;
printer.BeginDoc;
printer.Canvas.StretchDraw(rect(0,0,printer.PageWidth,printer.PageHeight),bmp);
for i:=2 to n do
printanotherpuzzle;
printer.EndDoc;
end;
procedure TSudokuGame.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if startsavingtoafileinsteadofregistry1.Checked then exportSavFile;
regclosekey(hkusr);
end;
procedure TSudokuGame.Newgame1Click(Sender: TObject);
begin
newgame;
end;
procedure TSudokuGame.Easiest1Click(Sender: TObject);
begin
clevel:=TMenuItem(Sender).tag;
regsetvalueex(hkusr,'Level',0,reg_dword,@clevel,4);
Easiest1.Checked:=false;
easy1.Checked:=false;
medium1.Checked:=false;
hard1.Checked:=false;
veryhard1.Checked:=false;
randomlevel1.Checked:=false;
loadpuzzles(clevel);
if messagebox(handle,'Do you want to start a new puzzle?','Sudoku',mb_yesno or
mb_iconquestion)=idyes then newgame;
end;
procedure TSudokuGame.ChoosePuzzle1Click(Sender: TObject);
var i:integer;
emsg:array[0..255]of char;
label tryagain;
begin
tryagain:
puzzledat.gamenum:=strtointdef(inputbox('Choose A Puzzle','Enter puzzle number',
inttostr(puzzledat.gamenum)),puzzledat.gamenum);
if(puzzledat.gamenum>=puzzles.Count) then begin
if Messagebox(handle,strfmt(emsg,'The puzzle number must be between 0 and %d.',[
puzzles.count-1]),'Sudoku',mb_iconexclamation or mb_okcancel)=id_cancel then exit;
goto tryagain;
end;
zeromemory(@puzzledat.puzzle,81);
puzzledat.Time:=0;
for i:=1to 81 do begin
puzzledat.Puzzle[i]:=strtoint(puzzles[puzzledat.gamenum][i]);
edits[i].text:=inttostr(puzzledat.puzzle[i]);
edits[i].enabled:=(edits[i].text='0');
puzzledat.Enabled[i]:=edits[i].enabled;
if edits[i].text='0' then edits[i].clear;
end;
sudokugame.Label1.Caption:='Puzzle: '+inttostr(puzzledat.gamenum);
Sudokugame.Label2.Caption:='Level: '+levels[clevel];
end;
procedure TSudokuGame.Exit1Click(Sender: TObject);
begin
close;
end;
procedure TSudokuGame.AboutSudoku1Click(Sender: TObject);
var msg:array[0..512]of char;
begin
Messagebox(handle,strfmt(msg,
'Sudoku v%s by Justin Roeder'#13#10'Puzzle database owned by printable-sudoku-puzzles.com',
[APPVERSION]),'About Sudoku',0);
end;
procedure TSudokuGame.Timer1Timer(Sender: TObject);
begin
puzzledat.Time:=puzzledat.Time+EncodeTime(0,0,1,0);
caption:=formatdatetime('"Sudoku ("hh:nn:ss")"',puzzledat.Time);
regsetvalueex(hkusr,'SavedGame',0,reg_binary,@puzzledat,sizeof(puzzledat));
end;
procedure TSudokuGame.PauseResume1Click(Sender: TObject);
var i:integer;
begin
timer1.Enabled:=not timer1.Enabled;
for i:=1to 81do edits[i].visible :=timer1.Enabled;
if not timer1.Enabled then caption:='Sudoku(paused)';
end;
procedure TSudokuGame.HowToPlay1Click(Sender: TObject);
var msg:array[0..1024]of char;
begin
messagebox(0,strpcopy(Msg,
'Objective of Sudoku is to fill every cell with digits 1 to 9'#13#10+
'But the rules are every row, column and 3x3 square must use the '#13#10+
'digits 1 to 9 once. Also when a full column,row or square is filled in wrong'#13#10+
'it is highlighted red.'),'Sudoku Rules',0);
end;
procedure TSudokuGame.BlankPuzzle1Click(Sender: TObject);
var i:integer;
begin
puzzledat.gamenum:=$ffff;
zeromemory(@puzzledat.puzzle,81);
fillmemory(@puzzledat.enabled,81,sizeof(puzzledat.enabled));
for i:=1to 81do begin edits[i].enabled:=true;edits[i].clear;end;
end;
procedure TSudokuGame.ResetPuzzle1Click(Sender: TObject);
var i:integer;
begin
if messagebox(handle,
'This will clear everything you entered.'#13#10'Do you wish to do that?',
'Sudoku',MB_YESNO or mb_iconquestion)<>idyes then exit;
for i:=1to 81do if edits[i].enabled then begin
puzzledat.Puzzle[i]:=0;
edits[i].clear;end;
end;
function Divide(n,d:extended):extended;
begin
result:=0;
if d=0 then exit;
result:=n/d;
end;
procedure TSudokuGame.Stats1Click(Sender: TObject);
var msg:array[0..255]of char;
stat:tsudokustats;
rs:dword;
begin
zeromemory(@stat,sizeof(stat));
rs:=sizeof(stat);
RegQueryValueex(hkusr,'Stat',nil,nil,@stat,@rs);
messagebox(handle,strfmt(msg,Pchar(
'Easiest Level:Games Played: %d Average Time: %d days %s'#13#10+
'Easy Level:Games Played: %d Average Time: %d days %s'#13#10+
'Medium Level:Games Played: %d Average Time: %d days %s'#13#10+
'Hard Level:Games Played: %d Average Time: %d days %s'#13#10+
'Very Hard Level:Games Played: %d Average Time: %d days %s'),[
stat[1].totalplayed,trunc(divide(stat[1].totaltime,stat[1].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[1].totaltime,stat[1].TotalPlayed)),
stat[2].totalplayed,trunc(divide(stat[2].totaltime,stat[2].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[2].totaltime,stat[2].TotalPlayed)),
stat[3].totalplayed,trunc(divide(stat[3].totaltime,stat[3].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[3].totaltime,stat[3].TotalPlayed)),
stat[4].totalplayed,trunc(divide(stat[4].totaltime,stat[4].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[4].totaltime,stat[1].TotalPlayed)),
stat[5].totalplayed,trunc(divide(stat[5].totaltime,stat[5].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[5].totaltime,stat[5].TotalPlayed))]),
'Sudoku Stats',0);
end;
procedure TSudokuGame.StartSavingToafileinsteadofregistry1Click(
Sender: TObject);
var hkjustin:HKey;
savname:string;
FileSavingEnabled:dword;
begin
startsavingtoafileinsteadofregistry1.Checked:=not startsavingtoafileinsteadofregistry1.Checked;
savname:=changefileext(paramstr(0),'.sav');
if startsavingtoafileinsteadofregistry1.Checked then exportsavfile else
deletefile(savname);
filesavingenabled:=byte(startsavingtoafileinsteadofregistry1.checked);
RegOpenKey(hkey_current_user,'Software\Justin',hkjustin);regsetvalueex(
hkjustin,'FileSavingEnabled',0,reg_dword,@filesavingenabled,4);regclosekey(hkjustin);
end;
function GetHTMLSudoku(edindex:byte):String;
begin
if edits[edindex].enabled then result:=format(
'<input type="text" maxlength="1" name="sudo%d" value="%s">',[edindex-1,
edits[edindex].text])else result:=format(
'%s<input type="hidden" name="sudo%d" value="%s">',[edits[edindex].text,edindex-1,
edits[edindex].text]);
end;
function SudokuSpace(edindex:byte):string;
begin
if edits[edindex].text=''then result:=#32#32else result:=#32+edits[edindex].text;
end;
function getfilecount:integer;
var i:integer;
begin
result:=1;
for i:=3to paramcount do
if paramstr(i)='/E'then result:=strtointdef(paramstr(i+1),1);
end;
procedure TSudokuGame.ExportPuzzle1Click(Sender: TObject);
var col,csv:tstringlist;
i,fn,c:integer;
forr:TResourceStream;
bm:tbitmap;
fns:String;
begin
if not savedialog1.Execute then exit;
fns:=extractfilepath(savedialog1.filename)+'\%d_'+
extractfilename(savedialog1.filename);
c:=strtointdef(inputbox('Sudoku','Number of puzzles','1'),1);
for fn:=1to c do begin savedialog1.filename:=format(fns,[fn]);
if stricomp('.csv',pchar(extractfileext(savedialog1.filename)))=0then begin
col:=tstringlist.Create;
csv:=tstringlist.Create;
for i :=1to 9 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=10to 18 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=19to 27 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=28to 36 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=37to 45 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=46to 54 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=55to 63 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=64to 72 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=73to 81 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
csv.SaveToFile(savedialog1.filename);
csv.Free;col.Free;
end else if stricomp('.txt',pchar(extractfileext(savedialog1.filename)))=0then
begin
forr:=tresourcestream.create(hinstance,'DOSTEXT','BIN');
csv:=tstringlist.create;
csv.loadfromstream(forr);
csv.text:=format(csv.text,[puzzledat.gamenum,
SudokuSpace(1),sudokuspace(2),sudokuspace(3),sudokuspace(4),sudokuspace(5),
sudokuspace(6),sudokuspace(7),sudokuspace(8),sudokuspace(9),
sudokuspace(10),sudokuspace(11),sudokuspace(12),sudokuspace(13),sudokuspace(14),
sudokuspace(15),sudokuspace(16),sudokuspace(17),sudokuspace(18),
sudokuspace(19),sudokuspace(20),sudokuspace(21),sudokuspace(22),sudokuspace(23),
sudokuspace(24),sudokuspace(25),sudokuspace(26),sudokuspace(27),
sudokuspace(28),sudokuspace(29),sudokuspace(30),sudokuspace(31),sudokuspace(32),
sudokuspace(33),sudokuspace(34),sudokuspace(35),sudokuspace(36),
sudokuspace(37),sudokuspace(38),sudokuspace(39),sudokuspace(40),sudokuspace(41),
sudokuspace(42),sudokuspace(43),sudokuspace(44),sudokuspace(45),
sudokuspace(46),sudokuspace(47),sudokuspace(48),sudokuspace(49),sudokuspace(50),
sudokuspace(51),sudokuspace(52),sudokuspace(53),sudokuspace(54),
sudokuspace(55),sudokuspace(56),sudokuspace(57),sudokuspace(58),sudokuspace(59),
sudokuspace(60),sudokuspace(61),sudokuspace(62),sudokuspace(63),
sudokuspace(64),sudokuspace(65),sudokuspace(66),sudokuspace(67),sudokuspace(68),
sudokuspace(69),sudokuspace(70),sudokuspace(71),sudokuspace(72),
sudokuspace(73),sudokuspace(74),sudokuspace(75),sudokuspace(76),sudokuspace(77),
sudokuspace(78),sudokuspace(79),sudokuspace(80),sudokuspace(81)]);
forr.Free;csv.SaveToFile(savedialog1.filename);csv.free;
end else if(stricomp('.htm',pchar(extractfileext(savedialog1.filename)))=0)or(
stricomp('.html',pchar(extractfileext(savedialog1.filename)))=0)then
begin
csv:=tstringlist.Create;
forr:=tresourcestream.Create(hinstance,'WEBPAGE1','BIN');
csv.LoadFromStream(forr);forr.Free;
csv.Text:=format(csv.Text,[puzzledat.gamenum,AppVersion,
GetHTMLSudoku(1),GetHTMLSudoku(2),GetHTMLSudoku(3),GetHTMLSudoku(4),GetHTMLSudoku(5),
GetHTMLSudoku(6),GetHTMLSudoku(7),GetHTMLSudoku(8),GetHTMLSudoku(9),
GetHTMLSudoku(10),GetHTMLSudoku(11),GetHTMLSudoku(12),GetHTMLSudoku(13),GetHTMLSudoku(14),
GetHTMLSudoku(15),GetHTMLSudoku(16),GetHTMLSudoku(17),GetHTMLSudoku(18),
GetHTMLSudoku(19),GetHTMLSudoku(20),GetHTMLSudoku(21),GetHTMLSudoku(22),GetHTMLSudoku(23),
GetHTMLSudoku(24),GetHTMLSudoku(25),GetHTMLSudoku(26),GetHTMLSudoku(27),
GetHTMLSudoku(28),GetHTMLSudoku(29),GetHTMLSudoku(30),GetHTMLSudoku(31),GetHTMLSudoku(32),
GetHTMLSudoku(33),GetHTMLSudoku(34),GetHTMLSudoku(35),GetHTMLSudoku(36),
GetHTMLSudoku(37),GetHTMLSudoku(38),GetHTMLSudoku(39),GetHTMLSudoku(40),GetHTMLSudoku(41),
GetHTMLSudoku(42),GetHTMLSudoku(43),GetHTMLSudoku(44),GetHTMLSudoku(45),
GetHTMLSudoku(46),GetHTMLSudoku(47),GetHTMLSudoku(48),GetHTMLSudoku(49),GetHTMLSudoku(50),
GetHTMLSudoku(51),GetHTMLSudoku(52),GetHTMLSudoku(53),GetHTMLSudoku(54),
GetHTMLSudoku(55),GetHTMLSudoku(56),GetHTMLSudoku(57),GetHTMLSudoku(58),GetHTMLSudoku(59),
GetHTMLSudoku(60),GetHTMLSudoku(61),GetHTMLSudoku(62),GetHTMLSudoku(63),
GetHTMLSudoku(64),GetHTMLSudoku(65),GetHTMLSudoku(66),GetHTMLSudoku(67),GetHTMLSudoku(68),
GetHTMLSudoku(69),GetHTMLSudoku(70),GetHTMLSudoku(71),GetHTMLSudoku(72),
GetHTMLSudoku(73),GetHTMLSudoku(74),GetHTMLSudoku(75),GetHTMLSudoku(76),GetHTMLSudoku(77),
GetHTMLSudoku(78),GetHTMLSudoku(79),GetHTMLSudoku(80),GetHTMLSudoku(81)]);
csv.savetofile(savedialog1.filename);csv.Free;
end else if stricomp('.bmp',pchar(extractfileext(savedialog1.filename)))=0then
begin
bm:=getformimage;
bm.SaveToFile(savedialog1.filename);
bm.Free;
end else begin
messagebox(handle,'Invalid file extension','Sudoku',mb_iconerror);
exit;
end;
if c>1then newgame;
end;
end;
end.
All programs are virus free. Some antivirus software might say its "suspicious" or a "Potentionaly Unwanted Program". Some of them rate them on what there code looks like no matter if theres a definition in the virus database. If any of them are detected any Antivirus I will zip the software with the password "justin" j is lowercase
This tool allows you to display a message box from a batch file or schedule
tasks
To see how to use it just open the file up with no parameters and it will
explain it.
program msgbox;
{$APPTYPE CONSOLE}
{ MessageBox tool for batch files}
{$RESOURCE MSGBOXAPP.RES}
uses
SysUtils,
windows,
Classes;
function GetConsoleWindow:hwnd;stdcall;external 'kernel32.dll';
var params,iconcsv:tstringlist;
i,ret,mode,typ:integer;
msgparamset:msgboxparams;
osver:tosversioninfo;
contitle,text:array[0..1024]of char;
begin
typ:=0;
params:=tstringlist.Create;
zeromemory(@msgparamset,sizeof(msgboxparams));
msgparamset.cbSize:=sizeof(msgparamset);
for i:=1to paramcount do begin
params.Add(Paramstr(i));
if StrScan(Pchar(paramstr(i)),'=')=nil then begin
writeln('Bad parameter option or unquoted text:',paramstr(i));
exitprocess(9);
end;
end;
mode:= strtointdef(params.values['mode'],0);
if(paramcount=0)or(params.Values['text']='') then begin
writeln('Usage: ',extractfilename(paramstr(0)),
' text= [button=] [mode=]');
writeln('text= The message to show in the messagebox');
writeln('caption= MessageBox window title');
writeln('icon= Specifies the icon to use:');
writeln(' 0=No icon(default)');
writeln(' ',mb_iconinformation,'=Information icon');
writeln(' ',mb_iconwarning,'=Warning icon');
writeln(' ',mb_iconerror,'=Error icon');
writeln(' ',mb_iconquestion,'=Question Mark');
writeln('button= Button type number');
writeln(' 0=ok(default)');
writeln(' ',mb_yesno,'=Yes/no');
writeln(' ',mb_yesnocancel,'=Yes/no/cancel');
writeln(' ',mb_okcancel,'=Ok/cancel');
writeln(' ',MB_ABORTRETRYIGNORE,'=abort/retry/ignore');
writeln(' ',MB_RETRYCANCEL,'=Retry/cancel');
writeln('mode= Set optional modes, can be a combination of the following numbers:');
writeln(' 1=Hide console window until finished');
writeln(' 2=Don'#39't set console window as parent of the messagebox');
writeln(' 4=Show message box to the current active desktop, even when no one is logged in.');
writeln(' 8=the icon= specifies an icon filename and resource name seperated by a comma');
writeln(' 16=the icon resource is an integer resource, only used with mode 8');
writeln;
writeln('ErrorLevel codes:');
writeln(IDABORT,' Abort button was selected.');
writeln(IDCANCEL,' Cancel button was selected.');
writeln(IDIGNORE,' Ignore button was selected.');
writeln(IDNO,' No button was selected.');
writeln(IDOK,' OK button was selected.');
writeln(IDRETRY,' Retry button was selected.');
writeln(IDYES,' Yes button was selected.');
writeln(0,' Out of memory error');
writeln(8,' text= wasn'#39't provided error');
writeln(9,' Parameter syntax error');
if paramcount=0then begin writeln('Press enter to return...');readln;end;
exitprocess(8);
end;
if mode and 8=8then begin
iconcsv:=tstringlist.Create;
iconcsv.CommaText:=params.Values['icon'];
typ:=typ or MB_USERICON;
msgparamset.hInstance:=loadlibrary(pchar(iconcsv[0]));
if mode and 16=0then msgparamset.lpszIcon :=pchar(iconcsv[1]) else
msgparamset.lpszIcon:=makeintresource(strtointdef(iconcsv[1],1));
iconcsv.Free;
end;
if mode and 4=4then
begin
zeromemory(@osver,sizeof(osver));
osver.dwOSVersionInfoSize:=sizeof(osver);
getversionex(osver);
if osver.dwMajorVersion>3 then typ:=typ or MB_SERVICE_NOTIFICATION else
typ:=typ or MB_SERVICE_NOTIFICATION_NT3X;//not sure if this tool is compatible with nt3.5
//but just include it just incase.
end;
getconsoletitle(contitle,1025);
if params.Values['caption']=''then params.Values['caption']:=strpas(contitle);
if mode and 6=0 then msgparamset.hwndOwner:=getconsolewindow;
if mode and 1=1then showwindow(getconsolewindow,sw_hide);
msgparamset.lpszText:=strpcopy(text,params.values['text']);
msgparamset.lpszCaption:=strpcopy(contitle,params.values['caption']);
msgparamset.dwStyle:=msgparamset.dwStyle or typ or strtointdef(
params.values['icon'],0)or strtointdef(params.values['button'],0);
ret:=integer(messageboxindirect(msgparamset));
if mode and 1=1then showwindow(getconsolewindow,sw_show);
if ret=0 then writeln('MessageBox Failed');
exitprocess(ret);
end.
All programs are virus free. Some antivirus software might say its "suspicious" or a "Potentionaly Unwanted Program". Some of them rate them on what there code looks like no matter if theres a definition in the virus database. If any of them are detected any Antivirus I will zip the software with the password "justin" j is lowercase
This tool works great for converting pictures or clipboard objects to pictures It supports JPEG Bitmap Icons and Metafiles. It can draw directly to the screen or default printer. Very simple and easy to do. Great for photographers
!
To see how to use it just unzip the .DLL file and .exe file to a folder and
type imgconvert.exe to see the help page
unit imgconvert1;
interface
uses windows,classes,graphics,sysutils,jpeg,clipbrd,printers,controls,scanimg,
mmsystem;
function delphianMain(parameters:tstringlist):DWORD;
type
EOutFileType=class(Exception);
{$RESOURCE IMGCONVERT32.RES}
implementation
procedure ScreenShot(Bild: TBitMap);
var
c: TCanvas;
r,desk: TRect;
begin
c := TCanvas.Create;
getwindowrect(getdesktopwindow,desk);
c.Handle := GetWindowDC(GetDesktopWindow);
try
r := Rect(0, 0,desk.right, desk.bottom);
Bild.Width := desk.right;
Bild.Height := desk.bottom;
Bild.Canvas.CopyRect(r, c, r);
finally
ReleaseDC(0, c.Handle);
c.Free;
end;
end;
procedure ScreenShotActiveWindow(Bild: TBitMap);
var
c: TCanvas;
r, t: TRect;
h: THandle;
begin
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
h := GetForeGroundWindow;
if h <> 0 then
GetWindowRect(h, t);
try
r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);
Bild.Width := t.Right - t.Left;
Bild.Height := t.Bottom - t.Top;
Bild.Canvas.CopyRect(r, c, t);
finally
ReleaseDC(0, c.Handle);
c.Free;
end;
end;
function GetConsoleWindow:hwnd;stdcall;external'kernel32.dll';
procedure screenshotfrommouse(bild:tbitmap);
var mouse:tpoint;
c: TCanvas;
r, t: TRect;
h: THandle;
begin
c := TCanvas.Create;
playsound('SNAP',HInstance,snd_resource or snd_sync);
getcursorpos(mouse);
c.Handle := GetWindowDC(GetDesktopWindow);
h := windowfrompoint(mouse);
if h <> 0 then
GetWindowRect(h, t);
try
r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);
Bild.Width := t.Right - t.Left;
Bild.Height := t.Bottom - t.Top;
Bild.Canvas.CopyRect(r, c, t);
finally
ReleaseDC(0, c.Handle);
c.Free;
end;
end;
function ReadScanner:tbitmap;
begin
result:=tbitmap.Create;
TWAIN_SelectImageSource(getconsolewindow);
if (TWAIN_LoadSourceManager >0) Then
Begin
if (TWAIN_AcquireToClipboard(getconsolewindow,TWAIN_ANYTYPE)>0)
Then
result.LoadFromClipboardFormat(
cf_BitMap,
ClipBoard.GetAsHandle(cf_Bitmap),
0
);
ClipBoard.Clear;
TWAIN_UnLoadSourceManager;
End;
end;
function GetGIFFile(filename:PChar):hbitmap;stdcall;external'gifview.dll';
function delphianMain(parameters:tstringlist):DWORD;
//Main Function
var pic:tpicture;
desktop:tcanvas;
sshot,bmp:tbitmap;
text,extout,extin:String;
ico:ticon;
il:timagelist;
i:integer;
jpg:tjpegimage;
htxt:thandle;
written:dword;
mf:tmetafile;
begin
result:=0;
if parameters.Count<2 then begin
writeln('Usage: ',extractfilename(paramstr(0)),' picture_read picture_write [/monochrome]');
writeln('Converts picture_read to picture_write file format');
writeln('Formats supported(Read and write formats): BMP,JPG,ICO');
writeln('Read-only formats: GIF,WMF,EMF');
writeln('Set picture_read to clipboard and a filename ending .TXT to create a text file from clipboard');
writeln('Set picture_read to scan: to scan a picture');
writeln('Set picture read to screen:mouse to capture the window where the mouse is covering');
writeln('Set picture_read to screen: to capture the entire screen.');
writeln('Set picture_read to window: to capture the window behind the console window.');
writeln('Set picture_write to screen: to write to the screen');
writeln('set picture_write to print: to print the picture');
writeln(
'Set either or both picture_read or picture_write to clipboard: to import or export from the clipboard');
writeln('Press enter to return...');
readln;
exit;
end;
try
pic:=tpicture.Create;
extin:=extractfileext(parameters[0]);
extout:=extractfileext(parameters[1]);
if(StrIComp('.emf',pchar(extin))=0)then begin
mf:=tmetafile.Create;
mf.Enhanced:=true;
mf.LoadFromFile(parameters[0]);
pic.Bitmap.Height:=mf.Height;
pic.Bitmap.Width:=mf.Width;
pic.Bitmap.Canvas.Draw(0,0,mf);
end else if(StrIComp('.wmf',pchar(extin))=0)then begin
mf:=tmetafile.Create;
mf.Enhanced:=false;
mf.LoadFromFile(parameters[0]);
pic.Bitmap.Height:=mf.Height;
pic.Bitmap.Width:=mf.Width;
pic.Bitmap.Canvas.Draw(0,0,mf);
end else
if stricomp('screen:mouse',pchar(parameters[0]))=0then begin
writeln('Screenshot will begin in...');
for i:=10downto 1do begin writeln(i,' seconds...');sleep(1000);end;
sshot:=tbitmap.Create;
screenshotfrommouse(sshot);
pic.Bitmap.Handle:=sshot.Handle;
end else
if stricomp('scan:',pchar(parameters[0]))=0 then pic.Bitmap:=readscanner else
if pos('text:',lowercase(parameters[0]))=1then
begin
text:=copy(parameters[0],6,maxint);
pic.Bitmap.height:=pic.Bitmap.Canvas.TextHeight(text);
pic.Bitmap.Width:=pic.Bitmap.Canvas.TextWidth(text);
pic.Bitmap.Canvas.TextOut(0,0,text);
end else if stricomp('screen:',pchar(parameters[0]))=0then
begin
showwindow(getconsolewindow,sw_hide);
sshot:=tbitmap.Create;
screenshot(sshot);
pic.Bitmap.Handle:=sshot.Handle;
showwindow(getconsolewindow,sw_show);
end else if stricomp('window:',pchar(parameters[0]))=0then
begin
showwindow(getconsolewindow,sw_hide);
sshot:=tbitmap.Create;
screenshotactivewindow(sshot);
pic.Bitmap.Handle:=sshot.Handle;
showwindow(getconsolewindow,sw_show);
end else if stricomp('clipboard:',PChar(parameters[0]))=0then begin
if stricomp('.txt',pchar(extout))=0then
text:=clipboard.AsText else
pic.Assign(clipboard);
end else if stricomp('.gif',pchar(extractfileext(parameters[0])))=0 then
pic.Bitmap.Handle:= getgiffile(pchar(parameters[0]))else
pic.LoadFromFile(Parameters[0]);
if parameters.IndexOf('/monochrome')>-1then pic.Bitmap.Monochrome:=true;
if stricomp('clipboard:',pchar(parameters[1]))=0then clipboard.Assign(pic)else
if stricomp('screen:',pchar(parameters[1]))=0then begin
desktop:=tcanvas.Create;
desktop.Handle:=getwindowdc(getdesktopwindow);
desktop.Draw(0,0,pic.Graphic);
desktop.Free;
end else if stricomp('print:',pchar(parameters[1]))=0then begin
printer.BeginDoc;
printer.Canvas.Draw((printer.pagewidth - pic.graphic.width) div 2,
(printer.PageHeight-pic.graphic.height div 2),pic.Graphic);
printer.EndDoc;
end else if(stricomp('.txt',pchar(extout))=0)and(stricomp('clipboard:',
pchar(parameters[0]))=0)then begin
htxt:=createfile(pchar(parameters[1]),generic_write,file_share_read or
file_share_write,nil,create_always,file_attribute_normal,0);
if htxt=invalid_handle_value then begin writeln('Create:',syserrormessage(
getlasterror));result:=getlasterror;exit;end;
if not writefile(htxt,text[1],length(text),written,nil) then begin writeln('Write:',
syserrormessage(getlasterror));result:=getlasterror;closehandle(htxt);exit;end;
closehandle(htxt);
end else
if stricomp('.bmp',pchar(extout))=0then
pic.Bitmap.savetofile(parameters[1]) else
if stricomp('.ico',pchar(extout))=0 then begin
ico:=ticon.Create;
bmp:=tbitmap.Create;
if(stricomp('.jpg',pchar(extin))=0)or(stricomp('.jpeg',pchar(extin))=0)then begin
jpg:=tjpegimage.Create;
jpg.LoadFromFile(parameters[0]);
bmp.Assign(jpg);
end else if(stricomp('.bmp',pchar(extin))=0)then
bmp.Handle:=pic.Bitmap.Handle else
if(stricomp('.gif',pchar(extin))=0)then
bmp.Handle:=getgiffile(pchar(parameters[0]))else
if(stricomp('.emf',PChar(extin))=0)then
begin
mf:=tmetafile.Create;
mf.Enhanced:=true;
mf.LoadFromFile(parameters[0]);
bmp.Height:=mf.Height;bmp.Width:=mf.Width;
bmp.Canvas.Draw(0,0,mf);
end else if(stricomp('.wmf',PChar(extin))=0)then
begin
mf:=tmetafile.Create;
mf.Enhanced:=false;
mf.LoadFromFile(parameters[0]);
bmp.Height:=mf.Height;bmp.Width:=mf.Width;
bmp.Canvas.Draw(0,0,mf);
end;
il:= timagelist.CreateSize(bmp.width,bmp.height);
il.AddMasked(bmp,bmp.TransparentColor);
il.GetIcon(0,ico);
ico.SaveToFile(parameters[1]);
end else if(stricomp('.jpg',pchar(extout))=0)or(stricomp('.jpeg',pchar(extout))=0)
then begin
jpg:=tjpegimage.Create;
jpg.assign(pic.bitmap);
jpg.savetofile(parameters[1]);
end else
raise eoutfiletype.Create('Unknown file type: '+extout);
except on e:exception do begin result:=getlasterror;writeln('Error:',e.message);
exit;end;
end;
writeln('Picture converted successfully');
end;
end.
All programs are virus free. Some antivirus software might say its "suspicious" or a "Potentionaly Unwanted Program". Some of them rate them on what there code looks like no matter if theres a definition in the virus database. If any of them are detected any Antivirus I will zip the software with the password "justin" j is lowercase
This is golf solitaire that runs as a text based console program. I choose to do it this way to be creative and unqic.It should work with most 32-bit versions of windows including windows 10.
ScreenShots:
unit golfsol1;
//GolfSolitaire() is the main function
interface
uses graphics,windows,classes,sysutils,shellapi;
const
SCORES_SHOW_ONLY=126;
SCORES_INIT=127;
CurrentVersion=$01000000;
procedure GolfSolitaire(params:tstringlist);
implementation
type TRandom=function(range:integer):integer;stdcall;
TCard=record
face,suit,deck,notused:byte;
end;
TGolfScore=record
Name:shortstring;
gametype:byte;
score:shortint;
end;
TGolfGame=record
gamenum:integer;
decks:byte;
cardcount:array[-1..9]of byte;
drawpile:array[1..40]of pointer;
discardpile:array[1..104]of pointer;
end;
PGolfScore=^TGolfScore;
TGetConsoleWindow=Function:HWND;stdcall;
var rand:hmodule=0;
suits:array[1..4]of longint;
drandom:TRandom;
GetConsoleWindow:TGetConsoleWindow;//for compatiblity with older windows
carddeck:array[1..4,1..14]of byte;
tableua:array[-1..9]of tlist;
hout:thandle;
gameover,inGame:boolean;
defattrib: word;
currentscore:shortint;
scores:array[0..9]of tgolfscore;
hk:hkey;
gamenum,intour:integer;
lost,win,jokersused,aceking,decks,showdiscard,oldestver:dword;
drawpile_bonus_points:Shortint;
function AllUsedJokers:boolean;
begin
result:=(carddeck[1,14]=jokersused);
end;
procedure SaveGame;
var sav:tgolfgame;
i:integer;
begin
sav.gamenum:=gamenum;
sav.decks:=decks;
for i:=-1to 9do sav.cardcount[i]:=tableua[i].count;
for i:=1to tableua[-1].count do
sav.drawpile[i]:=tableua[-1][i-1];
for i:=1to tableua[0].count do
sav.discardpile[i]:=tableua[0][i-1];
regsetvalueex(hk,'SavedGame',0,reg_binary,@sav,sizeof(sav));
end;
function allused:boolean;
var i,j:integer;
begin
result:=allusedjokers;
for i:=1to 4do
for j:=1to 13do
result:=result and(carddeck[i,j]>=decks);
end;
function drawcard:pointer;
var car:tcard;
label shuffle;
begin
car.face:=16;
car.suit:=5;
result:=pointer(car);
if allused then exit;
shuffle:if jokersused>0then car.face:=drandom(14)+1 else car.face:=drandom(13)+1;
car.suit:=drandom(4)+1;
if(car.face=14) and (car.suit>1) then goto shuffle;
if carddeck[car.suit,car.face]=decks then goto shuffle;
inc(carddeck[car.suit,car.face]);
car.deck:=carddeck[car.suit,car.face];
result:=pointer(car);
end;
procedure clearconsole;
var co:coord;
written:dword;
begin
co.x:=0;
co.y:=0;
setconsolecursorposition(hout,co);
fillconsoleoutputcharacter(hout,#32,$ffff,co,written);
setconsolecursorposition(hout,co);
end;
procedure Randominit(gamenum:integer);
var i,j:integer;
begin
if decks=1then
drawpile_bonus_points:=-(16+JokersUsed);
if decks=2then
drawpile_bonus_points:=-(40+jokersused);
zeromemory(@carddeck,sizeof(carddeck));
if rand<>0then
freelibrary(rand);
zeromemory(@carddeck,sizeof(carddeck));
rand:=LoadLibrary('random32.dll');
@drandom:=getprocaddress(rand,'MyRandom');
if not assigned(drandom)then begin writeln('Could'#39't load random32.dll');readln;
regclosekey(hk);exitprocess(0);end;
for i:=0to gamenum do drandom(gamenum);
setconsoletitle(pchar('Golf Solitaire #'+inttostr(gamenum)));
if decks=1then
for i:=1to 7do begin tableua[i].clear;
for j:=1to 5do tableua[i].add(drawcard);
end;
if decks=2then
for i:=1to 9do begin tableua[i].clear;
for j:=1to 7do tableua[i].add(drawcard);
end;
tableua[0].clear;
tableua[-1].clear;
tableua[0].add(drawcard);
while not allused do tableua[-1].add(drawcard);
end;
const background_white=background_red or background_green or background_blue or
background_intensity;
char_heart=#3;
char_diamond=#4;
char_club=#5;
char_spade=#6;
function cardtostring(card:tcard):string;
var attrib:word;
begin
if lobyte(hiword(suits[card.suit]))=ord('R')then attrib:=foreground_red or foreground_intensity or
background_white else
attrib:=background_white;
if card.suit=0then attrib:=0;
setconsoletextattribute(hout, attrib);
case card.face of
0,16:result:=#32;
1:result:='A';
10:result:='T';
11:result:='J';
12:result:='Q';
13:result:='K';
14:begin result:='??';exit;end;//Joker
else result:=inttostr(card.face);end;
case card.suit of
1,2,3,4:result:=result+chr(hibyte(hiword(suits[card.suit])));
else result:=result+#32;
end;
end;
function sortscores(Item1, Item2: pointer): Integer;
begin
if pgolfscore(item1).score<pgolfscore(item2).score then result:=-1;
if pgolfscore(item1).score=pgolfscore(item2).score then result:=0;
if pgolfscore(item1).score>pgolfscore(item2).score then result:=1;
end;
function ScoreStr(score:PGolfScore):string;
begin
result:=inttostr(score.score);
if score.score=scores_init then result:='N/A';
end;
function gametypetostr(gt:byte):string;
begin
result:='';
if gt and 1=1then result:='AceKing ';
if gt and 2=2then result:=result+'2-decks';
end;
procedure ShowScores(score:shortint);
var cbscores:dword;
I:integer;
thisscore:TGolfScore;
scorea:array[0..9]of tgolfscore;
sortedscores:tlist;
begin
setconsoletextattribute(hout,defattrib);
sortedscores:=tlist.Create;
thisscore.gametype:=0;
cbscores:=0;
if(aceking=1)then thisscore.gametype:=1;
if(decks=2)then thisscore.gametype:=thisscore.gametype or 2;
if score<scores_show_only then begin write('Enter your name:');readln(thisscore.name);
thisscore.score:=score;end;
regqueryvalueex(hk,'Scores',nil,nil,nil,@cbscores);
if cbscores=sizeof(scores)then
regqueryvalueex(hk,'Scores',nil,nil,@scores,@cbscores);
for i:=0to 9do sortedscores.Add(@scores[i]);
if score<126then sortedscores.Add(@thisscore);
sortedscores.Sort(sortscores);
writeln('Place,Score,Name,GameType');
for i:=0to 9do begin write(i+1,'. ',scorestr(sortedscores[i]),' ',pgolfscore(
sortedscores[i]).name,' ',gametypetostr(pgolfscore(sortedscores[i]).gametype));
if sortedscores[i]=@thisscore then write('<--');writeln;copymemory(@scorea[i],
sortedscores[i],sizeof(tgolfscore));
end;
copymemory(@scores,@scorea,sizeof(scorea));
regsetvalueex(hk,'Scores',0,reg_binary,@scores,sizeof(scores));
sortedscores.Free;
writeln('Wins: ',win,' Lost: ',lost,' Games Played: ',win+lost);
write('Press enter to return...');readln;
clearconsole;
end;
procedure loadgame;
var sav:tgolfgame;
i,j,colcount:integer;
cb:dword;
Begin
cb:=sizeof(sav);
RegQueryValueEx(hk,'SavedGame',nil,nil,@sav,@cb);
decks:=sav.decks;
if decks=1 then colcount:=5 else colcount:=7;
gamenum:=sav.gamenum;
randominit(gamenum);
for i:=1to 9do
if tableua[i].count>0then for j:=1to colcount-sav.cardcount[i] do tableua[i].remove(
tableua[i].last);
tableua[0].clear;tableua[-1].clear;
for i:=1 to sav.cardcount[-1] do
tableua[-1].add(sav.drawpile[i]);
for i:=1to sav.cardcount[0]do tableua[0].add(sav.discardpile[i]);
end;
procedure youwinproc;
var
conrect:trect;
sortedscores:tlist;
ywbmp:graphics.tbitmap;
concan:tcanvas;
begin
ingame:=false;
GetWindowRect(getconsolewindow,conrect);
writeln('ÉÍÍÍÍÍÍÍÍÍÍ»');
writeln('º You win! º');
writeln('ÈÍÍÍÍÍÍÍÍÍͼ');
gameover:=true;
@getconsolewindow:=GetProcAddress(getmodulehandle('kernel32.dll'),
'GetConsoleWindow');
if assigned(getconsolewindow)then
if getconsolewindow<>0then begin
ywbmp:=graphics.tbitmap.create;
ywbmp.Handle:=loadbitmap(hinstance,'YOUWON');
Concan:=tcanvas.Create;
concan.Handle:=GetWindowDC(getconsolewindow);
concan.Draw((conrect.Right-ywbmp.width)div 2,(conrect.Bottom-ywbmp.height)div 2,
ywbmp);
releasedc(getconsolewindow,concan.handle);
concan.Free;
ywbmp.FreeImage;
ywbmp.Free;
end;
showscores(drawpile_bonus_points);
inc(win);
regdeletevalue(hk,'SavedGame');
regsetvalueex(hk,'Win',0,reg_dword,@win,4);
end;
{$RESOURCE GOLFSOL32.RES}
function quit(typ:dword):Bool;stdcall;
var dwGame:dword;
begin
result:=true;
dwGame:=gamenum;
if ingame then savegame;
regsetvalueex(hk,'Win',0,reg_dword,@win,4);
regsetvalueex(hk,'Lost',0,reg_dword,@lost,4);
regclosekey(hk);
exitprocess(0);
end;
function ismove(pile1,pile2:tlist):boolean;
var p1,p2:pointer;
c1,c2:tcard;
begin
result:=false;
if(pile1.Count*pile2.Count=0)then exit;
p1:=pile1.last;
p2:=pile2.last;
copymemory(@c1,@p1,4);
copymemory(@c2,@p2,4);
result:=(abs(c1.face-c2.face)=1)or(c1.face=14)or(c2.face=14);
if(((c1.face=1)and(c2.face=13))or((c1.face=13)and(c2.face=1)))and(aceking=1)then
result:=true;
end;
function AnyMoreMoves:byte;
var i:integer;
begin
result:=0;
for i:=1to 9 do if ismove(tableua[0],tableua[i])then inc(result);
end;
procedure ShowRules;
begin
clearconsole;
writeln('ÉÍÍÍÍÍÍÍÍÍÍ͹Golf RulesÌÍÍÍÍÍÍÍÍÍÍ»');
writeln('ºThe rules for golf solitaire are º');
writeln('ºvery simple. The whole idea of º');
writeln('ºgame is to get rid of all cards º');
writeln('ºin the seven columns(1 deck) or º');
writeln('ºnine columns(2 decks). As in º');
writeln('ºregular golf you want to get the º');
writeln('ºlowest points. When the game endsº');
writeln('ºwhatever cards are left count as º');
writeln('ºone point per card. If you go outº');
writeln('ºthe number of cards left will º');
writeln('ºbecome a negative points. You º');
writeln('ºwill try to move the cards from º');
writeln('ºthe columns to the discard pile. º');
writeln('ºThey must be one card bigger or º');
writeln('ºone card smaller.Example: a 5 canº');
writeln('ºbe moved to the discard pile onlyº');
writeln('ºif the top card is a 6 or a 4,theº');
writeln('ºsuit doesnt matter. You can choseº');
writeln('ºa column by entering the number 1º');
writeln('ºthough 9 and then pressng enter. º');
writeln('ºWhen there are no more moves you º');
writeln('ºcan type in 0 and hit enter or º');
writeln('ºtype in 10 and hit enter to go toº');
writeln('ºmenu. º');
writeln('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
writeln('Press enter to return...');
readln;
intour:=2;
end;
procedure Tour;
begin
clearconsole;
writeln('ÉÍÍÍÍÍÍÍÍÍ͹Golf TourÌÍÍÍÍÍÍÍÍÍÍÍÍ»');
writeln('ºTo know how to use this game you º');
writeln('ºwill be entering in numbers to º');
writeln('ºtell the game your moves & what º');
writeln('ºyou want to do. The columns are º');
writeln('ºnumbered and so is the draw pile.º');
writeln('ºTo draw you enter in 0 and press º');
writeln('ºenter. Next we will look at the º');
writeln('ºrules. º');
writeln('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
writeln('Press enter to continue...');
readln;
intour:=1;
end;
procedure GolfSolitaire(params:tstringlist);
var i,j,choice:integer;
topcard:tcard;
pc:pointer;
cb,sgame:dword;
label gamepmt,gameend,menu,trytour;
begin
hout:=getstdhandle(std_output_handle);
defattrib:=foreground_intensity or foreground_red or foreground_blue or
foreground_green;
decks:=1;
randomize;
ingame:=false;
setconsoleoutputcp(437);
oldestver:=0;
for i:=0to 9do begin scores[i].Name:='N/A';scores[i].score:=scores_init;end;
SetConsoleCtrlHandler(@quit,true);
regcreatekey(hkey_current_user,'Software\Justin\GolfSolitaire',hk);
intour:=0;
suits[1]:=makelong(ord('C'),makeword(ord('B'),ord(char_club)));
suits[2]:=makelong(ord('S'),makeword(ord('B'),ord(char_spade)));
suits[3]:=makelong(ord('H'),makeword(ord('R'),ord(char_heart)));
suits[4]:=makelong(ord('D'),makeword(ord('R'),ord(char_diamond)));
cb:=sizeof(suits);
regqueryvalueex(hk,'Suit',nil,nil,@suits,@cb);
regsetvalueex(hk,'Suit',0,reg_binary,@suits,sizeof(suits));
cb:=4;regqueryvalueex(hk,'Decks',nil,nil,@decks,@cb);
if(decks=0)or(decks>2)then decks:=1;
showdiscard:=0;
cb:=4;
lost:=0;
win:=0;
regqueryvalueex(hk,'Lost',nil,nil,@lost,@cb);
cb:=4;
gameover:=true;
regqueryvalueex(hk,'Win',nil,nil,@win,@cb);
cb:=4;
aceking:=0;jokersused:=0;sgame:=0;
//regqueryvalueex(hk,'JokersUsed',nil,nil,@jokersused,@cb);
//Jokers for some reason freeze up the game being delt.
regqueryvalueex(hk,'LastGame',nil,nil,@sgame,@cb);
cb:=4;
//if jokersused>2then jokersused:=0;
regqueryvalueex(hk,'AceKing',nil,nil,@aceking,@cb);
cb:=4;
if aceking>1then aceking:=0;
regqueryvalueex(hk,'ShowDiscard',nil,nil,@showdiscard,@cb);
if showdiscard>1then showdiscard:=0;
for i:=-1 to 9do tableua[i]:=tlist.create;
if regqueryvalueex(hk,'OldestVersion',nil,nil,nil,nil)<>error_success then
begin
trytour:
write('Would you like to take a tour? type in 1 for Yes or 0 for No:');
readln(choice);
case choice of
1:tour;
0:goto menu;
else goto trytour;
end;
oldestver:=currentversion;
regsetvalueex(hk,'OldestVersion',0,reg_dword,@oldestver,4);
if intour=1 then goto menu;
end;
menu:clearconsole;
setconsoletextattribute(hout,defattrib);
writeln('ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');
writeln('ºWelcome to Golf Solitaire º');
writeln('ºWhat would you like to do? º');
writeln('º1. Start a new game º');
writeln('º2. Enter in a game number º');
writeln('º3. View top ten º');
cb:=4;
writeln('º4. See game rules º');
writeln('º5. Change rules and settings º');
if ingame then
writeln('º6. Return to game º');
if regqueryvalueex(hk,'SavedGame',nil,nil,nil,nil)=error_success then
writeln('º7. Load Saved Game º');
writeln('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
if intour=1 then
writeln('To see rules type 4 and press enter');
write('Choice Number:');readln(choice);
case choice of
4:begin showrules;goto menu;end;
1:begin
gamenum:=random(maxint)+1; randominit(gamenum);end;
2:begin write('Enter game#:');readln(gamenum);randominit(gamenum);end;
3:begin showscores(scores_show_only);goto menu;end;
5:begin writeln('Current Settings:');
write('Aces can be played on kings: ');if aceking=1then writeln('Yes')else
writeln('No');//writeln('Jokers used: ',jokersused);
writeln('Number of card decks:',decks);
write('Show all cards in the discard pile:');
if showdiscard=1then writeln('Yes')else writeln('No');
writeln('2=DontChange 1=Yes 0=No Any Other number returns to menu');
Write('Play Kings on Aces? Number Choice:');readln(aceking);
if aceking>1then goto menu;
{tryjoker:
write('Number of jokers to use. 0 though 2 are valid numbers:');
readln(jokersused);
if(JokersUsed>2)then begin Writeln('Too many jokers.');goto tryjoker;end;
}
write('Show all cards in the discard pile?(0=No 1=yes)');readln(showdiscard);
regsetvalueex(hk,'ShowDiscard',0,reg_dword,@showdiscard,4);
//regsetvalueex(hk,'JokersUsed',0,reg_dword,@jokersused,4);
regsetvalueex(HK,'AceKing',0,reg_dword,@aceking,4);
write('Enter number of decks to use(1 or 2):');readln(decks);
regsetvalueex(hk,'Decks',0,reg_dword,@decks,4);
goto menu;
end;
6:if ingame then goto gamepmt else goto menu;
7:if RegQueryValueex(hk,'SavedGame',nil,nil,nil,nil)=error_success then
loadgame else goto menu;
else goto menu;
end;
gameover:=false;
drawpile_bonus_points:=-tableua[-1].count;
gamepmt:
clearconsole;
setconsoletextattribute(hout,defattrib);
ingame:=true;
write('Game#: ',gamenum,' Cards left:');
j:=0;
for i:=1to 9do j:=j+tableua[i].count;
write(j,' Draws left:',tableua[-1].count,' Type in 10 for menu');
writeln;
writeln('[1][2][3][4][5][6][7][8][9]');
if decks=1 then
for i:=0to 4do begin write(' ');
for j:=1to 9do begin if tableua[j].count>i then write(cardtostring(tcard(tableua[j][i])))
else write(' ');write(' ');end;
writeln;
end;
if decks=2 then
for i:=0to 6do begin write(' ');
for j:=1to 9do begin if tableua[j].count>i then write(cardtostring(tcard(tableua[j][i])))
else write(' ');write(' ');end;
writeln;
end;
setconsoletextattribute(hout,defattrib);
pc:=tableua[0].last;
copymemory(@topcard,@pc,4);
write('Draw[0]: ');
if showdiscard=0then
write(cardtostring(topcard))
else for i:=0to tableua[0].count-1do begin pc:=tableua[0][i];copymemory(@topcard,
@pc,4);write(cardtostring(topcard));end;
writeln;
setconsoletextattribute(hout,defattrib);
write('Choice:');
readln(choice);
case choice of
1,2,3,4,5,6,7,8,9:if ismove(tableua[0],tableua[choice])then
begin tableua[0].add(tableua[choice].last);tableua[choice].remove(
tableua[choice].last);if(tableua[-1].count=0) and(anymoremoves=0) then goto gameend;
end;
0:begin if((tableua[-1].count=0) and(anymoremoves=0)) then
goto gameend;tableua[0].add(tableua[-1].last);inc(drawpile_bonus_points);
tableua[-1].remove(tableua[-1].last);
end;
10:goto menu;
end;
if(tableua[1].count+tableua[2].count+tableua[3].count+tableua[4].count+
tableua[5].count+tableua[6].count+tableua[7].count+tableua[8].count+
tableua[9].count=0)then begin
youwinproc;
goto menu;
end;
goto gamepmt;
gameend:
regdeletevalue(hk,'SavedGame');
Writeln('Sorry, no more moves');
writeln('Tableua points: ',tableua[1].count+tableua[2].count+tableua[3].count+
tableua[4].count+tableua[5].count+tableua[6].count+tableua[7].count+
tableua[8].count+tableua[9].count);
gameover:=true;
inc(lost);
ingame:=false;
regsetvalueex(hk,'Lost',0,reg_dword,@lost,4);
showscores(tableua[1].count+tableua[2].count+tableua[3].count+tableua[4].count+
tableua[5].count+tableua[6].count+tableua[7].count);
//writeln('Press enter to return...');readln;
goto menu;
end;
end.
All programs are virus free. Some antivirus software might say its "suspicious" or a "Potentionaly Unwanted Program". Some of them rate them on what there code looks like no matter if theres a definition in the virus database. If any of them are detected any Antivirus I will zip the software with the password "justin" j is lowercase
This is a fun card game that I learned from camp and I made a game for Windows. It’s easy to play and win. And soon will come more card decks to choose from. The card deck current;y included in
the game by default came from Microsoft Windows XP.
The game is fun and includes sound effects. The game is portable and doesn’t
need to be installed or have administrative rights. Just tell the web browser to
run or save the file. There is even a web version as well.
ScreenShots
How to build a card deck?
In order to build a card deck you must create a DLL Resource file with
bitmaps. No coding required! Just make sure to name it with a .CAR file
extension.
unit garbage1;
//Main Card Game Unit
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, Menus, ComCtrls,shellapi,mmsystem, DBClient, MConnect;
const
Version=$100;
card_error=1;
card_visible=4;
card_flipped=8;
card_exists=2;
card_dead=16+card_flipped;
type
Tgarbagegame = class(TForm)
GroupBox1: TGroupBox;
Image1: TImage;
Image2: TImage;
Image3: TImage;
Image4: TImage;
Image5: TImage;
Image6: TImage;
Image7: TImage;
Image8: TImage;
Image9: TImage;
Image10: TImage;
Image12: TImage;
Image11: TImage;
GroupBox2: TGroupBox;
Image13: TImage;
Image14: TImage;
Image15: TImage;
Image16: TImage;
Image17: TImage;
Image18: TImage;
Image19: TImage;
Image20: TImage;
Image21: TImage;
Image22: TImage;
StatusBar1: TStatusBar;
MainMenu1: TMainMenu;
Game1: TMenuItem;
ChangeBack1: TMenuItem;
Button1: TButton;
Help1: TMenuItem;
AboutGarbage1: TMenuItem;
ListBox1: TListBox;
Rules1: TMenuItem;
KingsAreWild1: TMenuItem;
DCOMConnection1: TDCOMConnection;
procedure FormCreate(Sender: TObject);
procedure ChangeBack1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Image13Click(Sender: TObject);
procedure Image11Click(Sender: TObject);
procedure AboutGarbage1Click(Sender: TObject);
procedure ListBox1DblClick(Sender: TObject);
procedure Rules1Click(Sender: TObject);
procedure KingsAreWild1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TPlayingCard=record
face,suit:byte;
flags:word;
end;
TPlayingCards=array[1..10]of tplayingcard;
procedure newgame;
function pcback(index:integer):pchar;
procedure updatecards;
var
garbagegame: Tgarbagegame;
playerpos:byte=10;
hdeck:hmodule;
computerpos:byte=10;
back:dword;
deck_pics:array[0..12,1..4]of HBITMAP;
hbacks:array[0..11]of hbitmap;
emptyslots:array[0..2]of hbitmap;
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');
discard:tlist;
kingswild:dword=1;
cturn,pturn:byte;
candraw:boolean;
gamenum,whoseturn:integer;
harrows:array[0..1]of hicon;
playercards,computercards:tplayingcards;
used:array[0..12,1..4]of boolean;
implementation
{$R *.DFM}
{$RESOURCE DECK.RES}
{$RESOURCE GARBAGE32.RES}
uses garbage2;
procedure endround;
var msg,par:array[0..512]of char;
i:integer;
hk:hkey;
begin
for i:=1to 10do begin if computercards[i].flags and card_flipped=0then
computercards[i].flags:=computercards[i].flags or card_dead;
if playercards[i].flags and card_flipped=0then playercards[i].flags:=
playercards[i].flags or card_dead;
end;
updatecards;
regcreatekey(hkey_current_user,'Software\Justin\Garbage',hk);
regdeletevalue(hk,'SavedGame');
regclosekey(hk);
if inttostr(playerpos)=garbagegame.StatusBar1.Panels[2].text then begin
dec(playerpos);
if playerpos=0 then begin
playsound('GOOD2',hinstance,snd_resource or snd_sync);
if messagebox(garbagegame.handle,strfmt(msg,
'You won!'#13#10'Your score:0 points'#13#10'Computer score:%d points'#13#10'Play again?',
[computerpos]),'Game Over',mb_yesno)=idno then exit;
computerpos:=10;
playerpos:=10;
gamenum:=0;
end else begin playsound('CLAP',hinstance,snd_resource or snd_sync);messagebox(
garbagegame.handle,strfmt(msg,
'You won this round!'#13#10'Your score:%d points'#13#10'Computer score:%d points',
[playerpos,computerpos]),'Garbage',0);
end;
end;
if inttostr(computerpos)=garbagegame.StatusBar1.Panels[3].text then begin
dec(computerpos);
if computerpos=0 then begin
if messagebox(garbagegame.handle,strfmt(msg,
'You lost!'#13#10'Your score:%d'#13#10'Computer score:0 points'#13#10'Play again?',
[playerpos]),'Game Over',mb_yesno)=idno then exit;
computerpos:=10;
playerpos:=10;
gamenum:=0;
end else messagebox(garbagegame.handle,strfmt(msg,
'You lost this round!'#13#10'Your score:%d points'#13#10'Computer score:%d points',
[playerpos,computerpos]),'Garbage',0);
end;
shellexecute(0,nil,pchar(application.exename),strfmt(par,'%d %d %d %d %d',[
playerpos,computerpos,gamenum,whoseturn,back]),nil,SW_SHOWNORMAL);
exitprocess(0);
end;
procedure reshuffle;
var i:integer;
p:pointer;
c:tplayingcard;
l:tlist;
begin
//With the game being two player I don't think this function will ever be called!
l:=tlist.Create;
for i:=0 to discard.Count-2do begin p:=discard[i];copymemory(@c,@p,4);l.Add(p);
used[c.face,c.suit]:=false;
end;
for i:=0to l.Count-1do discard.Remove(l[i]);
l.Free;
end;
function CardBack:byte;
var rs,rtyp:Dword;
hk:hkey;
begin
RegCreateKey(hkey_current_user,'Software\Justin\Garbage',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 allused:boolean;
var i,j:integer;
begin
result :=true;
for i:=0to 12do for j:=1to 4do result:= result and used[i,j];
end;
function drawcard:tplayingcard;
label newcard;
begin
result.flags:=card_error;
if allused then exit;
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;
result.flags:=card_exists;
end;
procedure playermoveenable;
var p:pointer;
c:tplayingcard;
begin
garbagegame.Image13.Enabled:=false;
garbagegame.Image14.Enabled:=false;
garbagegame.Image15.Enabled:=false;
garbagegame.Image16.Enabled:=false;
garbagegame.Image17.Enabled:=false;
garbagegame.Image18.Enabled:=false;
garbagegame.Image19.Enabled:=false;
garbagegame.Image20.Enabled:=false;
garbagegame.Image21.Enabled:=false;
garbagegame.Image22.Enabled:=false;
p:=discard.Last;
copymemory(@c,@p,4);
if(c.face<10)then
if((1+c.face)>playerpos)and(c.face<12)then exit;
if(c.face<10)then
if playercards[c.face+1].flags and card_flipped>0then exit;
case c.face of
0:garbagegame.Image13.Enabled:=true;
1:garbagegame.Image14.Enabled:=true;
2:garbagegame.Image15.Enabled:=true;
3:garbagegame.Image16.Enabled:=true;
4:garbagegame.Image17.Enabled:=true;
5:garbagegame.Image18.Enabled:=true;
6:garbagegame.Image19.Enabled:=true;
7:garbagegame.Image20.Enabled:=true;
8:garbagegame.Image21.Enabled:=true;
9:garbagegame.Image22.Enabled:=true;
end;
if(kingswild=1)and(c.face=12)then begin
garbagegame.Image13.Enabled:=(playercards[1].flags and card_flipped=0);
garbagegame.Image14.Enabled:=(playercards[2].flags and card_flipped=0);
garbagegame.Image15.Enabled:=(playercards[3].flags and card_flipped=0);
garbagegame.Image16.Enabled:=(playercards[4].flags and card_flipped=0);
garbagegame.Image17.Enabled:=(playercards[5].flags and card_flipped=0);
garbagegame.Image18.Enabled:=(playercards[6].flags and card_flipped=0);
garbagegame.Image19.Enabled:=(playercards[7].flags and card_flipped=0);
garbagegame.Image20.Enabled:=(playercards[8].flags and card_flipped=0);
garbagegame.Image21.Enabled:=(playercards[9].flags and card_flipped=0);
garbagegame.Image22.Enabled:=(playercards[10].flags and card_flipped=0);
end;
end;
procedure AddCardToListBox(car:pointer;typ:integer;nturns:pbyte);
var c:tplayingcard;
p:pointer;
rwave:array[0..8]of char;
begin
p:=car;
copymemory(@C,@p,4);
if nturns<>nil then nturns^:=nturns^+1;
case typ of
0:garbagegame.ListBox1.Items.insert(0,format('You drawn an %s of %s.',[faces[c.face],
suits[c.suit]]));
1:begin garbagegame.ListBox1.Items.insert(0,format('You flipped over an %s of %s.',
[faces[c.face],suits[c.suit]]));if nturns=nil then playsound('DING',hinstance,
snd_Resource or SND_SYNC)else if nturns^>3 then playsound(strfmt(rwave,'GOOD%d',
[random(3)]),hinstance,snd_Resource or SND_SYNC)else playsound('DING',hinstance,
snd_Resource or SND_SYNC);end;
2:garbagegame.ListBox1.Items.insert(0,format('Computer has drawn an %s of %s.',[
faces[c.face],suits[c.suit]]));
3:Begin garbagegame.ListBox1.Items.insert(0,format(
'Computer has flipped over an %s of %s.',[faces[c.face],suits[c.suit]]));
if nturns=nil then playsound('DING',hinstance,snd_Resource or SND_SYNC)else if
nturns^>3 then playsound(strfmt(rwave,'GOOD%d',[random(3)]),hinstance,
snd_Resource or SND_SYNC)else playsound('DING',hinstance,snd_Resource or SND_SYNC);end;
end;
end;
procedure NewGame;
var i:integer;
begin
candraw:=true;
discard.clear;
Garbagegame.StatusBar1.Panels[1].text:=format('%d/%d',[playerpos,computerpos]);
for i:=2 to 3do
garbagegame.StatusBar1.Panels[i].text:='0';
inc(gamenum);
garbagegame.StatusBar1.Panels[0].text:=format('Game %d',[gamenum]);
zeromemory(@used,sizeof(used));
zeromemory(@playercards,sizeof(playercards));
zeromemory(@computercards,sizeof(computercards));
for i:=1to playerpos do playercards[i]:=drawcard;
for i:=1to computerpos do computercards[i]:= drawcard;
if allused then reshuffle;
discard.Add(pointer(drawcard));
addcardtolistbox(discard.Last,0,nil);
garbagegame.Image11.Enabled:=false;
playermoveenable;
garbagegame.Button1.visible:=true;
end;
function pccard(i,j:integer):pchar;
begin
result:=stralloc(8);
strfmt(result,'CARD%d%x',[j,i]);
end;
function pcback(index:integer):pchar;
begin
result:=stralloc(8);
strfmt(result,'BACK%d',[index]);
end;
procedure updatecards;
var p:pointer;
c:tplayingcard;
i,j:integer;
pc:pchar;
nocard:tbitmap;
begin
candraw:=not allused;
with garbagegame do begin
image1.Transparent:=(computercards[1].flags and card_dead=card_dead);
image2.Transparent:=(computercards[2].flags and card_dead=card_dead);
image3.Transparent:=(computercards[3].flags and card_dead=card_dead);
image4.Transparent:=(computercards[4].flags and card_dead=card_dead);
image5.Transparent:=(computercards[5].flags and card_dead=card_dead);
image6.Transparent:=(computercards[6].flags and card_dead=card_dead);
image7.Transparent:=(computercards[7].flags and card_dead=card_dead);
image8.Transparent:=(computercards[8].flags and card_dead=card_dead);
image9.Transparent:=(computercards[9].flags and card_dead=card_dead);
image10.Transparent:=(computercards[10].flags and card_dead=card_dead);
image13.Transparent:=(playercards[1].flags and card_dead=card_dead);
image14.Transparent:=(playercards[2].flags and card_dead=card_dead);
image15.Transparent:=(playercards[3].flags and card_dead=card_dead);
image16.Transparent:=(playercards[4].flags and card_dead=card_dead);
image17.Transparent:=(playercards[5].flags and card_dead=card_dead);
image18.Transparent:=(playercards[6].flags and card_dead=card_dead);
image19.Transparent:=(playercards[7].flags and card_dead=card_dead);
image20.Transparent:=(playercards[8].flags and card_dead=card_dead);
image21.Transparent:=(playercards[9].flags and card_dead=card_dead);
image22.Transparent:=(playercards[10].flags and card_dead=card_dead);
end;
for i:=0to 2do begin deleteobject(emptyslots[i]);pc:=pccard(i,0);emptyslots[i]:=loadbitmap(hdeck,pc);
strdispose(pc);end;
for i:=0to 11 do begin deleteobject(hbacks[i]);pc:=pcback(i);hbacks[i]:=loadbitmap(hdeck,pc);
strdispose(pc);end;
for i:=0 to 12do for j:=1to 4do begin deleteobject(deck_pics[i,j]);pc:=pccard(i,j);deck_pics[i,j]:=
loadbitmap(hdeck,pc);strdispose(pc);end;
if computercards[1].flags and card_flipped=0then
garbagegame.image1.picture.bitmap.handle:= hbacks[back] else
garbagegame.image1.picture.bitmap.handle:= deck_pics[computercards[1].face,
computercards[1].suit];
if computercards[2].flags and card_flipped=0then
garbagegame.image2.picture.bitmap.handle:= hbacks[back] else
garbagegame.image2.picture.bitmap.handle:= deck_pics[computercards[2].face,
computercards[2].suit];
if computercards[3].flags and card_flipped=0then
garbagegame.image3.picture.bitmap.handle:= hbacks[back] else
garbagegame.image3.picture.bitmap.handle:= deck_pics[computercards[3].face,
computercards[3].suit];
if computercards[4].flags and card_flipped=0then
garbagegame.image4.picture.bitmap.handle:= hbacks[back] else
garbagegame.image4.picture.bitmap.handle:= deck_pics[computercards[4].face,
computercards[4].suit];
if computercards[5].flags and card_flipped=0then
garbagegame.image5.picture.bitmap.handle:= hbacks[back] else
garbagegame.image5.picture.bitmap.handle:= deck_pics[computercards[5].face,
computercards[5].suit];
if computercards[6].flags and card_flipped=0then
garbagegame.image6.picture.bitmap.handle:= hbacks[back] else
garbagegame.image6.picture.bitmap.handle:= deck_pics[computercards[6].face,
computercards[6].suit];
if computercards[7].flags and card_flipped=0then
garbagegame.image7.picture.bitmap.handle:= hbacks[back] else
garbagegame.image7.picture.bitmap.handle:= deck_pics[computercards[7].face,
computercards[7].suit];
if computercards[8].flags and card_flipped=0then
garbagegame.image8.picture.bitmap.handle:= hbacks[back] else
garbagegame.image8.picture.bitmap.handle:= deck_pics[computercards[8].face,
computercards[8].suit];
if computercards[9].flags and card_flipped=0then
garbagegame.image9.picture.bitmap.handle:= hbacks[back] else
garbagegame.image9.picture.bitmap.handle:= deck_pics[computercards[9].face,
computercards[9].suit];
if computercards[10].flags and card_flipped=0then
garbagegame.image10.picture.bitmap.handle:= hbacks[back] else
garbagegame.image10.picture.bitmap.handle:= deck_pics[computercards[10].face,
computercards[10].suit];
if discard.Count=0 then garbagegame.Image12.Picture.Bitmap.Handle:=emptyslots[0]
else begin p:=discard.Last;Copymemory(@c,@p,4);
garbagegame.Image12.Picture.Bitmap.handle:=deck_pics[c.face,c.suit];
end;
if playercards[1].flags and card_flipped=0then
garbagegame.image13.picture.bitmap.handle:= hbacks[back] else
garbagegame.image13.picture.bitmap.handle:= deck_pics[playercards[1].face,
playercards[1].suit];
if playercards[2].flags and card_flipped=0then
garbagegame.image14.picture.bitmap.handle:= hbacks[back] else
garbagegame.image14.picture.bitmap.handle:= deck_pics[playercards[2].face,
playercards[2].suit];
if playercards[3].flags and card_flipped=0then
garbagegame.image15.picture.bitmap.handle:= hbacks[back] else
garbagegame.image15.picture.bitmap.handle:= deck_pics[playercards[3].face,
playercards[3].suit];
if playercards[4].flags and card_flipped=0then
garbagegame.image16.picture.bitmap.handle:= hbacks[back] else
garbagegame.image16.picture.bitmap.handle:= deck_pics[playercards[4].face,
playercards[4].suit];
if playercards[5].flags and card_flipped=0then
garbagegame.image17.picture.bitmap.handle:= hbacks[back] else
garbagegame.image17.picture.bitmap.handle:= deck_pics[playercards[5].face,
playercards[5].suit];
if playercards[6].flags and card_flipped=0then
garbagegame.image18.picture.bitmap.handle:= hbacks[back] else
garbagegame.image18.picture.bitmap.handle:= deck_pics[playercards[6].face,
playercards[6].suit];
if playercards[7].flags and card_flipped=0then
garbagegame.image19.picture.bitmap.handle:= hbacks[back] else
garbagegame.image19.picture.bitmap.handle:= deck_pics[playercards[7].face,
playercards[7].suit];
if playercards[8].flags and card_flipped=0then
garbagegame.image20.Picture.bitmap.handle:= hbacks[back] else
garbagegame.image20.picture.bitmap.handle:= deck_pics[playercards[8].face,
playercards[8].suit];
if playercards[9].flags and card_flipped=0then
garbagegame.image21.picture.bitmap.handle:= hbacks[back] else
garbagegame.image21.picture.bitmap.handle:= deck_pics[playercards[9].face,
playercards[9].suit];
if playercards[10].flags and card_flipped=0then
garbagegame.image22.picture.bitmap.handle:= hbacks[back] else
garbagegame.image22.picture.bitmap.handle:= deck_pics[playercards[10].face,
playercards[10].suit];
if allused then garbagegame.Image11.Picture.Bitmap.Handle:=emptyslots[2]
else garbagegame.Image11.Picture.Bitmap.handle:=hbacks[back];
end;
function computerthread(dummy:pointer):dword;stdcall;
var p:pointer;
c,cd:tplayingcard;
drawused:boolean;
i,kingpos:integer;
label draw,discard0,endturn,ktry;
begin
inc(whoseturn);
cturn:=0;
pturn:=0;
garbagegame.Button1.Visible:=false;
drawused:=false;
discard0:
p:=discard.Last;
copymemory(@c,@p,4);
if(c.face=12)and(kingswild=1)then begin
ktry:kingpos:=random(computerpos)+1;
if(computercards[kingpos].flags and card_flipped>0)then goto ktry;
i:=strtoint(garbagegame.statusbar1.panels[3].text)+1;
garbagegame.StatusBar1.Panels[3].text:=inttostr(i);
discard[discard.Count-1]:=pointer(computercards[kingpos]);
c.flags:=c.flags or card_flipped;
computercards[kingpos]:=c;
addcardtolistbox(discard.last,3,@cturn);
drawused:=true;
updatecards;
if i=computerpos then begin endround;exit;end;
goto discard0;
end;
if c.face+1>computerpos then goto draw;
if computercards[c.face+1].flags and card_flipped>0then goto draw;
i:=strtoint(garbagegame.statusbar1.panels[3].text)+1;
garbagegame.StatusBar1.Panels[3].text:=inttostr(i);
discard[discard.Count-1]:=pointer(computercards[c.face+1]);
c.flags:=c.flags or card_flipped;
computercards[c.face+1]:=c;
addcardtolistbox(discard.last,3,@cturn);
drawused:=true;
updatecards;
if i=computerpos then begin endround;exit;end;
goto discard0;
draw:
sleep(1000);
if drawused then goto endturn;
drawused:=true;
if allused then reshuffle;
discard.Add(pointer(drawcard));
addcardtolistbox(discard.last,2,nil);
goto discard0;
endturn:garbagegame.Button1.Visible:=true;
updatecards;
playermoveenable;
garbagegame.Image11.Enabled:=true;
end;
procedure Tgarbagegame.FormCreate(Sender: TObject);
var i,j:integer;
pc:pchar;
hk:hkey;
tid,rs:dword;
deckdll:array[0..max_path]of char;
begin
randomize;
candraw:=true;
discard:=tlist.Create;
regcreatekey(hkey_current_User,'Software\Justin\Garbage',hk);
if regqueryvalueex(hk,'DeckDLL',nil,nil,@deckdll,@rs)=error_success then
hdeck:=loadlibrary(deckdll)else hdeck:=hinstance;cardback;
rs:=4;
regqueryvalueex(hk,'KingsWild',nil,nil,@kingswild,@rs);
kingsarewild1.checked:=(kingswild=1);
playerpos:=strtointdef(paramstr(1),10);
computerpos:=strtointdef(paramstr(2),10);
gamenum:=strtointdef(paramstr(3),0);
regclosekey(hk);
whoseturn:=strtointdef(paramstr(4),0);
image1.Visible:=true;
image2.Visible:=(computerpos>1);
image3.Visible:=(computerpos>2);
image4.Visible:=(computerpos>3);
image5.Visible:=(computerpos>4);
image6.Visible:=(computerpos>5);
image7.Visible:=(computerpos>6);
image8.Visible:=(computerpos>7);
image9.Visible:=(computerpos>8);
image10.Visible:=(computerpos>9);
image13.Visible:=true;
image14.Visible:=(playerpos>1);
image15.Visible:=(playerpos>2);
image16.Visible:=(playerpos>3);
image17.Visible:=(playerpos>4);
image18.Visible:=(playerpos>5);
image19.Visible:=(playerpos>6);
image20.Visible:=(playerpos>7);
image21.Visible:=(playerpos>8);
image22.Visible:=(playerpos>9);
pturn:=0;
newgame;
updatecards;
end;
procedure Tgarbagegame.ChangeBack1Click(Sender: TObject);
begin
changebackwnd.Visible:=true;
changebackwnd.BringToFront;
visible:=false;
end;
procedure Tgarbagegame.Button1Click(Sender: TObject);
var tid:dword;
begin
createthread(nil,0,@computerthread,nil,0,tid);
end;
procedure Tgarbagegame.Image13Click(Sender: TObject);
var p:pointer;
c,cd:tplayingcard;
i:integer;
begin
inc(whoseturn);
p:=discard.Last;
copymemory(@c,@p,4);
if kingswild=0 then
if TImage(sender).tag<>c.face then exit;
cd:=playercards[TImage(sender).tag+1];
discard[discard.Count-1]:=pointer(cd);
addcardtolistbox(discard.last,1,@pturn);
playercards[timage(sender).tag+1]:=c;
playercards[timage(sender).tag+1].flags:=c.flags or card_flipped;
playermoveenable;
garbagegame.Image11.Enabled:=false;
updatecards;
i:=strtoint(statusbar1.panels[2].text)+1;
statusbar1.Panels[2].text:=inttostr(i);
if i=playerpos then begin endround;exit;end;
end;
procedure Tgarbagegame.Image11Click(Sender: TObject);
begin
if allused then reshuffle;
discard.add(pointer(drawcard));
addcardtolistbox(discard.last,0,nil);
updatecards;
image11.Enabled:=false;
playermoveenable;
end;
procedure Tgarbagegame.AboutGarbage1Click(Sender: TObject);
var aboutt:array[0..1024]of char;
begin
messagebox(handle,strfmt(aboutt,
'Garbage v%d.%d by Justin Roeder.'#13#10'Special thanks goes to Camp CILCA'#13#10'Website: https://delphijustin.biz',[
hibyte(version),lobyte(version)]),'About Garbage',0);
end;
procedure Tgarbagegame.ListBox1DblClick(Sender: TObject);
begin
messagebox(handle,PChar(Listbox1.items[listbox1.itemindex]),'Garbage',0);
end;
procedure Tgarbagegame.Rules1Click(Sender: TObject);
begin
shellexecute(handle,nil,'http://www.gathertogethergames.com/garbage',nil,nil,
sw_show);
end;
procedure Tgarbagegame.KingsAreWild1Click(Sender: TObject);
var hk:hkey;
begin
kingsarewild1.Checked:=not kingsarewild1.Checked;
if kingsarewild1.Checked then kingswild:=1 else kingswild:=0;
regcreatekey(hkey_current_user,'Software\Justin\Garbage',hk);
regsetvalueex(hk,'KingsWild',0,reg_dword,@kingswild,4);
regclosekey(hk);
end;
end.
unit garbage2;
//Change CardDeck Unit
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ExtDlgs,Shellapi;
type
Tchangebackwnd = class(TForm)
ScrollBar1: TScrollBar;
Button1: TButton;
Button2: TButton;
CheckBox1: TCheckBox;
Button3: TButton;
Button4: TButton;
OpenDialog1: TOpenDialog;
Button5: TButton;
procedure Button1Click(Sender: TObject);
procedure ScrollBar1Change(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button4Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
changebackwnd: Tchangebackwnd;
implementation
{$R *.DFM}
uses garbage1;
procedure Tchangebackwnd.Button1Click(Sender: TObject);
var hk:hkey;
ba:dword;
begin
regcreatekey(hkey_current_user,'software\Justin\Garbage',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;
updatecards;
close;
end;
procedure Tchangebackwnd.ScrollBar1Change(Sender: TObject);
begin
formpaint(nil);
end;
procedure Tchangebackwnd.Button2Click(Sender: TObject);
begin
close;
end;
procedure Tchangebackwnd.FormPaint(Sender: TObject);
var bmp:tbitmap;
backst:array[0..8]of char;
begin
bmp:=tbitmap.Create;
bmp.Handle:=loadbitmap(hdeck,strfmt(backst,'BACK%d',[scrollbar1.position]));
canvas.Draw(0,0,bmp);
bmp.FreeImage;
bmp.Free;
end;
procedure Tchangebackwnd.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
garbagegame.Visible:=true;
end;
procedure Tchangebackwnd.Button4Click(Sender: TObject);
var hk:hkey;
begin
regcreatekey(hkey_current_user,'Software\Justin\Garbage',hk);
regdeletevalue(hk,'DeckDLL');
Regdeletevalue(hk,'CardBack');
regclosekey(hk);
end;
procedure Tchangebackwnd.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,'Software\Justin\Garbage',hk);
regsetvalueex(hk,'DeckDLL',0,reg_sz,strpcopy(buff,opendialog1.filename),length(
opendialog1.filename)+1);
Regclosekey(hk);
repaint;
end;
procedure Tchangebackwnd.Button5Click(Sender: TObject);
begin
shellexecute(handle,nil,'https://delphijustin.biz/bin/carddecks/',nil,nil,sw_show);
end;
end.
All programs are virus free. Some antivirus software might say its "suspicious" or a "Potentionaly Unwanted Program". Some of them rate them on what there code looks like no matter if theres a definition in the virus database. If any of them are detected any Antivirus I will zip the software with the password "justin" j is lowercase
NEW HTML Version is available
delphijustin Industries is an Autism Supported Business
Circuit Simulator