olectrls.pas

这是不可多得的源代码

    on E: Exception do
      if not SuppressException(E) then
        raise;
  end;
end;

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

procedure TOleControl.DestroyControl;
begin
  InterfaceDisconnect(FOleObject, FControlData^.EventIID, FEventsConnection);
  InterfaceDisconnect(FOleObject, IPropertyNotifySink, FPropConnection);
  FPropBrowsing := nil;
  FControlDispatch := nil;
  FOleControl := nil;
end;

procedure TOleControl.DestroyEnumPropDescs;
var
  I: Integer;
begin
  with FControlData^ do
    if EnumPropDescs <> nil then
    begin
      for I := 0 to EnumPropDescs.Count - 1 do
        TEnumPropDesc(EnumPropDescs[I]).Free;
      EnumPropDescs.Free;
      EnumPropDescs := nil;
    end;
end;

procedure TOleControl.DestroyStorage;
begin
  if FObjectData <> 0 then
  begin
    GlobalFree(FObjectData);
    FObjectData := 0;
  end;
end;

procedure TOleControl.DestroyWindowHandle;
begin
  if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  begin
    SetWindowLong(WindowHandle, GWL_WNDPROC, Longint(DefWndProc));
    if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE);
    WindowHandle := 0;
  end else
    inherited DestroyWindowHandle;
end;

procedure TOleControl.DoObjectVerb(Verb: Integer);
var
  ActiveWindow: HWnd;
  WindowList: Pointer;
begin
  CreateControl;
  ActiveWindow := GetActiveWindow;
  WindowList := DisableTaskWindows(0);
  try
    OleCheck(FOleObject.DoVerb(Verb, nil, Self, 0,
      GetParentHandle, BoundsRect));
  finally
    EnableTaskWindows(WindowList);
    SetActiveWindow(ActiveWindow);
    Windows.SetFocus(ActiveWindow);
  end;
  if FPersistStream.IsDirty <> S_FALSE then DesignModified;
end;

function TOleControl.GetByteProp(Index: Integer): Byte;
begin
  Result := GetIntegerProp(Index);
end;

function TOleControl.GetColorProp(Index: Integer): TColor;
begin
  Result := GetIntegerProp(Index);
end;

function TOleControl.GetTColorProp(Index: Integer): TColor;
begin
  Result := GetIntegerProp(Index);
end;

function TOleControl.GetCompProp(Index: Integer): Comp;
begin
  Result := GetDoubleProp(Index);
end;

function TOleControl.GetCurrencyProp(Index: Integer): Currency;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VCurrency;
end;

function TOleControl.GetDoubleProp(Index: Integer): Double;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VDouble;
end;

function TOleControl.GetEnumPropDesc(DispID: Integer): TEnumPropDesc;
var
  I: Integer;
begin
  with FControlData^ do
  begin
    if EnumPropDescs = nil then CreateEnumPropDescs;
    for I := 0 to EnumPropDescs.Count - 1 do
    begin
      Result := EnumPropDescs[I];
      if Result.FDispID = DispID then Exit;
    end;
    Result := nil;
  end;
end;

procedure TOleControl.GetEventMethod(DispID: TDispID; var Method: TMethod);
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    ECX
        MOV     EBX,EAX
        MOV     ECX,[EBX].TOleControl.FControlData
        MOV     EDI,[ECX].TControlData.EventCount
        MOV     ESI,[ECX].TControlData.EventDispIDs
        XOR     EAX,EAX
        JMP     @@1
@@0:    CMP     EDX,[ESI].Integer[EAX*4]
        JE      @@2
        INC     EAX
@@1:    CMP     EAX,EDI
        JNE     @@0
        XOR     EAX,EAX
        XOR     EDX,EDX
        JMP     @@3
@@2:    PUSH    EAX
        CMP     [ECX].TControlData.Version, 401
        JB      @@2a
        MOV     EAX, [ECX].TControlData2.FirstEventOfs
        TEST    EAX, EAX
        JNE     @@2b
@@2a:   MOV     EAX, [EBX]
        CALL    TObject.ClassParent
        CALL    TObject.InstanceSize
        ADD     EAX, 7
        AND     EAX, not 7  // 8 byte alignment
@@2b:   ADD     EBX, EAX
        POP     EAX
        MOV     EDX,[EBX][EAX*8].TMethod.Data
        MOV     EAX,[EBX][EAX*8].TMethod.Code
@@3:    POP     ECX
        MOV     [ECX].TMethod.Code,EAX
        MOV     [ECX].TMethod.Data,EDX
        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure Exchange(var A,B); register;
asm
  MOV   ECX, [EDX]
  XCHG  ECX, [EAX]
  MOV   [EDX], ECX
end;

{ TOleControl.GetHelpContext:  Fetch the help file name and help context
  id of the given member (property, event, or method) of the Ole Control from
  the control's ITypeInfo interfaces.  GetHelpContext returns False if
  the member name is not found in the control's ITypeInfo.
  To obtain a help context for the entire control class, pass an empty
  string as the Member name.  }

function TOleControl.GetHelpContext(Member: string;
  var HelpCtx: Integer; var HelpFile: string): Boolean;
var
  TypeInfo: ITypeInfo;
  HlpFile: TBStr;
  ImplTypes, MemberID: Integer;
  TypeAttr: PTypeAttr;

  function Find(const MemberStr: string; var TypeInfo: ITypeInfo): Boolean;
  var
    Code: HResult;
    I, Flags: Integer;
    RefType: HRefType;
    Name: TBStr;
    Temp: ITypeInfo;
  begin
    Result := False;
    Name := StringToOleStr(Member);
    try
      I := 0;
      while (I < ImplTypes) do
      begin
        OleCheck(TypeInfo.GetImplTypeFlags(I, Flags));
        if Flags and (IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE) <> 0 then
        begin
          OleCheck(TypeInfo.GetRefTypeOfImplType(I, RefType));
          OleCheck(TypeInfo.GetRefTypeInfo(RefType, Temp));
          Code := Temp.GetIDsOfNames(@Name, 1, @MemberID);
          if Code <> DISP_E_UNKNOWNNAME then
          begin
            OleCheck(Code);
            Exchange(TypeInfo, Temp);
            Result := True;
            Break;
          end;
        end;
        Inc(I);
      end;
    finally
      SysFreeString(Name);
    end;
  end;

begin
  HelpCtx := 0;
  HelpFile := '';
  CreateControl;
  OleCheck((FOleObject as IProvideClassInfo).GetClassInfo(TypeInfo));
  MemberID := MEMBERID_NIL;
  if Length(Member) > 0 then
  begin
    OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
    ImplTypes := TypeAttr.cImplTypes;
    TypeInfo.ReleaseTypeAttr(TypeAttr);
    Result := Find(Member, TypeInfo);
    if (not Result) and (Member[Length(Member)] = '_') then
    begin
      Delete(Member, Length(Member)-1, 1);
      Result := Find(Member, TypeInfo);
    end;
    if (not Result) and (Pos('On', Member) = 1) then
    begin
      Delete(Member, 1, 2);
      Result := Find(Member, TypeInfo);
    end;
    if not Result then Exit;
  end;
  OleCheck(TypeInfo.GetDocumentation(MemberID, nil, nil, @HelpCtx, @HlpFile));
  HelpFile := OleStrToString(HlpFile);
  SysFreeString(HlpFile);
  Result := True;
end;

function TOleControl.GetIDispatchProp(Index: Integer): IDispatch;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := IDispatch(Temp.VDispatch);
end;

function TOleControl.GetIntegerProp(Index: Integer): Integer;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VInteger;
end;

function TOleControl.GetIUnknownProp(Index: Integer): IUnknown;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := IUnknown(Temp.VUnknown);
end;

function TOleControl.GetMainMenu: TMainMenu;
var
  Form: TCustomForm;
begin
  Result := nil;
  Form := GetParentForm(Self);
  if Form <> nil then
    if (Form is TForm) and (TForm(Form).FormStyle <> fsMDIChild) then
      Result := Form.Menu
    else
      if Application.MainForm <> nil then
        Result := Application.MainForm.Menu;
end;

procedure TOleControl.GetObjectVerbs(List: TStrings);
var
  EnumOleVerb: IEnumOleVerb;
  OleVerb: TOleVerb;
  Code: HResult;
begin
  CreateControl;
  List.Clear;
  Code := FOleObject.EnumVerbs(EnumOleVerb);
  if Code = OLE_S_USEREG then
    Code := OleRegEnumVerbs(FControlData.ClassID, EnumOleVerb);
  if Code = 0 then
    while (EnumOleVerb.Next(1, OleVerb, nil) = 0) do
      if (OleVerb.grfAttribs and OLEVERBATTRIB_ONCONTAINERMENU <> 0) then
      begin
        List.AddObject(StripHotkey(OleVerb.lpszVerbName), TObject(OleVerb.lVerb));
      end;
end;

function TOleControl.GetWordBoolProp(Index: Integer): WordBool;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VBoolean;
end;

function TOleControl.GetTDateTimeProp(Index: Integer): TDateTime;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VDate;
end;

function TOleControl.GetTFontProp(Index: Integer): TFont;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to FFonts.Count-1 do
    if FControlData^.FontIDs^[I] = Index then
    begin
      Result := TFont(FFonts[I]);
      if Result.FontAdapter = nil then
        SetOleFont(Result, GetIDispatchProp(Index) as IFontDisp);
    end;
end;

function TOleControl.GetOleBoolProp(Index: Integer): TOleBool;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VBoolean;
end;

function TOleControl.GetOleDateProp(Index: Integer): TOleDate;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VDate;
end;

function TOleControl.GetOleEnumProp(Index: Integer): TOleEnum;
begin
  Result := GetIntegerProp(Index);
end;

function TOleControl.GetTOleEnumProp(Index: Integer): TOleEnum;
begin
  Result := GetIntegerProp(Index);
end;

function TOleControl.GetOleObject: Variant;
begin
  CreateControl;
  Result := Variant(FOleObject as IDispatch);
end;

function TOleControl.GetDefaultDispatch: IDispatch;
begin
  CreateControl;
  Result := FOleObject as IDispatch;
end;

function TOleControl.GetOleVariantProp(Index: Integer): OleVariant;
begin
  VarClear(Result);
  GetProperty(Index, TVarData(Result));
end;

function TOleControl.GetTPictureProp(Index: Integer): TPicture;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to FPictures.Count-1 do
    if FControlData^.PictureIDs^[I] = Index then
    begin
      Result := TPicture(FPictures[I]);
      if Result.PictureAdapter = nil then
        SetOlePicture(Result, GetIDispatchProp(Index) as IPictureDisp);
    end;
end;


function TOleControl.GetPropDisplayString(DispID: Integer): string;
var
  S: WideString;
begin
  CreateControl;
  if (FPropBrowsing <> nil) and
    (FPropBrowsing.GetDisplayString(DispID, S) = 0) then
    Result := S else
    Result := GetStringProp(DispID);
end;

procedure TOleControl.GetPropDisplayStrings(DispID: Integer; List: TStrings);
var
  Strings: TCAPOleStr;
  Cookies: TCALongint;
  I: Integer;
begin
  CreateControl;
  List.Clear;
  if (FPropBrowsing <> nil) and
    (FPropBrowsing.GetPredefinedStrings(DispID, Strings, Cookies) = 0) then
    try
      for I := 0 to Strings.cElems - 1 do
        List.AddObject(Strings.pElems^[I], TObject(Cookies.pElems^[I]));
    finally
      for I := 0 to Strings.cElems - 1 do
        CoTaskMemFree(Strings.pElems^[I]);
      CoTaskMemFree(Strings.pElems);
      CoTaskMemFree(Cookies.pElems);
    end;
end;

var  // init to zero, never written to
  DispParams: TDispParams = ();

procedure TOleControl.GetProperty(Index: Integer; var Value: TVarData);
var
  Status: HResult;
  ExcepInfo: TExcepInfo;
begin
  CreateControl;