cximage.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,762 行 · 第 1/4 页

{********************************************************************}
{                                                                    }
{       Developer Express Visual Component Library                   }
{       ExpressEditors                                               }
{                                                                    }
{       Copyright (c) 1998-2008 Developer Express Inc.               }
{       ALL RIGHTS RESERVED                                          }
{                                                                    }
{   The entire contents of this file is protected by U.S. and        }
{   International Copyright Laws. Unauthorized reproduction,         }
{   reverse-engineering, and distribution of all or any portion of   }
{   the code contained in this file is strictly prohibited and may   }
{   result in severe civil and criminal penalties and will be        }
{   prosecuted to the maximum extent possible under the law.         }
{                                                                    }
{   RESTRICTIONS                                                     }
{                                                                    }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES            }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE     }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS    }
{   LICENSED TO DISTRIBUTE THE EXPRESSEDITORS AND ALL                }
{   ACCOMPANYING VCL CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY. }
{                                                                    }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED       }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE         }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE        }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT   }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                       }
{                                                                    }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON        }
{   ADDITIONAL RESTRICTIONS.                                         }
{                                                                    }
{********************************************************************}

unit cxImage;

{$I cxVer.inc}

interface

uses
{$IFDEF DELPHI6}
  Types, Variants,
{$ENDIF}
  Windows, Messages, ExtDlgs, SysUtils, Classes, Clipbrd, Controls, Dialogs,
  ExtCtrls, Forms, Graphics, Menus, StdCtrls, cxClasses, cxContainer,
  cxControls, cxDataUtils, cxEdit, cxEditConsts, cxGraphics, cxLookAndFeels;

const
  cxImageDefaultInplaceHeight = 15;

type
  TcxCustomImage = class;
  TcxPopupMenuItem = (pmiCut, pmiCopy, pmiPaste, pmiDelete, pmiLoad, pmiSave,
    pmiCustom);
  TcxPopupMenuItemClick = procedure(Sender: TObject;
    MenuItem: TcxPopupMenuItem) of object;
  TcxPopupMenuItems = set of TcxPopupMenuItem;

  { TcxPopupMenuLayout }

  TcxPopupMenuLayout = class(TPersistent)
  private
    FCustomMenuItemCaption: string;
    FCustomMenuItemGlyph: TBitmap;
    FImage: TcxCustomImage;
    FMenuItems: TcxPopupMenuItems;
    function GetCustomMenuItemGlyph: TBitmap; virtual;
    procedure SetCustomMenuItemGlyph(Value: TBitmap);
  public
    constructor Create(AImage: TcxCustomImage);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property MenuItems: TcxPopupMenuItems read FMenuItems write FMenuItems default
      [pmiCut, pmiCopy, pmiPaste, pmiDelete, pmiLoad, pmiSave];
    property CustomMenuItemCaption: string
      read FCustomMenuItemCaption write FCustomMenuItemCaption;
    property CustomMenuItemGlyph: TBitmap
      read GetCustomMenuItemGlyph write SetCustomMenuItemGlyph;
  end;

  { TcxImageViewInfo }

  TcxImageViewInfo = class(TcxCustomEditViewInfo)
  private
    FFreePicture: Boolean;
    FTempBitmap: TBitmap;
    procedure DrawTransparentBackground(ACanvas: TcxCanvas; const R: TRect);
  protected
    procedure InternalPaint(ACanvas: TcxCanvas); override;
    function IsRepaintOnStateChangingNeeded: Boolean; override;
  public
    ShowFocusRect: Boolean;
    TopLeft: TPoint;
    Caption: string;
    Center: Boolean;
    Picture: TPicture;
    Proportional: Boolean;
    Stretch: Boolean;
    destructor Destroy; override;
  end;

  { TcxImageViewData }

  TcxImageViewData = class(TcxCustomEditViewData)
  public
    procedure Calculate(ACanvas: TcxCanvas; const ABounds: TRect; const P: TPoint;
      Button: TcxMouseButton; Shift: TShiftState; AViewInfo: TcxCustomEditViewInfo;
      AIsMouseEvent: Boolean); override;
    procedure EditValueToDrawValue(ACanvas: TcxCanvas; const AEditValue: TcxEditValue;
      AViewInfo: TcxCustomEditViewInfo); override;
    function GetEditContentSize(ACanvas: TcxCanvas;
      const AEditValue: TcxEditValue;
      const AEditSizeProperties: TcxEditSizeProperties): TSize; override;
  end;

  { TcxCustomImageProperties }

  TcxImageAssignPictureEvent = procedure(Sender: TObject;
    const Picture: TPicture) of object;
  TcxImageGraphicClassEvent = procedure(AItem: TObject; ARecordIndex: Integer;
    APastingFromClipboard: Boolean; var AGraphicClass: TGraphicClass) of object;
  TcxImageEditGraphicClassEvent = procedure(Sender: TObject;
    APastingFromClipboard: Boolean; var AGraphicClass: TGraphicClass) of object;

  TcxImageTransparency = (gtDefault, gtOpaque, gtTransparent);

  TcxCustomImageProperties = class(TcxCustomEditProperties)
  private
    FCaption: string;
    FCenter: Boolean;
    FCustomFilter: string;
    FDefaultHeight: Integer;
    FGraphicClass: TGraphicClass;
    FGraphicTransparency: TcxImageTransparency;
    FPopupMenuLayout: TcxPopupMenuLayout;
    FProportional: Boolean;
    FShowFocusRect: Boolean;
    FStretch: Boolean;
    FOnAssignPicture: TcxImageAssignPictureEvent;
    FOnCustomClick: TNotifyEvent;
    FOnGetGraphicClass: TcxImageGraphicClassEvent;
    function GetGraphicClassName: string;
    function IsGraphicClassNameStored: Boolean;
    procedure ReadIsGraphicClassNameEmpty(Reader: TReader);
    procedure SetCaption(const Value: string);
    procedure SetCenter(Value: Boolean);
    procedure SetGraphicClass(const Value: TGraphicClass);
    procedure SetGraphicClassName(const Value: string);
    procedure SetGraphicTransparency(Value: TcxImageTransparency);
    procedure SetPopupMenuLayout(Value: TcxPopupMenuLayout);
    procedure SetProportional(AValue: Boolean);
    procedure SetShowFocusRect(Value: Boolean);
    procedure SetStretch(Value: Boolean);
    procedure WriteIsGraphicClassNameEmpty(Writer: TWriter);
  protected
    function CanValidate: Boolean; override;
    procedure DefineProperties(Filer: TFiler); override;
    function IsDesigning: Boolean;
    function GetDefaultGraphicClass: TGraphicClass; virtual;
    class function GetViewDataClass: TcxCustomEditViewDataClass; override;
    property DefaultHeight: Integer read FDefaultHeight write FDefaultHeight
      default cxImageDefaultInplaceHeight;
  public
    constructor Create(AOwner: TPersistent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    class function GetContainerClass: TcxContainerClass; override;
    function GetDisplayText(const AEditValue: TcxEditValue;
      AFullText: Boolean = False; AIsInplace: Boolean = True): WideString; override;
    function GetEditValueSource(AEditFocused: Boolean): TcxDataEditValueSource; override;
    function GetGraphicClass(AItem: TObject;
      ARecordIndex: Integer;
      APastingFromClipboard: Boolean = False): TGraphicClass; virtual;
    function GetSpecialFeatures: TcxEditSpecialFeatures; override;
    function GetSupportedOperations: TcxEditSupportedOperations; override;
    class function GetViewInfoClass: TcxContainerViewInfoClass; override;
    function IsResetEditClass: Boolean; override;
    procedure ValidateDisplayValue(var DisplayValue: TcxEditValue; var ErrorText: TCaption;
      var Error: Boolean; AEdit: TcxCustomEdit); override;
    property GraphicClass: TGraphicClass read FGraphicClass write SetGraphicClass;
    // !!!
    property Caption: string read FCaption write SetCaption;
    property Center: Boolean read FCenter write SetCenter default True;
    property CustomFilter: string read FCustomFilter write FCustomFilter;
    property GraphicClassName: string read GetGraphicClassName
      write SetGraphicClassName stored IsGraphicClassNameStored;
    property GraphicTransparency: TcxImageTransparency
      read FGraphicTransparency write SetGraphicTransparency default gtDefault;
    property PopupMenuLayout: TcxPopupMenuLayout
      read FPopupMenuLayout write SetPopupMenuLayout;
    property Proportional: Boolean read FProportional write SetProportional default True;
    property ShowFocusRect: Boolean read FShowFocusRect write SetShowFocusRect default True;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property OnAssignPicture: TcxImageAssignPictureEvent
      read FOnAssignPicture write FOnAssignPicture;
    property OnCustomClick: TNotifyEvent read FOnCustomClick
      write FOnCustomClick;
    property OnGetGraphicClass: TcxImageGraphicClassEvent read FOnGetGraphicClass
      write FOnGetGraphicClass;
  end;

  { TcxImageProperties }

  TcxImageProperties = class(TcxCustomImageProperties)
  published
    property AssignedValues;
    property Caption;
    property Center;
    property ClearKey;
    property CustomFilter;
    property GraphicClassName;
    property GraphicTransparency;
    property ImmediatePost;
    property PopupMenuLayout;
    property Proportional;
    property ReadOnly;
    property ShowFocusRect;
    property Stretch;
    property OnAssignPicture;
    property OnChange;
    property OnCustomClick;
    property OnEditValueChanged;
    property OnGetGraphicClass;
  end;

  { TcxCustomImage }

  TcxCustomImage = class(TcxCustomEdit)
  private
    FClipboardFormat: Word;
    FEditPopupMenu: TPopupMenu;
    FInternalChanging: Boolean;
    FIsDialogShowed: Boolean;
    FPicture: TPicture;
    FTransparent: Boolean;
    FOnGetGraphicClass: TcxImageEditGraphicClassEvent;
    procedure EditAndClear;
    procedure EditPopupMenuClick(Sender: TObject);
  {$IFDEF CBUILDER10}
    function GetPicture: TPicture;
  {$ENDIF}
    function GetProperties: TcxCustomImageProperties;
    function GetActiveProperties: TcxCustomImageProperties;
    procedure MenuItemClick(Sender: TObject; MenuItem: TcxPopupMenuItem);
    procedure PictureChanged(Sender: TObject);
    procedure PreparePopup;
    procedure ResetImage;
    procedure SetPicture(Value: TPicture);
    procedure SetProperties(const Value: TcxCustomImageProperties);
    procedure SetTransparent(AValue: Boolean);
    procedure SynchronizeImage;
  protected
    function CanAutoSize: Boolean; override;
    function CanAutoWidth: Boolean; override;
    procedure DoContextPopup( MousePos: TPoint;
      var Handled: Boolean); override;
    procedure Initialize; override;
    procedure InitScrollBarsParameters; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    function NeedsInvokeAfterKeyDown(AKey: Word; AShift: TShiftState): Boolean; override;
    function NeedsScrollBars: Boolean; override;
    procedure Scroll(AScrollBarKind: TScrollBarKind; AScrollCode: TScrollCode;
      var AScrollPos: Integer); override;
    function GetEditValue: TcxEditValue; override;
    procedure InternalSetEditValue(const Value: TcxEditValue;
      AIsValueValid: Boolean); override;
    procedure PropertiesChanged(Sender: TObject); override;
    procedure UpdateScrollBars; override;

    // virtual methods
    function CanPasteFromClipboard: Boolean; virtual;
    procedure CustomClick; virtual;
    procedure DoOnAssignPicture;
    function GetGraphicClass(APastingFromClipboard: Boolean = False): TGraphicClass; virtual;
    property AutoSize default False;
    property ParentColor default False;
    property OnGetGraphicClass: TcxImageEditGraphicClassEvent
      read FOnGetGraphicClass write FOnGetGraphicClass;
  public
    destructor Destroy; override;
    procedure CopyToClipboard; override;
    procedure CutToClipboard; override;
    function Focused: Boolean; override;
    class function GetPropertiesClass: TcxCustomEditPropertiesClass; override;
    procedure LoadFromFile;
    procedure PasteFromClipboard; override;
    procedure SaveToFile;
    property ActiveProperties: TcxCustomImageProperties read GetActiveProperties;
    property ClipboardFormat: Word
      read FClipboardFormat write FClipboardFormat;
    property Picture: TPicture read {$IFDEF CBUILDER10}GetPicture{$ELSE}FPicture{$ENDIF}
      write SetPicture;
    property Properties: TcxCustomImageProperties read GetProperties
      write SetProperties;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
  end;

  { TcxImage }

  TcxImage = class(TcxCustomImage)
  private
    function GetActiveProperties: TcxImageProperties;
    function GetProperties: TcxImageProperties;
    procedure SetProperties(Value: TcxImageProperties);
  public
    class function GetPropertiesClass: TcxCustomEditPropertiesClass; override;
    property ActiveProperties: TcxImageProperties read GetActiveProperties;
  published
    property Align;
    property Anchors;
    property AutoSize;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ParentColor;
    property ParentShowHint;
    property Picture;
    property PopupMenu;
    property Properties: TcxImageProperties read GetProperties
      write SetProperties;
    property Style;
    property StyleDisabled;
    property StyleFocused;
    property StyleHot;
    property TabOrder;
    property TabStop;
    property Transparent;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEditing;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetGraphicClass;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

function IsPictureEmpty(APicture: TPicture): Boolean;
procedure LoadPicture(APicture: TPicture; AGraphicClass: TGraphicClass;
  const AValue: Variant);
procedure SavePicture(APicture: TPicture; var AValue: AnsiString);

function GetGraphicClassByName(const AClassName: string): TGraphicClass;
function GetRegisteredGraphicClasses: TList;
procedure RegisterGraphicClass(AGraphicClass: TGraphicClass);
procedure UnRegisterGraphicClass(AGraphicClass: TGraphicClass);

implementation

uses
{$IFNDEF DELPHI6}
  cxVariants,
{$ENDIF}
{$IFDEF USEJPEGIMAGE}
  Jpeg,
{$ENDIF}
  dxGDIPlusApi, dxGDIPlusClasses, cxGeometry,
  Math, ImgList, cxEditUtils;

type
  {$IFNDEF DELPHI6}
  TDummyGraphic = class(TGraphic);
  TDummyGraphicClass = class of TDummyGraphic;
  {$ENDIF}
  TMemoryStreamAccess = class(TMemoryStream);
  {$IFDEF USEJPEGIMAGE}
  TJPEGImageAccess = class(TJPEGImage);
  {$ENDIF}

var
  cxGraphicPopupMenuImages: TImageList;
  cxRegisteredGraphicClasses: TList;

function GetGraphicClassByName(const AClassName: string): TGraphicClass;
var
  I: Integer;
begin
  Result := nil;
  for i := 0 to GetRegisteredGraphicClasses.Count - 1 do
    if InternalCompareString(AClassName, TClass(GetRegisteredGraphicClasses[I]).ClassName, False) then
    begin
      Result := TGraphicClass(GetRegisteredGraphicClasses[I]);
      Break;
    end;
end;

function GetRegisteredGraphicClasses: TList;
begin
  if cxRegisteredGraphicClasses = nil then
  begin
    cxRegisteredGraphicClasses := TList.Create;
    RegisterGraphicClass(TBitmap);
    RegisterGraphicClass(TIcon);
    RegisterGraphicClass(TMetaFile);
    if GetClass(TdxPNGImage.ClassName) <> nil then
      RegisterGraphicClass(TdxPNGImage);
  {$IFDEF USEJPEGIMAGE}
    RegisterGraphicClass(TJpegImage);
  {$ENDIF}
  end;
  Result := cxRegisteredGraphicClasses
end;

procedure RegisterGraphicClass(AGraphicClass: TGraphicClass);
begin
  if cxRegisteredGraphicClasses.IndexOf(TObject(AGraphicClass)) = -1 then
    cxRegisteredGraphicClasses.Add(TObject(AGraphicClass));
end;

procedure UnRegisterGraphicClass(AGraphicClass: TGraphicClass);
var
  I: Integer;
begin
  I := cxRegisteredGraphicClasses.IndexOf(TObject(AGraphicClass));
  if I <> -1 then
    cxRegisteredGraphicClasses.Delete(I);
end;

procedure CalcStretchRect(R: TRect; W, H: Integer; out CalcRect: TRect);
var
  W1, H1: Integer;
begin
  if IsRectEmpty(R) then
  begin