Global mouse hook

Here is a global mouse hook on Delphi which will intercept middle (scroll) button click (WM_NCMBUTTONDOWN and WM_MBUTTONDOWN messages), check if any top level window is under the cursor and if yes then minimize that window.

The code is pretty simple.

We need two projects: one - which runs the hook and then kills it; the other - the hook itself (it is supposed to be a DLL because it is a global hook). Nothing difficult (at least if you what is DLL and how to use them)!

Here is the mouse hook (WH_MOUSE) implementation:

library MiddleButton;

uses
Windows,
Messages;

const
MemMapFile = 'temp_thief';
type
PDLLGlobal = ^TDLLGlobal;
TDLLGlobal = packed record
HookHandle: HHOOK;
end;

var
GlobalData: PDLLGlobal;
MMF: THandle;

{$R *.res}

function HookProc(Code: integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
CurrWND: THandle;
begin
if Code < wparam =" WM_NCMBUTTONDOWN)" wparam =" WM_MBUTTONDOWN)" mmf =" 0" globaldata =" nil">nil then
UnmapViewOfFile(GlobalData);

if MMF<> INVALID_HANDLE_VALUE then
CloseHandle(MMF);
end;

procedure RunHook; stdcall;
begin
GlobalData^.HookHandle:= SetWindowsHookEx(WH_MOUSE, @HookProc, HInstance, 0);
if GlobalData^.HookHandle = INVALID_HANDLE_VALUE then
begin
MessageBox(0, 'Error :)' , '' , MB_OK);
Exit;
end;
end;

procedure KillHook; stdcall;
begin
if (GlobalData<>nil) and (GlobalData^.HookHandle<>INVALID_HANDLE_VALUE) then
UnhookWindowsHookEx(GlobalData^.HookHandle);
end;

procedure DLLEntry(dwReason: DWORD);
begin
case dwReason of
DLL_PROCESS_ATTACH: CreateGlobalHeap;
DLL_PROCESS_DETACH: DeleteGlobalHeap;
end;
end;

exports
KillHook,
RunHook;

begin
DLLProc:= @DLLEntry;
DLLEntry(DLL_PROCESS_ATTACH);
end.And here is an implementation of the hook launcher:
unit RunMiddleButton;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;

type
TfrmMain = class(TForm)
btnRunHook: TButton;
btnKillHook: TButton;
procedure btnRunHookClick(Sender: TObject);
procedure btnKillHookClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

procedure RunHook; stdcall; external 'MiddleButton.dll' name 'RunHook';
procedure KillHook; stdcall; external 'MiddleButton.dll' name 'KillHook';

var
frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.btnRunHookClick(Sender: TObject);
begin
RunHook;
end;

procedure TfrmMain.btnKillHookClick(Sender: TObject);
begin
KillHook;
end;

end.

Rounded buttons with bitmaps for the up/down state

unit Bibutton;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, ExtCtrls;

type
TBiButton = class(TCustomControl)
private
FTPicture : TPicture;
FPPicture : TPicture;
FOnPaint : TNotifyEvent;
FRegion : THandle;
FBRegion : THandle;
FBorder : Boolean;
FOffset : Integer;
FCaption : String;

FXRad,
FYRad : Integer;

Down,
Pressed : Boolean;

procedure SetTPicture (Value : TPicture);
procedure SetPPicture (Value : TPicture);
procedure SetXRadius (Value : Integer);
procedure SetYRadius (Value : Integer);
procedure SetBorder (Value : Boolean);
procedure PictureChanged(Sender : TObject);
procedure WM_LButtonDown (var Msg : TWMLButtonDown); message wm_LButtonDown;
procedure WM_LButtonUp (var Msg : TWMLButtonUp); message wm_LButtonUp;
procedure WM_MouseMove (var Msg : TWMMouseMove); message wm_MouseMove;
procedure WM_Size (var Msg : TWMSize); message wm_Size;
procedure SetRegion;
procedure SetOffest(const Value: Integer);
procedure SetCaption(const Value: String);

public
constructor Create (AOwner : TComponent); override;
destructor Destroy; override;
property Canvas;

protected
function GetPalette : HPalette; override;
procedure Paint; override;

published
// The "not-pressed-picture"
property TopPicture : TPicture read FTPicture write SetTPicture;
// The "pressed-picture" - if none, TopPicture will be used
property PressedPicture : TPicture read FPPicture write SetPPicture;
// for round buttons
property XRadius : Integer read FXRad write SetXRadius;
property YRadius : Integer read FYRad write SetYRadius;
// showing a border or not
property Border : Boolean read FBorder write SetBorder;
// offset of the "pressed-picture"
property Offset : Integer read FOffset write SetOffest;
property Caption : String read FCaption write SetCaption;

property Color;
property Font;
property Align;
property Visible;
property ShowHint;
property Enabled;
property ParentColor;
property ParentFont;
property ParentShowHint;
property TabOrder;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('GBit', [TBiButton]);
end;


constructor TBiButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FRegion := 0;
FBRegion := 0;
ControlStyle := [csCaptureMouse, csClickEvents];
FTPicture := TPicture.Create;
FTPicture.OnChange := PictureChanged;
FPPicture := TPicture.Create;
FPPicture.OnChange := PictureChanged;
FBorder := True;
Height := 100;
Width := 100;
XRadius := Width;
YRadius := Height;
Offset := 2;
Pressed := False;
end;


destructor TBiButton.Destroy;
begin
FTPicture.Free;
FPPicture.Free;
DeleteObject (FRegion);
DeleteObject (FBRegion);
inherited Destroy;
end;


function TBiButton.GetPalette: HPalette;
begin
Result := 0;
if FTPicture.Graphic is TBitmap then
Result := TBitmap(FTPicture.Graphic).Palette;
end;


procedure TBiButton.SetTPicture(Value: TPicture);
begin
FTPicture.Assign(Value);
end;


procedure TBiButton.SetPPicture(Value: TPicture);
begin
FPPicture.Assign(Value);
end;


procedure TBiButton.Paint;
var
Rect : TRect;
Ha : HDC;
ps : TPaintStruct;
x, y : Integer;
R, rx,
G, gx,
B, bx : Word;
AColor,
LightC,
DarkC : TColor;
begin
Rect := GetClientRect;
InvalidateRgn (Handle, FRegion, False);
try
SetWindowRgn (Self.Handle, FBRegion, True);
except
end;

if Color < width =" Width)" height =" Height)" width =" Width)" height =" Height)"> Down then begin
Down := D;
Invalidate;
end;
end;
inherited;
end;


procedure TBiButton.SetYRadius (Value : Integer);
begin
if Value > Height then
Value := Height;
if Value <> YRadius then begin
FYRad := Value;
SetRegion;
Invalidate;
end;
end;


procedure TBiButton.SetXRadius (Value : Integer);
begin
if Value > Width then
Value := Width;
if Value <> XRadius then begin
FXRad := Value;
SetRegion;
Invalidate;
end;
end;


procedure TBiButton.SetRegion;
begin
DeleteObject (FRegion);
DeleteObject (FBRegion);
if XRadius > Width then
FXRad := Width;
if YRadius > Height then
FYRad := Height;
FRegion := CreateRoundRectRgn (0, 0, Width+1, Height+1, XRadius, YRadius);
FBRegion := CreateRoundRectRgn (0, 0, Width+1, Height+1, XRadius, YRadius);
end;


procedure TBiButton.WM_Size (var Msg : TWMSize);
begin
SetRegion;
Invalidate;
end;


procedure TBiButton.SetBorder (Value : Boolean);
begin
if Value <> FBorder then begin
FBorder := Value;
Invalidate;
end;
end;

procedure TBiButton.SetOffest(const Value: Integer);
begin
FOffset := Value;
Invalidate;
end;

procedure TBiButton.SetCaption(const Value: String);
begin
FCaption := Value;
Invalidate;
end;

end.

Drawing a form by the shape of a bitmap

Question:

How do i shape a form by the outlines of a TBitmap image?

Answer:

How to make this work for your application :
-------------------------------------------------

(I rewrote this part since some people didn't
manage to run the application)

1. Create new application.
2. Insert a TBitmap object called 'image1'
and place it in the most top-left location
by setting the top and left properties of
the TImage object to zero.
(selecting a bmp for it will be cool too-
do that by clicking the 'Picture' property
of the TImage object)
3. Paste my code into you project.
4. Assign the FormCreate proc of your form.
(by double clicking the 'OnCreate' event
in the object inspector)
5. Set the form's border style to bsNone.
6. Press F9 :)
(in order to close the application
press Alt+F4)


Some comments
-------------------------------------------------

1. The image must be saved as 24bit format.
(However , you CAN make it work in other
formats too, but that'll require some
changes in the code)

2. This code will assume that the [0,0]
pixel is background color and should
not be visable.(you can change that
by assigning something else to the
'transp' variable located at the
beggining of the FormCreate proc)
All pixels in your image, that has
the same color as [0,0] will become
transparent.

3. I wrote this one after I read the an
article in the GUI category and decided
that there must be a shorter way of
doing this.


The code
---------------------------------------------

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;

type

//structure of the bitmap
bit24=record
r,g,b:byte;
end;
bit24array=array[0..0] of bit24;
pbit24array=^bit24array;

TForm1 = class(TForm)
Image1: TImage;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
x,y,rc:integer;
tmprgn,tmprgn2,tmprgn3: HRGN;
NewRgn : HRGN;
b:tbitmap;
p:pbit24Array;
transp:bit24;
begin
NewRgn := CreateRectRgn(0,0,0,0);
b:=image1.Picture.Bitmap;
p:= b.scanline[0];

//change this in order to set other color as bg
transp:=p[0];

//loop for lines
for y := 0 to b.height-1 do
begin
p:= b.scanline[y];
x:=0;

//loop for rows :
//this loop looks very stupid...
//but it didn't work any other way:
while x<(b.width) do if (p[x].r<>transp.r)or(p[x].g<>transp.g)
or(p[x].b<>transp.b) then
begin
rc:=1;
while (p[x+rc].r<>transp.r)and(p[x+rc].g<>transp.g)
and(p[x+rc].b<>transp.b) do inc(rc);
tmprgn:=CreateRectRgn(x,y,x+rc,y+1);
tmpRgn2:=CreateRectRgn(0,0,0,0);
CombineRgn(tmpRgn2,newRgn,tmpRgn,RGN_OR);
DeleteObject(newrgn);
newrgn := tmprgn2;
inc(x,rc);
end else inc(x);
end;
//set to the new region
SetWindowRgn(handle,NewRgn,false);
DeleteObject(newrgn);
DeleteObject(tmprgn);
DeleteObject(tmprgn2);
end;


end.

Enjoy !