private
    { Private-Deklarationen }
      procedure WMNCHittest(var Msg: TMessage); message WM_NCHITTEST;
...
procedure TForm1.WMNCHittest(var Msg: TMessage);
begin
  Msg.Result := HTCAPTION;
end;

unit Tranbtn;

interface

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

type
  BStyle = (BSnone,BsNormal,BsIe);
  TMTranBtn = class(TGraphicControl)
  private
    FBitMap : TBitmap;
    FOver : Boolean;
    Pushed : boolean;
    Fborder : BStyle;
    BRect : Trect;
    procedure SetBitMap(Value : TBitMap);
    procedure WMLButtonDown(var msg: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var msg: TWMLButtonUp); message WM_LBUTTONUP;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    function OnGlyphP(X, Y: integer): boolean;
    procedure mouseleave(var msg : tmessage); message cm_mouseleave;
    procedure mousein(var msg : tmessage); message cm_mouseenter;
    Procedure setborderstyle(value:Bstyle);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    procedure DrawTransparentBitmap (ahdc: HDC; Image: TBitmap; xStart, yStart: Word; TrCol : Tcolor);
    property BitMap : TBitMap read FBitMap write SetBitMap;
    Property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Visible;
    Property Hint;
    Property ShowHint;
    Property Border : BStyle read fborder write SetBorderStyle;
    Property Caption;
    Property Font;
  end;

procedure Register;

implementation

constructor TMTranBtn.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 30;
Height := 30;
FBitMap := TBitMap.Create;
ControlStyle := ControlStyle - [csOpaque];
Pushed := false;
Font.name := 'Arial';
Font.size := 9;
Fborder := BsNormal;
end;

destructor TMTranBtn.Destroy;
begin
FBitMap.Free;
inherited Destroy;
end;

procedure TMTranBtn.SetBitMap(Value : TBitMap);
begin
 FBitMap.Assign(Value);
 invalidate;
end;

{this routine come from unit XparBmp of Michael Vincze (vincze@ti.com), I think it can be
optimized more. Will find time to check it again}
procedure TMTranBtn.DrawTransparentBitmap (ahdc: HDC; Image: TBitmap; xStart, yStart: Word; TrCol : Tcolor);
var
  TransparentColor: TColor;
  cColor : TColorRef;
  bmAndBack,
  bmAndObject,
  bmAndMem,
  bmSave,
  bmBackOld,
  bmObjectOld,
  bmMemOld,
  bmSaveOld : HBitmap;
  hdcMem,
  hdcBack,
  hdcObject,
  hdcTemp,
  hdcSave : HDC;
  ptSize : TPoint;
begin
TransparentColor := TrCol;
TransparentColor := TransparentColor or $02000000;

hdcTemp := CreateCompatibleDC (ahdc);
SelectObject (hdcTemp, Image.Handle); { select the bitmap }
ptSize.x := Image.Width;
ptSize.y := Image.Height;
DPtoLP (hdcTemp, ptSize, 1); { convert from device logical points }
hdcBack := CreateCompatibleDC(ahdc);
hdcObject := CreateCompatibleDC(ahdc);
hdcMem := CreateCompatibleDC(ahdc);
hdcSave := CreateCompatibleDC(ahdc);

bmAndBack := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);
bmAndObject := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);

bmAndMem := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);
bmSave := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);

bmBackOld := SelectObject (hdcBack, bmAndBack);
bmObjectOld := SelectObject (hdcObject, bmAndObject);
bmMemOld := SelectObject (hdcMem, bmAndMem);
bmSaveOld := SelectObject (hdcSave, bmSave);

SetMapMode (hdcTemp, GetMapMode (ahdc));
BitBlt (hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);
cColor := SetBkColor (hdcTemp, TransparentColor);
BitBlt (hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);

SetBkColor (hdcTemp, cColor);
BitBlt (hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);

BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, ahdc, xStart, yStart, SRCCOPY);
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);
BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCPAINT);
BitBlt (ahdc, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);
BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);
DeleteObject (SelectObject (hdcBack, bmBackOld));
DeleteObject (SelectObject (hdcObject, bmObjectOld));
DeleteObject (SelectObject (hdcMem, bmMemOld));
DeleteObject (SelectObject (hdcSave, bmSaveOld));
DeleteDC (hdcMem);
DeleteDC (hdcBack);
DeleteDC (hdcObject);
DeleteDC (hdcSave);
DeleteDC (hdcTemp);
end;

procedure TMTranBtn.setborderstyle(value:Bstyle);
begin
if Fborder <> value then
 begin
  Fborder := value;
  Invalidate;
 end;
end;

procedure TMTranBtn.Paint;
var
  ARect: TRect;
  Tmp : TBitMap;
  x,y : integer;
  text : array[0..40] of char;
  Fontheight : integer;
begin
ARect := Rect(0,0,Width,Height);
Canvas.font := font;
FontHeight := Canvas.TextHeight('W');
if not FBitMap.empty then
  begin
  x := (width - FBitMap.width) div 2;
  if caption <> '' then
    y := ((Height - FBitMap.Height- FontHeight) div 2)
  else
   y := ((Height - FBitMap.Height) div 2);
     BRect := rect(x, y, x + FBitMap.width, y + FBitMap.height);
     Tmp := TBitmap.Create;
     Tmp.Height := FBitMap.Height;
     Tmp.Width := FBitMap.Width;
     Tmp.Canvas.CopyRect(ARect, FBitmap.Canvas, ARect);
     if pushed then
      DrawTransparentBitmap( Canvas.Handle, Tmp, x +1, y+1, FBitmap.TransparentColor )
     else
      DrawTransparentBitmap( Canvas.Handle, Tmp, x, y, FBitmap.TransparentColor );
     Tmp.Free;
  end;

  if caption <> '' then
  with Canvas do
  begin
   Brush.Style := bsClear;
   with ARect do
    begin
     if Fbitmap.empty then
       Top := ((Bottom + Top) - FontHeight) shr 1
     else
       top := Brect. bottom;
      Bottom := Top + FontHeight;
      if pushed then
        begin
         top := top + 1;
         left := 2;
        end;
    end;
    StrPCopy(Text, Caption);
    DrawText(Handle, Text, StrLen(Text), ARect, (DT_EXPANDTABS or DT_center));
   end;

 ARect := getclientrect;
 case fborder of
 BsNormal : BEGIN
            if pushed then
                frame3d(canvas, ARect ,clBtnShadow,clBtnHighlight, 1)
            else
                frame3d(canvas, ARect ,clBtnHighlight,clBtnShadow, 1);
            END;
 BsIe : Begin
         if pushed then
            frame3d(canvas, ARect ,clBtnShadow,clBtnHighlight, 1)
         else
          if Fover then
            frame3d(canvas, ARect ,clBtnHighlight,clBtnShadow, 1);
         end;
 end; { case}
end;


function TMTranBtn.OnGlyphP(X, Y: integer): boolean;
begin
  Result := PtInRect({ClientRect} BRect, Point(X, Y)) and
            (FBitmap.Canvas.Pixels[X, Y] <> FBitmap.TransparentColor);
end;

procedure TMTranBtn.MouseMove(Shift: TShiftState; X, Y: Integer);

begin
  FOver := (fborder = bsnormal) or (fborder = bsie) or OnGlyphP(X, Y);
  Inherited MouseMove(Shift, X, Y);
end;

procedure TMTranBtn.mouseleave(var msg : tmessage);
var rc : Trect;
BEGIN
  FOver := false;
  rc := getclientrect;
  if Fborder = bsie then
    INVALIDATE;
END;

procedure TMTranBtn.mousein(var msg : tmessage);
var rc : Trect;
BEGIN
  FOver := true;
  rc := getclientrect;
  if Fborder = bsie then
    frame3d(canvas, rc ,clBtnHighlight,clBtnShadow, 1);
END;

procedure TMTranBtn.WMLButtonDown;
begin
 inherited;
  Pushed := (fborder = bsnormal) or (fborder = bsie) OR FOver;
  if pushed then
     invalidate;
end;

procedure TMTranBtn.WMLButtonUp;
begin
 inherited;
 if (fborder = bsnormal) or (fborder = bsie) or FOver then
    Pushed := false;
 if Pushed = false then
   invalidate;
end;

procedure Register;
begin
  RegisterComponents('Mik', [TMTranBtn]);
end;

end.