lrsbmp32.pas

在delphi3-7的环境下

{*********************************************************}
{*                    LrsBmp32 1.01                      *}
{*            Copyright (c) Terje Larsen 1996            *}
{*                 All rights reserved.                  *}
{*********************************************************}


{*********************************************************}
{*                       History                         *}
{*                                                       *}
{*   July 8 1996: added Stretch and Align properties     *}
{*********************************************************}

unit lrsbmp32;

interface

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

const
   DefaultWidth  = 32;
   DefaultHeight = 32;

type
  TLrsBmp = class(TGraphicControl)
  private
    FBmpWidth         : Integer;
    FBmpHeight        : Integer;
    FBitMap           : TBitmap;
    FTransparentColor : TColor;
    FStretch          : Boolean;
    procedure SetBitMap(Value : TBitMap);
    procedure SetTransparentColor(Value : TColor);
    procedure WMSize(var Message: TWMSize); message WM_PAINT;
    procedure SetStretch(Value: Boolean);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BitMap : TBitMap read FBitMap write SetBitMap;
    property TransparentColor : TColor read FTransparentColor
             write SetTransparentColor default -1;
    property Stretch: Boolean read FStretch Write SetStretch default False;
    property Height default 30;
    property Width default 30;
    property Align;
    property ShowHint;
    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Visible;
  end;

procedure Register;

implementation

constructor TLrsBmp.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
   Width  := DefaultWidth;
   Height := DefaultHeight;
   FBmpWidth  := DefaultWidth;
   FBmpHeight := DefaultHeight;
   FBitMap := TBitMap.Create;
   ControlStyle := ControlStyle +[csOpaque];
   FTransparentColor := -1;
end;

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

procedure TLrsBmp.WMSize(var Message: TWMSize);
begin
   inherited;
   {No resizing allowed}
   FBmpWidth :=FBmpWidth;
   FBmpHeight:=FBmpHeight;
end;

procedure TLrsBmp.SetStretch(Value: Boolean);
begin
   if Value <> FStretch then
   begin
      FStretch := Value;
      Invalidate;
   end;
end;

procedure TLrsBmp.SetBitMap(Value : TBitMap);
begin
   FBitMap.Assign(Value);
   FBmpHeight := FBitMap.Height;
   FBmpWidth  := FBitMap.Width;
   Height := FBmpHeight;
   Width  := FBmpWidth;
   if Height = 0 then
      Height := DefaultHeight;
   if Width = 0 then
      Width := DefaultWidth;
end;

procedure TLrsBmp.SetTransparentColor(Value : TColor);
begin
   if Value <> FTransparentColor then
   begin
      FTransparentColor := Value;
      Invalidate;
   end;
end;

procedure TLrsBmp.Paint;
var
  ARect, BRect : TRect;
  TmpBmp : TBitMap;
begin
   ARect := Rect(0,0,Width,Height);
   if FBitMap.Height > 0 then
   begin
      if Stretch then
         BRect := ClientRect
      else
      begin
         Width := FBitMap.Width;
         Height := FBitMap.Height;
         BRect := Rect(0,0, Width, Height);
      end;
      if (FTransparentColor >= 0) and (FTransparentColor <= $7FFFFFFF) then
      begin    {draw on temporary bitmap to avoid flicker}
         TmpBmp := TBitmap.Create;
         TmpBmp.Height := FBitMap.Height;
         TmpBmp.Width := FBitMap.Width;
         TmpBmp.Canvas.Brush.Color := Color;
         TmpBmp.Canvas.BrushCopy(ARect, FBitmap, BRect, FTransparentColor);
         if Stretch then
            Canvas.StretchDraw(BRect, TmpBmp {Picture.Graphic})
         else
            Canvas.CopyRect(ARect, TmpBmp.Canvas, ARect);
         TmpBmp.Free;
      end
      else  {direct draw}
      if Stretch then
         Canvas.StretchDraw(BRect, FBitMap {Picture.Graphic})
      else   
         Canvas.CopyRect(ARect, FBitmap.Canvas, BRect);
   end
   else
   begin   {fill it with white color}
      Canvas.Brush.Color := clWhite;
      Canvas.FillRect(BoundsRect);
   end;
   if csDesigning in ComponentState then
   begin    {To see the outline of the Bitmap at designing time}
      Canvas.Pen.Style := psDash;
      Canvas.Brush.Style := bsClear;
      Canvas.Rectangle(0, 0, Width, Height);
   end;
end;

procedure Register;
begin
   RegisterComponents('Larsen', [TLrsBmp]);
end;

end.