olectnrs.pas

这是不可多得的源代码

end;

function TDataObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
  fRelease: BOOL): HResult;
begin
  Result := E_NOTIMPL;
end;

function TDataObject.EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:
  IEnumFormatEtc): HResult;
begin
  if dwDirection = DATADIR_GET then
  begin
    enumFormatEtc := TEnumFormatEtc.Create(@DataFormats, DataFormatCount, 0);
    Result := S_OK;
  end else
  begin
    enumFormatEtc := nil;
    Result := E_NOTIMPL;
  end;
end;

function TDataObject.DAdvise(const formatetc: TFormatEtc; advf: Longint;
  const advSink: IAdviseSink; out dwConnection: Longint): HResult;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TDataObject.DUnadvise(dwConnection: Longint): HResult;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

function TDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
begin
  Result := OLE_E_ADVISENOTSUPPORTED;
end;

{ TOleContainer.IOleUIObjInfo - helper interface for Object Properties dialog }

function TOleContainer.GetObjectInfo(dwObject: Longint;
  var dwObjSize: Longint; var lpszLabel: PChar;
  var lpszType: PChar; var lpszShortType: PChar;
  var lpszLocation: PChar): HResult;
begin
  if @dwObjSize <> nil then
    dwObjSize := GetObjectDataSize;
  if @lpszLabel <> nil then
    lpszLabel := CoAllocCStr(GetFullNameStr(FOleObject));
  if @lpszType <> nil then
    lpszType := CoAllocCStr(GetFullNameStr(FOleObject));
  if @lpszShortType <> nil then
    lpszShortType := CoAllocCStr(GetShortNameStr(FOleObject));
  if @lpszLocation <> nil then
    lpszLocation := CoAllocCStr(Caption);
  Result := S_OK;
end;

function TOleContainer.GetConvertInfo(dwObject: Longint; var ClassID: TCLSID;
  var wFormat: Word; var ConvertDefaultClassID: TCLSID;
  var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HResult;
begin
  FOleObject.GetUserClassID(ClassID);
  Result := S_OK;
end;

function TOleContainer.ConvertObject(dwObject: Longint;
  const clsidNew: TCLSID): HResult;
begin
  Result := E_NOTIMPL;
end;

function TOleContainer.GetViewInfo(dwObject: Longint; var hMetaPict: HGlobal;
  var dvAspect: Longint; var nCurrentScale: Integer): HResult;
begin
  if @hMetaPict <> nil then hMetaPict := GetIconMetaPict;
  if @dvAspect <> nil then dvAspect := FDrawAspect;
  if @nCurrentScale <> nil then nCurrentScale := 0;
  Result := S_OK;
end;

function TOleContainer.SetViewInfo(dwObject: Longint; hMetaPict: HGlobal;
  dvAspect: Longint; nCurrentScale: Integer;
  bRelativeToOrig: BOOL): HResult;
var
  ShowAsIcon: Boolean;
begin
  case dvAspect of
    DVASPECT_CONTENT: ShowAsIcon := False;
    DVASPECT_ICON: ShowAsIcon := True;
  else
    ShowAsIcon := Iconic;
  end;
  SetDrawAspect(ShowAsIcon, hMetaPict);
  Result := S_OK;
end;

{ TOleContainer.IOleClientSite }

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

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

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

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

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

{ TOleContainer.IOleInPlaceSite }

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

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

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

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

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

function TOleContainer.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 TOleContainer.Scroll(scrollExtent: TPoint): HResult;
begin
  Result := E_NOTIMPL;
end;

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

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

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

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

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

{ TOleContainer.IAdviseSink }

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

procedure TOleContainer.OnViewChange(dwAspect: Longint; lindex: Longint);
begin
  if dwAspect = FDrawAspect then UpdateView;
end;

procedure TOleContainer.OnRename(const mk: IMoniker);
begin
end;

procedure TOleContainer.OnSave;
begin
end;

procedure TOleContainer.OnClose;
begin
end;

{ TOleContainer.IOleDocumentSite }

function TOleContainer.ActivateMe(View: IOleDocumentView): HRESULT;
var
  Doc: IOleDocument;
begin
  Result := E_FAIL;
  if View = nil then
  begin   // If we're given a nil view, try to get one from the document object.
    if FOleObject.QueryInterface(IOleDocument, Doc) <> 0 then Exit;
    if Doc = nil then Exit;
    Result := Doc.CreateView(Self, nil, 0, View);
    if Result <> 0 then Exit;
  end
  else
    View.SetInPlaceSite(Self);

  FDocObj := True;
  FDocView := View;
  View.UIActivate(TRUE);    //Set up toolbars and menus first
  UpdateObjectRect;         //Then set window size, after toolbars
  View.Show(TRUE);
  Result := NOERROR;
end;

{ TOleContainer }

constructor TOleContainer.Create(AOwner: TComponent);
const
  ContainerStyle = [csClickEvents, csSetCaption, csOpaque, csDoubleClicks];
begin
  inherited Create(AOwner);
  FRefCount := 1;
  if NewStyleControls then
    ControlStyle := ContainerStyle else
    ControlStyle := ContainerStyle + [csFramed];
  Width := 121;
  Height := 121;
  TabStop := True;
  ParentColor := False;
  FAllowInPlace := True;
  FAllowActiveDoc := True;
  FAutoActivate := aaDoubleClick;
  FAutoVerbMenu := True;
  FBorderStyle := bsSingle;
  FCopyOnSave := True;
  FDrawAspect := DVASPECT_CONTENT;
end;

destructor TOleContainer.Destroy;
begin
  DestroyObject;
  inherited Destroy;
end;

function TOleContainer._AddRef: Integer;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

procedure TOleContainer.AdjustBounds;
var
  Size: TPoint;
  Extra: Integer;
begin
  if not (csReading in ComponentState) and (FSizeMode = smAutoSize) and
    (FOleObject <> nil) then
  begin
    Size := HimetricToPixels(FViewSize);
    Extra := GetBorderWidth * 2;
    SetBounds(Left, Top, Size.X + Extra, Size.Y + Extra);
  end;
end;

function TOleContainer.ChangeIconDialog: Boolean;
var
  Data: TOleUIChangeIcon;
begin
  CheckObject;
  Result := False;
  FillChar(Data, SizeOf(Data), 0);
  Data.cbStruct := SizeOf(Data);
  Data.dwFlags := CIF_SELECTCURRENT;
  Data.hWndOwner := Application.Handle;
  Data.lpfnHook := OleDialogHook;
  OleCheck(FOleObject.GetUserClassID(Data.clsid));
  Data.hMetaPict := GetIconMetaPict;
  try
    if OleUIChangeIcon(Data) = OLEUI_OK then
    begin
      SetDrawAspect(True, Data.hMetaPict);
      Result := True;
    end;
  finally
    DestroyMetaPict(Data.hMetaPict);
  end;
end;

procedure TOleContainer.CheckObject;
begin
  if FOleObject = nil then
    raise EOleError.CreateRes(@SEmptyContainer);
end;

procedure TOleContainer.Close;
begin
  CheckObject;
  OleCheck(FOleObject.Close(OLECLOSE_SAVEIFDIRTY));
end;

procedure TOleContainer.Copy;
begin
  Close;
  OleCheck(OleSetClipboard(TDataObject.Create(FOleObject) as IDataObject));
end;

procedure TOleContainer.CreateAccelTable;
var
  Menu: TMainMenu;
begin
  if FAccelTable = 0 then
  begin
    Menu := FFrameForm.Form.Menu;
    if Menu <> nil then
      Menu.GetOle2AcceleratorTable(FAccelTable, FAccelCount, [0, 2, 4]);
  end;
end;

procedure TOleContainer.CreateLinkToFile(const FileName: string;
  Iconic: Boolean);
var
  CreateInfo: TCreateInfo;
begin
  CreateInfo.CreateType := ctLinkToFile;
  CreateInfo.ShowAsIcon := Iconic;
  CreateInfo.IconMetaPict := 0;
  CreateInfo.FileName := FileName;
  CreateObjectFromInfo(CreateInfo);
end;

procedure TOleContainer.CreateObject(const OleClassName: string;
  Iconic: Boolean);
var
  CreateInfo: TCreateInfo;
begin
  CreateInfo.CreateType := ctNewObject;
  CreateInfo.ShowAsIcon := Iconic;
  CreateInfo.IconMetaPict := 0;
  CreateInfo.ClassID := ProgIDToClassID(OleClassName);
  CreateObjectFromInfo(CreateInfo);
end;

procedure TOleContainer.CreateObjectFromFile(const FileName: string;
  Iconic: Boolean);
var
  CreateInfo: TCreateInfo;
begin
  CreateInfo.CreateType := ctFromFile;
  CreateInfo.ShowAsIcon := Iconic;
  CreateInfo.IconMetaPict := 0;
  CreateInfo.FileName := FileName;
  CreateObjectFromInfo(CreateInfo);
end;

procedure TOleContainer.CreateObjectFromInfo(const CreateInfo: TCreateInfo);
begin
  DestroyObject;
  try
    CreateStorage;
    with CreateInfo do
    begin
      case CreateType of
        ctNewObject:
          OleCheck(OleCreate(ClassID, IOleObject, OLERENDER_DRAW, nil,
            Self, FStorage, FOleObject));
        ctFromFile:
          OleCheck(OleCreateFromFile(GUID_NULL, PWideChar(FileName), IOleObject,
            OLERENDER_DRAW, nil, Self, FStorage, FOleObject));
        ctLinkToFile:
          OleCheck(OleCreateLinkToFile(PWideChar(FileName), IOleObject,