gdipclasses.pas

Workflow Studio是一款专为商业进程管理（BPM）设计的Delphi VCL框架。通过Workflow Studio你可以轻易地将工作流与BPM功能添加到你的应用程序里。这样能使你或你的最

unit GdipClasses;

{$I Diagram.Inc}

interface

{$IFDEF GDIPLUS}

uses
  Windows, SysUtils, Classes,
  {$IFDEF GDIPLUS}
  DgrGdipApi, DgrGdipObj, //Put before Graphics
  {$ENDIF}
  Graphics, ActiveX, DiagramUtils
  ;

type
  TDgrGraphic = class(TGraphic)
  private
    { Private declarations }
    FGPImage: TGPImage;
    FDatastream: TMemoryStream;
    FIsEmpty: Boolean;
    FWidth, FHeight: Integer;
    //FDoubleBuffered: Boolean;
    //FBackgroundColor: TColor;
    procedure DestroyGPImage;
    procedure CreateGPImage;
  protected
    { Protected declarations }
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure SetHeight(Value: Integer); override;
    procedure SetWidth(Value: Integer); override;
    procedure ReadData(Stream: TStream); override;
    procedure WriteData(Stream: TStream); override;
    function GPImage: TGPImage;
  protected
    procedure Changed(Sender: TObject); override;
  public
    { Public declarations }
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    procedure LoadFromFile(const FileName: string); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    {procedure LoadFromResourceName(Instance: THandle; const ResName: String);
    procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
    procedure LoadFromURL(url:string);}
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    //property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered;
    //property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor;
    function GetImageSizes: boolean;
  end;

  TDgrPicture = class(TPicture)
  private
    FGPImage: TGPImage;
    FStream: TStream;
    FTransparency: integer;
    procedure DestroyGPImage;
    procedure CreateGPImage;
    procedure SetTransparency(const Value: integer);
  protected
    procedure Changed(Sender: TObject); override;
    function GPImage: TGPImage;
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Transparency: integer read FTransparency write SetTransparency;
  end;

  TDgrGraphicsObject = class(TPersistent)
  private
    FOnChange: TNotifyEvent;
  protected
    procedure Change; virtual;
  public
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TDgrBrushMode = (bmSolid, bmClear, bmHatch, bmGradient, bmTexture);
  TDgrGradientMode = (gmTopBottom, gmBottomTop, gmLeftRight, gmRightLeft,
    gmLeftTop, gmRightTop, gmLeftBottom, gmRightBottom,
    gmInOut, gmOutIn, gmHorzInOut, gmHorzOutIn, gmVertInOut, gmVertOutIn);

  TDgrBrush = class(TDgrGraphicsObject)
  private
    FGPBrush: TGPBrush;
    FColor: TColor;
    FTransparency: integer;
    FHatchStyle: THatchStyle;
    FBrushMode: TDgrBrushMode;
    FColor2: TColor;
    FGradientRect: TGPRectF;
    FGradientMode: TDgrGradientMode;
    FTexture: TDgrPicture;
    FRotMatrix: TGPMatrix;
    FTransp1: integer;
    FTransp2: integer;
    procedure DestroyGPBrush;
    procedure CreateGPBrush;
    procedure SetColor(const Value: TColor);
    procedure SetTransparency(const Value: integer);
    procedure SetHatchStyle(const Value: THatchStyle);
    function GetAlpha1: byte;
    function GetAlpha2: byte;
    procedure SetBrushMode(const Value: TDgrBrushMode);
    procedure SetColor2(const Value: TColor);
    procedure SetGradientMode(const Value: TDgrGradientMode);
    procedure SetTexture(const Value: TDgrPicture);
    procedure ItemChange(Sender: TObject);
  protected
    procedure Change; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure UpdateBrushPosition(ARect: TRectX; AAngle: single; ARotCenter: TPointX);
    function GPBrush: TGPBrush;
  published
    property Color: TColor read FColor write SetColor default clWhite;
    property Color2: TColor read FColor2 write SetColor2;
    property Transparency: integer read FTransparency write SetTransparency default 0;
    property HatchStyle: THatchStyle read FHatchStyle write SetHatchStyle;
    property BrushMode: TDgrBrushMode read FBrushMode write SetBrushMode;
    property GradientMode: TDgrGradientMode read FGradientMode write SetGradientMode;
    property Texture: TDgrPicture read FTexture write SetTexture;
  end;

  TDgrPen = class(TDgrGraphicsObject)
  private
    FGPPen: TGPPen;
    FWidth: single;
    FColor: TColor;
    FTransparency: integer;
    FDashStyle: TDashStyle;
    procedure DestroyGPPen;
    procedure CreateGPPen;
    procedure SetColor(const Value: TColor);
    procedure SetWidth(const Value: single);
    procedure SetTransparency(const Value: integer);
    function GetAlpha: byte;
    procedure SetDashStyle(const Value: TDashStyle);
  protected
    procedure Change; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function GPPen: TGPPen;
  published
    property Color: TColor read FColor write SetColor default clBlack;
    property Transparency: integer read FTransparency write SetTransparency;
    property Width: single read FWidth write SetWidth;
    property DashStyle: TDashStyle read FDashStyle write SetDashStyle;
    //property Mode: TPenMode read FMode write SetMode default pmCopy;
    //property Style: TPenStyle read GetStyle write SetStyle default psSolid;
  end;

  TGPCanvas = class(TPersistent)
  private
    FInternalGraphics: TGPGraphics;
    FTempGraphics: TGPGraphics;
    State: TCanvasState;
    FPen: TDgrPen;
    FBrush: TDgrBrush;
    FDestRect: TRectX;
    FSourceRect: TRectX;
    FTranslateRects: boolean;
    FValidRects: boolean;
    FScaleX: single;
    FScaleY: single;
    FTransMatrix: TGPMatrix;
    FAngle: single;
    FRotCenter: TPointX;
    function GetHandle: HDC;
    procedure SetHandle(const Value: HDC);
    procedure SetGraphics(AGraphics: TGPGraphics);
    procedure DestroyGraphics;
    procedure SetPen(const Value: TDgrPen);
    procedure SetBrush(const Value: TDgrBrush);
    procedure SetDestRect(const Value: TRectX);
    procedure SetSourceRect(const Value: TRectX);
    procedure UpdateFactors;
    function PX(X: single): single;
    function PY(Y: single): single;
    function PP(P: TGPPointF): TGPPointF; overload;
    function PP(R: TRectX): TRectX; overload;
    //procedure SetTranslateRects(const Value: boolean);
    function MustTranslateRects: boolean;
    function SX(X: single): single;
    function SY(Y: single): single;
    function GetGraphics: TGPGraphics;
    procedure SetRotCenter(const Value: TPointX);
    procedure SetAngle(const Value: single);
    //FHandle: HDC;
    //FFont: TFont;
    //FPen: TPen;
    //FBrush: TBrush;
    //FPenPos: TPoint;
    //FCopyMode: TCopyMode;
    //FOnChange: TNotifyEvent;
    //FOnChanging: TNotifyEvent;
    //FLock: TRTLCriticalSection;
    //FLockCount: Integer;
    //FTextFlags: Longint;
    //procedure CreateBrush;
    //procedure CreateFont;
    //procedure CreatePen;
    //procedure BrushChanged(ABrush: TObject);
    //procedure DeselectHandles;
    //function GetCanvasOrientation: TCanvasOrientation;
    //function GetClipRect: TRect;
    //function GetHandle: HDC;
    //function GetPenPos: TPoint;
    //function GetPixel(X, Y: Integer): TColor;
    //procedure FontChanged(AFont: TObject);
    //procedure PenChanged(APen: TObject);
    //procedure SetBrush(Value: TBrush);
    //procedure SetFont(Value: TFont);
    //procedure SetHandle(Value: HDC);
    //procedure SetPen(Value: TPen);
    //procedure SetPenPos(Value: TPoint);
    //procedure SetPixel(X, Y: Integer; Value: TColor);
  protected
    procedure Changed; virtual;
    procedure Changing; virtual;
    //procedure CreateHandle; virtual;
    procedure RequiredState(ReqState: TCanvasState);
    property SourceRect: TRectX read FSourceRect write SetSourceRect;
    property DestRect: TRectX read FDestRect write SetDestRect;
    property RotationCenter: TPointX read FRotCenter write SetRotCenter;
    property Angle: single read FAngle write SetAngle;
  public
    constructor Create(AHandle: HDC = 0);
    destructor Destroy; override;
    property Handle: HDC read GetHandle write SetHandle;
    property GPGraphics: TGPGraphics read GetGraphics;
    //procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
    //procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap; const Source: TRect; Color: TColor);
    //procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
    //procedure CopyRect(const Dest: TRect; Canvas: TCanvas; const Source: TRect);
    //procedure Draw(X, Y: Integer; Graphic: TGraphic);
    //procedure DrawFocusRect(const Rect: TRect);
    procedure Ellipse(X1, Y1, X2, Y2: single);
    //procedure Ellipse(const Rect: TRect); overload;
    //procedure FillRect(const Rect: TRect);
    //procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
    //procedure FrameRect(const Rect: TRect);
    //procedure LineTo(X, Y: Integer);
    //procedure Lock;
    //procedure MoveTo(X, Y: Integer);
    //procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
    procedure Polygon(const Points: TPointFDynArray); overload;
    //procedure Polygon(const Points: TPointArray); overload;
    //procedure Polyline(const Points: array of TPoint);
    //procedure PolyBezier(const Points: array of TPoint);
    //procedure PolyBezierTo(const Points: array of TPoint);
    procedure Rectangle(X1, Y1, X2, Y2: single); overload;
    //procedure Rectangle(const Rect: TRect); overload;
    //procedure Refresh;
    procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: single);
    procedure AddRoundRectPath(APath: TGPGraphicsPath; X1, Y1, X2, Y2, X3, Y3: single);
    procedure Path(APath: TGPGraphicsPath);
    procedure DrawPath(APath: TGPGraphicsPath);
    procedure DrawLine(X1, Y1, X2, Y2: single);
    procedure StretchDraw(const Rect: TRect; Graphic: TGraphic; ATransparency: integer = 0); overload;
    procedure StretchDraw(const Rect: TRectX; Graphic: TGraphic; ATransparency: integer = 0); overload;
    procedure StretchDraw(const Rect: TRectX; AGPImage: TGPImage; ATransparency: integer = 0;
      ABitmapTransparent: boolean = false); overload;
    //function TextExtent(const Text: string): TSize;
    //function TextHeight(const Text: string): Integer;
    //procedure TextOut(X, Y: Integer; const Text: string);
    //procedure TextRect(Rect: TRect; X, Y: Integer; const Text: string);
    //function TextWidth(const Text: string): Integer;
    //function TryLock: Boolean;
    //procedure Unlock;
    //property Handle: HDC read GetHandle write SetHandle;
    //property LockCount: Integer read FLockCount;
    //property CanvasOrientation: TCanvasOrientation read GetCanvasOrientation;
    //property PenPos: TPoint read GetPenPos write SetPenPos;
    //property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
    //property TextFlags: Longint read FTextFlags write FTextFlags;
    //property OnChange: TNotifyEvent read FOnChange write FOnChange;
    //property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
    //property TranslateRects: boolean read FTranslateRects write SetTranslateRects;
    //property TransMatrix: TGPMatrix read FTransMatrix;
  published
    //property Brush: TBrush read FBrush write SetBrush;
    //property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy;
    //property Font: TFont read FFont write SetFont;
    property Pen: TDgrPen read FPen write SetPen;
    property Brush: TDgrBrush read FBrush write SetBrush;
  end;

  TGPBlockDrawer = class
  private
    FGPCanvas: TGPCanvas;
    //FMatrix: TGPMatrix;
    //FAngle: single;
    //FRotCenter: TPointX;
    function GetDestRect: TRectX;
    function GetSourceRect: TRectX;
    procedure SetDestRect(const Value: TRectX);
    procedure SetSourceRect(const Value: TRectX);
    function GetRotCenter: TPointX;
    procedure SetRotCenter(const Value: TPointX);
    function GetAngle: single;
    procedure SetAngle(const Value: single);
  public
    constructor Create;
    destructor Destroy; override;
    procedure SetDeviceContext(AHandle: HDC);
    procedure SetGraphics(AGraphics: TGPGraphics);
    procedure RotatePath(APath: TGPGraphicsPath);
    procedure TranslateRectsPath(APath: TGPGraphicsPath);
    procedure TransformPath(APath: TGPGraphicsPath);
    property RotationCenter: TPointX read GetRotCenter write SetRotCenter;
    property Angle: single read GetAngle write SetAngle;
    property SourceRect: TRectX read GetSourceRect write SetSourceRect;
    property DestRect: TRectX read GetDestRect write SetDestRect;
    property GPCanvas: TGPCanvas read FGPCanvas;
  end;

function PointGP(X, Y: single): TGPPointF;
function RectGP(ARectX: TRectX): TGPRectF;
function ToRectX(ARectGP: TGPRectF): TRectX;

procedure RegisterGdipFileFormats;
procedure UnRegisterGdipFileFormats;
function ColorToARGB(AColor: TColor; Alpha: byte = 255): DWORD;

{$ENDIF}

implementation

{$IFDEF GDIPLUS}

resourcestring
  sPNGImageFile = 'PNG Image File';
  sTIFImageFile = 'TIFF Image File';
  sGIFImageFile = 'GIF Image File';
  sJPGImageFile = 'JPG Image File';

procedure RegisterGdipFileFormats;
begin
  TPicture.RegisterFileFormat('jpg', sJPGImageFile, TDgrGraphic);
  TPicture.RegisterFileFormat('gif', sGIFImageFile, TDgrGraphic);

  TPicture.RegisterFileFormat('png', sPNGImageFile, TDgrGraphic);
  TPicture.RegisterFileFormat('tif', sTIFImageFile, TDgrGraphic);
  TPicture.RegisterFileFormat('tiff', sTIFImageFile, TDgrGraphic);
end;

procedure UnRegisterGdipFileFormats;
begin
  TPicture.UnregisterGraphicClass(TDgrGraphic);
end;

function ColorToARGB(AColor: TColor; Alpha: byte = 255): DWORD;
begin
  AColor := ColorToRgb(AColor);
  result := MakeColor(Alpha, GetRValue(AColor), GetGValue(AColor), GetBValue(AColor));
end;

function PointGP(X, Y: single): TGPPointF;
begin
  result.X := X;
  result.Y := Y;
end;

function RectGP(ARectX: TRectX): TGPRectF;
begin
  result.X := ARectX.Left;
  result.Y := ARectX.Top;
  result.Width := ARectX.Right - ARectX.Left;
  result.Height := ARectX.Bottom - ARectX.Top;
end;

function ToRectX(ARectGP: TGPRectF): TRectX;
begin
  result.Left := ARectGP.X;
  result.Top := ARectGP.Y;
  result.Right := ARectGP.X + ARectGP.Width;
  result.Bottom := ARectGP.Y + ARectGP.Height;
end;

{ TGPCanvas }

constructor TGPCanvas.Create(AHandle: HDC = 0);
begin
  FInternalGraphics := nil;
  FTempGraphics := nil;
  FPen := TDgrPen.Create;
  FBrush := TDgrBrush.Create;
  SetHandle(AHandle);
  FTranslateRects := false;
  FValidRects := false;
  FTransMatrix := TGPMatrix.Create;
end;

procedure TGPCanvas.DestroyGraphics;
begin
  if FInternalGraphics <> nil then
  begin
    FInternalGraphics.Free;
    FInternalGraphics := nil;
  end;
end;

destructor TGPCanvas.Destroy;
begin
  FTransMatrix.Free;
  FPen.Free;
  FBrush.Free;
  DestroyGraphics;
  inherited;