Joke Delphi Source

Back to the Download Page
Torna alla Sezione Download

program Joke; // (C) 2003 Salvatore Meschini - Give credits where due! :-)))

(*

If you like this joke or you are looking for a custom version please write me at salvatoremeschini@tiscali.it ! Thank you!
Se ti piace questo scherzo oppure vuoi una versione personalizzata scrivi a salvatoremeschini@tiscali.it ! Grazie!

Salvatore Meschini
http://salvatoremeschini.cjb.net

*)


(* This program uses some nice tricks (Keyboard lights, disable input from keyboard/mouse, write text with On Screen 
Display style, screen flipping, shows/hide traybar). Have fun! You can customize
it in order to make a joke to your friends! :-) *)

uses Windows;

// Blockinput Windows API function - Lock/unlock input from mouse and keyboard - Press CTRL+ALT+DEL to unlock them

function BlockInput(fBlockInput: boolean): DWord; stdcall; external
'user32.DLL';

{ 
// Disable/Enable CTRL+ALT+DEL - Look at Windows API reference/documentation for further details
procedure SystemKeys(Disable: Boolean);
var OldVal : LongInt;
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING, Word(Disable), @OldVal, 0);
}

// Turn on/off keyboard leds (lights) 

procedure SetState(Key: Integer; Value: Boolean);
begin
  if Odd(GetAsyncKeyState(Key)) <> Value then
  begin
    keybd_event(Key, MapVirtualkey(Key, 0), KEYEVENTF_EXTENDEDKEY, 0);
    keybd_event(Key, MapVirtualkey(Key, 0), KEYEVENTF_EXTENDEDKEY or
      KEYEVENTF_KEYUP, 0);
  end;
end;

procedure Lighting; // Flashing leds / lights
begin
  SetState(VK_NUMLOCK, True);
  Sleep(50);
  SetState(VK_NUMLOCK, False);
  Sleep(50);
  SetState(VK_CAPITAL, True);
  Sleep(50);
  SetState(VK_CAPITAL, False);
  Sleep(50);
  SetState(VK_SCROLL, True);
  Sleep(50);
  SetState(VK_SCROLL, False);
  Sleep(50);
  SetState(VK_CAPITAL, True);
  Sleep(50);
  SetState(VK_CAPITAL, False);
  Sleep(50);
end;

procedure AllOff; // Turn all keyboard leds off
begin
  SetState(VK_NUMLOCK, False);
  SetState(VK_SCROLL, False);
  SetState(VK_CAPITAL, False);
end;

// Make a RECTANGLE

function Rect(Left, Top, Right, Bottom: Integer): TRect;
begin
  Result.Left := Left;
  Result.Top := Top;
  Result.Bottom := Bottom;
  Result.Right := Right;
end;

// FLIP ROUTINE

procedure CopyRect(const Dest: TRect; const Source: TRect);
var
  DC: THandle;
begin
  DC := CreateDC('DISPLAY', nil, nil, nil);
  StretchBlt(DC, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
    Dest.Bottom - Dest.Top, DC, Source.Left, Source.Top,
    Source.Right - Source.Left, Source.Bottom - Source.Top, SRCCOPY);
  // StretchBlt
end;

procedure FlipTheScreen; // Execute the screen flip
var
  MaxX, MaxY: Integer;
begin
  AllOff;
  MaxX := GetSystemMetrics(SM_CXSCREEN); // Get screen width
  MaxY := GetSystemMetrics(SM_CYSCREEN); // Get screen heigth
  SetCursorPos(MaxX, MaxY); // "Hide" mouse cursor
  CopyRect(Rect(0, 0, MaxX, MaxY), Rect(0, MaxY, MaxX, 0)); // Flip the screen
end;

procedure WriteText(S: string; Size, Y: Integer); // OSD effect
// S = String to write, Size = Font size, Y = vertical position
var
  MyFont: HFont;
  H: Integer;
  hDC: THandle;
  rc: TRect;
begin
  hDC := CreateDC('DISPLAY', nil, nil, nil);
  H := -MulDiv(Size, GetDeviceCaps(hDC, LOGPIXELSY), 72);
  MyFont := CreateFont(H, 0, 0, 0, FW_BOLD, 0, 0, 0, ANSI_CHARSET,
    OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, ANTIALIASED_QUALITY, DEFAULT_PITCH,
    'Verdana');
  if MyFont <> 0 then
  begin
    SetTextColor(hDC, RGB(0, 255, 0)); // Text is green-You can change the color
    SetBkMode(hDC, TRANSPARENT);
    SelectObject(hDC, MyFont);
    GetClientRect(GetDesktopWindow, rc);
    rc.top := rc.top + Y; // Set vertical position
    DrawText(hDC, pchar(S), -1, rc, DT_CENTER);
    DeleteObject(MyFont);
  end;
end;

procedure Greetings;
begin
  Sleep(5000);
  WriteText('This is a joke!', 72, (GetSystemMetrics(SM_CYSCREEN) - 72) div 2);
  MessageBeep(0);
  Sleep(3000);
  WriteText('Press CTRL+ALT+DEL to quit!', 20, (GetSystemMetrics(SM_CYSCREEN) +
    160) div 2);
  MessageBeep(0);
end;

procedure MinimizeALL;
// Minimize All (I was used to do it using EnumWindows)
var
  Wnd: Integer;

begin
  Wnd := FindWindow('Shell_TrayWnd', nil);
  PostMessage(Wnd, $0111, 419, 0); // WM_COMMAND = $0111
  ShowWindow(Wnd, SW_HIDE); // Hide traybar, we'll get a fullscreen desktop
end;

begin
  MinimizeALL; // Minimize all Windows -> Uncover the desktop
  BlockInput(True); // Lock input
  FlipTheScreen; // Flip the screen
  Greetings; // Draw some text (OSD effect)
  repeat // Repeat until user press CTRL+ALT+DEL
    Lighting; // Turn on/off keyboard leds
  until BlockInput(True) <> 0;
  // Keyb/mouse remain locked if this application is running
  InvalidateRect(GetFocus, nil, TRUE); // Erase the screen
  ShowWindow(FindWindow(PChar('Shell_TrayWnd'), nil), SW_SHOW);
    // Show Traybar again
end.