olectnrs.pas

这是不可多得的源代码

            OLERENDER_DRAW, nil, Self, FStorage, FOleObject));
        ctFromData:
          OleCheck(OleCreateFromData(DataObject, IOleObject,
            OLERENDER_DRAW, nil, Self, FStorage, FOleObject));
        ctLinkFromData:
          OleCheck(OleCreateLinkFromData(DataObject, IOleObject,
            OLERENDER_DRAW, nil, Self, FStorage, FOleObject));
      end;
      FDrawAspect := DVASPECT_CONTENT;
      InitObject;
      FOleObject.SetExtent(DVASPECT_CONTENT, PixelsToHimetric(
        Point(ClientWidth, ClientHeight)));
      SetDrawAspect(ShowAsIcon, IconMetaPict);
      UpdateView;
    end;
  except
    DestroyObject;
    raise;
  end;
end;

procedure TOleContainer.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 TOleContainer.CreateStorage;
begin
  OleCheck(CreateILockBytesOnHGlobal(0, True, FLockBytes));
  OleCheck(StgCreateDocfileOnILockBytes(FLockBytes, STGM_READWRITE
    or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, FStorage));
end;

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

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

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

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

procedure TOleContainer.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 TOleContainer.DestroyVerbs;
begin
  FPopupVerbMenu.Free;
  FPopupVerbMenu := nil;
  FObjectVerbs.Free;
  FObjectVerbs := nil;
end;

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

procedure TOleContainer.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.CreateRes(@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 TOleContainer.GetBorderWidth: Integer;
begin
  if FBorderStyle = bsNone then
    Result := 0
  else
    if NewStyleControls and Ctl3D then
      Result := 2
    else
      Result := 1;
end;

function TOleContainer.GetCanPaste: Boolean;
var
  DataObject: IDataObject;
begin
  Result := Succeeded(OleGetClipboard(DataObject)) and
    ((OleQueryCreateFromData(DataObject) = 0) or
     (OleQueryLinkFromData(DataObject) = 0));
end;

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

function TOleContainer.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 DataObject <> nil 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 TOleContainer.GetLinked: Boolean;
var
  OleLink: IOleLink;
begin
  CheckObject;
  FOleObject.QueryInterface(IOleLink, OleLink);
  Result := (OleLink <> nil);
end;

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

function TOleContainer.GetObjectVerbs: TStrings;
begin
  if FObjectVerbs = nil then UpdateVerbs;
  Result := FObjectVerbs;
end;

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

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

function TOleContainer.GetPopupMenu: TPopupMenu;
var
  I: Integer;
  Item: TMenuItem;
begin
  if FAutoVerbMenu and (FOleObject <> nil) and (ObjectVerbs.Count > 0) then
  begin
    if FPopupVerbMenu = nil 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 TOleContainer.GetPrimaryVerb: Integer;
begin
  if FObjectVerbs = nil then UpdateVerbs;
  for Result := 0 to FObjectVerbs.Count - 1 do
    if Integer(FObjectVerbs.Objects[Result]) and $0000FFFF = 0 then Exit;
  Result := 0;
end;

function TOleContainer.GetSourceDoc: string;
var
  OleLink: IOleLink;
begin
  CheckObject;
  Result := '';
  FOleObject.QueryInterface(IOleLink, OleLink);
  if OleLink <> nil then
    Result := GetDisplayNameStr(OleLink);
end;

function TOleContainer.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 TOleContainer.InitObject;

  function FindForm(Component: TComponent): TCustomForm;
  begin
    while Component <> nil do
      if Component is TCustomForm then
      begin
        Result := TCustomForm(Component);
        Exit;
      end
      else
        Component := Component.Owner;
    Result := nil;
  end;

var
  DataObject: IDataObject;
  FormatEtc: TFormatEtc;
  DocForm: TCustomForm;
begin
  DocForm := GetParentForm(Self);
  if DocForm = nil then
    DocForm := FindForm(Self);
  if DocForm = nil then ValidParentForm(Self);
  FDocForm := GetVCLFrameForm(DocForm);
  FFrameForm := FDocForm;
  FDocForm.AddContainer(Self);
  if IsFormMDIChild(FDocForm.Form) then
  begin
    FFrameForm := GetVCLFrameForm(Application.MainForm);
    FFrameForm.AddContainer(Self);
  end;
  SetViewAdviseSink(True);
  FOleObject.SetHostNames(PWideChar(WideString(Application.Title)),
    PWideChar(WideString(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 TOleContainer.InsertObjectDialog: Boolean;
var
  Data: TOleUIInsertObject;
  NameBuffer: array[0..255] of Char;
  CreateInfo: TCreateInfo;
begin
  Result := False;
  FNewInserted := False;
  FillChar(Data, SizeOf(Data), 0);
  FillChar(NameBuffer, SizeOf(NameBuffer), 0);
  Data.cbStruct := SizeOf(Data);
  Data.dwFlags := IOF_SELECTCREATENEW;
  Data.hWndOwner := Application.Handle;
  Data.lpfnHook := OleDialogHook;
  Data.lpszFile := NameBuffer;
  Data.cchFile := SizeOf(NameBuffer);
  try
    if OleUIInsertObject(Data) = OLEUI_OK then
    begin
      if Data.dwFlags and IOF_SELECTCREATENEW <> 0 then
      begin
        CreateInfo.CreateType := ctNewObject;
        CreateInfo.ClassID := Data.clsid;
      end else
      begin
        if Data.dwFlags and IOF_CHECKLINK = 0 then
          CreateInfo.CreateType := ctFromFile else
          CreateInfo.CreateType := ctLinkToFile;
        CreateInfo.FileName := NameBuffer;
      end;
      CreateInfo.ShowAsIcon := Data.dwFlags and IOF_CHECKDISPLAYASICON <> 0;
      CreateInfo.IconMetaPict := Data.hMetaPict;
      CreateObjectFromInfo(CreateInfo);
      if CreateInfo.CreateType = ctNewObject then FNewInserted := True;
      Result := True;
    end;
  finally
    DestroyMetaPict(Data.hMetaPict);
  end;
end;

procedure TOleContainer.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 TOleContainer.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TOleContainer.LoadFromStream(Stream: TStream);
var
  DataHandle: HGlobal;
  Buffer: Pointer;
  Header: TStreamHeader;
begin
  DestroyObject;
  Stream.ReadBuffer(Header, SizeOf(Header));
  if (Header.Signature <> StreamSignature) and not FOldStreamFormat then
    raise EOleError.CreateRes(@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, STGM_READWRITE or
      STGM_SHARE_EXCLUSIVE, nil, 0, FStorage));
    OleCheck(OleLoad(FStorage, IOleObject, Self, FOleObject));
    FDrawAspect := Header.DrawAspect;
    InitObject;
    UpdateView;
  except
    if DataHandle <> 0 then GlobalFree(DataHandle);
    DestroyObject;
    raise;
  end;
end;

procedure TOleContainer.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then SetFocus;