PingEx Alternative to Network PING

This tool is a great alternative to Windows Ping.exe file. Not only does it work with ICMP, it works with Internet Explorer type protocols (such as HTTP, HTTPS and FTP). On the ICMP Protocol (which is the protocol Windows Ping uses) allows you to specify the data that will be echoed back from the host If you don’t specify a the data string it will use the date time, packet index number and process id as the default data. This is option -d.

The default data will look like something like this if its being sniffed:

12/19/2017 4:39:28 PM#1 5676.

Where blue is the date and time red is the packet number and purple is the process id. And to end packet to make it more readable I put a period at the end of it.

To see what available command line options are type in pingex.exe /?  At the command prompt where you unzipped it to.

Here are some few examples here

Pingex.exe 8.8.8.8 -d “Hi Google DNS”

The command above pings google dns(8.8.8.8) with the data bytes set to “Hi Google DNS’

Pingex.exe http://www.pontaic90.org/ -n 5 –url

The command above does an HTTP ping with 5 request, don’t forget to put in –url in the command line otherwise you will have problems.

You can press Control+C at anytime to abort the ping tool and see the results. As well as viewing them without ending the ping by pressing Control+Break

Also checkout the Internet resetter option in it that can reboot any router or modem when the internet goes down see SerialResetter.bat and SerialResetter_Schematic.pdf file. Requires a circuit to be built and working with mains voltage.

Features of version 1.0.0.1 are offline batch file and random website URL Ping
program pingex;
{$RESOURCE PINGEX32.RES}
{$APPTYPE CONSOLE}

uses
  SysUtils,
  math,
  httpapp,
  windows,
  winsock,
  mmsystem,
  Classes,
  urlmon,
  shellapi,
  ICMP in '..\delphi\ICMP.PAS';
const MAX_URLBUFFER=64*1024;

VAR MyICMP:TICMP;
count,successcount,trigger,i,irto:integer;
reply:PIcmpEchoReply;
LastPong:tdatetime;
errres,sitesres:TResourceStream;
icmperr:tstringlist;
t,tmax,bread,bmax,timerid:dword;
tmin:dword=$FFFFFFFF;
bmin:dword=$ffffffff;
hstat:hresult;
scomport,sh,s:string;
sites:tstringlist;
htimer,hf,hcom:thandle;
urlfile,oldtitle:array[0..max_path]of char;
PMask:pchar;
ipoptions:TIPOptionInformation;
urlbuff:array of ansichar;
data:array of byte;
totalt,totalb:extended;
a,b,c,d:byte;
function GetStatCode:string;
begin
result:='Unknown: '+Inttostr(reply.status);
if icmperr.IndexOf(inttostr(reply.status))=-1 then exit;
result := icmperr[icmperr.indexof(inttostr(reply.status))-1];
if reply.Status=0 then inc(Successcount);
if not comparemem(@myicmp.data[1],reply.data,length(myicmp.data)) then
result:=result+' INVALID DATA';
end;

function GetSize(fs:dword):String;
begin
result:=inttostr(fs)+' bytes';
if fs>1023 then result:=formatfloat('0.00',fs/1024)+' kilobytes';
if fs>(1024*1024)-1then result:=formatfloat('0.00',fs/(1024*1024))+' megabytes';
if fs=$FFFFFFFFthen result:='Size Error';
end;

function PingTime(tx:dword):string;
begin
if tx>999 then result:=formatdatetime('hh:mm:ss',tx*encodetime(0,0,0,1))else
result:=inttostr(tx)+'ms';
end;

function Divide(n,d:extended):Extended;
begin
result:=0;
if d>0then result:=n/d;
end;

function TimerThread(Dummy:pointer):dword;stdcall;
var contitle:array[0..255]of char;
label loop;
begin
loop:
setconsoletitle(strfmt(contitle,
'PingEx - %u Success, Packet Count %u, Packet Success: %f%s Last Pong: %s',[
successcount,count-1,Divide(successcount,count-1)*100,'%',DateTimeToStr(
lastpong)]));
sleep(100);
goto loop;
end;

function CtrlPing(typ:dword):bool;stdcall;
begin
result:=true;
writeln('Ping Details:');
writeln('Packets: Sent=',count-1,' Recevied=',successcount,' Lost=',(count-1)-
successcount);
if pos(' -url',lowercase(getcommandline))>0 then
writeln('Min. data: ',GetSize(bmin),' Max. data: ',getsize(bmax),' Ave. data: ',
getsize(trunc(divide(totalb,count-1))));
writeln('Min. Time: '+pingtime(tmin),' Max. Time: ',pingtime(tmax),' Ave. Time: ',
pingtime(Trunc(divide(totalt,count-1))));
writeln('Success rate:',trunc(100*divide(successcount,count-1)),'%');
writeln('Last Pong: ',datetimetostr(lastpong));
if typ<>CTRL_BREAK_EVENT then begin
setconsoletitle(oldtitle);
if scomport<>''then closehandle(hcom);
errres.Free;
icmperr.Free;
myicmp.Destroy;
if count-1>0 then
exitprocess(trunc(100*(successcount/(count-1))))else Exitprocess(0);
end;
end;

function GetDataSizeP:integer;
var i:integer;
begin
result:=0;
for i:=2 to paramcount do
if stricomp(pchar(paramstr(i)),'-l')=0then
result:=strtointdef(paramstr(i+1),32);
setlength(data,result);
for i:=0 to length(data)-2 do
data[i]:=(i mod 255)+1;
end;

function CheckPattern(const pattern:string;len:integer):boolean;
var i:integer;
begin
result:=false;
if(len<>length(pattern))then exit;
result:=true;
for i:=1to length(pattern)do result:=result and((i mod 16)=strtointdef('$'+
pattern[i],16));
end;

function GeneratePattern(len:integer):string;
var i:integer;
begin
result:='';
for i:=1to len do result:=result+inttohex(i mod 16,1);
end;

function GetDataString:string;
var i:integer;
begin
result:=datetimetostr(now)+'#'+inttostr(count)+' '+inttostr(getcurrentprocessid)+'.';
if strpos(getcommandline,' -url')<>nil then result:=generatepattern(getdatasizep);
for i:=1 to paramcount do begin
if stricomp('-d',pchar(paramstr(i)))=0then result:=paramstr(i+1);
if(stricomp('-dhex',pchar(paramstr(i)))=0) then result:=generatepattern(strtointdef(paramstr(i+1),32));
end;
if result='' then begin
writeln('Err:data parameter needs a string');
exitprocess(0);
end;
if getdatasizep>0 then result:=strpas(@Data[0]);
end;

function GetPacketCount:integer;
var i:integer;
begin
result:=-1;
for i:= 2 to paramcount do
if stricomp('-n',pchar(paramstr(i)))=0then result:=strtointdef(paramstr(i+1),4);
end;

Function GetDelay:dword;
var i:integer;
begin
result:=1000;
for i:=2 to paramcount do
if stricomp('-de',pchar(paramstr(i)))=0then result:=strtointdef(paramstr(i+1),
result);
end;

function GetTimeout:integer;
var i:integer;
begin
result:= myicmp.TimeOut;
for i:=2 to paramcount do
if stricomp('-w',pchar(paramstr(i)))=0then result:=strtointdef(paramstr(i+1),
result);
end;

function GetTOS:Integer;
var i:integer;
begin
result := myicmp.IPOptions.TOS;
for i:=2to paramcount do
if stricomp('-v',pchar(paramstr(i)))=0then result:=Strtointdef(paramstr(i+1),
result);
end;

function GetTTL:Integer;
var i:integer;
begin
result := myicmp.IPOptions.TTL;
for i:=2to paramcount do
if stricomp('-i',pchar(paramstr(i)))=0then result:=Strtointdef(paramstr(i+1),
result);
end;

function GetHTMLTitle:string;
begin
result :=copy(strpas(@urlbuff[0]),pos('<title>',lowercase(pchar(@urlbuff[0])))+
length('<title>'),pos('</title>',lowercase(pchar(@urlbuff[0])))-pos('<title>',
lowercase(pchar(@urlbuff[0])))-Length('</title'));
end;

function GetURLError:string;
begin
result:='Unknown Error';
if hstat=urlmon.INET_E_INVALID_URL then result:='Invalid URL';
if hstat=urlmon.INET_E_NO_SESSION then result:='No session';
if hstat=urlmon.INET_E_CANNOT_CONNECT then result:='Cannot Connect';
if hstat=urlmon.INET_E_RESOURCE_NOT_FOUND then result:='Resource Not Found';
if hstat=urlmon.INET_E_OBJECT_NOT_FOUND then result:='Object not found';
if hstat=urlmon.INET_E_DATA_NOT_AVAILABLE then result :='Data not available';
if hstat=urlmon.INET_E_DOWNLOAD_FAILURE then result := 'Download Failed';
if hstat=urlmon.INET_E_AUTHENTICATION_REQUIRED then result:='Login required';
if hstat=urlmon.INET_E_NO_VALID_MEDIA then result:='No valid media';
if hstat=urlmon.INET_E_CONNECTION_TIMEOUT then result:='Connection timedout';
if hstat=urlmon.INET_E_INVALID_REQUEST then result:='Invalid request';
if hstat=urlmon.INET_E_UNKNOWN_PROTOCOL then result:='Unsupported protocol';
end;

function ProcessPingExServer(html:PChar):boolean;
var data:tstringlist;
begin
result:=(paramstr(1)='');
if not result then Result:=((paramstr(1)[1]='-')and(stricomp(pchar(paramstr(1)),
'-urlr')<>0))or(strpos(getcommandline,' -ht')<>nil);
if not result then begin result:=true;exit;end;
if strpos(html,'<!-- PingEx_Server -->')=nil then result:=false;
data:=tstringlist.Create;
data.Text:=strpas(html);
if length(data.values['hex'])<>getdatasizep then begin result:=false;exit;end;
for i:=1to getdatasizep do result:=result and((i mod 16)=strtointdef('$'+
data.values['hex'][i],16));
end;

function HTMLValidate(const html:pchar):boolean;
var i:integer;
begin
result:=true;
for i:=2to paramcount do if stricomp(PChar(paramstr(i)),'-k')=0then
result:=result and (StrPos(html,pchar(paramstr(i+1)))=nil);
end;

function GetTrigger:integer;
var i:integer;
begin
result:=-1;
for i:=2 to paramcount do
if stricomp(PChar(paramstr(i)),'-tl')=0then result:=strtointdef(paramstr(i+1),5);
end;

function PlayWave(xwave:byte):bool;
const aWaves:array[0..2]of pchar=('PONG','OFFLINE','ONLINE');
begin
result:=false;
if strpos(getcommandline,' -nosound')<>nil then exit;
result:=playsound(awaves[xwave],hinstance,snd_resource or snd_sync);
end;

function InternetActup:boolean;
var hoffline:thandle;
dwwrite:dword;
a:atom;
cmdline:String;
comb:char;
batcmd,ab:array[0..255]of char;
statepath:array[0..max_path]of char;
txsuccess:bool;
i:integer;
begin
cmdline:=lowercase(getcommandline);
result := false;
inc(trigger);
if(trigger<gettrigger)or(gettrigger=-1)then exit;
trigger:=0;
result:=(scomport<>'');
txsuccess:=true;
for i:=2to paramcount do
if stricomp(pchar(paramstr(i)),'-bat')=0then result:=true;
if not result then exit;
writeln('Resetting internet connection. Please wait for ',irto div 60000,' minutes');
if pos(' -bat',cmdline)=0 then begin
comb:='1';
if pos(' -tx',cmdline)>0then txsuccess:=txsuccess and writefile(hcom,comb,1,
dwwrite,nil)else begin
//escapecommfunction(hcom,setdtr);
escapecommfunction(hcom,SETRTS);end;if not txsuccess then writeln('ComTXFail1:',
syserrormessage(getlasterror));
sleep(10000);
if pos(' -tx',cmdline)=0then
escapecommfunction(hcom,clrrts);
sleep(irto);
comb:='0';
if pos(' -tx',cmdline)>0then txsuccess:=txsuccess and writefile(hcom,comb,1,
dwwrite,nil)else escapecommfunction(hcom,clrdtr);if not txsuccess then
writeln('ComTXFail0:',syserrormessage(getlasterror));
end else begin
a:=globaladdatom(PChar('PingEx_OFFLINEBAT_'+floattostr(now)));
shellexecute(0,nil,'offline.bat',strfmt(batcmd,'%d %d',[a,trigger]),nil,
sw_hide);
writeln('Waiting for batch file to complete...');
while GlobalGetAtomName(a,ab,256)>0do sleep(2500);
end;
playwave(2);
writeln('Now rechecking...');
end;

function GetFileSize2(hf:thandle):DWord;
begin
result:= getfilesize(hf,nil);
if result=$FFFFFFFF then result:=0;
end;

function CharCount(const s:string;c:char):integer;
var i:integer;
begin
result:=0;
for i:=1to length(s)do if s[i]=c then inc(result);
end;

function FormatIP(var a,b,c,d:byte;size:integer;Host:string):String;
begin
result:=stringreplace(host,'@','%d',[rfReplaceAll]);
case size of
0:asm nop end;
1:begin if d=255then d:=0;D:=d+1;result:=format(result,[d]);end;
2:begin if c=255then begin c:=0;d:=d+1;end;if d=255then begin d:=0;c:=c+1;end;
d:=d+1;result:=format(result,[c,d]);end;
3:begin if b=255then b:=0;if c=255then begin c:=0;b:=b+1;end;
if d=255then begin d:=0;c:=c+1;end;d:=d+1;result:=format(result,[b,c,d]);end;
4:begin if a=255then a:=0;if b=255then begin b:=0;a:=a+1;end;if c=255then begin
c:=0;b:=b+1;end;if d=255then begin d:=0;c:=c+1;end;d:=d+1;result:=format(result,
[a,b,c,d]);end;
else begin writeln('Only up to 4 @ symbols allowed');exitprocess(
ERROR_INVALID_PARAMETER);end;
end;
end;



label PingLoop,URLLoop,lookup;
begin
getconsoletitle(oldtitle,max_path+1);
if stricomp('/resume',pchar(paramstr(1)))=0then exitprocess(globaldeleteatom(
strtoint(paramstr(2))));
if paramstr(1)='/?' then begin
writeln('Usage: ',extractfilename(paramstr(0)),' [address] [options]');
writeln('Options:');
writeln('-n count   Number of packets to send');
writeln('-d "data"  Data string to send in the echo request,by default is the system time,packet number and process id');
writeln('-w timeout timeout in milliseconds.');
writeln('-i TTL     Time To Live');
writeln('-v TOS     Type Of Service');
writeln('-de delay  Specifies the delay time between each request.');
writeln('-url       Use URL instead of ICMP [address] is the URL');
writeln('-urlr      Use random website URLs in the built-in database.');
writeln('-k "word"  HTML Error Keywords,used to tell if the URL request was successful, you can put more than one of this option in one command');
writeln('-l [size]  Size of data buffer');
writeln('-ir232 comport [timeout] Starts the internet resetter which toggles a relay to restart a misbehaving router/modem, [timeout] is in minutes');
writeln('-tl [count] Number of failed attemps before resetting the internet router/modem. Default is 5. This must be used with -ir232');
writeln('-bat        Run offline.bat file hiddenly when if went offline');
writeln('-tx         Transmitt ACSII 1s and 0s through the internet resetter serial port for using Arduino');
writeln('-nosound    Disable alert sounds.');
writeln('-dhex [size] Use a hexadecimal loop pattern. This will make the data string start from ASCII Number 1 to ASCII Letter F and then ASCII Number 0 then looping back around to make a string the specified size. This overrides the -d option.');
writeln('-ht          Uses PingEx HTTP Server url');
writeln;
writeln('Supported URL Protocols: HTTP,HTTPS,FTP');
writeln('You can put @ symbols in the address for ip address range example 127.0.0.@ will replace it with number between 1-255');
exitprocess(0);
end;
htimer:=createthread(nil,0,@timerthread,nil,0,timerid);
sitesres:=TResourceStream.Create(hinstance,'WEBSITES','TXT');
scomport:='';
for i:=2to paramcount do if stricomp('-ir232',pchar(paramstr(i)))=0then begin
scomport:='\\.\'+paramstr(i+1);
irto:=strtointdef(paramstr(i+2),5)*60000;
end;
if scomport<>''then begin
hcom:=createfile(pchar(scomport),generic_read or generic_write,0,nil,
open_existing,file_attribute_normal,0);
if hcom=invalid_handle_value then writeln('OpenCom:',syserrormessage(getlasterror));
end;
SetConsoleCtrlHandler(@ctrlping,true);
sites:=tstringlist.create;
sites.LoadFromStream(sitesres);sitesres.Free;
randomize;
icmperr:=tstringlist.Create;
errres:=tresourcestream.Create(hinstance,'ICMPERR','TXT');
icmperr.LoadFromStream(errres);
myicmp:=ticmp.create(nil);
ipoptions.OptionsSize:=myicmp.IPOptions.OptionsSize;
ipoptions.OptionsData:=myicmp.IPOptions.OptionsData;
IPOptions.TTL:=getttl;
iPOptions.TOS:=gettos;
myicmp.IPOptions:=ipoptions;
myicmp.TimeOut := gettimeout;
count:=1;
if (pos(' -url',lowercase(getcommandline))>0)or(paramcount=0)or(strpos(
getcommandline,' -ht')<>nil)then begin
if pos(' -urlr',lowercase(getcommandline))=0then begin
if paramcount<>0 then
writeln('Pinging ',paramstr(1),'...')else
writeln('Pinging http://172.86.120.127/test.asp...');
end else writeln('Pinging random URLs...');
a:=0;b:=0;c:=0;d:=0;
urlloop:
t:=gettickcount;
s:=paramstr(1);
if(paramcount=0)or(stricomp('-urlspeed',pchar(paramstr(1)))=0)then s:=
'http://172.86.120.127/test.asp';
s:=formatip(a,b,c,d,charcount(paramstr(1),'@'),s);
if pos(' -urlr',lowercase(getcommandline))>0then begin s:='http://'+sites[random(
sites.count)]+'/';write(copy(s,length('http://')+1,length(s)));end;
if pos('ftp:',lowercase(s))=0then
if strscan(pchar(s),'?')=nil then s:=s+'?'else s:=s+'&';
if pos('ftp:',lowercase(s))=0 then
s:=format(
'%sping.count=%d&ping.success=%d&ping.pid=%d&ping.size=%d',[s,count,successcount,
getcurrentprocessid,getdatasizep]);
if strscan(getcommandline,'@')<>nil then begin sh:=copy(s,pos('://',s)+3,length(s));
delete(sh,pos('?',sh),length(sh));write(sh,#32);end;
hstat:=URLDownloadToCacheFile(nil,pchar(s),urlfile,max_path,0,nil);
if (hstat=s_ok) then
begin
lastpong:=now;
hf:=createfile(urlfile,generic_read,0,nil,open_Existing,file_attribute_normal,0);
setlength(urlbuff,getfilesize(hf,nil)+1);
readfile(hf,urlbuff[0],length(urlbuff)-1,bread,nil);
trigger:=0;
if not htmlvalidate(@urlbuff[0]) then
write('KWFound: ');
if processpingexserver(@urlbuff[0])then
writeln(datetimetostr(now),'#',count,' Title:',gethtmltitle,' - Got ',getsize(
getfilesize(hf,nil)),' in ',pingtime(gettickcount-t))else begin
writeln(datetimetostr(now),'#',count,'Failed:',gethtmltitle,' - Got ',getsize(
getfilesize(hf,nil)),' in ',pingtime(gettickcount-t));dec(count);playwave(1);end;
bmin:=min(GetFilesize2(hf),bmin);
bmax:=max(getfilesize2(hf),bmax);
totalb:=totalb+getfilesize2(hf);
closehandle(hf);
deletefile(urlfile);
if htmlvalidate(@urlbuff[0]) then begin PlayWave(0); inc(successcount);end;
end else begin playwave(1);
 Writeln(datetimetostr(now),'#',count,' URL Error:',inttohex(hstat,0),#32,
geturlerror);
internetactup;
end;
totalt:=totalt+(gettickcount-t);
tmin:=min(tmin,gettickcount-t);
tmax:=max(tmax,gettickcount-t);
inc(count);
sleep(getdelay);
if getpacketcount=count-1 then ctrlping(ctrl_close_event);
goto urlloop;
end;
lookup:if strscan(getcommandline,'@')=nil then begin
myicmp.HostName:=paramstr(1);
if not myicmp.LookupAddress then begin
writeln(datetimetostr(now),' Failed to lookup ',myicmp.hostname);
sleep(2500);
playwave(1);
goto lookup;
end;end;
writeln('Pinging ',myicmp.hostname,'[',myicmp.hostip,']...');
a:=0;b:=0;c:=0;d:=0;
PingLoop:if strscan(getcommandline,'@')<>nil then begin
myicmp.HostName:=formatip(a,b,c,d,charcount(paramstr(1),'@'),myicmp.HostName);
write(myicmp.hostname,#32);
end;
t:=gettickcount;
myicmp.Data:=GetDataString;
reply:=myicmp.ping;
if reply=nil then begin
writeln(Datetimetostr(now),'#',count,' - No response');
playwave(0);
internetactup;
end else begin lastpong:=now;
writeln(datetimetostr(now),'#',count,#32,inet_ntoa(in_addr(reply.address)),' - ',
getstatcode,' Time:',pingtime(gettickcount-t),' TTL:',reply.options.ttl);
trigger:=0;
end;
totalt:=totalt+(gettickcount-t);
tmin:=min(tmin,gettickcount-t);
tmax:=max(tmax,gettickcount-t);
inc(count);
sleep(getdelay);
if getpacketcount=count-1 then ctrlping(ctrl_close_event);
goto pingloop;
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

MoveEx The Windows file mover and deleter on startup

This tool allows you to delete or move files at winidows bootup. It does

it like its a service, BUT it doesnt use a Windows nt service. It uses

Windows NT Exported function MoveFileEx. By using that the file will be

deleted or moved before anything loads. Its a great tool to have if you

have a virus that is preventing itself from being deleted. A batch file

has been included called delete.bat. Just drag and drop the file you wish

to delete onto it. To see on ways to use this tool just open moveex by

itself at the command prompt.

 

WARNING THIS TOOL HASN’T BEEN TESTED ON WINDOWS 9X/ME,AND ACCOURDING TO

THE WIN32 API MANUAL IT SAYS THAT ONLY WINDOWS NT PLATFORM SUPPORT

OPERATIONS ON REBOOT.

 

More tools available at

www.delphijustin.biz

 

program MoveEx;
{$RESOURCE moveex32.res}
{$APPTYPE Console}

uses
  SysUtils,
  windows,
  Classes;

var dwopt:Dword;
b:boolean;
s:string;

begin
if paramcount<2 then begin
writeln('Usage: ',extractfilename(paramstr(0)),' oldfilename [newfilename] [options]');
writeln('Options:');
writeln('/D         Deletes the file instead of moving/renaming it');
writeln('/E         Work even when newfilename exists');
writeln('/T         Try moving/deleting file before doing it on next boot');
writeln('OPTIONS ARE CASE SENSITVE');
writeln('IF FILEPATHS CONTAIN SPACES THEY SHOULD HAVE QUOTES(") SURROUNDING THEM');
write('Press Enter to quit...');
readln(s);
exitprocess(0);
end;
setlasterror(0);
dwopt:=0;
if strpos(getcommandline,' /E')<>nil then
dwopt:=MOVEFILE_REPLACE_EXISTING;
if StrPos(getcommandline,' /T')<>nil then
begin
if StrPos(getcommandline,' /D')<>nil then
b:=deletefile(Pchar(paramstr(1)))else
b:=movefileex(PChar(paramstr(1)),pchar(paramstr(2)),dwopt);
writeln('Try:',syserrormessage(getlasterror));
if b then exitprocess(0);
end;
dwopt:=dwopt or MOVEFILE_DELAY_UNTIL_REBOOT;
if strpos(getcommandline,' /D')=nil then
MoveFileex(PChar(paramstr(1)),pchar(paramstr(2)),dwopt) else
movefileex(pchar(paramstr(1)),nil,dwopt);
writeln(syserrormessage(getlasterror));
exitprocess(getlasterror);
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

jsTraffup

jsTraffup v1.1 by delphijustin

Website: delphijustin.biz

E-mail:  admin@delphijustin.biz

 

What is this?

This is a script file used to tell traffup users how to revisit your Website. It has 3 modes:

JSTUP_MODE_HTML This puts a widget on to the page if it was referred by traffup, this is the recommended mode

JSTUP_MODE_POPUP Show a popup alert messagebox when a traffup users leaves the page(This doesn’t work on all browsers).

JSTUP_MODE_DISABLD This mode disables the script all together.

Function Parameters:

Mode: The Mode

Debug: For debugging jsTraffup, it should be false on a public page.

Left: Left position in pixels.

Right: Right position in pixels.

Version: This is for future versions; you should still use it, just set it to 1.1

The example code below shows you how to use it:
<script type="text/javascript" src="jsTraffup.js"></script>
<script type="text/javascript">
   initTraffup({Mode: JSTUP_MODE_HTML,
   Debug: false,
   Left: "0px",
   Top: "0px",
   Version: 1.1});
</script>

jsTraffup.js file

/* jsTraffup v1,1 By delphijustin
Not created by traffup

*/
const JSTUP_MODE_HTML=1;//This mode makes it write to the document instead of popup.
const JSTUP_MODE_DISABLED=0;
const JSTUP_MODE_POPUP=2;
const JSTUP_CURRENT_VERSION=1.1;
var JSTUP_CURRENT_CONFIG=0;

function initTraffup(config){
if(config.OverrideUnload){
document.onunload=CallTraffup;
}
JSTUP_CURRENT_CONFIG=config;
switch(config.Mode){
case JSTUP_MODE_HTML:
CallTraffup();
break;
case JSTUP_MODE_POPUP:
if((navigator.userAgent.indexOf("Firefox")>-1)||(navigator.userAgent.indexOf("Chrome")>-1)){JSTUP_CURRENT_CONFIG.Mode=JSTUP_MODE_HTML;return CallTraffup();}
window.onbeforeunload=CallTraffup;
break;
}
}

function CallTraffup(){
var S="To visit this site again goto "+location.href;
if(JSTUP_CURRENT_CONFIG.Debug||isTraffup(document.referrer)){
switch(JSTUP_CURRENT_CONFIG.Mode){
case JSTUP_MODE_HTML:
document.writeln(
'<DIV ID="jsTraffupDIV" STYLE="position:fixed; top:'+JSTUP_CURRENT_CONFIG.Top+'; left:'+JSTUP_CURRENT_CONFIG.Left+';"><TEXTAREA ROWS="1" COLS="'+S.length+'">'+
S+'</TEXTAREA><INPUT TYPE="BUTTON" VALUE="X" ONCLICK="CloseTraffup()"></DIV>');
break; 
case JSTUP_MODE_POPUP:
return S;
break;
}
}
}

function CloseTraffup(){
document.getElementById("jsTraffupDIV").innerHTML="";
}

function isTraffup(url){
var s=url.toLowerCase();
return s.indexOf('traffup.net/')>-1;
}

IP Address Calculators

This here is a collection of tools that a Network Administrator will

find useful. It calculates subnet masks, IP address ranges and number

of hosts that the subnet can have. One that does IPv4 address and

another that does IPv6 addresses.

 

It uses win32 api functions to convert IP addresses into their

integer form and back into a string. The IPv6 will require windows xp

or higher

 

More free tools available at http://www.delphijustin.biz

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.

FindSID For Domain Controllers

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

Extract Icons Tool

This tool is a great tool for programmers to have. It extracts icons

from DLL and EXE files. So then you dont have to go on the internet and

search for a icon for your program.

 

Usage: exticons.exe file_with_icons save_folder

It even extract icons from Windows 10 System files,where resource hacker doesn’t detect!
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.  

Compare File Tool

Contents

Command line syntax. 1

 

This tool is a great tool for finding files and see if they are the

same in certain ways or a percentage of equalness. The tool checks to

see if it can find a certain string in the file(ANSI or Unicode). The

tool can check for binary data. Its a whole lot better than the windows

FIND command.

 

Here are some examples on how to use it.

 

To check to see how much a file is the same

 

compare.exe file1.doc file2.doc

 

You can tell it to ignore the file size by adding the /SZ switch

 

compare.exe file1.doc file2.doc /SZ

 

Want to do a quick file scan(64kb buffer) then add /M /AE switches.

 

compare.exe file1.doc file2.doc /M /AE

 

What about searching for Unicode or ANSI strings

 

for Unicode its /TWT Switch

 

compare.exe "search for me" file2.doc /TWT

 

and for ANSI its /TXT

 

compare.exe "Search for me" file2.doc /TXT

 

for binary you should URL Encode the string like this

 

compare.exe Search%20for%20me file2.doc /URL

 

You can see an example on Search.bat file.

Command line syntax

Here’s a list of all command-line switches:

Usage: compare.exe file1 file2 [options]

Options:

/M         Performs a 64kb scan instead of a 1-byte scan.

/AE        All bytes in the files must be the same

/DEL       Delete file2 if 100% same.

/COP       Copies file2 to a .cop file if its the same.

/SZ        Ignore file size

/TXT       Searches for a ANSI string in a file, file1 will be the string

/TWT       Searches for a Unicode string in a file, file1 will be the string

/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.

/TN        file2 is newer. See readme file for information on using time options

/TO        file2 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

 

click here to see a screenshot of XCompare

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.

AmpHour Calculator

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

Sudoku For Windows

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 available Screenshot
Console 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

Commandline MessageBox tool

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

delphijustin Industries is an Autism Supported Business
Social Media Auto Publish Powered By : XYZScripts.com
All in one
Start
Amazon.com, Inc. OH Dublin
Your cart is empty.
Loading...