olectnrs.pas

这是不可多得的源代码

  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TOleContainer.Changed;
begin
  if not (csReading in ComponentState) then
  begin
    FModified := True;
    FModSinceSave := True;
    DesignModified;
  end;
end;

procedure TOleContainer.ObjectMoved(const ObjectRect: TRect);
var
  R: TRect;
  I: Integer;
begin
  if Assigned(FOnObjectMove) then
  begin
    R := ObjectRect;
    I := GetBorderWidth;
    InflateRect(R, I, I);
    FOnObjectMove(Self, R);
  end;
end;

function TOleContainer.ObjectPropertiesDialog: Boolean;
var
  ObjectProps: TOleUIObjectProps;
  PropSheet: TPropSheetHeader;
  GeneralProps: TOleUIGnrlProps;
  ViewProps: TOleUIViewProps;
  LinkProps: TOleUILinkProps;
  DialogCaption: string;
begin
  CheckObject;
  Result := False;
  FillChar(ObjectProps, SizeOf(ObjectProps), 0);
  FillChar(PropSheet, SizeOf(PropSheet), 0);
  FillChar(GeneralProps, SizeOf(GeneralProps), 0);
  FillChar(ViewProps, SizeOf(ViewProps), 0);
  FillChar(LinkProps, SizeOf(LinkProps), 0);
  ObjectProps.cbStruct := SizeOf(ObjectProps);
  ObjectProps.dwFlags := OPF_DISABLECONVERT;
  ObjectProps.lpPS := @PropSheet;
  ObjectProps.lpObjInfo := Self;
  if Linked then
  begin
    ObjectProps.dwFlags := ObjectProps.dwFlags or OPF_OBJECTISLINK;
    ObjectProps.lpLinkInfo := TOleUILinkInfo.Create(Self);  // acquire olelink
  end;
  ObjectProps.lpGP := @GeneralProps;
  ObjectProps.lpVP := @ViewProps;
  ObjectProps.lpLP := @LinkProps;
  PropSheet.dwSize := SizeOf(PropSheet);
  PropSheet.hWndParent := Application.Handle;
  PropSheet.hInstance := MainInstance;
  DialogCaption := Format(SPropDlgCaption, [GetFullNameStr(FOleObject)]);
  PropSheet.pszCaption := PChar(DialogCaption);
  GeneralProps.cbStruct := SizeOf(GeneralProps);
  GeneralProps.lpfnHook := OleDialogHook;
  ViewProps.cbStruct := SizeOf(ViewProps);
  ViewProps.dwFlags := VPF_DISABLESCALE;
  LinkProps.cbStruct := SizeOf(LinkProps);
  LinkProps.dwFlags := ELF_DISABLECANCELLINK;
  if OleUIObjectProperties(ObjectProps) = OLEUI_OK then Result := True;
end;

procedure TOleContainer.Paint;
var
  W, H: Integer;
  S: TPoint;
  R, CR: TRect;
  Flags: Integer;
begin
  if FDocObj and FUIActive then Exit;
  CR := Rect(0,0,Width,Height);
  if FBorderStyle = bsSingle then
  begin
    if NewStyleControls and Ctl3D then
      Flags := BF_ADJUST or BF_RECT
    else
      Flags := BF_ADJUST or BF_RECT or BF_MONO;
  end
  else
    Flags := BF_FLAT;

  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := Color;
  DrawEdge(Canvas.Handle, CR, EDGE_SUNKEN, Flags or BF_MIDDLE);
  if FOleObject <> nil then
  begin
    W := CR.Right - CR.Left;
    H := CR.Bottom - CR.Top;
    S := HimetricToPixels(FViewSize);
    if (FDrawAspect = DVASPECT_CONTENT) and (FSizeMode = smScale) then
      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;
    if (FDrawAspect = DVASPECT_ICON) or (FSizeMode = smCenter) or
      (FSizeMode = smScale) then
    begin
      R.Left := (W - S.X) div 2;
      R.Top := (H - S.Y) div 2;
      R.Right := R.Left + S.X;
      R.Bottom := R.Top + S.Y;
    end
    else if FSizeMode = smClip then
    begin
      SetRect(R, CR.Left, CR.Top, S.X, S.Y);
      IntersectClipRect(Canvas.Handle, CR.Left, CR.Top, CR.Right, CR.Bottom);
    end
    else
      SetRect(R, CR.Left, CR.Top, W, H);

    OleDraw(FOleObject, FDrawAspect, Canvas.Handle, R);

    if FObjectOpen then ShadeRect(Canvas.Handle, CR);
  end;
  if FFocused then Canvas.DrawFocusRect(CR);
end;

procedure TOleContainer.Paste;
var
  DataObject: IDataObject;
  Descriptor: PObjectDescriptor;
  FormatEtc: TFormatEtc;
  Medium: TStgMedium;
  CreateInfo: TCreateInfo;
begin
  if not CanPaste then Exit;
  OleCheck(OleGetClipboard(DataObject));
  try
    CreateInfo.CreateType := ctFromData;
    CreateInfo.ShowAsIcon := False;
    CreateInfo.IconMetaPict := 0;
    CreateInfo.DataObject := DataObject;
    FormatEtc.cfFormat := CFObjectDescriptor;
    FormatEtc.ptd := nil;
    FormatEtc.dwAspect := DVASPECT_CONTENT;
    FormatEtc.lIndex := -1;
    FormatEtc.tymed := TYMED_HGLOBAL;
    if Succeeded(DataObject.GetData(FormatEtc, Medium)) then
    begin
      Descriptor := GlobalLock(Medium.hGlobal);
      if Descriptor^.dwDrawAspect = DVASPECT_ICON then
        CreateInfo.ShowAsIcon := True;
      GlobalUnlock(Medium.hGlobal);
      ReleaseStgMedium(Medium);
    end;
    if CreateInfo.ShowAsIcon 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
        CreateInfo.IconMetaPict := Medium.hMetaFilePict;
    end;
    CreateObjectFromInfo(CreateInfo);
  finally
    DestroyMetaPict(CreateInfo.IconMetaPict);
  end;
end;

function TOleContainer.PasteSpecialDialog: Boolean;
const
  PasteFormatCount = 2;
var
  Data: TOleUIPasteSpecial;
  PasteFormats: array[0..PasteFormatCount - 1] of TOleUIPasteEntry;
  CreateInfo: TCreateInfo;
begin
  Result := False;
  if not CanPaste then Exit;
  FillChar(Data, SizeOf(Data), 0);
  FillChar(PasteFormats, SizeOf(PasteFormats), 0);
  Data.cbStruct := SizeOf(Data);
  Data.hWndOwner := Application.Handle;
  Data.lpfnHook := OleDialogHook;
  Data.arrPasteEntries := @PasteFormats;
  Data.cPasteEntries := PasteFormatCount;
  Data.arrLinkTypes := @CFLinkSource;
  Data.cLinkTypes := 1;
  PasteFormats[0].fmtetc.cfFormat := CFEmbeddedObject;
  PasteFormats[0].fmtetc.dwAspect := DVASPECT_CONTENT;
  PasteFormats[0].fmtetc.lIndex := -1;
  PasteFormats[0].fmtetc.tymed := TYMED_ISTORAGE;
  PasteFormats[0].lpstrFormatName := '%s';
  PasteFormats[0].lpstrResultText := '%s';
  PasteFormats[0].dwFlags := OLEUIPASTE_PASTE or OLEUIPASTE_ENABLEICON;
  PasteFormats[1].fmtetc.cfFormat := CFLinkSource;
  PasteFormats[1].fmtetc.dwAspect := DVASPECT_CONTENT;
  PasteFormats[1].fmtetc.lIndex := -1;
  PasteFormats[1].fmtetc.tymed := TYMED_ISTREAM;
  PasteFormats[1].lpstrFormatName := '%s';
  PasteFormats[1].lpstrResultText := '%s';
  PasteFormats[1].dwFlags := OLEUIPASTE_LINKTYPE1 or OLEUIPASTE_ENABLEICON;
  try
    if OleUIPasteSpecial(Data) = OLEUI_OK then
    begin
      if Data.fLink then
        CreateInfo.CreateType := ctLinkFromData else
        CreateInfo.CreateType := ctFromData;
      CreateInfo.ShowAsIcon := Data.dwFlags and PSF_CHECKDISPLAYASICON <> 0;
      CreateInfo.IconMetaPict := Data.hMetaPict;
      CreateInfo.DataObject := Data.lpSrcDataObj;
      CreateObjectFromInfo(CreateInfo);
      Result := True;
    end;
  finally
    DestroyMetaPict(Data.hMetaPict);
  end;
end;

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

function TOleContainer.QueryInterface(const iid: TIID; out obj): HResult;
begin
  Pointer(obj) := nil;
  Result := E_NOINTERFACE;
  if IsEqualIID(iid, IOleDocumentSite) and
    (not FAllowActiveDoc or (csDesigning in ComponentState)) then Exit;
  if GetInterface(iid, obj) then Result := S_OK;
end;

function TOleContainer._Release: Integer;
begin
  Dec(FRefCount);
  Result := FRefCount;
end;

procedure TOleContainer.Run;
begin
  CheckObject;
  OleCheck(OleRun(FOleObject));
end;

function TOleContainer.SaveObject: HResult;
var
  PersistStorage: IPersistStorage;
begin
  Result := S_OK;
  if FOleObject = nil then Exit;
  PersistStorage := FOleObject as IPersistStorage;
  OleCheck(OleSave(PersistStorage, FStorage, True));
  PersistStorage.SaveCompleted(nil);
  PersistStorage := nil;
  OleCheck(FStorage.Commit(STGC_DEFAULT));
  FModSinceSave := False;
end;

procedure TOleContainer.SaveAsDocument(const FileName: string);
var
  TempStorage: IStorage;
  PersistStorage: IPersistStorage;
begin
  CheckObject;
  if FModSinceSave then SaveObject;
  FOleObject.QueryInterface(IPersistStorage, PersistStorage);
  if PersistStorage <> nil then
  begin
    OleCheck(StgCreateDocFile(PWideChar(WideString(Filename)), STGM_READWRITE
      or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, TempStorage));
    OleCheck(OleSave(PersistStorage, TempStorage, False));
    PersistStorage.SaveCompleted(nil);
  end;
end;

procedure TOleContainer.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TOleContainer.SaveToStream(Stream: TStream);
var
  TempLockBytes: ILockBytes;
  TempStorage: IStorage;
  DataHandle: HGlobal;
  Buffer: Pointer;
  Header: TStreamHeader;
  R: TRect;
begin
  CheckObject;
  if FModSinceSave then SaveObject;
  if FCopyOnSave then
  begin
    OleCheck(CreateILockBytesOnHGlobal(0, True, TempLockBytes));
    OleCheck(StgCreateDocfileOnILockBytes(TempLockBytes, STGM_READWRITE
      or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, TempStorage));
    OleCheck(FStorage.CopyTo(0, nil, nil, TempStorage));
    OleCheck(TempStorage.Commit(STGC_DEFAULT));
    OleCheck(GetHGlobalFromILockBytes(TempLockBytes, DataHandle));
  end else
    OleCheck(GetHGlobalFromILockBytes(FLockBytes, DataHandle));
  if FOldStreamFormat then
  begin
    R := BoundsRect;
    Header.PartRect.Left := R.Left;
    Header.PartRect.Top := R.Top;
    Header.PartRect.Right := R.Right;
    Header.PartRect.Bottom := R.Bottom;
  end else
  begin
    Header.Signature := StreamSignature;
    Header.DrawAspect := FDrawAspect;
  end;
  Header.DataSize := GlobalSize(DataHandle);
  Stream.WriteBuffer(Header, SizeOf(Header));
  Buffer := GlobalLock(DataHandle);
  try
    Stream.WriteBuffer(Buffer^, Header.DataSize);
  finally
    GlobalUnlock(DataHandle);
  end;
end;

procedure TOleContainer.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    AdjustBounds;
    Invalidate;
  end;
end;

procedure TOleContainer.SetDrawAspect(Iconic: Boolean;
  IconMetaPict: HGlobal);
var
  OleCache: IOleCache;
  EnumStatData: IEnumStatData;
  OldAspect, AdviseFlags, Connection: Longint;
  TempMetaPict: HGlobal;
  FormatEtc: TFormatEtc;
  Medium: TStgMedium;
  ClassID: TCLSID;
  StatData: TStatData;
begin
  OldAspect := FDrawAspect;
  if Iconic then
  begin
    FDrawAspect := DVASPECT_ICON;
    AdviseFlags := ADVF_NODATA;
  end else
  begin
    FDrawAspect := DVASPECT_CONTENT;
    AdviseFlags := ADVF_PRIMEFIRST;
  end;
  if (FDrawAspect <> OldAspect) or (FDrawAspect = DVASPECT_ICON) then
  begin
    OleCache := FOleObject as IOleCache;
    if FDrawAspect <> OldAspect then
    begin
      OleCheck(OleCache.EnumCache(EnumStatData));
      if EnumStatData <> nil then
        while EnumStatData.Next(1, StatData, nil) = 0 do
          if StatData.formatetc.dwAspect = OldAspect then
            OleCache.Uncache(StatData.dwConnection);
      FillChar(FormatEtc, SizeOf(FormatEtc), 0);
      FormatEtc.dwAspect := FDrawAspect;
      FormatEtc.lIndex := -1;
      OleCheck(OleCache.Cache(FormatEtc, AdviseFlags, Connection));
      SetViewAdviseSink(True);
    end;
    if FDrawAspect = DVASPECT_ICON then
    begin
      TempMetaPict := 0;
      if IconMetaPict = 0 then
      begin
        OleCheck(FOleObject.GetUserClassID(ClassID));
        TempMetaPict := OleGetIconOfClass(ClassID, nil, True);
        IconMetaPict := TempMetaPict;
      end;
      try
        FormatEtc.cfFormat := CF_METAFILEPICT;
        FormatEtc.ptd := nil;
        FormatEtc.dwAspect := DVASPECT_ICON;
        FormatEtc.lIndex := -1;
        FormatEtc.tymed := TYMED_MFPICT;
        Medium.tymed := TYMED_MFPICT;
        Medium.hMetaFilePict := IconMetaPict;
        Medium.unkForRelease := nil;
        OleCheck(OleCache.SetData(FormatEtc, Medium, False));
      finally
        DestroyMetaPict(TempMetaPict);
      end;
    end;
    if FDrawAspect = DVASPECT_CONTENT then UpdateObject;
    UpdateView;
  end;
end;

procedure TOleContainer.SetFocused(Value: Boolean);
var
  R: TRect;
begin
  if FFocused <> Value then
  begin
    FFocused := Value;
    if GetUpdateRect(Handle, PRect(nil)^, False) then
      Invalidate
    else
    begin
      R := ClientRect;
      InflateRect(R, -GetBorderWidth, -GetBorderWidth);
      Canvas.DrawFocusRect(R);
    end;
  end;
end;

procedure TOleContainer.SetIconic(Value: Boolean);
begin
  if GetIconic <> Value then
  begin
    CheckObject;
    SetDrawAspect(Value, 0);
  end;
end;

procedure TOleContainer.SetSizeMode(Value: TSizeMode);
begin
  if FSizeMode <> Value then
  begin
    FSizeMode := Value;
    AdjustBounds;