vrspectrum.pas

作工控的好控件

{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}

unit VrSpectrum;

{$I VRLIB.INC}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Dialogs,
  VrTypes, VrClasses, VrControls, VrSysUtils;

type
  TVrSpectrum = class;

  TVrSpectrumBar = class(TVrCollectionItem)
  private
    FPosition: Integer;
    procedure SetPosition(Value: Integer);
  public
    constructor Create(Collection: TVrCollection); override;
    property Position: Integer read FPosition write SetPosition;
  end;

  TVrSpectrumBars = class(TVrCollection)
  private
    FOwner: TVrSpectrum;
    function GetItem(Index: Integer): TVrSpectrumBar;
  protected
    procedure Update(Item: TVrCollectionItem); override;
  public
    constructor Create(AOwner: TVrSpectrum);
    property Items[Index: Integer]: TVrSpectrumBar read GetItem;
  end;

  TVrSpectrum = class(TVrGraphicImageControl)
  private
    FBarWidth: TVrMaxInt;
    FBarSpacing: Integer;
    FPlainColors: Boolean;
    FColumns: Integer;
    FMaxValue: Integer;
    FMinValue: Integer;
    FBevel: TVrBevel;
    FPalette1: TVrPalette;
    FPalette2: TVrPalette;
    FPalette3: TVrPalette;
    FPercent1: TVrPercentInt;
    FPercent2: TVrPercentInt;
    FMarkerColor: TColor;
    FMarkerVisible: Boolean;
    FShowInactive: Boolean;
    FTickHeight: Integer;
    FSpacing: Integer;
    FViewPort: TRect;
    FBarImages: array[0..1] of TBitmap;
    Ticks: Integer;
    Collection: TVrSpectrumBars;
    function GetCount: Integer;
    function GetItem(Index: Integer): TVrSpectrumBar;
    function GetPercentDone(Position: Longint): Longint;
    procedure SetColumns(Value: Integer);
    procedure SetMaxValue(Value: Integer);
    procedure SetMinValue(Value: Integer);
    procedure SetMarkerColor(Value: TColor);
    procedure SetMarkerVisible(Value: Boolean);
    procedure SetTickHeight(Value: Integer);
    procedure SetSpacing(Value: Integer);
    procedure SetPalette1(Value: TVrPalette);
    procedure SetPalette2(Value: TVrPalette);
    procedure SetPalette3(Value: TVrPalette);
    procedure SetPercent1(Value: TVrPercentInt);
    procedure SetPercent2(Value: TVrPercentInt);
    procedure SetBevel(Value: TVrBevel);
    procedure SetBarWidth(Value: TVrMaxInt);
    procedure SetBarSpacing(Value: Integer);
    procedure SetShowInactive(Value: Boolean);
    procedure SetPlainColors(Value: Boolean);
    procedure PaletteModified(Sender: TObject);
    procedure BevelChanged(Sender: TObject);
  protected
    procedure CreateObjects;
    procedure GetItemRect(Index: Integer; var R: TRect);
    procedure UpdateBar(Index: Integer);
    procedure UpdateBars;
    procedure Paint; override;
    procedure CalcPaintParams;
    procedure CreateBarImages;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Reset(Value: Integer);
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TVrSpectrumBar read GetItem;
  published
    property Palette1: TVrPalette read FPalette1 write SetPalette1;
    property Palette2: TVrPalette read FPalette2 write SetPalette2;
    property Palette3: TVrPalette read FPalette3 write SetPalette3;
    property Percent1: TVrPercentInt read FPercent1 write SetPercent1 default 60;
    property Percent2: TVrPercentInt read FPercent2 write SetPercent2 default 25;
    property Bevel: TVrBevel read FBevel write SetBevel;
    property Columns: Integer read FColumns write SetColumns default 24;
    property MaxValue: Integer read FMaxValue write SetMaxValue default 100;
    property MinValue: Integer read FMinValue write SetMinValue default 0;
    property MarkerColor: TColor read FMarkerColor write SetMarkerColor default clWhite;
    property MarkerVisible: Boolean read FMarkerVisible write SetMarkerVisible default True;
    property TickHeight: Integer read FTickHeight write SetTickHeight default 1;
    property Spacing: Integer read FSpacing write SetSpacing default 1;
    property BarWidth: TVrMaxInt read FBarWidth write SetBarWidth default 8;
    property BarSpacing: Integer read FBarSpacing write SetBarSpacing default 1;
    property ShowInactive: Boolean read FShowInactive write SetShowInactive default True;
    property PlainColors: Boolean read FPlainColors write SetPlainColors default false;
    property Color default clBlack;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Cursor;
    property DragMode;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragCursor;
    property ParentColor default false;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnDblClick;
    property OnDragOver;
    property OnDragDrop;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnEndDrag;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;


implementation


procedure DrawBarImage(Canvas: TCanvas; const Rect: TRect; Color1,
  Color2, Color3: TColor; Point1, Point2: Integer; PlainColors: Boolean);
var
  P: TPoint;
  I: Integer;
  ColorRect: TRect;
  R, G, B: Byte;
  R1, G1, B1, R2, G2, B2, R3, G3, B3: Byte;
begin
  P.X := WidthOf(Rect);
  P.Y := HeightOf(Rect);

  if PlainColors then
  begin
    I := P.Y - Point1 - Point2;
    ColorRect := Bounds(Rect.Left, Rect.Top, P.X, I);
    Canvas.Brush.Color := Color1;
    Canvas.FillRect(ColorRect);
    ColorRect := Bounds(Rect.Left, Rect.Top + I, P.X, Point2);
    Canvas.Brush.Color := Color2;
    Canvas.FillRect(ColorRect);
    ColorRect := Bounds(Rect.Left, Rect.Top + I + Point2, P.X, Point1);
    Canvas.Brush.Color := Color3;
    Canvas.FillRect(ColorRect);
    Exit;
  end;

  Point1 := MaxIntVal(1, Point1 + (Point2 div 2));
  Point2 := MaxIntVal(1, P.Y - Point1);

  GetRGB(Color1,  R1, G1, B1);
  GetRGB(Color2,  R2, G2, B2);
  GetRGB(Color3,  R3, G3, B3);

  ColorRect := Bounds(Rect.Left, Rect.Top, P.X, 1);

  I := 0;
  while I <= Point2 do
  begin
    R := R1 + I * (R2 - R1) div Point2;
    G := G1 + I * (G2 - G1) div Point2;
    B := B1 + I * (B2 - B1) div Point2;
    Canvas.Brush.Color := RGB(R, G, B);
    FillRect(Canvas.Handle, ColorRect, Canvas.Brush.Handle);
    OffsetRect(ColorRect, 0, 1);
    Inc(I, 1);
  end;

  I := 0;
  while I <= Point1 do
  begin
    R := R2 + I * (R3 - R2) div Point1;
    G := G2 + I * (G3 - G2) div Point1;
    B := B2 + I * (B3 - B2) div Point1;
    Canvas.Brush.Color := RGB(R, G, B);
    FillRect(Canvas.Handle, ColorRect, Canvas.Brush.Handle);
    OffsetRect(ColorRect, 0, 1);
    Inc(I, 1);
  end;
end;

{ TVrSpectrumBar }

constructor TVrSpectrumBar.Create(Collection: TVrCollection);
begin
  FPosition := 0;
  inherited Create(Collection);
end;

procedure TVrSpectrumBar.SetPosition(Value: Integer);
begin
  if FPosition <> Value then
  begin
    FPosition := Value;
    Changed(false);
  end;
end;

{ TVrSpectrumBars }

constructor TVrSpectrumBars.Create(AOwner: TVrSpectrum);
begin
  inherited Create;
  FOwner := AOwner;
end;

function TVrSpectrumBars.GetItem(Index: Integer): TVrSpectrumBar;
begin
  Result := TVrSpectrumBar(inherited Items[Index]);
end;

procedure TVrSpectrumBars.Update(Item: TVrCollectionItem);
begin
  if Item <> nil then
    FOwner.UpdateBar(Item.Index) else
    FOwner.UpdateBars;
end;

{TVrSpectrum}

constructor TVrSpectrum.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csReplicatable];
  Width := 217;
  Height := 117;
  ParentColor := false;
  Color := clBlack;
  FColumns := 24;
  FMinValue := 0;
  FMaxValue := 100;
  FMarkerColor := clWhite;
  FMarkerVisible := True;
  FTickHeight := 1;
  FSpacing := 1;
  FPercent1 := 60;
  FPercent2 := 25;
  FBarWidth := 8;
  FBarSpacing := 1;
  FShowInactive := True;
  FPlainColors := false;

  FPalette1 := TVrPalette.Create;
  FPalette1.OnChange := PaletteModified;

  FPalette2 := TVrPalette.Create;
  with FPalette2 do
  begin
    Low := clOlive;
    High := clYellow;
    OnChange := PaletteModified;
  end;

  FPalette3 := TVrPalette.Create;
  with FPalette3 do
  begin
    Low := clMaroon;
    High := clRed;
    OnChange := PaletteModified;
  end;

  FBevel := TVrBevel.Create;
  with FBevel do
  begin
    InnerStyle := bsLowered;
    InnerWidth := 2;
    InnerSpace := 1;
    InnerColor := clBlack;
    OnChange := BevelChanged;
  end;

  AllocateBitmaps(FBarImages);

  Collection := TVrSpectrumBars.Create(Self);
  CreateObjects;
end;

destructor TVrSpectrum.Destroy;
begin
  DeallocateBitmaps(FBarImages);
  Collection.Free;
  FBevel.Free;
  FPalette1.Free;
  FPalette2.Free;
  FPalette3.Free;
  inherited Destroy;
end;

procedure TVrSpectrum.CreateObjects;
var
  I: Integer;
begin
  Collection.Clear;
  for I := 0 to Pred(FColumns) do
    TVrSpectrumBar.Create(Collection);