How to modify the color of a TCheckBox

Problem/Question/Abstract:

How to modify the color of a TCheckBox

Answer:

I would do the drawing in the CN_DRAWITEM message handler. Below is the code of such a checkbox:

{ ... }
type
  TMyCheckBox = class(TCheckBox)
  protected
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure CMEnabledchanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure SetChecked(Value: Boolean); override;
    procedure SetButtonStyle;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  { ... }

constructor TMyCheckBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csDoubleClicks];
end;

procedure TMyCheckBox.CNDrawItem(var Message: TWMDrawItem);
var
  XCanvas: TCanvas;
  XCaptionRect, XGlyphRect: TRect;

  procedure xxDrawBitMap(ACanvas: TCanvas);
  const
    xx_h = 13;
    xx_w = 13;
  var
    xxGlyph: TBitmap;
    xxX, xxY, xxStepY, xxStepX: integer;
  begin
    xxGlyph := TBitmap.Create;
    try
      xxGlyph.Handle := LoadBitmap(0, PChar(OBM_CHECKBOXES));
      xxY := XGlyphRect.Top + (XGlyphRect.Bottom - XGlyphRect.Top - xx_h) div 2;
      xxX := 2;
      xxStepX := 0;
      xxStepY := 0;
      if Enabled then
      begin
        case State of
          cbChecked:
            xxStepX := xxStepX + xx_w;
          cbGrayed:
            xxStepX := xxStepX + xx_w * 3;
        end;
      end
      else if State = cbChecked then
        xxStepX := xxStepX + xx_w * 3
      else
        xxStepX := xxStepX + xx_w * 2;
      ACanvas.CopyRect(Rect(xxX, xxY, xxX + xx_w, xxY + xx_h), xxGlyph.Canvas,
        Rect(xxStepX, xxStepY, xx_w + xxStepX, xx_h + xxStepY));
    finally
      xxGlyph.Free;
    end;
  end;

  procedure xxDrawCaption;
  var
    xXFormat: longint;
  begin
    xXFormat := DT_VCENTER + DT_SINGLELINE + DT_LEFT;
    xXFormat := DrawTextBiDiModeFlags(xXFormat);
    DrawText(Message.DrawItemStruct.hDC, PChar(Caption),
      length(Caption), XCaptionRect, xXFormat);
  end;

begin
  XGlyphRect := Message.DrawItemStruct.rcItem;
  XGlyphRect.Right := 20;
  XCaptionRect := Message.DrawItemStruct.rcItem;
  XCaptionRect.Left := XGlyphRect.Right;
  XCanvas := TCanvas.Create;
  try
    XCanvas.Handle := Message.DrawItemStruct.hDC;
    XCanvas.Brush.Style := bsClear;
    xxDrawBitMap(XCanvas);
    xxDrawCaption;
  finally
    XCanvas.Free;
  end;
end;

procedure TMyCheckBox.CMEnabledchanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TMyCheckBox.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle or WS_EX_Transparent;
end;

procedure TMyCheckBox.CreateWnd;
begin
  inherited CreateWnd;
  SetButtonStyle;
end;

procedure TMyCheckBox.SetChecked(Value: Boolean);
begin
  inherited SetChecked(Value);
  Invalidate;
end;

procedure TMyCheckBox.SetButtonStyle;
const
  BS_MASK = $000F;
var
  Style: Word;
begin
  if HandleAllocated then
  begin
    Style := BS_CHECKBOX or BS_OWNERDRAW;
    if GetWindowLong(Handle, GWL_STYLE) and BS_MASK <> Style then
      SendMessage(Handle, BM_SETSTYLE, Style, 1);
  end;
end;

Painting the Form Menu bar

Problem/Question/Abstract:

When i uses programs like the game freecell that comes with windows 9x i see that there is a text in the menu bar tht tells me how many cards left me.

How can i make something like that in my programs ?

Answer:

Well, First of all we need to put a main menu component on our form.
Now set the OwnerDraw property to true.

If you have an item that you wish to paint by yourself, now is the time to create it and to make the OnDrawItem.
In this line you put also this line:

{... }
ACanvas.TextOut(1, ARect.Top + 1, 'I''m in the MainMenuDrawbar');
{... }

Note, If you need to use a changed variable you can do it from another function and ll you need to do afther the change is to call the API function DrawMenuBar.

If you are using Delphi 2,3 Use the Messages WM_MESUREITEM and the message WM_DRAWITEM to make this effect.

How to print bitmaps and controls placed on a TPanel

Problem/Question/Abstract:

I have placed several images and assorted graphic controls on a TPanel. Now I want to print it. My problem is that the panel does not have a canvas property. Somehow I should be able to manipulate the "graphics" on the panel. What I thought might work is to do a screen capture of the panel area, but I am not sure what the function calls are. Does anybody have any ideas? I want to be able to scale the image and print it to a specific part of the page.

Answer:

The form has a canvas. You can create a new bitmap the same size as your panel and then use CopyRect to copy the panel and its content from the form to this in- memory bitmap. Then you can print the in-memory bitmap. Here's an example:

procedure TFormPrintWindows.ButtonPrintPanelClick(Sender: TObject);
var
  Bitmap: TBitmap;
  FromLeft, FromTop, PrintedWidth, PrintedHeight: Integer;
begin
  Printer.BeginDoc;
  try
    Bitmap := TBitmap.Create;
    try
      Bitmap.Width := Panel1.Width;
      Bitmap.Height := Panel1.Height;
      Bitmap.PixelFormat := pf24bit; {Avoid palettes}
      {Copy the panel area from the form into a separate bitmap}
      Bitmap.Canvas.CopyRect(Rect(0, 0, Bitmap.Width, Bitmap.Height),
                        FormPrintWindows.Canvas, Rect(Panel1.Left, Panel1.Top, Panel1.Left +
                        Panel1.Width - 1, Panel1.Top + Panel1.Height - 1));
      {Assumes 10% left, right and top margin}
      {Assumes bitmap aspect ratio > ~0.75 for portrait mode}
      PrintedWidth := MulDiv(Printer.PageWidth, 80, 100); {80%}
      PrintedHeight := MulDiv(PrintedWidth, Bitmap.Height, Bitmap.Width);
      FromLeft := MulDiv(Printer.PageWidth, 10, 100); {10%}
      FromTop := MulDiv(Printer.PageHeight, 10, 100); {10%}
      PrintBitmap(Printer.Canvas, Rect(FromLeft, FromTop, FromLeft + PrintedWidth,
        FromTop + PrintedHeight), Bitmap);
    finally
      Bitmap.Free
    end;
  finally
    Printer.EndDoc
  end;
end;

Can your video handle 16, 256, 32768, 16777216, or more colors

Problem/Question/Abstract:

Can your video handle 16, 256, 32768, 16777216, or more colors?

Answer:

You can use WIN API function GetDeviceCaps() to calculate the number of colors supported by the current video mode. To make it even easier to use, here's a function that will simply return the number of maximum simultaneous colors current video device can handle:

function GetColorsCount: integer;
var
  h: hDC;
begin
  Result := 0;
  try
    h := GetDC(0);
    Result :=
      1 shl
      (
      GetDeviceCaps(h, PLANES) *
      GetDeviceCaps(h, BITSPIXEL)
      );
  finally
    ReleaseDC(0, h);
  end;
end;

How to use TCollection and TCollectionItem

Problem/Question/Abstract:

Has anyone out there attempted to use TCollection and TCollectionItem? What I am trying to do is mimic what the Columns Editor does in the TDBGrid for the TStringGrid component. This is the first time that I have made a component that needs properties and sub-properties. I am not sure how to go about this.

Answer:

This one worked for me:


unit ggImgLst;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Dialogs,
  ExtCtrls, Dsgnintf; {, jpeg;}

type
  TAboutProperty = class(TPropertyEditor)
  private
  protected
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
    function GetName: string; override;
    function GetValue: string; override;
  end;

  TggImageListPropertyEditor = class(TPersistent);

  TggImageListProperty = class(TClassProperty);

  TggImageSizes = (ggSmall, ggMedium, ggLarge);
  {TggImageSize  = set of TggImageSizes;}

  TggImage = class;
  TggImageList = class;

  TggImage = class(TCollectionItem)
  private
    FSize: TggImageSizes;
    FPicture: TPicture;
    FName: string;
    function GetDisplayName: string; override;
    procedure SetPicture(Value: TPicture);
  public
    constructor Create(Collection: TCollection); override;
    destructor destroy; override;
  published
    property Size: TggImageSizes read FSize write FSize;
    property Name: string read FName write FName;
    property Picture: TPicture read FPicture write SetPicture;
  end;

  TggImageClass = class of TggImage;

  TggImages = class(TCollection)
  private
    FggImageList: TggImageList;
    FggImageListPropertyEditor: TggImageListPropertyEditor;
    function GetImage(Index: Integer): TggImage;
    procedure SetImage(Index: Integer; Value: TggImage);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor create(ggImageList: TggImageList; ggImageClass: TggImageClass);
    function Add: TggImage;
    property ggImageList: TggImageList read FggImageList;
    property Items[Index: Integer]: TggImage read GetImage write SetImage; default;
  published
  end;

  TggImageList = class(TComponent)
  private
    FAbout: TAboutProperty;
    FImages: TggImages;
    procedure WriteImages(Writer: TWriter);
    procedure ReadImages(Reader: TReader);
    procedure SetImages(Value: TggImages);
  protected
    function CreateImages: Tggimages; dynamic;
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create(AOwner: TComponent); override;
    function GetImageNameList: TStringList;
    function GetPicture(PictureName: string): TPicture;
  published
    property About: TAboutProperty read FAbout write FAbout;
    property Images: TggImages read FImages write SetImages;
  end;

procedure Register;

implementation

uses
  jpeg;

{ggImage}

constructor TggImage.Create(Collection: TCollection);
var
  ggImageList: TggImageList;
begin
  FPicture := TPicture.Create;
  ggImageList := nil;
  if assigned(Collection) and (Collection is TggImages) then
    ggImageList := Tggimages(Collection).ggImageList;
  if assigned(ggImageList) then
    inherited Create(Collection);
end;

destructor TggImage.Destroy;
begin
  FPicture.Free;
  inherited Destroy;
end;

procedure TggImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;

function TggImage.GetDisplayName: string;
begin
  Result := Name;
  if Result = '' then
    Result := inherited GetDisplayName;
end;

{TggImages}

function TggImages.GetImage(Index: Integer): TggImage;
begin
  Result := TggImage(inherited Items[Index]);
end;

procedure TggImages.SetImage(Index: Integer; Value: TggImage);
begin
  Items[Index].Assign(Value);
end;

constructor TggImages.Create(ggImageList: TggImageList;
  ggImageClass: TggImageClass);
begin
  inherited Create(ggImageClass);
  FggImageList := ggImageList;
  FggImageListPropertyEditor := TggImageListPropertyEditor.Create;
end;

function TggImages.GetOwner: TPersistent;
begin
  Result := FggImageList;
end;

function TggImages.Add: TggImage;
begin
  Result := TggImage(inherited Add);
end;

{ggImageList}

procedure TggImageList.WriteImages(Writer: TWriter);
begin
  Writer.WriteCollection(Images);
end;

procedure TggImageList.ReadImages(Reader: TReader);
begin
  Images.Clear;
  Reader.ReadValue;
  Reader.ReadCollection(Images);
end;

procedure TggImageList.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('ggImages', ReadImages, WriteImages, Filer.Ancestor < > nil);
end;

procedure TggImageList.SetImages(Value: TggImages);
begin
  Images.Assign(Value);
end;

function TggImageList.CreateImages: TggImages;
begin
  Result := TggImages.Create(Self, TggImage);
end;

function TggImageList.GetImageNameList: TStringList;
var
  I: Integer;
begin
  Result := TStringList.Create;
  for I := 0 to Self.Images.Count - 1 do
    Result.Add(Self.Images.Items[I].Name);
end;

function TggImageList.GetPicture(PictureName: string): TPicture;
var
  I: Integer;
begin
  I := 0;
  Result := nil;
  PictureName := uppercase(Picturename);
  while I <= Self.Images.Count - 1 do
  begin
    if PictureName = uppercase(Self.Images.Items[I].Name) then
    begin
      Result := Self.Images.Items[I].Picture;
      I := Self.Images.Count;
    end
    else
      Inc(I);
  end;
end;

constructor TggImageList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FImages := CreateImages;
end;

{TAboutProperty}

procedure TAboutProperty.Edit;
begin
  MessageBox(0, PChar('TggImageList component' + #13 + #13 + 'by Geurts Guido -
    guido.geurts@advalvas.be ' + #13 + ' 10 / 03 / 1999'),
    PChar('The GuidoG utilities present...'), MB_OK);
end;

function TAboutProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog, paReadOnly];
end;

function TAboutProperty.GetName: string;
begin
  Result := 'About';
end;

function TAboutProperty.GetValue: string;
begin
  Result := GetStrValue;
end;

{Non class related procedures and functions:}

procedure register;
begin
  RegisterComponents('GuidoG', [TggImageList]);
  RegisterPropertyEditor(TypeInfo(TggImageListPropertyEditor), TGGImages,
    'Images', TGGImageListProperty);
  RegisterPropertyEditor(TypeInfo(TAboutProperty), TggImageList, 'About',
    TAboutProperty);
end;

end.

How to access a single object in a metafile

Problem/Question/Abstract:

How to access a single object in a metafile

Answer:

Below is an example of getting metafile information and enumerating each metafile record :

function MyEnhMetaFileProc(DC: HDC; {handle to device context}
  lpHTable: PHANDLETABLE; {pointer to metafile handle table}
  lpEMFR: PENHMETARECORD; {pointer to metafile record}
  nObj: integer; {count of objects}
  TheForm: TForm1): integer; stdcall;
begin
  {draw the metafile record}
  PlayEnhMetaFileRecord(dc, lpHTable^, lpEMFR^, nObj);
  {set to zero to stop metafile enumeration}
  result := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyMetafile: TMetafile;
  lpENHMETAHEADER: PENHMETAHEADER; {extra metafile info}
  lpENHMETAHEADERSIZE: DWORD;
  NumMetaRecords: DWORD;
begin
  {Create a metafile}
  MyMetafile := TMetafile.Create;
  with TMetafileCanvas.Create(MyMetafile, 0) do
  try
    Brush.Color := clRed;
    Ellipse(0, 0, 100, 100);
    Ellipse(100, 100, 200, 200);
    Ellipse(200, 200, 300, 300);
    Ellipse(300, 300, 400, 400);
    Ellipse(400, 400, 500, 500);
    Ellipse(500, 500, 600, 600);
  finally
    Free;
  end;
  {we might as well get some extra metafile info}
  lpENHMETAHEADERSIZE := GetEnhMetaFileHeader(MyMetafile.Handle, 0, nil);
  NumMetaRecords := 0;
  if (lpENHMETAHEADERSIZE > 0) then
  begin
    GetMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
    GetEnhMetaFileHeader(MyMetafile.Handle, lpENHMETAHEADERSIZE, lpENHMETAHEADER);
    {Here is an example of getting number of metafile records}
    NumMetaRecords := lpENHMETAHEADER^.nRecords;
    {enumerate the records}
    EnumEnhMetaFile(Canvas.Handle, MyMetafile.Handle, @MyEnhMetaFileProc, self,
      Rect(0, 0, 600, 600));
    FreeMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
  end;
  MyMetafile.Free;
end;

Reference a column of a TDBGrid by name instead of integer index

Problem/Question/Abstract:

Is there a way in TDBGrid to reference a column by name rather than by integer index? Right now I am using "ListGrd.Columns[ 5 ]" (for example) to access a particular column but that is dangerous if moving columns is enabled. Can I reference a column by a column name instead?

Answer:

function TForm1.ColumnByFieldName(AGrid: TDBGrid; const AFieldName: string): TColumn;
var
  I: Integer;
begin
  for I := 0 to AGrid.Columns.Count - 1 do
  begin
    Result := AGrid.Columns[I];
    if AnsiCompareText(Result.FieldName, AFieldName) = 0 then
      Exit;
  end;
  raise Exception.Create(AGrid.Name + ', ' + AFieldName);
end;

How to create a countdown timer (2)

Problem/Question/Abstract:

All I want to do is to read the system time of the computer, then read it again a little later, and compare the times. I want hours, minutes, seconds and milliseconds. I have looked into TimeStamp and GetSystemTime, but I just can't get it to work. What should I do?

Answer:

var
  T0, T1: TDateTime;
  ElapsedSeconds: Double;
begin
  T0 := Now;
  { ... }
  T1 := Now;
  ElapsedSeconds := 86400.0 * (T1 - T0);
end;

How to put the content of a TStringGrid into an Excel range

Problem/Question/Abstract:

How to put the content of a TStringGrid into an Excel range

Answer:

{ ... }
var
  ArrV: Variant;
  Cell: Range;
  { ... }

ArrV := VarArrayCreate([0, NumRows, 0, NumCols], varOleStr);
for Row := 0 to NumRows do
  for Col := 0 to NumCols do
    ArrV[Row, Col] := StringGrid1.Cells[Col, Row];
Cell := Excel.ActiveCell;
WS.Range[Cell, Cell.Offset[NumRows, NumCols]].Value := ArrV;
{ ... }

Retrieve a list of available BDE language drivers

Problem/Question/Abstract:

How can I retrieve a list of available BDE language drivers?  

Answer:

The following Delphi procedure returns a formatted list of available BDE language drivers. The procedure can be called as shown in the buttonclick method below.

Add BDE and DBTables to your unit's uses clause.

procedure GetLdList(Lines: TStrings);
var
  hCur: hDBICur;
  LD: LDDesc;
  cnt: integer;
begin
  // get a cursor to the in-mem table containing language
  // driver information...
  cnt := 0;
  check(dbiinit(nil));
  Check(DbiOpenLdList(hCur));
  try
    while (DbiGetNextRecord(hCur, dbiNOLOCK, @LD, nil) = DBIERR_NONE) do
    begin
      cnt := cnt + ;
      Lines.Add(format('%4d %-6s%- 0s %- 0s%5s %- 0s %- 0s', [cnt, 'Name:', LD.szName,
        'Code Page:', IntToStr(LD.iCodePage), 'Description:', LD.szDesc]));
    end;
  finally Check(DbiCloseCursor(hCur));
    check(dbiexit);
  end;
end;

procedure TForm.Button Click(Sender: TObject);
begin
  getldlist(memo.lines);
end;

end.

How to compare two strings and measure the percentage they match

Problem/Question/Abstract:

Does anyone know how or does anyone know of a good procedure to match two strings? What I want is a % match between two strings. Something like Hart and Harts are 80% equal.

Answer:

uses
  math;

function IsStrMatch(s1, s2: string): Double;
var
  i, iMin, iMax, iSameCount: Integer;
begin
  iMax := Max(Length(s1), Length(s2));
  iMin := Min(Length(s1), Length(s2));
  iSameCount := -1;
  for i := 0 to iMax do
  begin
    if i > iMin then
      break;
    if s1[i] = s2[i] then
      Inc(iSameCount)
    else
      break;
  end;
  if iSameCount > 0 then
    Result := (iSameCount / iMax) * 100
  else
    Result := 0.00;
end;

How to create non-selectable separator lines in a TComboBox

Problem/Question/Abstract:

How to create non-selectable separator lines in a TComboBox

Answer:

Note that the Combobox1.Style is csOwnerDrawvariable.

procedure TForm1.FormCreate(Sender: TObject);
begin
  with combobox1 do
  begin
    items.add('Item 1');
    items.add('Item 2');
    items.addObject('Item 3', Pointer(1));
    Perform(CB_SetItemHeight, 2, ItemHeight + 5);
    items.add('Item 4');
    items.add('Item 5');
  end;
end;

procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
  var Height: Integer);
begin
  Height := (Control as TCombobox).Itemheight;
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  needsSeparator: Boolean;
begin
  with Control as TCombobox do
  begin
    needsSeparator := Assigned(Items.Objects[index]) and not (odComboBoxEdit in State);
    if needsSeparator then
      Rect.Bottom := Rect.Bottom - 5;
    Canvas.FillRect(Rect);
    Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top, Items[index]);
    if needsSeparator then
    begin
      Rect.Top := Rect.Bottom;
      Rect.Bottom := Rect.Bottom + 5;
      Canvas.Brush.Color := color;
      Canvas.Pen.Color := font.Color;
      Canvas.Pen.Style := psSolid;
      Canvas.Fillrect(Rect);
      Canvas.MoveTo(rect.left, rect.top + 2);
      Canvas.LineTo(rect.right, rect.top + 2);
    end;
  end;
end;

Get filepath from shortcut

Problem/Question/Abstract:

How to obtain the linked file from a shortcut

Answer:

uses ShellAPI;

function ExeFromLink(const linkname: string): string;
var
  FDir,
    FName,
    ExeName: PChar;
  z: integer;
begin
  ExeName := StrAlloc(MAX_PATH);
  FName := StrAlloc(MAX_PATH);
  FDir := StrAlloc(MAX_PATH);
  StrPCopy(FName, ExtractFileName(linkname));
  StrPCopy(FDir, ExtractFilePath(linkname));
  z := FindExecutable(FName, FDir, ExeName);
  if z > 32 then
    Result := StrPas(ExeName)
  else
    Result := '';
  StrDispose(FDir);
  StrDispose(FName);
  StrDispose(ExeName);
end;

How to catch windows keystrokes and pass them to an assigned event

Problem/Question/Abstract:

How to catch windows keystrokes and pass them to an assigned event

Answer:

For those interested, here's a keyboard hook component that catches windows keystrokes and passes them to an assigned event.

unit KeyboardHook;
{
  By William Egge
  Sep 20, 2002
  egge@eggcentric.com
  http://www.eggcentric.com

  This code may be used/modified however you wish.
}

interface

uses
  Windows, Classes;

type
  TCallbackThunk = packed record
    POPEDX: Byte;
    MOVEAX: Byte;
    SelfPtr: Pointer;
    PUSHEAX: Byte;
    PUSHEDX: Byte;
    JMP: Byte;
    JmpOffset: Integer;
  end;

  {See windows help on KeyboardProc or press F1 while your cursor is on "KeyboardProc"}
  TKeyboardCallback = procedure(code: Integer; wparam: WPARAM; lparam: LPARAM) of
    object;

  TKeyboardHook = class(TComponent)
  private
    { Private declarations }
    FHook: HHook;
    FThunk: TCallbackThunk;
    FOnCallback: TKeyboardCallBack;
    function CallBack(code: Integer; wparam: WPARAM; lparam: LPARAM): LRESULT stdcall;
    procedure SetOnCallback(const Value: TKeyboardCallBack);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property OnCallback: TKeyboardCallBack read FOnCallback write SetOnCallback;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('EggMisc', [TKeyboardHook]);
end;

{ TKeyboardHook }

function TKeyboardHook.CallBack(code: Integer; wparam: WPARAM; lparam: LPARAM):
  LRESULT;
begin
  if Code < 0 then
    Result := CallNextHookEx(FHook, Code, wparam, lparam)
  else
  begin
    if Assigned(FOnCallback) then
      FOnCallback(Code, wParam, lParam);
    Result := 0;
  end;
end;

constructor TKeyboardHook.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FThunk.POPEDX := $5A;
  FThunk.MOVEAX := $B8;
  FThunk.SelfPtr := Self;
  FThunk.PUSHEAX := $50;
  FThunk.PUSHEDX := $52;
  FThunk.JMP := $E9;
  FThunk.JmpOffset := Integer(@TKeyboardHook.Callback) - Integer(@FThunk.JMP) - 5;
  FHook := SetWindowsHookEx(WH_KEYBOARD, TFNHookProc(@FThunk), 0, MainThreadID);
end;

destructor TKeyboardHook.Destroy;
begin
  UnhookWindowsHookEx(FHook);
  inherited;
end;

procedure TKeyboardHook.SetOnCallback(const Value: TKeyboardCallBack);
begin
  FOnCallback := Value;
end;

end.