rm_ole.pas

这是一个功能强大

{*****************************************}
{                                         }
{         Report Machine v2.0             }
{            OLE Add-In Object            }
{                                         }
{*****************************************}

unit RM_Ole;

interface

{$I RM.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Menus, OleCtnrs, DB, RM_DataSet, RM_Class, ActiveX, RM_Ctrls
{$IFDEF USE_INTERNAL_JVCL}, rm_JvInterpreter{$ELSE}, JvInterpreter{$ENDIF}
{$IFDEF COMPILER6_UP}, Variants{$ENDIF};

type
  TRMOLEObject = class(TComponent) // fake component
  end;

 { TRMOleView }
  TRMOLEView = class(TRMReportView)
  private
    FOleContainer: TOleContainer;
    FPrintType: TRMPrintMethodType;

    function GetSizeMode: TSizeMode;
    procedure SetSizeMode(Value: TSizeMode);
    function GetDirectDraw: Boolean;
    procedure SetDirectDraw(Value: Boolean);
  protected
    procedure GetBlob; override;
    function GetViewCommon: string; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(aCanvas: TCanvas); override;
    procedure LoadFromStream(aStream: TStream); override;
    procedure SaveToStream(aStream: TStream); override;
    procedure DefinePopupMenu(Popup: TRMCustomMenuItem); override;
    procedure ShowEditor; override;

    procedure LoadFromOle(aOle: TOleContainer);
  published
    property OleContainer: TOleContainer read FOleContainer;
    property SizeMode: TSizeMode read GetSizeMode write SetSizeMode;
    property PrintType: TRMPrintMethodType read FPrintType write FPrintType;
    property LeftFrame;
    property RightFrame;
    property TopFrame;
    property BottomFrame;
    property FillColor;
    property ReprintOnOverFlow;
    property ShiftWith;
    property BandAlign;
    property DirectDraw: Boolean read GetDirectDraw write SetDirectDraw;
    property DataField;
    property PrintFrame;
    property Printable;
  end;

  { TRMOleFomr }
  TRMOleForm = class(TForm)
    Panel2: TPanel;
    PopupMenu1: TPopupMenu;
    ItmInsertObject: TMenuItem;
    ItmObjectProp: TMenuItem;
    OleContainer1: TOleContainer;
    Panel1: TPanel;
    btnInsert: TButton;
    btnEdit: TButton;
    btnOk: TButton;
    procedure btnInsertClick(Sender: TObject);
    procedure btnEditClick(Sender: TObject);
    procedure PopupMenu1Popup(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure PopupVerbMenuClick(Sender: TObject);
    procedure OnCopyObject(Sender: TObject);
    procedure OnDeleteObject(Sender: TObject);
    procedure OnPasteObject(Sender: TObject);
    procedure OnEditObjectProp(Sender: TObject);
    procedure Localize;
  public
    { Public declarations }
  end;

implementation

uses RM_Common, RM_Utils, RM_Const, RM_Const1;

{$R *.DFM}

const
  flOleDirectDraw = $2;

procedure AssignOle(aDest, aSource: TOleContainer);
var
  liStream: TMemoryStream;
begin
  if aSource.OleObjectInterface = nil then
  begin
    aDest.DestroyObject;
    Exit;
  end;

  liStream := TMemoryStream.Create;
  try
    aSource.SaveToStream(liStream);
    liStream.Position := 0;
    aDest.LoadFromStream(liStream);
  finally
    liStream.Free;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMOLEView}

constructor TRMOLEView.Create;
begin
  inherited Create;
  BaseName := 'Ole';

  FOleContainer := TOleContainer.Create(nil);
  with FOleContainer do
  begin
    Parent := RMDialogForm;
    Visible := False;
    AllowInPlace := False;
    AutoVerbMenu := False;
    BorderStyle := bsNone;
  end;
  SizeMode := smClip;
  FPrintType := rmptMetafile;
end;

destructor TRMOLEView.Destroy;
begin
  if RMDialogForm <> nil then
  begin
    FOleContainer.Free;
    FOleContainer := nil;
  end;
  inherited Destroy;
end;

procedure TRMOLEView.Draw(aCanvas: TCanvas);
var
  liBitmap: TBitmap;
  w, h: Integer;

  procedure _PaintControl(aRect: TRect);
  var
    lMetafile: TMetafile;
    lMetaFileCanvas: TMetaFileCanvas;
    lBitmap: TBitmap;
    liRect: TRect;
  begin
    if (aRect.Right < aRect.Left) or (aRect.Bottom < aRect.Top) then Exit;
    
    liRect := Rect(0, 0, aRect.Right - aRect.Left, aRect.Bottom - aRect.Top);
    case FPrintType of
      rmptMetafile:
        begin
          lMetafile := TMetaFile.Create;
          lMetaFile.Enhanced := True;
          lMetaFile.Width := aRect.Right - aRect.Left + 1;
          lMetaFile.Height := aRect.Bottom - aRect.Top + 1;
          lMetaFileCanvas := TMetaFileCanvas.Create(lMetaFile, 0);
          try
            OleDraw(FOleContainer.OleObjectInterface, DVASPECT_CONTENT, lMetaFileCanvas.Handle, liRect);
            lMetaFileCanvas.Free;
            RMPrintGraphic(aCanvas, aRect, lMetaFile, IsPrinting, DirectDraw, True);
          finally
            lMetafile.Free;
          end;
        end;
      rmptBitmap:
        begin
          lBitmap := TBitmap.Create;
          try
            lBitmap.Width := aRect.Right - aRect.Left + 1;
            lBitmap.Height := aRect.Bottom - aRect.Top + 1;
            OleDraw(FOleContainer.OleObjectInterface, DVASPECT_CONTENT, lBitmap.Canvas.Handle, liRect);
            RMPrintGraphic(aCanvas, aRect, lBitmap, IsPrinting, DirectDraw, True);
          finally
            lBitmap.Free;
          end;
        end;
    end;
  end;

  function _HimetricToPixels(const P: TPoint): TPoint;
  begin
    Result.X := MulDiv(P.X, RMPixPerInchX, 2540);
    Result.Y := MulDiv(P.Y, RMPixPerInchY, 2540);
  end;

  procedure _DrawOLE;
  var
    liPoint: TPoint;
    liRect: TRect;
    liViewSize: TPoint;
    lidx, lidy: Integer;
  begin
    lidx := FOleContainer.Width;
    lidy := FOleContainer.Height;
    with FOleContainer do
    begin
      if SizeMode <> smStretch then
      begin
        OleObjectInterface.GetExtent(DVASPECT_CONTENT, liViewSize);
        liPoint := _HimetricToPixels(liViewSize);
        if SizeMode = smScale then
        begin
          if lidx * liPoint.Y > lidy * liPoint.X then
          begin
            liPoint.X := liPoint.X * lidy div liPoint.Y;
            liPoint.Y := lidy;
          end
          else
          begin
            liPoint.Y := liPoint.Y * lidx div liPoint.X;
            liPoint.X := lidx;
          end;
        end;

        if SizeMode = smCenter then //居中
        begin
          liRect := RealRect;
          w := RealRect.Right - RealRect.Left;
          h := RealRect.Bottom - RealRect.Top;
          OffsetRect(liRect, (w - Round(FactorX * liPoint.X)) div 2, (h - Round(FactorY * liPoint.Y)) div 2);
          liRect.Right := liRect.Left + Round(liPoint.X * FactorX);
          liRect.Bottom := liRect.Top + Round(liPoint.Y * FactorY);
        end
        else if SizeMode = smScale then //缩放
        begin
          liRect.Left := RealRect.Left + (lidx - liPoint.X) div 2;
          liRect.Top := RealRect.Top + (lidy - liPoint.Y) div 2;
          liRect.Right := liRect.Left + liPoint.X;
          liRect.Bottom := liRect.Top + liPoint.Y;
        end
        else if SizeMode = smClip then //原始大小
        begin
          SetRect(liRect, RealRect.Left, RealRect.Top, RealRect.Left + Round(liPoint.X * FactorX),
            RealRect.Top + Round(liPoint.Y * FactorY));
        end;
      end
      else
        SetRect(liRect, RealRect.Left, RealRect.Top, RealRect.Right, RealRect.Bottom);

        _PaintControl(liRect);
    end;
  end;

  procedure _DrawDefaultText;
  begin
    with aCanvas do
    begin
      if RMIsChineseGB then
      begin
        Font.Name := '宋体'; //'Arial';
        Font.Size := 9; //8;
      end
      else
      begin
        Font.Name := 'Arial';
        Font.Size := 8;
      end;
      Font.Style := [];
      Font.Color := clBlack;
      TextRect(RealRect, RealRect.Left + 20, RealRect.Top + 3, '[OLE]');
      liBitmap := TBitmap.Create;
      liBitmap.Handle := LoadBitmap(hInstance, 'RM_EMPTY');
      Draw(RealRect.Left + 1, RealRect.Top + 2, liBitmap);
      liBitmap.Free;
    end;
  end;

begin
  BeginDraw(aCanvas);
  CalcGaps;
  IntersectClipRect(aCanvas.Handle, RealRect.Left, RealRect.Top, RealRect.Right, RealRect.Bottom);
  try
    if (RealRect.Right > RealRect.Left) and (RealRect.Bottom > RealRect.Top) then
    begin
      ShowBackground;

      if FOleContainer.OleObjectInterface <> nil then
      begin
        FOleContainer.Width := RealRect.Right - RealRect.Left;
        FOleContainer.Height := RealRect.Bottom - RealRect.Top;
        _DrawOLE;
      end
      else if DocMode = rmdmDesigning then
        _DrawDefaultText;