359 lines
8.6 KiB
ObjectPascal
359 lines
8.6 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastReport VCL }
|
|
{ OLE object }
|
|
{ }
|
|
{ Copyright (c) 1998-2021 }
|
|
{ by Fast Reports Inc. }
|
|
{ }
|
|
{******************************************}
|
|
|
|
unit frxOLE;
|
|
|
|
interface
|
|
|
|
{$I frx.inc}
|
|
|
|
uses
|
|
{$IFNDEF FPC}
|
|
Windows, Messages,
|
|
{$ENDIF}
|
|
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|
{$IFNDEF FPC}
|
|
OleCtnrs,
|
|
{$ENDIF}
|
|
StdCtrls, ExtCtrls, frxClass
|
|
{$IFNDEF FPC}
|
|
, ActiveX
|
|
{$ENDIF}
|
|
{$IFDEF FPC}
|
|
, LCLType, LCLIntf, LazHelper
|
|
{$ENDIF}
|
|
{$IFDEF Delphi6}
|
|
, Variants
|
|
{$ENDIF}
|
|
{$IFDEF FR_COM}
|
|
, FastReport_TLB
|
|
{$ENDIF};
|
|
|
|
|
|
type
|
|
TfrxSizeMode = (fsmClip, fsmScale);
|
|
{$IFDEF DELPHI16}
|
|
/// <summary>
|
|
/// The TfrxOLEObject allows the use of OLE objects in your report.
|
|
/// TfrxOLEObject is an empty component. It is used to add thefrxOLE.pas file
|
|
/// to the "uses" list. The main component is TfrxOLEView.
|
|
/// </summary>
|
|
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
|
|
{$ENDIF}
|
|
TfrxOLEObject = class(TComponent) // fake component
|
|
end;
|
|
|
|
{$IFDEF FR_COM}
|
|
TfrxOLEView = class(TfrxView, IfrxOLEView)
|
|
{$ELSE}
|
|
/// <summary>
|
|
/// The TfrxOLEView component represents an OLE object. Component can show
|
|
/// an OLE object from the DB field (you should set DataSet, DataField
|
|
/// properties).
|
|
/// </summary>
|
|
TfrxOLEView = class(TfrxView)
|
|
{$ENDIF}
|
|
private
|
|
FOleContainer: TOleContainer;
|
|
FSizeMode: TfrxSizeMode;
|
|
FStretched: Boolean;
|
|
procedure ReadData(Stream: TStream);
|
|
procedure SetStretched(const Value: Boolean);
|
|
procedure WriteData(Stream: TStream);
|
|
protected
|
|
procedure DefineProperties(Filer: TFiler); override;
|
|
{$IFDEF FR_COM}
|
|
function Get_OleContainer(out Value: IUnknown): HResult; stdcall;
|
|
function Get_SizeMode(out Value: Integer): HResult; stdcall;
|
|
function Set_SizeMode(Value: Integer): HResult; stdcall;
|
|
function Get_Stretched(out Value: WordBool): HResult; stdcall;
|
|
function Set_Stretched(Value: WordBool): HResult; stdcall;
|
|
{$ENDIF}
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended); override;
|
|
procedure GetData; override;
|
|
class function GetDescription: String; override;
|
|
/// <summary>
|
|
/// Reference to internal TOleContainer object.
|
|
/// </summary>
|
|
property OleContainer: TOleContainer read FOleContainer;
|
|
function IsEMFExportable: Boolean; override;
|
|
published
|
|
property BrushStyle;
|
|
property Color;
|
|
property Cursor;
|
|
property DataField;
|
|
property DataSet;
|
|
property DataSetName;
|
|
property FillType;
|
|
property Fill;
|
|
property Frame;
|
|
property SizeMode: TfrxSizeMode read FSizeMode write FSizeMode default fsmClip;
|
|
/// <summary>
|
|
/// Determines if it is necessary to stretch an OLE object to the area
|
|
/// occupied by the object in a report. It may be useful for showing MS
|
|
/// Excel objects.
|
|
/// </summary>
|
|
property Stretched: Boolean read FStretched write SetStretched default False;
|
|
property TagStr;
|
|
property URL;
|
|
end;
|
|
|
|
/// <summary>
|
|
/// This method copies the contents from ContFrom to ContTo OLE container.
|
|
/// </summary>
|
|
procedure frxAssignOle(ContFrom, ContTo: TOleContainer);
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
frxOLERTTI,
|
|
{$IFNDEF NO_EDITORS}
|
|
frxOLEEditor,
|
|
{$ENDIF}
|
|
frxDsgnIntf, frxRes;
|
|
|
|
|
|
procedure frxAssignOle(ContFrom, ContTo: TOleContainer);
|
|
var
|
|
st: TMemoryStream;
|
|
begin
|
|
{$IFNDEF FPC}
|
|
if (ContFrom = nil) or (ContFrom.OleObjectInterface = nil) then
|
|
begin
|
|
ContTo.DestroyObject;
|
|
Exit;
|
|
end;
|
|
st := TMemoryStream.Create;
|
|
ContFrom.SaveToStream(st);
|
|
st.Position := 0;
|
|
ContTo.LoadFromStream(st);
|
|
st.Free;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function HimetricToPixels(const P: TPoint): TPoint;
|
|
begin
|
|
Result.X := MulDiv(P.X, Screen.PixelsPerInch, 2540);
|
|
Result.Y := MulDiv(P.Y, Screen.PixelsPerInch, 2540);
|
|
end;
|
|
|
|
|
|
{ TfrxOLEView }
|
|
|
|
constructor TfrxOLEView.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
Font.Name := 'Tahoma';
|
|
Font.Size := 8;
|
|
|
|
FOleContainer := TOleContainer.Create(nil);
|
|
with FOleContainer do
|
|
begin
|
|
Parent := frxParentForm;
|
|
{$IFNDEF FPC}
|
|
SendMessage(frxParentForm.Handle, WM_CREATEHANDLE, frxInteger(FOleContainer), 0);
|
|
AllowInPlace := False;
|
|
AutoVerbMenu := False;
|
|
BorderStyle := bsNone;
|
|
SizeMode := smClip;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
destructor TfrxOLEView.Destroy;
|
|
begin
|
|
{$IFNDEF FPC}
|
|
SendMessage(frxParentForm.Handle, WM_DESTROYHANDLE, frxInteger(FOleContainer), 0);
|
|
{$ENDIF}
|
|
FOleContainer.Free;
|
|
inherited;
|
|
end;
|
|
|
|
class function TfrxOLEView.GetDescription: String;
|
|
begin
|
|
Result := frxResources.Get('obOLE');
|
|
end;
|
|
|
|
procedure TfrxOLEView.DefineProperties(Filer: TFiler);
|
|
begin
|
|
inherited;
|
|
{$IFNDEF FPC}
|
|
Filer.DefineBinaryProperty('OLE', ReadData, WriteData,
|
|
OleContainer.OleObjectInterface <> nil);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfrxOLEView.ReadData(Stream: TStream);
|
|
begin
|
|
{$IFNDEF FPC}
|
|
FOleContainer.LoadFromStream(Stream);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfrxOLEView.WriteData(Stream: TStream);
|
|
begin
|
|
{$IFNDEF FPC}
|
|
FOleContainer.SaveToStream(Stream);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfrxOLEView.SetStretched(const Value: Boolean);
|
|
var
|
|
VS: TPoint;
|
|
begin
|
|
FStretched := Value;
|
|
{$IFNDEF FPC}
|
|
if not Stretched then
|
|
with FOleContainer do
|
|
if OleObjectInterface <> nil then
|
|
begin
|
|
Run;
|
|
VS.X := MulDiv(Width, 2540, Screen.PixelsPerInch);
|
|
VS.Y := MulDiv(Height, 2540, Screen.PixelsPerInch);
|
|
{$IFDEF WIN64}
|
|
OleObjectInterface.SetExtent(DVASPECT_CONTENT, @VS);
|
|
{$ELSE}
|
|
OleObjectInterface.SetExtent(DVASPECT_CONTENT, VS);
|
|
{$ENDIF}
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfrxOLEView.Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended);
|
|
{$IFNDEF FPC}
|
|
var
|
|
DRect, R: TRect;
|
|
W, H: Integer;
|
|
ViewObject2: IViewObject2;
|
|
S, ViewSize: TPoint;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFNDEF FPC}
|
|
BeginDraw(Canvas, ScaleX, ScaleY, OffsetX, OffsetY);
|
|
DRect := Rect(FX, FY, FX1, FY1);
|
|
OleContainer.Width := FDX;
|
|
OleContainer.Height := FDY;
|
|
DrawBackground;
|
|
|
|
if (FDX > 0) and (FDY > 0) then
|
|
with OleContainer do
|
|
if OleObjectInterface <> nil then
|
|
if Self.SizeMode = fsmClip then
|
|
OleDraw(OleObjectInterface, DVASPECT_CONTENT, Canvas.Handle, DRect)
|
|
else
|
|
begin
|
|
if Succeeded(OleObjectInterface.QueryInterface(IViewObject2,
|
|
ViewObject2)) then
|
|
begin
|
|
ViewObject2.GetExtent(DVASPECT_CONTENT, -1, nil, ViewSize);
|
|
W := DRect.Right - DRect.Left;
|
|
H := DRect.Bottom - DRect.Top;
|
|
S := HimetricToPixels(ViewSize);
|
|
if W * S.Y > H * S.X then
|
|
begin
|
|
S.X := S.X * H div S.Y;
|
|
S.Y := H;
|
|
end
|
|
else
|
|
begin
|
|
S.Y := S.Y * W div S.X;
|
|
S.X := W;
|
|
end;
|
|
|
|
R.Left := DRect.Left + (W - S.X) div 2;
|
|
R.Top := DRect.Top + (H - S.Y) div 2;
|
|
R.Right := R.Left + S.X;
|
|
R.Bottom := R.Top + S.Y;
|
|
OleDraw(OleObjectInterface, DVASPECT_CONTENT, Canvas.Handle, R);
|
|
end
|
|
end
|
|
else
|
|
frxResources.ObjectImages.Draw(Canvas, FX + 1, FY + 2, 22);
|
|
|
|
DrawFrame;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfrxOLEView.GetData;
|
|
var
|
|
s: TMemoryStream;
|
|
begin
|
|
inherited;
|
|
{$IFNDEF FPC}
|
|
if IsDataField then
|
|
begin
|
|
s := TMemoryStream.Create;
|
|
try
|
|
DataSet.AssignBlobTo(DataField, s);
|
|
FOleContainer.LoadFromStream(s);
|
|
finally
|
|
s.Free;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TfrxOLEView.IsEMFExportable: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
{$IFDEF FR_COM}
|
|
function TfrxOLEView.Get_OleContainer(out Value: IUnknown): HResult; stdcall;
|
|
begin
|
|
Value := OleContainer;
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TfrxOLEView.Get_SizeMode(out Value: Integer): HResult; stdcall;
|
|
begin
|
|
Value := Integer(SizeMode);
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TfrxOLEView.Set_SizeMode(Value: Integer): HResult; stdcall;
|
|
begin
|
|
SizeMode := TfrxSizeMode(Value);
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TfrxOLEView.Get_Stretched(out Value: WordBool): HResult; stdcall;
|
|
begin
|
|
Value := Stretched;
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TfrxOLEView.Set_Stretched(Value: WordBool): HResult; stdcall;
|
|
begin
|
|
Stretched := Value;
|
|
Result := S_OK;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
|
|
initialization
|
|
{$IFDEF DELPHI16}
|
|
StartClassGroup(TControl);
|
|
ActivateClassGroup(TControl);
|
|
GroupDescendentsWith(TfrxOLEObject, TControl);
|
|
{$ENDIF}
|
|
frxObjects.RegisterObject1(TfrxOLEView, nil, '', '', 0, 22);
|
|
|
|
finalization
|
|
frxObjects.UnRegister(TfrxOLEView);
|
|
|
|
end.
|
|
|