backdrop.pas

用于开发税务票据管理的软件

unit Backdrop;

interface

uses
  Windows, Messages, Graphics, Classes, Controls{, DIBType, DIBUltra};

type
  TFillDirection = (drLeftRight, drRightLeft, drUpDown, drDownUp);
  TBackdrop = class(TGraphicControl)
  private
    { Private declarations }
    FChanged: Boolean;
    FDIB: TBitmap;//TDIBUltra;

    FStartR: Byte;
    FStartG: Byte;
    FStartB: Byte;

    FChangeR: Boolean;
    FChangeG: Boolean;
    FChangeB: Boolean;

    FDirection: TFillDirection;

    procedure FillBackdrop;
    function RectLeftRight(i, w2: Integer; w: Real): TRect;
    function RectRightLeft(i, w2: Integer; w: Real): TRect;
    function RectUpDown(i, w2: Integer; w: Real): TRect;
    function RectDownUp(i, w2: Integer; w: Real): TRect;

    procedure ChangeDrawR(NewVal: Boolean);
    procedure ChangeDrawG(NewVal: Boolean);
    procedure ChangeDrawB(NewVal: Boolean);

    procedure ChangeStartR(NewVal: Byte);
    procedure ChangeStartG(NewVal: Byte);
    procedure ChangeStartB(NewVal: Byte);

    procedure ChangeDirection(NewVal: TFillDirection);
  protected
    { Protected declarations }
    procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;

    procedure ForceRedraw;

    property Canvas;
  published
    { Published declarations }
    property ChangeRColour: Boolean Read FChangeR Write ChangeDrawR default True;
    property ChangeGColour: Boolean Read FChangeG Write ChangeDrawG default True;
    property ChangeBColour: Boolean Read FChangeB Write ChangeDrawB default True;

    property Direction: TFillDirection Read FDirection Write ChangeDirection;

    property StartR: Byte Read FStartR Write ChangeStartR;
    property StartG: Byte Read FStartG Write ChangeStartG;
    property StartB: Byte Read FStartB Write ChangeStartB;

    property Align;
    property Cursor;
    property DragCursor;
    property Enabled;
    property Hint;
    property OnClick;
    property OnDblClick;
    property OnDragOver;
    property OnDragDrop;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
  end;

procedure Register;

implementation

procedure TBackdrop.WMEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := 1; // Stop Windows from erasing the backdrop manually, since
                   // the control paints itself entirely anyway
end;

constructor TBackdrop.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  ControlStyle := ControlStyle + [csOpaque];
  Align := AlClient;
  SendToBack;

  FDIB := TBitmap.Create;//TDIBUltra.Create(1, 1, dupf24, nil);
  FDIB.PixelFormat := pf24Bit;
  FDIB.Width := 1;
  FDIB.Height := 1;

  FChangeR := True;
  FChangeG := True;
  FChangeB := True;

  FChanged := True;
end;

destructor TBackdrop.Destroy;
begin
  FDIB.Free;
  inherited Destroy;
end;

procedure TBackdrop.Paint;
begin
  inherited Paint;

  SendToBack;

//  FDIB.BufferDim(Parent.Width, Parent.Height);

  // Check if the background has been resized
  if FDIB.Width <> Width then
  begin
    FDIB.Width := Width;
    FChanged := True;
  end;

  if FDIB.Height <> Height then
  begin
    FDIB.Height := Height;
    FChanged := True;
  end;

  if (FChanged) then//or not FDIB.BufferOf(Parent) then
  begin
    FillBackdrop;
    FChanged := False;
  end;

  Canvas.Draw(0,0,FDIB);
//  FDIB.DrawOn(ClientRect, Canvas,0,0);
end;

procedure TBackdrop.FillBackdrop;
var
  W: Real;
  W2: Integer;
  R,G,B: Byte;
  i: Integer;
  RectArea: TRect;
begin
  // Calculate the size of each strip of colour (there will be 256 of them)
  if FDirection <= drRightLeft then
    W := Parent.Width / 256
  else
    W := Parent.Height / 256;

  W2 := Round(W + 0.5);

  // The starting values for each colour.  If a colour is not used then the
  // starting value will tint the entire control in a funky fashion
  R := FStartR;
  G := FStartG;
  B := FStartB;

  // Display 256 different coloured rectangles along the component to display
  // a smooth gradient
  for i := 0 to 255 do
  begin
    if FChangeR then R := i;
    if FChangeG then G := i;
    if FChangeB then B := i;

    FDIB.Canvas.Brush.Color := RGB(R, G, B);

    // Figure out which part of the image to fill
    case FDirection of
      drLeftRight: RectArea := RectLeftRight(i,w2,w);
      drRightLeft: RectArea := RectRightLeft(i,w2,w);
      drUpDown   : RectArea := RectUpDown(i,w2,w);
      drDownUp   : RectArea := RectDownUp(i,w2,w);
    end;

    FDIB.Canvas.FillRect(RectArea);
  end;
end;

function TBackdrop.RectLeftRight(i, w2: Integer; w: Real): TRect;
begin
  Result := Bounds(Round(w * i), 0, w2, HEIGHT);
end;

function TBackdrop.RectRightLeft(i, w2: Integer; w: Real): TRect;
begin
  Result := Bounds(Round(w * (255 - i)), 0, w2, HEIGHT);
end;

function TBackdrop.RectUpDown(i, w2: Integer; w: Real): TRect;
begin
  Result := Bounds(0, Round(w * i), WIDTH, w2);
end;

function TBackdrop.RectDownUp(i, w2: Integer; w: Real): TRect;
begin
  Result := Bounds(0, Round(w * (255 - i)), WIDTH, w2);
end;

procedure TBackdrop.ChangeDrawR(NewVal: Boolean);
begin
  if NewVal <> FChangeR then
  begin
    FChangeR := NewVal;
    FChanged := True;
    Invalidate;
  end;
end;

procedure TBackdrop.ChangeDrawG(NewVal: Boolean);
begin
  if NewVal <> FChangeG then
  begin
    FChangeG := NewVal;
    FChanged := True;
    Invalidate;
  end;
end;

procedure TBackdrop.ChangeDrawB(NewVal: Boolean);
begin
  if NewVal <> FChangeB then
  begin
    FChangeB := NewVal;
    FChanged := True;
    Invalidate;
  end;
end;

procedure TBackdrop.ChangeStartR(NewVal: Byte);
begin
  if FStartR <> NewVal then
  begin
    FStartR := NewVal;
    FChanged := True;
    Invalidate;
  end;
end;

procedure TBackdrop.ChangeStartG(NewVal: Byte);
begin
  if FStartG <> NewVal then
  begin
    FStartG := NewVal;
    FChanged := True;
    Invalidate;
  end;
end;

procedure TBackdrop.ChangeStartB(NewVal: Byte);
begin
  if FStartB <> NewVal then
  begin
    FStartB := NewVal;
    FChanged := True;
    Invalidate;
  end;
end;

procedure TBackdrop.ChangeDirection(NewVal: TFillDirection);
begin
  if NewVal <> FDirection then
  begin
    FDirection := NewVal;
    FChanged := True;
    Invalidate;
  end;
end;

procedure TBackdrop.ForceRedraw;
begin
  FChanged := True;
  Invalidate;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TBackdrop]);
end;

end.