icomponent.pas

iocopm3.04源码,一套很好的工控开发工具

{*******************************************************}
{                                                       }
{       TiComponent                                     }
{                                                       }
{       Copyright (c) 1997,2003 Iocomp Software         }
{                                                       }
{*******************************************************}
{$I iInclude.inc}

{$ifdef iVCL}unit  iComponent;{$endif}
{$ifdef iCLX}unit QiComponent;{$endif}

interface

uses
  {$I iIncludeUses.inc}
  {$IFDEF iVCL} iTypes, iGPFunctions,   iMath, ActiveX;{$ENDIF}
  {$IFDEF iCLX}QiTypes, QiGPFunctions, QiMath;         {$ENDIF}

type
  TiPaintEvent = procedure(Sender: TObject; Canvas: TCanvas) of object;

  TiComponent = class(TCustomControl)
  private
    FOnPaint                      : TiPaintEvent;
    FCreationTime                 : Double;
   {$IFDEF EVAL}
    FFirstEvalExpiredPainted      : Boolean;
    {$ENDIF}
    FUpdateActive                 : Boolean;
    FUpdateFrameRate              : Integer;
    FLastUpdate                   : Double;
    FNeedsInvalidateChange        : Boolean;
    FNeedsBackGroundChange        : Boolean;
    FBackGroundBitmap             : TBitmap;
    FOffScreenBitmap              : TBitmap;
    FBackGroundPicture            : TBitmap;
    FBackGroundColor              : TColor;
    FBackGroundChanged            : Boolean;
    FBorderStyle                  : TiBevelStyle;
    FOffsetY                      : Integer;
    FOffsetX                      : Integer;
    FHasFocus                     : Boolean;
    FOnChangeProtected            : TChangePropertyEvent;
    FOnRequestEdit                : TRequestEditEvent;
    FAutoFrameRate                : Boolean;
    FLoading                      : Boolean;
    FOnGetDesigning               : TGetDesigningEvent;
    FActiveXDesigning             : Boolean;
    FCachedDrawing                : Boolean;
    FOptionSaveAllProperties      : Boolean;
    FUserGenerated                : Boolean;

    FErrorActive                  : Boolean;
    FErrorText                    : String;
    FErrorBackGroundColor         : TColor;
    FErrorFont                    : TFont;
  protected
    function GetCenterPointDouble(Canvas:TCanvas): TPointDouble;
    function GetLoading           : Boolean;
    function GetBorderMargin      : Integer;
    function GetCenterPoint     (Canvas:TCanvas): TPoint;                    virtual;

    procedure SetOffsetX             (const Value: Integer);
    procedure SetOffsetY             (const Value: Integer);
    procedure SetBackGroundPicture   (const Value: TBitmap);
    procedure SetUpdateFrameRate     (const Value: Integer);
    procedure SetAutoFrameRate       (const Value: Boolean);
    procedure SetCachedDrawing       (const Value: Boolean);      virtual;
    procedure SetBorderStyle         (const Value: TiBevelStyle); virtual;
    procedure SetBackGroundColor     (const Value: TColor      ); virtual;

    procedure SetErrorActive         (const Value: Boolean);
    procedure SetErrorText           (const Value: String);
    procedure SetErrorBackGroundColor(const Value: TColor);
    procedure SetErrorFont           (const Value: TFont);

    procedure DrawBackGround      (Canvas: TCanvas; BackGroundColor: TColor); virtual;
    procedure DrawBorder          (Canvas: TCanvas);                          virtual;

    procedure CreateBackGroundBitmap;
    procedure CreateOffScreenBitmap;

    procedure ShowOffScreenBitmap (Bitmap: TBitmap);
    procedure ShowBackGround;

    procedure BackGroundChange;
    procedure InvalidateChange;                  
    procedure InvalidateNow;

    procedure BackGroundChangeEvent(Sender : TObject);
    procedure InvalidateChangeEvent(Sender : TObject);
    procedure InvalidateNowEvent   (Sender : TObject);

    function  GetIsDesigning: Boolean;
    function  GetBackGroundBitmap: TBitmap;
                                                      
    procedure ResetBackGroundChange;
    procedure TransferBackGround(Canvas: TCanvas);
    procedure DoRepaintType(Value : TiRepaintType);
    property  BackGroundBitmap  : TBitmap      read GetBackGroundBitmap;
    property  BackGroundChanged : Boolean      read FBackGroundChanged;

    procedure SetLoading(Value: Boolean);

    function  GetPropertyType(Instance: TPersistent; Path: String; PropertyName: String): TiTypeKind;

    procedure PropertyVarType(PropertyName: String; var AVarType: TiTypeKind);

    function  GetTimerRunning : Boolean;                   virtual; abstract;
    procedure TimerStart(InitialDelay, Interval: Integer); virtual; abstract;
    procedure TimerStop;                                   virtual; abstract;

    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp  (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(                      Shift: TShiftState; X, Y: Integer); override;

    procedure DblClick;                                                           override;

    procedure KeyDown (var Key: Word; Shift: TShiftState); override;
    procedure KeyUp   (var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char);                     override;

    function OPCOutputData(PropertyName: String; Value: OleVariant): Boolean; virtual;

    procedure iDoSetFocus;  virtual;
    procedure iDoKillFocus; virtual;

    procedure iWantSpecialKey(var CharCode: Word; var Result: Longint); virtual;
    procedure iKeyUp         (var CharCode: Word; Shift: TShiftState);  virtual;
    procedure iKeyDown       (var CharCode: Word; Shift: TShiftState);  virtual;
    procedure iKeyPress      (var Key: Char);                           virtual;

    procedure iMouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer         );          virtual;
    procedure iMouseUp   (Button: TMouseButton; Shift: TShiftState; X, Y: Integer         );          virtual;
    procedure iMouseMove (                      Shift: TShiftState; X, Y: Integer         );          virtual;

    procedure iDoubleClick;                                                                           virtual;

    function  iMouseWheel(WheelDelta: Integer;  Shift: TShiftState; const MousePos: TPoint): Boolean; virtual;

    function  GetXYRadPoint(AngleDegrees, Radius: Double; Offset : TPoint) : TPoint;

    procedure Paint;                     override;

    procedure PaintToDC;
    procedure PaintToMetaFile;
    procedure PaintEvalExpired;
    procedure iPaintTo(Canvas: TCanvas); virtual; abstract;

    procedure CreateBackGroundPicture;

    property  BackGroundColor   : TColor       read FBackGroundColor   write SetBackGroundColor    default clBtnFace;
    property  BackGroundPicture : TBitmap      read FBackGroundPicture write SetBackGroundPicture;
    property  OffsetX           : Integer      read FOffsetX           write SetOffsetX            default 0;
    property  OffsetY           : Integer      read FOffsetY           write SetOffsetY            default 0;

    property  CachedDrawing     : Boolean      read FCachedDrawing     write SetCachedDrawing      default True;

    procedure SetBooleanProperty(Value : Boolean; var FVariable : Boolean; RepaintType : TiRepaintType);
    procedure SetIntegerProperty(Value : Integer; var FVariable : Integer; RepaintType : TiRepaintType);
    procedure SetDoubleProperty (Value : Double;  var FVariable : Double;  RepaintType : TiRepaintType);
    procedure SetStringProperty (Value : String;  var FVariable : String;  RepaintType : TiRepaintType);
    procedure SetColorProperty  (Value : TColor;  var FVariable : TColor;  RepaintType : TiRepaintType);
    procedure SetWideStringProperty(Value: WideString; var FVariable: WideString; RepaintType: TiRepaintType);

    procedure DoRepaint;
    procedure DoFrameRate;
    procedure DoIsDesigning(Sender: TObject; var Designing: Boolean);

    property  HasFocus              : Boolean              read FHasFocus;
    property  Loading               : Boolean              read GetLoading;
    property  UpdateActive          : Boolean              read FUpdateActive;

    property OnRequestEditProtected : TRequestEditEvent    read FOnRequestEdit        write FOnRequestEdit;
    property OnChangeProtected      : TChangePropertyEvent read FOnChangeProtected    write FOnChangeProtected;

    property OnPaint                : TiPaintEvent         read FOnPaint              write FOnPaint;

    property BorderMargin           : Integer              read GetBorderMargin;

    property IsDesigning            : Boolean              read GetIsDesigning;
    property OnGetDesigning         : TGetDesigningEvent   read FOnGetDesigning       write FOnGetDesigning;
    property ActiveXDesigning       : Boolean              read FActiveXDesigning     write FActiveXDesigning;

    property UserGenerated          : Boolean              read FUserGenerated        write FUserGenerated;

    property ErrorActive            : Boolean              read FErrorActive          write SetErrorActive;
    property ErrorText              : String               read FErrorText            write SetErrorText;
    property ErrorFont              : TFont                read FErrorFont            write SetErrorFont;
    property ErrorBackGroundColor   : TColor               read FErrorBackGroundColor write SetErrorBackGroundColor;
  public
    property    BorderStyle         : TiBevelStyle         read FBorderStyle       write SetBorderStyle        default ibsNone;

    constructor Create(AOwner: TComponent);                       override;
    destructor  Destroy;                                          override;
    procedure   RepaintAll;  virtual;
    procedure   BeginUpdate; virtual;
    procedure   EndUpdate;   virtual;
    procedure   Lock;        virtual; abstract;
    procedure   Unlock;      virtual; abstract;

    procedure SaveImageToBitmap  (FileName: String);

    procedure SavePropertiesToFile  (FileName: String); virtual;
    procedure LoadPropertiesFromFile(FileName: String); virtual;
  published
    property Visible;
    property Enabled;
    property ShowHint;
    property PopupMenu;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnStartDrag;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnEnter;
    property OnExit;

    property OptionSaveAllProperties : Boolean read FOptionSaveAllProperties write FOptionSaveAllProperties default False;
    property AutoFrameRate           : Boolean read FAutoFrameRate           write SetAutoFrameRate         default False;
    property UpdateFrameRate         : Integer read FUpdateFrameRate         write SetUpdateFrameRate       default 60;
  end;

{$ifdef iVCL}{$R  iIocompCommon.res} {$endif}
{$ifdef iCLX}{$R QiIocompCommon.res}{$endif}

implementation

type
  TWinControlAccess = class(TWinControl) end;
//****************************************************************************************************************************************************
constructor TiComponent.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csReplicatable, csOpaque];

  FCreationTime      := Now;
  FBackGroundColor   := clBtnFace;
  FBackGroundChanged := True;                                                   
  FLastUpdate        := Now;
  FCachedDrawing     := True;
  FUpdateFrameRate   := 60;
  FAutoFrameRate     := False;

  FErrorFont := TFont.Create;
  with FErrorFont do
    begin
      FErrorFont.Color := clRed;
      FErrorFont.Style := [fsBold];
      OnChange := InvalidateChangeEvent;
    end;

  FErrorText := 'Error';
end;
//****************************************************************************************************************************************************
destructor TiComponent.Destroy;
begin
  if Assigned(FBackGroundBitmap)  then FBackGroundBitmap.Free;
  if Assigned(FBackGroundPicture) then FBackGroundPicture.Free;

  FErrorFont.Free;
  inherited;
end;
//****************************************************************************************************************************************************
procedure TiComponent.SetBackGroundPicture(const Value: TBitmap);
begin
  FBackGroundPicture.Assign(Value);
end;
//****************************************************************************************************************************************************
procedure TiComponent.DoRepaint;
begin
  FNeedsBackGroundChange := False;
  FNeedsInvalidateChange := False;
  FLastUpdate            := Now;
  Invalidate;
end;
//****************************************************************************************************************************************************
procedure TiComponent.DoFrameRate;
var
  UpdateInterval : Double;
begin
  if not FAutoFrameRate   then
    begin
      DoRepaint;
      Exit;
    end;

  if FUpdateFrameRate = 0 then
    begin
      DoRepaint;
      Exit;
    end;

  UpdateInterval := 1/(FUpdateFrameRate *24*60*60);
  if Now > (FLastUpdate + UpdateInterval) then DoRepaint;
end;
//****************************************************************************************************************************************************
procedure TiComponent.BeginUpdate;
begin
  FUpdateActive := True;
end;
//****************************************************************************************************************************************************
procedure TiComponent.EndUpdate;
begin
  FUpdateActive := False;

  if FNeedsBackGroundChange or FNeedsInvalidateChange then DoFrameRate
end;
//****************************************************************************************************************************************************
procedure TiComponent.BackGroundChange;
begin
  FBackGroundChanged := True;

  if FUpdateActive then
    begin
      FNeedsBackGroundChange := True;
    end
  else if FAutoFrameRate then
    begin
      FNeedsBackGroundChange := True;
      DoFrameRate;
    end
  else DoRepaint;
end;
//****************************************************************************************************************************************************
procedure TiComponent.InvalidateChange;