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.