olectrls.pas

这是不可多得的源代码

function TEventDispatch.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  Pointer(TypeInfo) := nil;
  Result := E_NOTIMPL;
end;

function TEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TEventDispatch.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params;
  VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
  if (DispID >= DISPID_MOUSEUP) and (DispID <= DISPID_CLICK) then
    FControl.StandardEvent(DispID, TDispParams(Params)) else
    FControl.InvokeEvent(DispID, TDispParams(Params));
  Result := S_OK;
end;

{ TEnumPropDesc }

constructor TEnumPropDesc.Create(DispID, ValueCount: Integer;
  const TypeInfo: ITypeInfo);
var
  I: Integer;
  VarDesc: PVarDesc;
  Name: WideString;
begin
  FDispID := DispID;
  FValueCount := ValueCount;
  FValues := AllocMem(ValueCount * SizeOf(TEnumValue));
  for I := 0 to ValueCount - 1 do
  begin
    OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
    try
      OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @Name,
        nil, nil, nil));
      with FValues^[I] do
      begin
        Value := TVarData(VarDesc^.lpVarValue^).VInteger;
        Ident := Name;
        while (Length(Ident) > 1) and (Ident[1] = '_') do
          Delete(Ident, 1, 1);
      end;
    finally
      TypeInfo.ReleaseVarDesc(VarDesc);
    end;
  end;
end;

destructor TEnumPropDesc.Destroy;
begin
  if FValues <> nil then
  begin
    Finalize(FValues^[0], FValueCount);
    FreeMem(FValues, FValueCount * SizeOf(TEnumValue));
  end;
end;

procedure TEnumPropDesc.GetStrings(Proc: TGetStrProc);
var
  I: Integer;
begin
  for I := 0 to FValueCount - 1 do
    with FValues^[I] do Proc(Format('%d - %s', [Value, Ident]));
end;

function TEnumPropDesc.StringToValue(const S: string): Integer;
var
  I: Integer;
begin
  I := 1;
  while (I <= Length(S)) and (S[I] in ['0'..'9', '-']) do Inc(I);
  if I > 1 then
  begin
    Result := StrToInt(Copy(S, 1, I - 1));
    for I := 0 to FValueCount - 1 do
      if Result = FValues^[I].Value then Exit;
  end else
    for I := 0 to FValueCount - 1 do
      with FValues^[I] do
        if AnsiCompareText(S, Ident) = 0 then
        begin
          Result := Value;
          Exit;
        end;
  raise EOleError.CreateResFmt(@SBadPropValue, [S]);
end;

function TEnumPropDesc.ValueToString(V: Integer): string;
var
  I: Integer;
begin
  for I := 0 to FValueCount - 1 do
    with FValues^[I] do
      if V = Value then
      begin
        Result := Format('%d - %s', [Value, Ident]);
        Exit;
      end;
  Result := IntToStr(V);
end;

{ TOleControl }

const
  // The following flags may be or'd into the TControlData.Reserved field to override
  // default behaviors.

  // cdForceSetClientSite:
  //   Call SetClientSite early (in constructor) regardless of misc status flags
  cdForceSetClientSite = 1;

  // cdDeferSetClientSite:
  //   Don't call SetClientSite early.  Takes precedence over cdForceSetClientSite and misc status flags
  cdDeferSetClientSite = 2;

constructor TOleControl.Create(AOwner: TComponent);
var
  I: Integer;
begin
  inherited Create(AOwner);
  Include(FComponentStyle, csCheckPropAvail);
  InitControlData;
  Inc(FControlData^.InstanceCount);
  if FControlData^.FontCount > 0 then
  begin
    FFonts := TList.Create;
    FFonts.Count := FControlData^.FontCount;
    for I := 0 to FFonts.Count-1 do
      FFonts[I] := TFont.Create;
  end;
  if FControlData^.PictureCount > 0 then
  begin
    FPictures := TList.Create;
    FPictures.Count := FControlData^.PictureCount;
    for I := 0 to FPictures.Count-1 do
    begin
      FPictures[I] := TPicture.Create;
      TPicture(FPictures[I]).OnChange := PictureChanged;
    end;
  end;
  FEventDispatch := TEventDispatch.Create(Self);
  CreateInstance;
  InitControlInterface(FOleObject);
  OleCheck(FOleObject.GetMiscStatus(DVASPECT_CONTENT, FMiscStatus));
  if (FControlData^.Reserved and cdDeferSetClientSite) = 0 then
    if ((FMiscStatus and OLEMISC_SETCLIENTSITEFIRST) <> 0) or
      ((FControlData^.Reserved and cdForceSetClientSite) <> 0) then
      OleCheck(FOleObject.SetClientSite(Self));
  OleCheck(FOleObject.QueryInterface(IPersistStreamInit, FPersistStream));
  if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then
    Visible := False;
  if FMiscStatus and OLEMISC_SIMPLEFRAME <> 0 then
    ControlStyle := [csAcceptsControls, csDoubleClicks, csNoStdEvents] else
    ControlStyle := [csDoubleClicks, csNoStdEvents];
  TabStop := FMiscStatus and (OLEMISC_ACTSLIKELABEL or
    OLEMISC_NOUIACTIVATE) = 0;
  OleCheck(RequestNewObjectLayout);
end;

destructor TOleControl.Destroy;

  procedure FreeList(var L: TList);
  var
    I: Integer;
  begin
    if L <> nil then
    begin
      for I := 0 to L.Count-1 do
        TObject(L[I]).Free;
      L.Free;
      L := nil;
    end;
  end;

begin
  SetUIActive(False);
  if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE);
  DestroyControl;
  DestroyStorage;
  FPersistStream := nil;
  if FOleObject <> nil then FOleObject.SetClientSite(nil);
  FOleObject := nil;
  FEventDispatch.Free;
  FreeList(FFonts);
  FreeList(FPictures);
  Dec(FControlData^.InstanceCount);
  if FControlData^.InstanceCount = 0 then DestroyEnumPropDescs;
  inherited Destroy;
end;

procedure TOleControl.BrowseProperties;
begin
  DoObjectVerb(OLEIVERB_PROPERTIES);
end;

procedure TOleControl.CreateControl;
var
  Stream: IStream;
  CS: IOleClientSite;
  X: Integer;
begin
  if FOleControl = nil then
    try
      try  // work around ATL bug
        X := FOleObject.GetClientSite(CS);
      except
        X := -1;
      end;
      if (X <> 0) or (CS = nil) then
        OleCheck(FOleObject.SetClientSite(Self));
      if FObjectData = 0 then OleCheck(FPersistStream.InitNew) else
      begin
        OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream));
        OleCheck(FPersistStream.Load(Stream));
        DestroyStorage;
      end;
      OleCheck(FOleObject.QueryInterface(IOleControl, FOleControl));
      OleCheck(FOleObject.QueryInterface(IDispatch, FControlDispatch));
      FOleObject.QueryInterface(IPerPropertyBrowsing, FPropBrowsing);
      InterfaceConnect(FOleObject, IPropertyNotifySink,
        Self, FPropConnection);
      InterfaceConnect(FOleObject, FControlData^.EventIID,
        FEventDispatch, FEventsConnection);
      if FControlData^.Flags and cfBackColor <> 0 then
        OnChanged(DISPID_BACKCOLOR);
      if FControlData^.Flags and cfEnabled <> 0 then
        OnChanged(DISPID_ENABLED);
      if FControlData^.Flags and cfFont <> 0 then
        OnChanged(DISPID_FONT);
      if FControlData^.Flags and cfForeColor <> 0 then
        OnChanged(DISPID_FORECOLOR);
      FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN);
      RequestNewObjectLayout;
    except
      DestroyControl;
      raise;
    end;
end;

procedure TOleControl.CreateEnumPropDescs;

  function FindMember(DispId: Integer): Boolean;
  var
    I: Integer;
  begin
    for I := 0 to FControlData^.EnumPropDescs.Count - 1 do
      if TEnumPropDesc(FControlData^.EnumPropDescs).FDispID = DispID then
      begin
        Result := True;
        Exit;
      end;
    Result := False;
  end;

  procedure CreateEnum(TypeDesc: TTypeDesc; const TypeInfo: ITypeInfo;
    DispId: Integer);
  var
    RefInfo: ITypeInfo;
    RefAttr: PTypeAttr;
  begin
    if TypeDesc.vt <> VT_USERDEFINED then Exit;
    OleCheck(TypeInfo.GetRefTypeInfo(TypeDesc.hreftype, RefInfo));
    OleCheck(RefInfo.GetTypeAttr(RefAttr));
    try
      if RefAttr^.typekind = TKIND_ENUM then
        FControlData^.EnumPropDescs.Expand.Add(
          TEnumPropDesc.Create(Dispid, RefAttr^.cVars, RefInfo));
    finally
      RefInfo.ReleaseTypeAttr(RefAttr);
    end;
  end;

  procedure ProcessTypeInfo(const TypeInfo: ITypeInfo);
  var
    I: Integer;
    RefInfo: ITypeInfo;
    TypeAttr: PTypeAttr;
    VarDesc: PVarDesc;
    FuncDesc: PFuncDesc;
    RefType: HRefType;
  begin
    OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
    try
      if IsEqualGUID(TypeAttr^.guid, IDispatch) then Exit;
      if ((TypeAttr.typekind = TKIND_INTERFACE) or
        (TypeAttr.wTypeFlags and TYPEFLAG_FDUAL <> 0)) and
        (TypeAttr.wTypeFlags and TYPEFLAG_FNONEXTENSIBLE <> 0) then
      begin
        OleCheck(TypeInfo.GetRefTypeOfImplType(0, RefType));
        OleCheck(TypeInfo.GetRefTypeInfo(RefType, RefInfo));
        ProcessTypeInfo(RefInfo);
      end;
      for I := 0 to TypeAttr^.cVars - 1 do
      begin
        OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
        try
          CreateEnum(VarDesc^.elemdescVar.tdesc, TypeInfo, VarDesc^.memid);
        finally
          TypeInfo.ReleaseVarDesc(VarDesc);
        end;
      end;
      for I := 0 to TypeAttr^.cFuncs - 1 do
      begin
        OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc));
        try
          if not FindMember(FuncDesc^.memid) then
            case FuncDesc^.invkind of
              INVOKE_PROPERTYGET:
                CreateEnum(FuncDesc^.elemdescFunc.tdesc, TypeInfo, FuncDesc^.memid);
              INVOKE_PROPERTYPUT:
                CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc,
                  TypeInfo, FuncDesc^.memid);
              INVOKE_PROPERTYPUTREF:
                if FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.vt = VT_PTR then
                  CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.ptdesc^,
                    TypeInfo, FuncDesc^.memid);
            end;
        finally
          TypeInfo.ReleaseFuncDesc(FuncDesc);
        end;
      end;
    finally
      TypeInfo.ReleaseTypeAttr(TypeAttr);
    end;
  end;

var
  TypeInfo: ITypeInfo;
begin
  CreateControl;
  FControlData^.EnumPropDescs := TList.Create;
  try
    OleCheck(FControlDispatch.GetTypeInfo(0, 0, TypeInfo));
    ProcessTypeInfo(TypeInfo);
  except
    DestroyEnumPropDescs;
    raise;
  end;
end;

procedure TOleControl.CreateInstance;
var
  ClassFactory2: IClassFactory2;
  LicKeyStr: WideString;

  procedure LicenseCheck(Status: HResult; const Ident: string);
  begin
    if Status = CLASS_E_NOTLICENSED then
      raise EOleError.CreateFmt(Ident, [ClassName]);
    OleCheck(Status);
  end;

begin
  if not (csDesigning in ComponentState) and
    (FControlData^.LicenseKey <> nil) then
  begin
    OleCheck(CoGetClassObject(FControlData^.ClassID, CLSCTX_INPROC_SERVER or
      CLSCTX_LOCAL_SERVER, nil, IClassFactory2, ClassFactory2));
    LicKeyStr := PWideChar(FControlData^.LicenseKey);
    LicenseCheck(ClassFactory2.CreateInstanceLic(nil, nil, IOleObject,
      LicKeyStr, FOleObject), SInvalidLicense);
  end else
    LicenseCheck(CoCreateInstance(FControlData^.ClassID, nil,
      CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IOleObject,
      FOleObject), SNotLicensed);
end;

procedure TOleControl.CreateStorage;
var
  Stream: IStream;
begin
  DestroyStorage;
  FObjectData := GlobalAlloc(GMEM_MOVEABLE, 0);
  if FObjectData = 0 then OutOfMemoryError;
  try
    OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream));
    OleCheck(FPersistStream.Save(Stream, True));
  except
     DestroyStorage;
     raise;
  end;

end;

procedure TOleControl.CreateWnd;
begin
  CreateControl;
  if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  begin
    FOleObject.DoVerb(OLEIVERB_INPLACEACTIVATE, nil, Self, 0,
      GetParentHandle, BoundsRect);
    if FOleInPlaceObject = nil then
      raise EOleError.CreateRes(@SCannotActivate);
    HookControlWndProc;
    if not Visible and IsWindowVisible(Handle) then
      ShowWindow(Handle, SW_HIDE);
  end else
    inherited CreateWnd;
end;

procedure TOleControl.DefaultHandler(var Message);
begin
  try
    if HandleAllocated then
      with TMessage(Message) do
      begin
        if (Msg >= CN_BASE) and (Msg < CN_BASE + WM_USER) then
          Msg := Msg - (CN_BASE - OCM_BASE);
        if FMiscStatus and OLEMISC_SIMPLEFRAME = 0 then
        begin
          Result := CallWindowProc(DefWndProc, Handle, Msg, WParam, LParam);
          Exit;
        end;
      end;
    inherited DefaultHandler(Message);
  except
  end;
end;

function TOleControl.SuppressException(E : Exception): boolean;
{ Unhandled control generated exceptions created when Delphi is streaming a
  form can cause errant behavior of the IDE.  SuppressException is meant to
  allow misbehaving hosted ActiveX Controls to fail in some fashion and still not
  have the Delphi IDE fail along with them.
  If you need to see all control generated exceptions, override this function
  in your TOLEControl descendent and return FALSE.
}
begin
  if (E is EOleSysError) then
    Result := (csDesigning in ComponentState)
      else Result := False;
end;

procedure TOleControl.DefineProperties(Filer: TFiler);
begin
  try
    inherited DefineProperties(Filer);
    Filer.DefineBinaryProperty('ControlData', ReadData, WriteData, FOleObject <> nil);
  except