olecontainer.pas

是一个delphi的流程制作软件

procedure TOleUILinkInfo.SetLinkUpdateOptions (LinkId, UpdateOpt: integer; var Result : integer);
begin
  inherited SetLinkUpdateOptions (LinkId, UpdateOpt, Result);
  if Succeeded (Result) then
    FContainer.Changed
end;

procedure TOleUILinkInfo.SetLinkSource (LinkId: integer; DisplayName: string; var NameLen : integer; var Eaten: integer; ValidateSource: boolean; var Result : integer);
begin
  inherited SetLinkSource (LinkId, DisplayName, NameLen, Eaten, ValidateSource, Result);
  if Succeeded (Result) then
    try
      FContainer.UpdateObject
    except
      Application.HandleException (FContainer)
    end
end;


procedure TOleUILinkInfo.UpdateLink (LinkId: integer; ErrorMessage, ErrorAction: boolean; var Result : integer);
begin
  inherited UpdateLink (0, ErrorMessage, ErrorAction, Result);
  with FContainer do
    if (Result = integer(MK_E_UNAVAILABLE)) and Assigned (FOlePromptUserDialog) and Assigned (FOleEditLinksDialog) then
    begin
      FOlePromptUserDialog.UserStyle := usCannotUpdateLink;
      if FOlePromptUserDialog.Execute = urLinks then
      begin
        FOleEditLinksDialog.EditLink := TOleUILinkContainer.Create (FContainer);
        if FOleEditLinksDialog.Execute then
          Result := ddOk
      end
    end
end;

procedure TOleUILinkInfo.CancelLink (LinkId: integer; var Result : integer);
begin
  LinkError ('Cannot break link');
  Result := integer (E_NOTIMPL)
end;

procedure TOleUILinkInfo.GetLastUpdate (LinkId : integer; var LastUpdate: TFileTime; var Result : integer);
begin
  Result := ddOk
end;

//=== OLE UI Object Information ================================================

type
  TOleUIObjInfo = class (TBaseOleObjInfo)
  private
    FContainer : TOle2Container;
    function DisplayName : string;
  protected
    procedure GetObjectInfo (ObjectId: integer; var ObjectSize: integer; var ObjectLabel, ObjectLongType, ObjectShortType, ObjectLocation: string; var Result : integer); override;
    procedure GetConvertInfo (ObjectId: integer; var ClassID: TCLSID; var Format: TClipFormat; var ConvertDefaultClassID: TCLSID; var ClsidExclude: PCLSID; var ClsidExcludeCount: integer; var Result : integer); override;
    procedure ConvertObject (ObjectId: integer; const clsidNew: TCLSID; var Result : integer); override;
    procedure GetViewInfo (ObjectId: integer; var MetaPict: hGlobal; var Aspect, CurrentScale: integer; var Result : integer); override;
    procedure SetViewInfo (ObjectId: integer; MetaPict: hGlobal; Aspect, CurrentScale : integer; RelativeToOrig: boolean; var Result : integer); override;
  public
    constructor Create (Container : TOle2Container);
  end;

constructor TOleUIObjInfo.Create (Container : TOle2Container);
begin
  inherited Create;
  FContainer := Container
end;

function TOleUIObjInfo.DisplayName : string;
var
  OleLink : IOleLink;
  Moniker : IMoniker;
  BindCtx : IBindCtx;
  PWide : PWideChar;
begin
  Moniker := nil;
  if Assigned (FContainer.FOleObject) then
  begin
    FCOntainer.FOleObject.QueryInterface (IOleLink, OleLink);
    OleLink.GetSourceMoniker (Moniker)
  end;

  if Assigned (Moniker) then
  begin
    OleCheck (CreateBindCtx (0, BindCtx));
    OleCheck (Moniker.GetDisplayName (BindCtx, nil, PWide));
    Result := PWide;
    CoTaskMemFree (PWide)
  end else
    Result := ''
end;

procedure TOleUIObjInfo.GetObjectInfo (ObjectId: integer; var ObjectSize: integer; var ObjectLabel, ObjectLongType, ObjectShortType, ObjectLocation : string; var Result : integer);
var
  OleObject : IOleObject;
begin
  Result := ddOk;
  OleObject := FCOntainer.FOleObject;
  ObjectSize := FContainer.GetObjectDataSize;
  ObjectLabel := OleStdFullNameStr (OleObject);
  ObjectLongType := OleStdFullNameStr (OleObject);
  ObjectShortType := OleStdShortNameStr (OleObject);
  if FContainer.Linked then
    ObjectLocation := DisplayName
  else
    ObjectLocation := FContainer.Caption
end;

procedure TOleUIObjInfo.GetConvertInfo (ObjectId: integer; var ClassID: TCLSID; var Format: TClipFormat; var ConvertDefaultClassID: TCLSID; var ClsidExclude: PCLSID; var ClsidExcludeCount: integer; var Result : integer);
var
  UserType,
  LabelStr : string;
  MetaPict : hGlobal;
begin
  Result := ddOk;
  FContainer.ConvertInfo ([ciFormat], ClassID, Format, UserType, LabelStr, MetaPict);
end;

procedure TOleUIObjInfo.ConvertObject (ObjectId: integer; const clsidNew: TCLSID; var Result : integer);
begin
// look at ConvertObjectDialog to see how this works
  Screen.Cursor := crHourglass;
  with FContainer do
  try
    OleCheck (FOleObject.Close (OLECLOSE_SAVEIFDIRTY));
    FOleObject := nil;
    OleStdDoConvert (FStorage, CLSIDNew);
    FStorage.Commit (STGC_DEFAULT);
    OleCheck (OleLoad (FStorage, IOleObject, FContainer, FOleObject));
    InitObject;
    UpdateView;
    Result := ddOk
  finally
    Screen.Cursor := crDefault
  end
end;

procedure TOleUIObjInfo.GetViewInfo (ObjectId: integer; var MetaPict: hGlobal; var Aspect, CurrentScale: integer; var Result : integer);
begin
  MetaPict := FContainer.GetIconMetaPict;
  Aspect := FContainer.FDrawAspect;
  CurrentScale := FContainer.FCurrentScale;
  Result := ddOk
end;

procedure TOleUIObjInfo.SetViewInfo (ObjectId: integer; MetaPict: hGlobal; Aspect, CurrentScale : integer; RelativeToOrig: boolean; var Result : integer);
var
  ShowAsIcon: Boolean;
begin
  FContainer.FScaleRelative := RelativeToOrig;
  FContainer.SetScale (CurrentScale);

  case Aspect of
    dvaContent : ShowAsIcon := false;
    dvaIcon    : ShowAsIcon := true
  else
    ShowAsIcon := FContainer.Iconic
  end;

  if MetaPict = 0 then
    MetaPict := FContainer.GetIconMetaPict;
  FContainer.ClearDrawAspect;
  FContainer.SetDrawAspect(ShowAsIcon, MetaPict);
  FContainer.UpdateView;
  Result := ddOk
end;

//=== Data object ==============================================================

type
  TDataObject = class (TObjectBaseDataObject)
  private
    FContainer : TOle2Container;
    FOleObject : IOleObject;
  protected
    procedure GetData (const FormatEtc : TFormatEtc; var Medium : TStgMedium; var Result : integer); override;
    procedure GetDataHere (const FormatEtc: TFormatEtc; var Medium: TStgMedium; var Result : integer); override;
    procedure QueryGetData (const FormatEtc: TFormatEtc; var Result : integer); override;
    procedure GetCanonicalFormatEtc (const FormatEtcIn: TFormatEtc; var FormatEtcOut: TFormatEtc; var Result : integer); override;
    procedure SetData (const formatetc: TFormatEtc; var Medium: TStgMedium; Release: boolean; var Result : integer); override;
    procedure EnumFormatEtc (Direction: integer; var EnumFormatEtc: IEnumFormatEtc; var Result : integer); override;
    procedure DAdvise (const FormatEtc: TFormatEtc; Advf: integer; const AdvSink: IAdviseSink; var Connection: integer; var Result : integer); override;
    procedure DUnadvise (Connection: integer; var Result : integer); override;
    procedure EnumDAdvise (var EnumAdvise: IEnumStatData; var Result : integer); override;
  public
    constructor Create(const Container : TOle2Container);
  end;

constructor TDataObject.Create(const Container : TOle2Container);
begin
  inherited Create;
  FContainer := Container;
  FOleObject := FContainer.FOleObject
end;

procedure TDataObject.GetData (const FormatEtc : TFormatEtc; var Medium : TStgMedium; var Result : integer);
var
  Descriptor: hGlobal;
begin
  ZeroMemory (@Medium, sizeof (TStgMedium));
  with FormatEtc do
  begin
    if (cfFormat = cfObjectDescriptor) and (dwAspect = dvaContent) and (tymed = tsGlobal) then
    begin
      Descriptor := OleStdGetObjectDescriptor (FOleObject);
      if Descriptor <> 0 then
      begin
        medium.tymed := tsGlobal;
        medium.hGlobal := Descriptor;
        Result := ddOk
      end
    end
  end
end;

procedure TDataObject.GetDataHere (const FormatEtc: TFormatEtc; var Medium: TStgMedium; var Result : integer);
var
  PersistStorage : IPersistStorage;
begin
  with FormatEtc do
    if (cfFormat = cfEmbeddedObject) and (dwAspect = dvaContent) and (tymed = tsStorage) then
    begin
      medium.unkForRelease := nil;
      FOleObject.QueryInterface (IPersistStorage, PersistStorage);
      if Assigned (PersistStorage) then
      begin
        Result := OleSave (PersistStorage, IStorage (Medium.Stg), false);
        PersistStorage.SaveCompleted (nil)
      end
    end
end;

procedure TDataObject.QueryGetData (const FormatEtc: TFormatEtc; var Result : integer);
begin
  with FormatEtc do
    if (dwAspect = dvaContent) and
      (((cfFormat = cfEmbeddedObject) and (tymed = tsStorage)) or
       ((cfFormat = cfObjectDescriptor) and (tymed = tsGlobal))) then
      Result := ddOk
end;

procedure TDataObject.GetCanonicalFormatEtc (const FormatEtcIn: TFormatEtc; var FormatEtcOut: TFormatEtc; var Result : integer);
begin
end;

procedure TDataObject.SetData (const formatetc: TFormatEtc; var Medium: TStgMedium; Release: boolean; var Result : integer);
begin
end;

procedure TDataObject.EnumFormatEtc (Direction: integer; var EnumFormatEtc: IEnumFormatEtc; var Result : integer);
begin
  if Direction = ddGet then
  begin
    EnumFormatEtc := TStdEnumFormatEtc.Create (FDataFormats);
    Result := ddOk
  end
end;

procedure TDataObject.DAdvise (const FormatEtc: TFormatEtc; Advf: integer; const AdvSink: IAdviseSink; var Connection: integer; var Result : integer);
begin
end;

procedure TDataObject.DUnadvise (Connection: integer; var Result : integer);
begin
end;

procedure TDataObject.EnumDAdvise (var EnumAdvise: IEnumStatData; var Result : integer);
begin
end;

//--- TOle2Container.IOleClientSite --------------------------------------------

function TOle2Container.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  out mk: IMoniker): HResult;
begin
  mk := nil;
  Result := E_NOTIMPL
end;

function TOle2Container.GetContainer(out container: IOleContainer): HResult;
begin
  container := nil;
  Result := E_NOINTERFACE
end;

function TOle2Container.ShowObject: HResult;
begin
  Result := S_OK
end;

function TOle2Container.OnShowWindow(fShow: BOOL): HResult;
begin
  if FObjectOpen <> Boolean(fShow) then
  begin
    FObjectOpen := fShow;
    Invalidate
  end;
  Result := S_OK
end;

function TOle2Container.RequestNewObjectLayout: HResult;
begin
  Result := E_NOTIMPL
end;

//--- TOle2Container.IOleInPlaceSite -------------------------------------------

function TOle2Container.GetWindow(out wnd: HWnd): HResult;
begin
  if FDocObj then
    wnd := Handle
  else
    wnd := Parent.Handle;
  Result := S_OK;
end;

function TOle2Container.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
begin
  Result := S_OK;
end;

function TOle2Container.CanInPlaceActivate: HResult;
begin
  Result := S_FALSE;
  if not (csDesigning in ComponentState) and Visible and
    AllowInPlace and not Iconic then
    Result := S_OK;
end;

function TOle2Container.OnInPlaceActivate: HResult;
begin
  FOleObject.QueryInterface(IOleInPlaceObject, FOleInPlaceObject);
  FOleObject.QueryInterface(IOleInPlaceActiveObject, FOleInPlaceActiveObject);
  Result := S_OK;
end;

function TOle2Container.OnUIActivate: HResult;
begin
  SetUIActive(True);
  Result := S_OK;
end;

function TOle2Container.GetWindowContext(out frame: IOleInPlaceFrame;
  out doc: IOleInPlaceUIWindow; out rcPosRect: TRect;
  out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult;
var
  Origin: TPoint;
begin
  frame := FFrameForm;
  doc := nil;
  if FDocObj then
  begin
    rcPosRect := Rect(0,0,Width,Height);
    rcClipRect := rcPosRect;
  end
  else
  begin
    Origin := Parent.ScreenToClient(ClientOrigin);
    SetRect(rcPosRect, Origin.X, Origin.Y,
      Origin.X + ClientWidth, Origin.Y + ClientHeight);
      SetRect(rcClipRect, -16384, -16384, 16383, 16383);
  end;
  CreateAccelTable;
  with frameInfo do
  begin
    fMDIApp := False;
    FFrameForm.GetWindow(hWndFrame);
    hAccel := FAccelTable;
    cAccelEntries := FAccelCount;
  end;
  Result := S_OK;
end;

function TOle2Container.Scroll(scrollExtent: TPoint): HResult;
begin
  Result := E_NOTIMPL;
end;

function TOle2Container.OnUIDeactivate(fUndoable: BOOL): HResult;
begin
  FFrameForm.SetMenu(0, 0, 0);
  FFrameForm.ClearBorderSpace;
  SetUIActive(False);
  Result := S_OK;
end;

function TOle2Container.OnInPlaceDeactivate: HResult;
begin
  FOleInPlaceActiveObject := nil;
  FOleInPlaceObject := nil;
  Result := S_OK;
end;

function TOle2Container.DiscardUndoState: HResult;
begin
  Result := E_NOTIMPL;
end;

function TOle2Container.DeactivateAndUndo: HResult;
begin
  FOleInPlaceObject.UIDeactivate;
  Result := S_OK;
end;

function TOle2Container.OnPosRectChange(const rcPosRect: TRect): HResult;
begin
  try
    ObjectMoved(rcPosRect);
    UpdateObjectRect;
  except
    Application.HandleException(Self);
  end;
  Result := S_OK;
end;

{ TOle2Container.IAdviseSink }

procedure TOle2Container.OnDataChange(const formatetc: TFormatEtc;
  const stgmed: TStgMedium);
begin
  Changed
end;

procedure TOle2Container.OnViewChange(dwAspect: Longint; lindex: Longint);
begin