ivclcomponent.pas

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

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

{$IFDEF iVCL} unit  iVCLComponent;{$ENDIF}

interface

uses
  {$I iIncludeUses.inc}
  iTypes,  iGPFunctions, iMath, iComponent, iOPCItem, ActiveX, JPeg, iClasses, Registry, PNGImage, iOPCDLLLoader;

type                                                       
  TiVCLComponent = class(TiComponent)
  private
    FWindowHandle        : HWND;
    FPaintDCTransparent  : Boolean;
    FTransparentBitmap   : TBitmap;
    FDataCriticalSection : TRTLCriticalSection;
    FTransparent         : Boolean;

    FOPCItemManager      : TiOPCItemManager;
    FOPCSpecialList      : TStringList;
    FOPCIncomingActive   : Boolean;

    FTimerID             : Integer;
    FTimerFirstMessage   : Boolean;
    FTimerInterval       : Integer;
    FOnInternalTimer     : TNotifyEvent;
    FOnNewOPCData        : TIndexObjectEvent;

    FThemeCategoryList   : TStringList;
    FOnBeforeNewOPCData  : TBeforeOPCNewDataEvent;
  protected
    FNeedsTransparentCapture  : Boolean;

    procedure WMGetDLGCode      (var Message: TMessage);         message WM_GETDLGCODE;

    procedure CMWantSpecialKey  (var Message: TCMWantSpecialKey);message CM_WANTSPECIALKEY;

    procedure CMSYSColorChange  (var Message: TMessage);         message CM_SYSCOLORCHANGE;
    procedure CNKeyUp           (var Message: TWMKeyUp);         message CN_KEYUP;
    procedure WMSYSColorChange  (var Message: TMessage);         message WM_SYSCOLORCHANGE;
    procedure WMEraseBkGnd      (var Message: TMessage);         message WM_ERASEBKGND;
    procedure WMMove            (var Message: TMessage);         message WM_MOVE;
    procedure WMSetFocus        (var Message: TMessage);         message WM_SETFOCUS;
    procedure WMKillFocus       (var Message: TMessage);         message WM_KILLFOCUS;

    procedure WMLButtonDown     (var Message: TWMLButtonDown);   message WM_LBUTTONDOWN;
    procedure WMRButtonDown     (var Message: TWMRButtonDown);   message WM_RBUTTONDOWN;
    procedure WMMButtonDown     (var Message: TWMMButtonDown);   message WM_MBUTTONDOWN;

    procedure WMLButtonUp       (var Message: TWMLButtonUp);     message WM_LBUTTONUP;
    procedure WMRButtonUp       (var Message: TWMRButtonUp);     message WM_RBUTTONUP;
    procedure WMMButtonUp       (var Message: TWMMButtonUp);     message WM_MBUTTONUP;

    procedure WMLButtonDblClk   (var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure WMRButtonDblClk   (var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK;
    procedure WMMButtonDblClk   (var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK;

    procedure WndProc(var Message: TMessage); override;

    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;

    procedure CreateParams(var Params: TCreateParams); override;

    procedure SetTransparent(const Value: Boolean);              virtual;
    procedure GetTransparentBitmap;
    procedure RequestTransparentCapture;

    procedure DrawBackGround(Canvas: TCanvas; BackGroundColor: TColor); override;

    function  PaletteChanged(Foreground: Boolean): Boolean;             override;

    function  GetOPCItem(Index: Integer): TiOPCItem;
    function  OPCNewDataSpecial(iOPCItem: TiOPCItem): Boolean;   virtual;

    procedure UpdateOPCSpecialList;                              virtual;
    procedure OPCSetProperty(Instance: TPersistent; Path: String; PropertyName: String; PropertyValue: OleVariant);

    procedure OPCNewData(Sender: TObject);
    function OPCOutputData(PropertyName: String; Value: OleVariant): Boolean; override;

    property  OPCSpecialList: TStringList read FOPCSpecialList;

    procedure CreateWnd;                                          override;
    procedure DefineProperties(Filer: TFiler);                    override;
    procedure TimerProc(var Message: TMessage);

    function  GetJPEG(Compression: Integer; Progressive: Boolean): TJPEGImage;

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

    procedure ClearAllSchemes;
    procedure LoadAllThemes(FileStream: TiXMLMemoryStream; SchemeListClass: TiSchemeListClass);
    procedure GetThemePaths(var IocompPathName, UserPathName: String);
    function  GetThemeCategoryListByName(Name: String): TStringList;
    procedure SeparateNameValue(AText: String; var Name, Value: String);

    property  OnInternalTimer : TNotifyEvent read FOnInternalTimer write FOnInternalTimer;
    property  Transparent     : Boolean      read FTransparent     write SetTransparent        default False;
  public
    constructor Create(AOwner: TComponent);                       override;
    destructor  Destroy;                                          override;

    procedure   SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;

    procedure Lock;                                               override;
    procedure Unlock;                                             override;
    procedure RepaintAll;                                         override;

    procedure SaveImageToMetaFile(FileName: String);

    procedure LoadThemes;
    function  GetThemeCategoryCount                                            : Integer;
    function  GetThemeCategoryName        (CategoryIndex: Integer)             : String;
    function  GetThemeCategorySchemeCount (CategoryIndex: Integer)             : Integer;
    function  GetThemeCategorySchemeName  (CategoryIndex, SchemeIndex: Integer): String;
    function  GetThemeCategorySchemeIsUser(CategoryIndex, SchemeIndex: Integer): Boolean;
    procedure ApplyScheme                 (CategoryIndex, SchemeIndex: Integer);

    property  OPCItem[Index: Integer]: TiOPCItem read GetOPCItem;

    function  OPCAddItem   : Integer;
    procedure OPCDeleteItem(Index: Integer);
    function  OPCItemCount : Integer;
    procedure OPCRemoveAllItems;

    procedure OPCItemActivate       (Index:Integer);
    procedure OPCItemDeactivate     (Index:Integer);
    procedure OPCItemUpdateResume   (Index:Integer);
    procedure OPCItemUpdateSuspend  (Index:Integer);
    procedure OPCItemLoaded         (Index:Integer);

    function  GetOPCItemComputerName(Index: Integer):String;
    function  GetOPCItemServerName  (Index: Integer):String;
    function  GetOPCItemItemName    (Index: Integer):String;
    function  GetOPCItemPropertyName(Index: Integer):String;
    function  GetOPCItemAutoConnect (Index: Integer):Boolean;
    function  GetOPCItemUpdateRate  (Index: Integer):Integer;

    function  GetOPCItemData        (Index: Integer):OleVariant;
    function  GetOPCItemQuality     (Index: Integer):Word;
    function  GetOPCItemTimeStamp   (Index: Integer):TDateTime;

    procedure SetOPCItemData        (Index: Integer; Value: OleVariant);

    procedure SetOPCItemComputerName(Index: Integer; Value: String);
    procedure SetOPCItemServerName  (Index: Integer; Value: String);
    procedure SetOPCItemItemName    (Index: Integer; Value: String);
    procedure SetOPCItemPropertyName(Index: Integer; Value: String);
    procedure SetOPCItemAutoConnect (Index: Integer; Value: Boolean);
    procedure SetOPCItemUpdateRate  (Index: Integer; Value: Integer);

    procedure SaveImageToJPEG(FileName: String; Compression: Integer; Progressive: Boolean);
    procedure SaveImageToPNG (FileName: String; Compression: Integer);
    function  GetBytesJPEG   (Compression: Integer; Progressive: Boolean): OleVariant;
    function  GetBytesPNG    (Compression: Integer                      ): OleVariant;

    procedure iPaintToDC(X, Y: Integer; Transparent: Boolean; DC : HDC);
  published
    property  OnNewOPCData       : TIndexObjectEvent      read FOnNewOPCData       write FOnNewOPCData;
    property  OnBeforeNewOPCData : TBeforeOPCNewDataEvent read FOnBeforeNewOPCData write FOnBeforeNewOPCData;
  end;

implementation

type
  TWinControlAccess = class(TWinControl) end;
//****************************************************************************************************************************************************
constructor TiVCLComponent.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  InitializeCriticalSection(FDataCriticalSection);

  FOPCItemManager                := TiOPCItemManager.Create;
  FOPCItemManager.Owner          := Self;
  FOPCItemManager.OnGetDesigning := DoIsDesigning;
  FOPCItemManager.OnNewData      := OPCNewData;
  FOPCItemManager.OnGetType      := PropertyVarType;

  FOPCSpecialList    := TStringList.Create;

  FThemeCategoryList := TStringList.Create;

  FWindowHandle := AllocateHWnd(TimerProc);
end;
//****************************************************************************************************************************************************
destructor TiVCLComponent.Destroy;
begin
  DeleteCriticalSection(FDataCriticalSection);
  if Assigned(FTransparentBitmap) then FTransparentBitmap.Free;
                                       FOPCItemManager.Free;
                                       FOPCSpecialList.Free;
                                       FThemeCategoryList.Free;


  if FTimerID  <> 0 then KillTimer(FWindowHandle, 1);
 {$WARNINGS OFF}
  DeallocateHWnd(FWindowHandle);
 {$WARNINGS ON}
  inherited;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.CreateWnd;
begin
  inherited CreateWnd;
  SetWindowLong(Handle, GWL_ID, 0);
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if (ALeft = Left) and (ATop = Top) and (AWidth = Width) and (AHeight = Height) then Exit;
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);

  if Assigned(FTransparentBitmap) and (Width > 0) and (Height > 0) then
    begin
      FTransparentBitmap.Width  := Width;
      FTransparentBitmap.Height := Height;
    end;
  RequestTransparentCapture;

  if Assigned(BackGroundBitmap) and (Width > 0) and (Height > 0) then
    begin
      BackGroundBitmap.Width  := Width;
      BackGroundBitmap.Height := Height;
    end;
  BackGroundChange;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('OPCItems', FOPCItemManager.ReadFromStream, FOPCItemManager.WriteToStream, FOPCItemManager.DoWriteToStream);
  inherited;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.Lock;
begin
  if not(csDestroying  in ComponentState) then EnterCriticalSection(FDataCriticalSection);
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.Unlock;
begin
  if not(csDestroying  in ComponentState) then LeaveCriticalSection(FDataCriticalSection);
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.WMSYSColorChange(var Message: TMessage);
begin
  inherited;
  BackGroundChange;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.CMSYSColorChange(var Message: TMessage);
begin
  inherited;
  BackGroundChange;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.WMEraseBkGnd(var Message: TMessage);
begin
  Message.Result := 1;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.WMMove(var Message: TMessage);
begin
  inherited;
  RequestTransparentCapture;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.WMGetDLGCode(var Message: TMessage);
begin
  Message.Result := Message.Result or DLGC_WANTALLKEYS;
//  inherited; Do not Call Inherited. Lock up problem in Visual C++ on Win2000 
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.CMWantSpecialKey(var Message: TCMWantSpecialKey);
begin
  inherited;
  iWantSpecialKey(Message.CharCode, Message.Result);
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.WMKillFocus(var Message: TMessage);
begin
  UserGenerated := True;
  try
    if Message.WParam <> Longint(Handle) then iDoKillFocus;
  finally
    UserGenerated := False;
  end;
  inherited;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.WMSetFocus (var Message: TMessage);
begin
  UserGenerated := True;
  try
    iDoSetFocus;
    inherited;
  finally
    UserGenerated := False;
  end;