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_DBRel, RM_Class,
{$IFDEF Delphi2}
  Ole2
{$ELSE}
  ActiveX
{$ENDIF}
{$IFDEF Delphi6}, Variants{$ENDIF};

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

 { TRMOleView }
  TRMOLEView = class(TRMView)
  private
  protected
    function GetViewCommon: string; override;
    procedure GetBlob(b: TField); override;
    procedure OLEEditor(Sender: TObject);
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
  public
    OleContainer: TOleContainer;
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(aCanvas: TCanvas); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;
  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_CmpReg, RM_Intrp, RM_Utils, RM_Const, RM_Const1;

{$R *.DFM}

procedure AssignOle(Cont1, Cont2: TOleContainer);
var
  st: TMemoryStream;
begin
  if Cont2.OleObjectInterface = nil then
  begin
    Cont1.DestroyObject;
    Exit;
  end;
  st := TMemoryStream.Create;
  Cont2.SaveToStream(st);
  st.Position := 0;
  Cont1.LoadFromStream(st);
  st.Free;
end;

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

constructor TRMOLEView.Create;
begin
  inherited Create;
  OleContainer := TOleContainer.Create(nil);
  with OleContainer do
  begin
    Parent := RMDialogForm;
    Visible := False;
    AllowInPlace := False;
    AutoVerbMenu := False;
    BorderStyle := bsNone;
    SizeMode := smClip;
  end;
  Flags := 1;
  BaseName := 'Ole';

  RMConsts['smCenter'] := smCenter;
  RMConsts['smClip'] := smClip;
  RMConsts['smScale'] := smScale;
  RMConsts['smStretch'] := smStretch;
end;

destructor TRMOLEView.Destroy;
begin
  if RMDialogForm <> nil then
    OleContainer.Free;
  inherited Destroy;
end;

procedure TRMOLEView.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('OLE', [RMdtHasEditor, RMdtOneObject], OLEEditor);
  AddProperty('DataField', [RMdtOneObject, RMdtHasEditor, RMdtString], RMFieldEditor);
  AddEnumProperty('SizeMode',
    'smCenter;smClip;smScale;smStretch',
    [smCenter, smClip, smScale, smStretch], nil);

  AddProperty('OnBeforePrint', [RMdtHasEditor, RMdtOneObject], RMScript_BeforePrintEditor);
  AddProperty('OnAfterPrint', [RMdtHasEditor, RMdtOneObject], RMScript_AfterPrintEditor);
end;

procedure TRMOLEView.SetPropValue(Index: string; Value: Variant);
begin
  inherited SetPropValue(Index, Value);
  Index := AnsiUpperCase(Index);
  if Index = 'SIZEMODE' then
    OleContainer.SizeMode := Value;
end;

function TRMOLEView.GetPropValue(Index: string): Variant;
begin
  Index := AnsiUpperCase(Index);
  Result := inherited GetPropValue(Index);
  if Result <> Null then Exit;
  if Index = 'SIZEMODE' then
    Result := OleContainer.SizeMode;
end;

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

  function HimetricToPixels(const P: TPoint): TPoint;
  begin
    Result.X := MulDiv(P.X, RMPixPerInch.X, 2540);
    Result.Y := MulDiv(P.Y, RMPixPerInch.Y, 2540);
  end;

  procedure DrawOLE;
  var
    S: TPoint;
    R: TRect;
    liViewSize: TPoint;
    lidx, lidy: Integer;
  begin
    lidx := OleContainer.Width;
    lidy := OleContainer.Height;
    with OleContainer do
    begin
      if SizeMode <> smStretch then
      begin
        OleObjectInterface.GetExtent(DVASPECT_CONTENT, liViewSize);
        S := HimetricToPixels(liViewSize);
        if SizeMode = smScale then
        begin
          if lidx * S.Y > lidy * S.X then
          begin
            S.X := S.X * lidy div S.Y;
            S.Y := lidy;
          end
          else
          begin
            S.Y := S.Y * lidx div S.X;
            S.X := lidx;
          end;
        end;

        if SizeMode = smCenter then //居中
        begin
          R := DRect;
          w := DRect.Right - DRect.Left;
          h := DRect.Bottom - DRect.Top;
          OffsetRect(r, (w - Round(ScaleX * S.X)) div 2, (h - Round(ScaleY * S.Y)) div 2);
          R.Right := R.Left + Round(S.X * ScaleX);
          R.Bottom := R.Top + Round(S.Y * ScaleY);
        end
        else if SizeMode = smScale then //缩放
        begin
          R.Left := DRect.Left + (lidx - S.X) div 2;
          R.Top := DRect.Top + (lidy - S.Y) div 2;
          R.Right := R.Left + S.X;
          R.Bottom := R.Top + S.Y;
        end
        else if SizeMode = smClip then //原始大小
        begin
          SetRect(R, DRect.Left, DRect.Top, DRect.Left + Round(S.X * Scalex), DRect.Top + Round(S.Y * Scaley));
        end;
      end
      else
        SetRect(R, DRect.Left, DRect.Top, DRect.Right, DRect.Bottom);

      try
        IntersectClipRect(aCanvas.Handle, DRect.Left, DRect.Top, DRect.Right, DRect.Bottom);
        OleDraw(OleContainer.OleObjectInterface, DVASPECT_CONTENT, aCanvas.Handle, R);
      finally
        Windows.SelectClipRgn(aCanvas.Handle, 0);
      end;
    end;
  end;

begin
  BeginDraw(aCanvas);
  CalcGaps;
  if (DRect.Right - DRect.Left > 0) and (DRect.Bottom - DRect.Top > 0) then
  begin
    OleContainer.Width := DRect.Right - DRect.Left; //dx;
    OleContainer.Height := DRect.Bottom - DRect.Top; //dy;
    with aCanvas do
    begin
      ShowBackground;
//      ShowFrame;
      with OleContainer do
      begin
        if OleObjectInterface <> nil then
          DrawOLE
        else if DocMode = dmDesigning then
        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(DRect, DRect.Left + 20, DRect.Top + 3, '[OLE]');
          Bmp := TBitmap.Create;
          Bmp.Handle := LoadBitmap(hInstance, 'RM_EMPTY');
          Draw(DRect.Left + 1, DRect.Top + 2, Bmp);
          Bmp.Free;
        end;
      end;
      ShowFrame;
    end;
  end;
  RestoreCoord;
end;

procedure TRMOLEView.LoadFromStream(Stream: TStream);
var
  b: Byte;
begin
  inherited LoadFromStream(Stream);
  Stream.Read(b, 1);
  if b <> 0 then
    OleContainer.LoadFromStream(Stream);
  if RMVersion * 100 + HVersion * 10 + LVersion > 32 * 100 + 2 * 10 + 0 then
    OleContainer.SizeMode := TSizeMode(RMReadByte(Stream))
  else
    OleContainer.SizeMode := smStretch;
end;

procedure TRMOLEView.SaveToStream(Stream: TStream);
var
  b: Byte;
begin
  LVersion := 0;
  inherited SaveToStream(Stream);
  b := 0;
  if OleContainer.OleObjectInterface <> nil then
  begin
    b := 1;
    Stream.Write(b, 1);
    OleContainer.SaveToStream(Stream);
  end
  else
    Stream.Write(b, 1);
  RMWriteByte(Stream, Byte(OleContainer.SizeMode));
end;

procedure TRMOLEView.GetBlob(b: TField);
var
  s: TMemoryStream;
begin
  if Flag_TableEmpty or b.IsNull then
  begin
    OleContainer.DestroyObject;
    Exit;
  end;
  s := TMemoryStream.Create;
  try
    RMAssignBlobTo(b, s);
    OleContainer.LoadFromStream(s);
  finally
    s.Free;
  end;
end;

procedure TRMOLEView.DefinePopupMenu(Popup: TPopupMenu);
begin
end;

procedure TRMOLEView.ShowEditor;
var
  tmpForm: TRMOleForm;
begin
  tmpForm := TRMOleForm.Create(Application);
  try
    AssignOle(tmpForm.OleContainer1, OleContainer);
    if tmpForm.ShowModal = mrOK then
    begin
      RMDesigner.BeforeChange;
      AssignOle(OleContainer, tmpForm.OleContainer1);
      tmpForm.OleContainer1.DestroyObject;
      RMDesigner.AfterChange;
    end;
  finally
    tmpForm.Free;
  end;
end;

procedure TRMOLEView.OLEEditor(Sender: TObject);
begin
  ShowEditor;
end;

function TRMOleView.GetViewCommon: string;
begin
  Result := '[Ole]';
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMOLEForm}

procedure TRMOleForm.Localize;
begin
  Font.Name := RMLoadStr(SRMDefaultFontName);
  Font.Size := StrToInt(RMLoadStr(SRMDefaultFontSize));
  Font.Charset := StrToInt(RMLoadStr(SCharset));

  RMSetStrProp(Self, 'Caption', rmRes + 550);
  RMSetStrProp(btnInsert, 'Caption', rmRes + 551);
  RMSetStrProp(btnEdit, 'Caption', rmRes + 552);
  RMSetStrProp(ItmInsertObject, 'Caption', rmRes + 554);
  RMSetStrProp(ItmObjectProp, 'Caption', rmRes + 558);

  btnOk.Caption := RMLoadStr(rmRes + 553);
end;

procedure TRMOleForm.btnInsertClick(Sender: TObject);
begin
  with OleContainer1 do
  begin
    Screen.Cursor := crHourGlass;
    try
      if InsertObjectDialog then
        DoVerb(PrimaryVerb);
    finally
      Screen.Cursor := crDefault;
    end;
  end;
end;

procedure TRMOleForm.btnEditClick(Sender: TObject);
begin
  if OleContainer1.OleObjectInterface <> nil then
    OleContainer1.DoVerb(ovPrimary);
end;

type
  THackOleContainer = class(TOleContainer)
  end;

procedure TRMOleForm.PopupVerbMenuClick(Sender: TObject);
begin
  OleContainer1.DoVerb((Sender as TMenuItem).Tag);
end;

procedure TRMOleForm.OnCopyObject(Sender: TObject);
begin
  OleContainer1.Copy;
end;

procedure TRMOleForm.OnDeleteObject(Sender: TObject);
begin
  OleContainer1.DestroyObject;
end;

procedure TRMOleForm.OnPasteObject(Sender: TObject);
begin
  OleContainer1.PasteSpecialDialog;
end;

procedure TRMOleForm.OnEditObjectProp(Sender: TObject);
begin
  OleContainer1.ObjectPropertiesDialog;
end;

procedure TRMOleForm.PopupMenu1Popup(Sender: TObject);
var
  I: Integer;
  Item: TMenuItem;
begin
  while PopupMenu1.Items.Count > 0 do
    PopupMenu1.Items.Delete(0);
  with OleContainer1 do
  begin
    if (OleObjectInterface <> nil) and (ObjectVerbs.Count > 0) then
    begin
      for I := 0 to ObjectVerbs.Count - 1 do
      begin
        Item := TMenuItem.Create(Self);
        Item.Caption := ObjectVerbs[I];
        Item.Tag := I;
        Item.OnClick := PopupVerbMenuClick;
        PopupMenu1.Items.Add(Item);
      end;
      Item := TMenuItem.Create(Self);
      Item.Caption := '-';
      PopupMenu1.Items.Add(Item);
    end;

    Item := TMenuItem.Create(Self);
    RMSetStrProp(Item, 'Caption', rmRes + 554);
    Item.OnClick := btnInsertClick;
    PopupMenu1.Items.Add(Item);

    if CanPaste then
    begin
      Item := TMenuItem.Create(Self);
      RMSetStrProp(Item, 'Caption', rmRes + 555);
      Item.OnClick := onPasteObject;
      PopupMenu1.Items.Add(Item);
    end;
    if OleObjectInterface <> nil then
    begin
      Item := TMenuItem.Create(Self);
      RMSetStrProp(Item, 'Caption', rmRes + 556);
      Item.OnClick := OnCopyObject;
      PopupMenu1.Items.Add(Item);

      Item := TMenuItem.Create(Self);
      RMSetStrProp(Item, 'Caption', rmRes + 557);
      Item.OnClick := OnDeleteObject;
      PopupMenu1.Items.Add(Item);

      Item := TMenuItem.Create(Self);
      RMSetStrProp(Item, 'Caption', rmRes + 558);
      Item.OnClick := OnEditObjectProp;
      PopupMenu1.Items.Add(Item);
    end;
  end;
end;

procedure TRMOleForm.FormCreate(Sender: TObject);
begin
  Localize;
end;

initialization
  RMRegisterObjectByRes(TRMOLEView, 'RM_OLEObject', RMLoadStr(SInsOLEObject), TRMOleForm);

finalization

end.