vrclasses.pas

作工控的好控件

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

unit VrClasses;

{$I VRLIB.INC}

interface

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


type
  TVrPersistent = class(TPersistent)
  private
    FUpdateCount: Integer;
    FOnChange: TNotifyEvent;
  protected
    procedure Changed;
  public
    procedure BeginUpdate;
    procedure EndUpdate;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TVrBevelStyle = (bsNone, bsLowered, bsRaised);
  TVrBevelOutlineStyle = (osOuter, osInner, osNone);
  TVrBevelWidth = 1..MaxInt;
  TVrBorderWidth = 0..MaxInt;
  TVrBevelSpace = 0..MaxInt;

  TVrBevel = class(TVrPersistent)
  private
    FBorderWidth: TVrBorderWidth;
    FBorderColor: TColor;
    FInnerShadow: TColor;
    FInnerHighlight: TColor;
    FInnerWidth: TVrBevelWidth;
    FInnerStyle: TVrBevelStyle;
    FInnerOutline: TVrBevelOutlineStyle;
    FInnerSpace: TVrBevelSpace;
    FInnerColor: TColor;
    FOuterShadow: TColor;
    FOuterHighlight: TColor;
    FOuterWidth: TVrBevelWidth;
    FOuterStyle: TVrBevelStyle;
    FOuterOutline: TVrBevelOutlineStyle;
    FOuterSpace: TVrBevelSpace;
    FOuterColor: TColor;
    FVisible: Boolean;
    procedure SetBorderWidth(Value: TVrBorderWidth);
    procedure SetBorderColor(Value: TColor);
    procedure SetInnerShadow(Value: TColor);
    procedure SetInnerHighlight(Value: TColor);
    procedure SetInnerWidth(Value: TVrBevelWidth);
    procedure SetInnerStyle(Value: TVrBevelStyle);
    procedure SetInnerOutline(Value: TVrBevelOutlineStyle);
    procedure SetInnerSpace(Value: TVrBevelSpace);
    procedure SetInnerColor(Value: TColor);
    procedure SetOuterShadow(Value: TColor);
    procedure SetOuterHighlight(Value: TColor);
    procedure SetOuterWidth(Value: TVrBevelWidth);
    procedure SetOuterStyle(Value: TVrBevelStyle);
    procedure SetOuterOutline(Value: TVrBevelOutlineStyle);
    procedure SetOuterSpace(Value: TVrBevelSpace);
    procedure SetOuterColor(Value: TColor);
    procedure SetVisible(Value: Boolean);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    procedure GetVisibleArea(var Rect: TRect);
    procedure Paint(Canvas: TCanvas; var Rect: TRect);
  published
    property BorderWidth: TVrBorderWidth read FBorderWidth write SetBorderWidth default 0;
    property BorderColor: TColor read FBorderColor write SetBorderColor default clBtnFace;
{}  property InnerShadow: TColor read FInnerShadow write SetInnerShadow;
{}  property InnerHighlight: TColor read FInnerHighlight write SetInnerHighlight;
{}  property InnerWidth: TVrBevelWidth read FInnerWidth write SetInnerWidth;
{}  property InnerStyle: TVrBevelStyle read FInnerStyle write SetInnerStyle;
    property InnerOutline: TVrBevelOutlineStyle read FInnerOutline write SetInnerOutline default osNone;
{}  property InnerSpace: TVrBevelSpace read FInnerSpace write SetInnerSpace;
{}  property InnerColor: TColor read FInnerColor write SetInnerColor;
{}  property OuterShadow: TColor read FOuterShadow write SetOuterShadow;
{}  property OuterHighlight: TColor read FOuterHighlight write SetOuterHighlight;
    property OuterWidth: TVrBevelWidth read FOuterWidth write SetOuterWidth default 1;
{}  property OuterStyle: TVrBevelStyle read FOuterStyle write SetOuterStyle;
{}  property OuterOutline: TVrBevelOutlineStyle read FOuterOutline write SetOuterOutline;
    property OuterSpace: TVrBevelSpace read FOuterSpace write SetOuterSpace default 0;
    property OuterColor: TColor read FOuterColor write SetOuterColor default clBtnFace;
    property Visible: Boolean read FVisible write SetVisible default True;
  end;

  TVrPalette = class(TVrPersistent)
  private
    FLow: TColor;
    FHigh: TColor;
    procedure SetLow(Value: TColor);
    procedure SetHigh(Value: TColor);
    function GetColors(Index: Integer): TColor; virtual;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    procedure ToBMP(Bitmap: TBitmap; DarkColor, LightColor: TColor);
    property Colors[Index: Integer]: TColor read GetColors; default;
  published
    property Low: TColor read FLow write SetLow;
    property High: TColor read FHigh write SetHigh;
  end;

  TVrMinMax = class(TVrPersistent)
  private
    FMinValue: Integer;
    FMaxValue: Integer;
    FPosition: Integer;
    procedure SetMinValue(Value: Integer);
    procedure SetMaxValue(Value: Integer);
    procedure SetPosition(Value: Integer);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
  published
    property MinValue: Integer read FMinValue write SetMinValue;
    property MaxValue: Integer read FMaxValue write SetMaxValue;
    property Position: Integer read FPosition write SetPosition;
  end;

  TVrTextOutline = class(TVrPersistent)
  private
    FColor: TColor;
    FVisible: Boolean;
    procedure SetColor(Value: TColor);
    procedure SetVisible(Value: Boolean);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
  published
    property Color: TColor read FColor write SetColor default clNavy;
    property Visible: Boolean read FVisible write SetVisible default True;
  end;

  TVrBitmaps = class(TVrPersistent)
  private
    FItems: TList;
    function GetCount: Integer;
    function GetBitmap(Index: Integer): TBitmap;
    procedure SetBitmap(Index: Integer; Value: TBitmap);
    procedure ReadData(Stream: TStream);
    procedure WriteData(Stream: TStream);
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure Assign(Source: TPersistent); override;
    function Add(Value: TBitmap): Integer;
    procedure Delete(Index: Integer);
    procedure Insert(Index: Integer; Value: TBitmap);
    procedure Exchange(Index1, Index2: Integer);
    procedure Move(CurIndex, NewIndex: Integer);
    function IndexOf(Bitmap: TBitmap): Integer;
    procedure LoadFromStream(Stream: TStream); virtual;
    procedure SaveToStream(Stream: TStream); virtual;
    procedure LoadFromFile(const FileName: string); virtual;
    procedure SaveToFile(const FileName: string); virtual;
    property Bitmaps[Index: Integer]: TBitmap read GetBitmap write SetBitmap; default;
    property Count: Integer read GetCount;
  end;

  TVrRect = class(TVrPersistent)
  private
    FLeft: Integer;
    FTop: Integer;
    FWidth: Integer;
    FHeight: Integer;
    function GetBoundsRect: TRect;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
    procedure SetBoundsRect(const Rect: TRect);
    procedure SetLeft(Value: Integer);
    procedure SetTop(Value: Integer);
    procedure SetWidth(Value: Integer);
    procedure SetHeight(Value: Integer);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
  published
    property Left: Integer read FLeft write SetLeft default 0;
    property Top: Integer read FTop write SetTop default 0;
    property Width: Integer read FWidth write SetWidth default 0;
    property Height: Integer read FHeight write SetHeight default 0;
  end;

  TVrFont3DStyle = (f3dNone, f3dRaised, f3dSunken, f3dShadow);
  TVrFont3D = class(TVrPersistent)
  private
    FStyle: TVrFont3DStyle;
    FHighlightColor: TColor;
    FShadowColor: TColor;
    FHighlightDepth: Integer;
    FShadowDepth: Integer;
    procedure SetStyle(Value: TVrFont3DStyle);
    procedure SetHighlightColor(Value: TColor);
    procedure SetShadowColor(Value: TColor);
    procedure SetHighlightDepth(Value: Integer);
    procedure SetShadowDepth(Value: Integer);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    procedure Paint(Canvas: TCanvas; R: TRect;
      const Text: string; Flags: Integer);
  published
    property Style: TVrFont3DStyle read FStyle write SetStyle default f3dNone;
    property HighlightColor: TColor read FHighlightColor write SetHighlightColor default clBtnHighlight;
    property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow;
    property HighlightDepth: Integer read FHighlightDepth write SetHighlightDepth default 1;
    property ShadowDepth: Integer read FShadowDepth write SetShadowDepth default 1;
  end;

  TVrGlyphs = class(TVrPersistent)
  private
    FBitmap: TBitmap;
    FNumGlyphs: TVrNumGlyphs;
    procedure SetBitmap(Value: TBitmap);
    procedure SetNumGlyphs(Value: TVrNumGlyphs);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property NumGlyphs: TVrNumGlyphs read FNumGlyphs write SetNumGlyphs;
  end;

const
  MaxIntListSize = MaxInt div 16;

type
  PVrIntArray = ^TVrIntArray;
  TVrIntArray = array[0..MaxIntListSize - 1] of Integer;

  TVrIntList = class(TObject)
  private
    FCount: Integer;
    FCapacity: Integer;
    FItems: PVrIntArray;
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
    procedure Grow;
    function GetCount: Integer;
    function GetItem(Index: Integer): Integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function Add(Value: Integer): Integer;
    procedure Delete(Index: Integer);
    property Count: Integer read GetCount;
    property Items[Index: Integer]: Integer read GetItem;
  end;

  TVrCollection = class;

  TVrCollectionItem = class(TObject)
  private
    FCollection: TVrCollection;
    FIndex: Integer;
    procedure SetCollection(Value: TVrCollection);
  protected
    procedure Changed(AllItems: Boolean);
  public
    constructor Create(Collection: TVrCollection); virtual;
    destructor Destroy; override;
    property Collection: TVrCollection read FCollection write SetCollection;
    property Index: Integer read FIndex write FIndex;
  end;

  TVrCollection = class(TObject)
  private
    FItems: TList;
    FUpdateCount: Integer;
    function GetCount: Integer;
    procedure InsertItem(Item: TVrCollectionItem);
    procedure RemoveItem(Item: TVrCollectionItem);
  protected
    procedure Changed;
    function GetItem(Index: Integer): TVrCollectionItem;
    procedure Update(Item: TVrCollectionItem); virtual;
    property UpdateCount: Integer read FUpdateCount;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BeginUpdate; virtual;
    procedure Clear;
    procedure EndUpdate; virtual;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TVrCollectionItem read GetItem;
  end;


implementation

const
  BitmapsFileId: Integer = $355462;  //Define a unique stream format


{ TVrPersistent }

procedure TVrPersistent.Changed;
begin
  if FUpdateCount = 0 then
    if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TVrPersistent.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TVrPersistent.EndUpdate;
begin
  if FUpdateCount > 0 then Dec(FUpdateCount);
  Changed;
end;

{ TVrBevel }

constructor TVrBevel.Create;
begin
  inherited Create;
  FBorderWidth := 0;
  FBorderColor := clBtnFace;
  FInnerShadow := clBtnShadow;
  FInnerHighlight := clBtnHighlight;
  FInnerWidth := 1;
  FInnerStyle := bsLowered;
  FInnerOutline := osNone;
  FInnerSpace := 1;
  FInnerColor := clBtnFace;
  FOuterShadow := clBtnShadow;
  FOuterHighlight := clBtnHighlight;
  FOuterWidth := 1;
  FOuterStyle := bsRaised;
  FOuterOutline := osOuter;
  FOuterSpace := 0;
  FOuterColor := clBtnFace;
  FVisible := True;
end;

procedure TVrBevel.Assign(Source: TPersistent);
begin
  if (Source <> nil) and (Source is TVrBevel) then
  begin
    BeginUpdate;
    try
      BorderWidth := TVrBevel(Source).BorderWidth;
      BorderColor := TVrBevel(Source).BorderColor;
      InnerShadow := TVrBevel(Source).InnerShadow;
      InnerHighlight := TVrBevel(Source).InnerHighlight;
      InnerWidth := TVrBevel(Source).InnerWidth;
      InnerStyle := TVrBevel(Source).InnerStyle;
      InnerOutline := TVrBevel(Source).InnerOutline;
      InnerSpace := TVrBevel(Source).InnerSpace;
      InnerColor := TVrBevel(Source).InnerColor;
      OuterShadow := TVrBevel(Source).OuterShadow;
      OuterHighlight := TVrBevel(Source).OuterHighlight;
      OuterWidth := TVrBevel(Source).OuterWidth;
      OuterStyle := TVrBevel(Source).OuterStyle;
      OuterOutline := TVrBevel(Source).OuterOutline;
      OuterSpace := TVrBevel(Source).OuterSpace;
      OuterColor := TVrBevel(Source).OuterColor;
      Visible := TVrBevel(Source).Visible;
    finally
      EndUpdate;
    end;
  end else inherited Assign(Source);
end;

procedure TVrBevel.SetBorderWidth(Value: TVrBorderWidth);
begin
  if FBorderWidth <> Value then
  begin
    FBorderWidth := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetInnerShadow(Value: TColor);
begin
  if FInnerShadow <> Value then
  begin
    FInnerShadow := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetInnerHighlight(Value: TColor);
begin
  if FInnerHighlight <> Value then
  begin
    FInnerHighlight := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetInnerWidth(Value: TVrBevelWidth);
begin
  if FInnerWidth <> Value then
  begin
    FInnerWidth := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetInnerStyle(Value: TVrBevelStyle);
begin
  if FInnerStyle <> Value then
  begin
    FInnerStyle := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetInnerOutline(Value: TVrBevelOutlineStyle);
begin
  if FInnerOutline <> Value then
  begin
    FInnerOutline := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetInnerSpace(Value: TVrBevelSpace);
begin
  if FInnerSpace <> Value then
  begin
    FInnerSpace := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetInnerColor(Value: TColor);
begin
  if FInnerColor <> Value then
  begin
    FInnerColor := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetOuterShadow(Value: TColor);
begin
  if FOuterShadow <> Value then
  begin
    FOuterShadow := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetOuterHighlight(Value: TColor);
begin
  if FOuterHighlight <> Value then
  begin
    FOuterHighlight := Value;
    Changed;
  end;