olecontainer.pas

是一个delphi的流程制作软件

procedure TOle2Container.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style or WS_CLIPCHILDREN;
    WindowClass.Style := WindowClass.Style and not (CS_HREDRAW or CS_VREDRAW);
  end;
end;

procedure TOle2Container.CreateStorage;
begin
  OleCheck (CreateILockBytesOnHGlobal (0, True, FLockBytes));
  OleCheck (StgCreateDocfileOnILockBytes (FLockBytes, fmOpenReadWrite or fmShareExclusive or fmCreate, 0, FStorage))
end;

procedure TOle2Container.DblClick;
begin
  if FAutoActivate = aaDoubleClick then
    DoVerb(ovPrimary)
  else
    inherited;
end;

procedure TOle2Container.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('Data', LoadFromStream, SaveToStream,
    FOleObject <> nil);
end;

procedure TOle2Container.DesignModified;
var
  Form: TCustomForm;
begin
  Form := GetParentForm(Self);
  if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
end;

procedure TOle2Container.DestroyAccelTable;
begin
  if FAccelTable <> 0 then
  begin
    DestroyAcceleratorTable(FAccelTable);
    FAccelTable := 0;
    FAccelCount := 0;
  end;
end;

procedure TOle2Container.DestroyObject;
var
  DataObject: IDataObject;
begin
  if FOleObject <> nil then
  begin
    SetViewAdviseSink(False);
    if FDataConnection <> 0 then
    begin
      FOleObject.QueryInterface(IDataObject, DataObject);
      if DataObject <> nil then
      begin
        DataObject.DUnadvise(FDataConnection);
        DataObject := nil;
      end;
      FDataConnection := 0;
    end;
    FOleObject.Close(OLECLOSE_NOSAVE);
    Invalidate;
    Changed;
  end;
  FDocView := nil;
  FOleObject := nil;
  FStorage := nil;
  FLockBytes := nil;
  DestroyVerbs;
  DestroyAccelTable;
  if FDocForm <> nil then
  begin
    if FFrameForm <> FDocForm then FFrameForm.RemoveContainer(Self);
    FDocForm.RemoveContainer(Self);
    FFrameForm := nil;
    FDocForm := nil;
  end;
end;

procedure TOle2Container.DestroyVerbs;
begin
  FPopupVerbMenu.Free;
  FPopupVerbMenu := nil;
  FObjectVerbs.Free;
  FObjectVerbs := nil;
end;

procedure TOle2Container.DoEnter;
begin
  if FAutoActivate = aaGetFocus then DoVerb(ovShow);
  inherited;
end;

procedure TOle2Container.DoVerb(Verb: Integer);
var
  H: THandle;
  R: TRect;
begin
  CheckObject;
  if Verb > 0 then
  begin
    if FObjectVerbs = nil then UpdateVerbs;
    if Verb >= FObjectVerbs.Count then
      raise EOleError.Create(SInvalidVerb);
    Verb := Smallint(Integer(FObjectVerbs.Objects[Verb]) and $0000FFFF);
  end else
    if Verb = ovPrimary then Verb := 0;
  if FDocObj then
  begin
    R := ClientRect;
    H := Handle;
  end
  else
  begin
    R := BoundsRect;
    H := Parent.Handle;
  end;
  OleCheck(FOleObject.DoVerb(Verb, nil, Self, 0, H, R));
end;

function TOle2Container.EditLinksDialog : boolean;
begin
  if Linked and Assigned (FOleEditLinksDialog) then
  begin
    FOleEditLinksDialog.EditLink := TOleUILinkContainer.Create (Self);
    Result := FOleEditLinksDialog.Execute
  end else
    Result := false
end;

function TOle2Container.GetBorderWidth: Integer;
begin
  if FBorderStyle = bsNone then
    Result := 0
  else
    if NewStyleControls and Ctl3D then
      Result := 2
    else
      Result := 1
end;

function TOle2Container.GetCanConvert : boolean;
var
  Format : TClipFormat;
  CLSID : TCLSID;
  UserType,
  LabelStr : string;
  MetaPict : hGlobal;
begin
  ConvertInfo ([ciFormat], CLSID, Format, UserType, LabelStr, MetaPict);
  Result := OleUICanConvertOrActivateAs (CLSID, Linked, Format)
end;

function CanPasteThis (DataObject : IDataObject) : boolean;
begin
  Result := (OleQueryCreateFromData(DataObject) = ddOk) or (OleQueryLinkFromData(DataObject) = ddOk)
end;

function TOle2Container.GetCanPaste: boolean;
var
  DataObject: IDataObject;
begin
  Result := Succeeded(OleGetClipboard(DataObject)) and CanPasteThis (DataObject)
end;

function TOle2Container.GetEmpty : boolean;
begin
  Result := not Assigned (FOleObject)  // State = osEmpty
end;

function TOle2Container.GetIconic: Boolean;
begin
  Result := FDrawAspect = DVASPECT_ICON
end;

function TOle2Container.GetIconMetaPict: HGlobal;
var
  DataObject: IDataObject;
  FormatEtc: TFormatEtc;
  Medium: TStgMedium;
  ClassID: TCLSID;
begin
  CheckObject;
  Result := 0;
  if FDrawAspect = DVASPECT_ICON then
  begin
    FOleObject.QueryInterface(IDataObject, DataObject);
    if Assigned (DataObject) then
    begin
      FormatEtc.cfFormat := CF_METAFILEPICT;
      FormatEtc.ptd := nil;
      FormatEtc.dwAspect := DVASPECT_ICON;
      FormatEtc.lIndex := -1;
      FormatEtc.tymed := TYMED_MFPICT;
      if Succeeded(DataObject.GetData(FormatEtc, Medium)) then
        Result := Medium.hMetaFilePict
    end
  end;
  if Result = 0 then
  begin
    OleCheck (FOleObject.GetUserClassID (ClassID));
    Result := OleGetIconOfClass (ClassID, nil, True)
  end
end;

function TOle2Container.GetLinked: Boolean;
var
  OleLink: IOleLink;
begin
  CheckObject;
  FOleObject.QueryInterface(IOleLink, OleLink);
  Result := Assigned (OleLink)
end;

function TOle2Container.GetObjectDataSize: Integer;
var
  DataHandle: HGlobal;
begin
  if Succeeded (GetHGlobalFromILockBytes (FLockBytes, DataHandle)) then
    Result := GlobalSize(DataHandle)
  else
    Result := 0
end;

function TOle2Container.GetObjectVerbs: TStrings;
begin
  if not Assigned (FObjectVerbs) then
    UpdateVerbs;
  Result := FObjectVerbs
end;

function TOle2Container.GetOleClassName: string;
var
  ClassID: TCLSID;
begin
  CheckObject;
  OleCheck(FOleObject.GetUserClassID(ClassID));
  Result := ClassIDToProgID(ClassID)
end;

function TOle2Container.GetOleObject: Variant;
begin
  CheckObject;
  Result := Variant(FOleObject as IDispatch)
end;

function TOle2Container.GetPopupMenu: TPopupMenu;
var
  I: Integer;
  Item: TMenuItem;
begin
  if FAutoVerbMenu and Assigned (FOleObject) and (ObjectVerbs.Count > 0) then
  begin
    if not Assigned (FPopupVerbMenu) then
    begin
      FPopupVerbMenu := TPopupMenu.Create(Self);
      for I := 0 to ObjectVerbs.Count - 1 do
      begin
        Item := TMenuItem.Create(Self);
        Item.Caption := ObjectVerbs[I];
        Item.Tag := I;
        Item.OnClick := PopupVerbMenuClick;
        FPopupVerbMenu.Items.Add(Item)
      end
    end;
    Result := FPopupVerbMenu
  end else
    Result := inherited GetPopupMenu;
end;

function TOle2Container.GetPrimaryVerb: Integer;
begin
  if not Assigned (FObjectVerbs) then
    UpdateVerbs;
  for Result := 0 to FObjectVerbs.Count - 1 do
    if Integer(FObjectVerbs.Objects[Result]) and $0000FFFF = 0 then
      exit;
  Result := 0
end;

function TOle2Container.GetSourceDoc: string;
var
  OleLink: IOleLink;
begin
  CheckObject;
  Result := '';
  FOleObject.QueryInterface (IOleLink, OleLink);
  if Assigned (OleLink) then
    Result := OleStdDisplayNameStr (OleLink)
end;

function TOle2Container.GetState: TObjectState;
begin
  if FOleObject = nil then
    Result := osEmpty
  else
    if FObjectOpen then
      Result := osOpen
    else
      if FUIActive then
        Result := osUIActive
      else
        if OleIsRunning (FOleObject) then
          Result := osRunning
        else
          Result := osLoaded
end;

procedure TOle2Container.InitObject;
var
  DataObject: IDataObject;
  FormatEtc: TFormatEtc;
begin
  FDocForm := GetVCLFrameForm(ValidParentForm(Self));
  FFrameForm := FDocForm;
  FDocForm.AddContainer(Self);
  if IsFormMDIChild(FDocForm.Form) then
  begin
    FFrameForm := GetVCLFrameForm(Application.MainForm);
    FFrameForm.AddContainer(Self)
  end;
  SetViewAdviseSink(True);
  OleStdHostNames (FOleObject, Application.Title, Caption);
  OleSetContainedObject(FOleObject, True);
  FOleObject.QueryInterface(IDataObject, DataObject);
  if DataObject <> nil then
  begin
    FormatEtc.cfFormat := 0;
    FormatEtc.ptd := nil;
    FormatEtc.dwAspect := -1;
    FormatEtc.lIndex := -1;
    FormatEtc.tymed := -1;
    DataObject.DAdvise (FormatEtc, ADVF_NODATA, Self, FDataConnection)
  end
end;

function TOle2Container.InsertObjectDialog: Boolean;
var
  CreateInfo: TCreateInfo;
begin
  Result := false;
  if Assigned (FOleInsertObjectDialog) then
    with FOleInsertObjectDialog do
      if Execute then
      begin
        if SelectCreateNew then
        begin
          CreateInfo.CreateType := ctNewObject;
          CreateInfo.ClassID := CLSID
        end else begin
          if CheckLink then
            CreateInfo.CreateType := ctLinkToFile
          else
            CreateInfo.CreateType := ctFromFile;
        CreateInfo.FileName := Filename
      end;
      CreateInfo.ShowAsIcon := CheckDisplayAsIcon;
      CreateInfo.IconMetaPict := Metafile.MetaPict;
      CreateObjectFromInfo (CreateInfo);
      if CreateInfo.CreateType = ctNewObject then
        FNewInserted := true;
      Result := true
    end
end;

procedure TOle2Container.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown (Key, Shift);

  if (FAutoActivate <> aaManual) and (Key = VK_RETURN) then
  begin
    if ssCtrl in Shift then
      DoVerb (ovShow)
    else
      DoVerb (ovPrimary);
    Key := 0
  end
end;

procedure TOle2Container.LoadFromFile (const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(Stream)
  finally
    Stream.Free
  end
end;

procedure TOle2Container.LoadFromStream (Stream: TStream);
var
  DataHandle: HGlobal;
  Buffer: Pointer;
  Header: TStreamHeader;
begin
  DestroyObject;
  Stream.ReadBuffer(Header, SizeOf(Header));
  if Header.Signature <> StreamSignature then
    raise EOleError.Create(SInvalidStreamFormat);

  DataHandle := GlobalAlloc (GMEM_MOVEABLE, Header.DataSize);
  if DataHandle = 0 then
    OutOfMemoryError;
  try
    Buffer := GlobalLock (DataHandle);
    try
      Stream.Read (Buffer^, Header.DataSize)
    finally
      GlobalUnlock (DataHandle)
    end;
    OleCheck (CreateILockBytesOnHGlobal (DataHandle, true, FLockBytes));
    DataHandle := 0;
    OleCheck (StgOpenStorageOnILockBytes (FLockBytes, nil, fmOpenReadWrite or fmShareExclusive, nil, 0, FStorage));
    OleCheck (OleLoad (FStorage, IOleObject, Self, FOleObject));
    FDrawAspect := Header.DrawAspect;
    InitObject;
    FOrgSize := Header.OrgSize;