vrcontrols.pas

作工控的好控件

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

unit VrControls;

{$I VRLIB.INC}

interface

uses
{$IFDEF VRSHARE}VrShareWin,{$ENDIF}
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VrConst, VrTypes, VrSysUtils, ExtCtrls;


type
  TGraphicControlCanvas = class(TGraphicControl)
  public
    property Canvas;
  end;

  TCustomControlCanvas = class(TCustomControl)
  public
    property Canvas;
  end;

  TVrComponent = class(TComponent)
  private
    FVersion: TVrVersion;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Version: TVrVersion read FVersion write FVersion stored false;
  end;

  TVrCustomControl = class(TCustomControl)
  private
    FVersion: TVrVersion;
    FUpdateCount: Integer;
  protected
    function Designing: Boolean;
    function Loading: Boolean;
    procedure ClearClientCanvas;
    procedure UpdateControlCanvas; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    procedure BeginUpdate;
    procedure EndUpdate;
  published
    property Version: TVrVersion read FVersion write FVersion stored false;
  end;

  TVrCustomImageControl = class(TVrCustomControl)
  private
    FBitmapImage: TBitmap;
    function GetBitmapCanvas: TCanvas;
  protected
    DestCanvas: TCanvas;
    procedure ClearBitmapCanvas; virtual;
    procedure Paint; override;
    property BitmapImage: TBitmap read FBitmapImage;
    property BitmapCanvas: TCanvas read GetBitmapCanvas;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  end;

  TVrGraphicControl = class(TGraphicControl)
  private
    FVersion: TVrVersion;
    FUpdateCount: Integer;
  protected
    function Designing: Boolean;
    function Loading: Boolean;
    procedure ClearClientCanvas;
    procedure UpdateControlCanvas; virtual;
    procedure ShowDesignFrame(Dest: TCanvas);
  public
    constructor Create(AOwner: TComponent); override;
    procedure BeginUpdate;
    procedure EndUpdate;
  published
    property Version: TVrVersion read FVersion write FVersion stored false;
  end;

  TVrGraphicImageControl = class(TVrGraphicControl)
  private
    FOverlay: TBitmap;
    FBitmapImage: TBitmap;
    FRefreshOverlay: Boolean;
    FTransparent: Boolean;
    function GetBitmapCanvas: TCanvas;
    procedure SetTransparent(Value: Boolean);
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  protected
    DestCanvas: TCanvas;
    procedure ClearBitmapCanvas; virtual;
    procedure Paint; override;
    procedure CopyParentImage;
    procedure CopyOverlayImage;
    procedure UpdateControlCanvas; override;
    property BitmapImage: TBitmap read FBitmapImage;
    property BitmapCanvas: TCanvas read GetBitmapCanvas;
    property Transparent: Boolean read FTransparent write SetTransparent;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  end;

  TVrHyperLinkControl = class(TVrGraphicImageControl)
  private
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    procedure MouseEnter; virtual;
    procedure MouseLeave; virtual;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
  end;

  TVrChangeLink = class;

  TVrSharedComponent = class(TVrComponent)
  private
    FClients: TList;
  protected
    procedure NotifyClients;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure InsertLink(Value: TVrChangeLink);
    procedure RemoveLink(Value: TVrChangeLink);
  end;

  TVrChangeLink = class(TObject)
  private
    FSender: TVrSharedComponent;
    FOnChange: TNotifyEvent;
  public
    destructor Destroy; override;
    procedure Change; dynamic;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Sender: TVrSharedComponent read FSender write FSender;
  end;

{ Obsolete

  TVrThumbStates = 1..4;
  TVrCustomThumb = class(TVrGraphicImageControl)
  private
    FGlyph: TBitmap;
    FThumbStates: TVrThumbStates;
    FDown: Boolean;
    FHasMouse: Boolean;
    procedure SetGlyph(Value: TBitmap);
    procedure SetThumbStates(Value: TVrThumbStates);
    procedure SetDown(Value: Boolean);
    procedure AdjustBoundsRect; virtual;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    procedure Paint; override;
    procedure LoadFromResourceName(const ResName: string);
    function GetImageIndex: Integer; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property ThumbStates: TVrThumbStates read FThumbStates write SetThumbStates;
    property Down: Boolean read FDown write SetDown;
    property HasMouse: Boolean read FHasMouse;
  end;}


implementation


{ TVrComponent }

constructor TVrComponent.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FVersion := VrLibVersion;
{$IFDEF VRSHARE}
  if not (csDesigning in ComponentState) then
    ShowRegWin;
{$ENDIF}
end;

{ TVrCustomControl }

constructor TVrCustomControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FVersion := VrLibVersion;
{$IFDEF VRSHARE}
  if not Designing then
    ShowRegWin;
{$ENDIF}
end;

function TVrCustomControl.Designing: Boolean;
begin
  Result := (csDesigning in ComponentState);
end;

function TVrCustomControl.Loading: Boolean;
begin
  Result := (csLoading in ComponentState);
end;

procedure TVrCustomControl.ClearClientCanvas;
begin
  with inherited Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := Self.Color;
    FillRect(ClientRect);
  end;
end;

procedure TVrCustomControl.UpdateControlCanvas;
begin
  if not Loading then
    if FUpdateCount = 0 then Repaint;
end;

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

procedure TVrCustomControl.EndUpdate;
begin
  Dec(FUpdateCount);
  UpdateControlCanvas;
end;

{ TVrCustomImageControl }

constructor TVrCustomImageControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBitmapImage := TBitmap.Create;
  DestCanvas := Self.Canvas;
end;

destructor TVrCustomImageControl.Destroy;
begin
  FBitmapImage.Free;
  inherited Destroy;
end;

procedure TVrCustomImageControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  with FBitmapImage do
  begin
    Width := AWidth;
    Height := AHeight;
  end;
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;

procedure TVrCustomImageControl.ClearBitmapCanvas;
begin
  with FBitmapImage do
  begin
    Canvas.Brush.Style := bsSolid;
    Canvas.Brush.Color := Self.Color;
    Canvas.FillRect(Bounds(0, 0, Width, Height));
  end;
end;

procedure TVrCustomImageControl.Paint;
begin
  BitBlt(Canvas.Handle, 0, 0, Width, Height,
    FBitmapImage.Canvas.Handle, 0, 0, SRCCOPY);
end;

function TVrCustomImageControl.GetBitmapCanvas: TCanvas;
begin
  Result := FBitmapImage.Canvas;
end;

{ TVrGraphicControl }

constructor TVrGraphicControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FVersion := VrLibVersion;
{$IFDEF VRSHARE}
  if not Designing then
    ShowRegWin;
{$ENDIF}
end;

function TVrGraphicControl.Designing: Boolean;
begin
  Result := (csDesigning in ComponentState);
end;

function TVrGraphicControl.Loading: Boolean;
begin
  Result := (csLoading in ComponentState);
end;

procedure TVrGraphicControl.ClearClientCanvas;
begin
  with inherited Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := Self.Color;
    FillRect(ClientRect);
  end;
end;

procedure TVrGraphicControl.ShowDesignFrame(Dest: TCanvas);
begin
  if Designing then
    with Dest do
    begin
      Pen.Style := psDot;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;