Delphi控件源码

开发平台：
Delphi

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);
end;
procedure TVrSpectrum.CreateBarImages;
var
  I, Y, P1, P2, Point: Integer;
begin
  for I := 0 to 1 do
  begin
    FBarImages[I].Width := BarWidth;
    FBarImages[I].Height := HeightOf(FViewPort);
  end;
  P1 := Percent1;
  P2 := Percent2;
  Y := HeightOf(FViewPort);
  if PlainColors then
  begin
    Point := SolveForX(P1, Ticks);
    P1 := (Point * (TickHeight + Spacing));
    Point := SolveForX(P2, Ticks);
    P2 := (Point * (TickHeight + Spacing));
  end else
  begin
    P1 := SolveForX(P1, Y);
    P2 := SolveForX(P2, Y);
  end;
  DrawBarImage(FBarImages[0].Canvas, BitmapRect(FBarImages[0]),
    FPalette3[0], FPalette2[0], FPalette1[0], P1, P2, PlainColors);
  DrawBarImage(FBarImages[1].Canvas, BitmapRect(FBarImages[1]),
    FPalette3[1], FPalette2[1], FPalette1[1], P1, P2, PlainColors);
end;
procedure TVrSpectrum.PaletteModified(Sender: TObject);
begin
  UpdateControlCanvas;
end;
procedure TVrSpectrum.BevelChanged(Sender: TObject);
var
  R: TRect;
begin
  if not Loading then
  begin
    R := ClientRect;
    FBevel.GetVisibleArea(R);
    InflateRect(FViewPort, R.Left, R.Top);
    BoundsRect := Bounds(Left, Top, WidthOf(FViewPort),
      HeightOf(FViewPort));
  end;
  UpdateControlCanvas;
end;
function TVrSpectrum.GetCount: Integer;
begin
  Result := Collection.Count;
end;
function TVrSpectrum.GetItem(Index: Integer): TVrSpectrumBar;
begin
  Result := Collection.Items[Index];
end;
procedure TVrSpectrum.SetSpacing(Value: Integer);
begin
  if FSpacing <> Value then
  begin
    FSpacing := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetColumns(Value: Integer);
begin
  if (FColumns <> Value) and (Value > 0) then
  begin
    FColumns := Value;
    CreateObjects;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetMaxValue(Value: Integer);
var
  I: Integer;
begin
  if (FMaxValue <> Value) and (Value > FMinValue) then
  begin
    FMaxValue := Value;
    for I := 0 to Pred(Count) do
      with Items[I] do
        if (Position > FMaxValue) then Position := FMaxValue;
  end;
end;
procedure TVrSpectrum.SetMinValue(Value: Integer);
var
  I: Integer;
begin
  if (FMinValue <> Value) and (Value < FMaxValue) then
  begin
    FMinValue := Value;
    for I := 0 to Pred(Count) do
      with Items[I] do
        if (Position < FMinValue) then Position := FMinValue;
  end;
end;
procedure TVrSpectrum.SetMarkerColor(Value: TColor);
begin
  if FMarkerColor <> Value then
  begin
    FMarkerColor := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetMarkerVisible(Value: Boolean);
begin
  if FMarkerVisible <> Value then
  begin
    FMarkerVisible := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetTickHeight(Value: Integer);
begin
  if (FTickHeight <> Value) and (Value > 0) then
  begin
    FTickHeight := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetPalette1(Value: TVrPalette);
begin
  FPalette1.Assign(Value);
end;
procedure TVrSpectrum.SetPalette2(Value: TVrPalette);
begin
  FPalette2.Assign(Value);
end;
procedure TVrSpectrum.SetPalette3(Value: TVrPalette);
begin
  FPalette3.Assign(Value);
end;
procedure TVrSpectrum.SetBevel(Value: TVrBevel);
begin
  FBevel.Assign(Value);
end;
procedure TVrSpectrum.SetPercent1(Value: TVrPercentInt);
begin
  if (FPercent1 <> Value) then
  begin
    if not Loading then
      if Value + Percent2 > 100 then Value := 100 - Percent2;
    FPercent1 := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetPercent2(Value: TVrPercentInt);
begin
  if (FPercent2 <> Value) then
  begin
    if not Loading then
      if Value + Percent1 > 100 then Value := 100 - Percent1;
    FPercent2 := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetShowInactive(Value: Boolean);
begin
  if FShowInactive <> Value then
  begin
    FShowInactive := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetBarWidth(Value: TVrMaxInt);
begin
  if FBarWidth <> Value then
  begin
    FBarWidth := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetBarSpacing(Value: Integer);
begin
  if FBarSpacing <> Value then
  begin
    FBarSpacing := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSpectrum.SetPlainColors(Value: Boolean);
begin
  if FPlainColors <> Value then
  begin
    FPlainColors := Value;
    UpdateControlCanvas;
  end;
end;
function TVrSpectrum.GetPercentDone(Position: Longint): Longint;
begin
  Result := SolveForY(Position - FMinValue, FMaxValue - FMinValue);
end;
procedure TVrSpectrum.UpdateBar(Index: Integer);
var
  R, PaintRect, ImageRect: TRect;
  I: Integer;
  TicksOn, TicksOff: Integer;
  Item: TVrSpectrumBar;
begin
  Item := Collection.Items[Index];
  GetItemRect(Index, R);
  TicksOn := SolveForX(GetPercentDone(Item.Position), Ticks);
  TicksOff := Ticks - TicksOn;
  PaintRect := Bounds(R.Left, R.Top, R.Right - R.Left, FTickHeight);
  with DestCanvas do
  begin
    for I := 1 to TicksOff do
    begin
      if FShowInactive then
      begin
        ImageRect := Bounds(0, PaintRect.Top - FViewPort.Top,
          BarWidth, TickHeight);
        CopyRect(PaintRect, FBarImages[0].Canvas, ImageRect);
      end else
      begin
        Brush.Color := Self.Color;
        FillRect(PaintRect);
      end;
      OffsetRect(PaintRect, 0, FTickHeight + FSpacing);
    end;
    for I := 1 to TicksOn do
    begin
      if (MarkerVisible) and (I = 1) then
      begin
        Brush.Color := FMarkerColor;
        FillRect(PaintRect);
      end else
      begin
        ImageRect := Bounds(0, PaintRect.Top - FViewPort.Top,
          BarWidth, TickHeight);
        CopyRect(PaintRect, FBarImages[1].Canvas, ImageRect);
      end;
      OffsetRect(PaintRect, 0, FTickHeight + FSpacing);
    end;
  end;
end;
procedure TVrSpectrum.UpdateBars;
var
  I: Integer;
begin
  for I := 0 to Collection.Count - 1 do
    UpdateBar(I);
end;
procedure TVrSpectrum.Paint;
var
  R: TRect;
begin
  CalcPaintParams;
  ClearBitmapCanvas;
  DestCanvas := BitmapCanvas;
  try
    R := ClientRect;
    FBevel.Paint(BitmapCanvas, R);
    UpdateBars;
    inherited Paint;
  finally
    DestCanvas := Self.Canvas;
  end;
end;
procedure TVrSpectrum.CalcPaintParams;
var
  R: TRect;
  Step: Integer;
  NewWidth, NewHeight: Integer;
begin
  R := ClientRect;
  FBevel.GetVisibleArea(R);
  FViewPort := R;
  Step := FTickHeight + FSpacing;
  Ticks := (HeightOf(R) + FSpacing) div Step;
  CreateBarImages;
  NewWidth := (R.Left * 2) +
    ((FBarWidth + FBarSpacing) * FColumns) - FBarSpacing;
  NewHeight := (R.Top * 2) + (Ticks * Step) - FSpacing;
  if (Width <> NewWidth) or (Height <> NewHeight) then
    BoundsRect := Bounds(Left, Top, NewWidth, NewHeight);
end;
procedure TVrSpectrum.GetItemRect(Index: Integer; var R: TRect);
var
  X: Integer;
begin
  X := (BarWidth + BarSpacing) * Index;
  R := Bounds(FViewPort.Left + X, FViewPort.Top,
    BarWidth, HeightOf(FViewPort));
end;
procedure TVrSpectrum.Reset(Value: Integer);
var
  I: Integer;
begin
  if Value > FMaxValue then Value := FMaxValue
  else if Value < FMinValue then Value := FMinValue;
  for I := 0 to Pred(Count) do
    Collection.Items[I].Position := Value;
end;
end.

						