olectrls.pas

这是不可多得的源代码

procedure TOleControl.SetColorProp(Index: Integer; Value: TColor);
begin
  SetIntegerProp(Index, Value);
end;

procedure TOleControl.SetTColorProp(Index: Integer; Value: TColor);
begin
  SetIntegerProp(Index, Value);
end;

procedure TOleControl.SetCompProp(Index: Integer; const Value: Comp);
var
  Temp: TVarData;
begin
  Temp.VType := VT_I8;
  Temp.VDouble := Value;
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetCurrencyProp(Index: Integer; const Value: Currency);
var
  Temp: TVarData;
begin
  Temp.VType := varCurrency;
  Temp.VCurrency := Value;
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetDoubleProp(Index: Integer; const Value: Double);
var
  Temp: TVarData;
begin
  Temp.VType := varDouble;
  Temp.VDouble := Value;
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetIDispatchProp(Index: Integer; const Value: IDispatch);
var
  Temp: TVarData;
begin
  Temp.VType := varDispatch;
  Temp.VDispatch := Pointer(Value);
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetIntegerProp(Index: Integer; Value: Integer);
var
  Temp: TVarData;
begin
  Temp.VType := varInteger;
  Temp.VInteger := Value;
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetIUnknownProp(Index: Integer; const Value: IUnknown);
var
  Temp: TVarData;
begin
  Temp.VType := VT_UNKNOWN;
  Temp.VUnknown := Pointer(Value);
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetName(const Value: TComponentName);
var
  OldName: string;
  DispID: Integer;
begin
  OldName := Name;
  inherited SetName(Value);
  if FOleControl <> nil then
  begin
    FOleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DISPLAYNAME);
    if FControlData^.Flags and (cfCaption or cfText) <> 0 then
    begin
      if FControlData^.Flags and cfCaption <> 0 then
        DispID := DISPID_CAPTION else
        DispID := DISPID_TEXT;
      if OldName = GetStringProp(DispID) then SetStringProp(DispID, Value);
    end;
  end;
end;

procedure TOleControl.SetWordBoolProp(Index: Integer; Value: WordBool);
var
  Temp: TVarData;
begin
  Temp.VType := varBoolean;
  if Value then
    Temp.VBoolean := WordBool(-1) else
    Temp.VBoolean := WordBool(0);
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetTDateTimeProp(Index: Integer; const Value: TDateTime);
var
  Temp: TVarData;
begin
  Temp.VType := varDate;
  Temp.VDate := Value;
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetTFontProp(Index: Integer; Value: TFont);
var
  I: Integer;
  F: TFont;
  Temp: IFontDisp;
begin
  for I := 0 to FFonts.Count-1 do
    if FControlData^.FontIDs^[I] = Index then
    begin
      F := TFont(FFonts[I]);
      F.Assign(Value);
      if F.FontAdapter = nil then
      begin
        GetOleFont(F, Temp);
        SetIDispatchProp(Index, Temp);
      end;
    end;
end;

procedure TOleControl.SetOleBoolProp(Index: Integer; Value: TOleBool);
var
  Temp: TVarData;
begin
  Temp.VType := varBoolean;
  if Value then
    Temp.VBoolean := WordBool(-1) else
    Temp.VBoolean := WordBool(0);
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetOleDateProp(Index: Integer; const Value: TOleDate);
var
  Temp: TVarData;
begin
  Temp.VType := varDate;
  Temp.VDate := Value;
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetOleEnumProp(Index: Integer; Value: TOleEnum);
begin
  SetIntegerProp(Index, Value);
end;

procedure TOleControl.SetTOleEnumProp(Index: Integer; Value: TOleEnum);
begin
  SetIntegerProp(Index, Value);
end;

procedure TOleControl.SetOleVariantProp(Index: Integer; const Value: OleVariant);
begin
  SetProperty(Index, TVarData(Value));
end;

procedure TOleControl.SetParent(AParent: TWinControl);
var
  CS: IOleClientSite;
  X: Integer;
begin
  inherited SetParent(AParent);
  if (AParent <> nil) then
  begin
    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 FOleControl <> nil then
      FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN);
  end;
end;

procedure TOleControl.SetTPictureProp(Index: Integer; Value: TPicture);
var
  I: Integer;
  P: TPicture;
  Temp: IPictureDisp;
begin
  if FUpdatingPictures then Exit;
  FUpdatingPictures := True;
  try
    for I := 0 to FPictures.Count-1 do
      if FControlData^.PictureIDs^[I] = Index then
      begin
        P := TPicture(FPictures[I]);
        P.Assign(Value);
        GetOlePicture(P, Temp);
        SetIDispatchProp(Index, Temp);
      end;
  finally
    FUpdatingPictures := False;
  end;
end;

procedure TOleControl.SetPropDisplayString(DispID: Integer;
  const Value: string);
var
  I: Integer;
  Values: TStringList;
  V: OleVariant;
begin
  Values := TStringList.Create;
  try
    GetPropDisplayStrings(DispID, Values);
    for I := 0 to Values.Count - 1 do
      if AnsiCompareText(Value, Values[I]) = 0 then
      begin
        OleCheck(FPropBrowsing.GetPredefinedValue(DispID,
          Integer(Values.Objects[I]), V));
        SetProperty(DispID, TVarData(V));
        Exit;
      end;
  finally
    Values.Free;
  end;
  SetStringProp(DispID, Value);
end;

procedure TOleControl.SetProperty(Index: Integer; const Value: TVarData);
const
  DispIDArgs: Longint = DISPID_PROPERTYPUT;
var
  Status, InvKind: Integer;
  DispParams: TDispParams;
  ExcepInfo: TExcepInfo;
begin
  CreateControl;
  DispParams.rgvarg := @Value;
  DispParams.rgdispidNamedArgs := @DispIDArgs;
  DispParams.cArgs := 1;
  DispParams.cNamedArgs := 1;
  if Value.VType <> varDispatch then
    InvKind := DISPATCH_PROPERTYPUT else
    InvKind := DISPATCH_PROPERTYPUTREF;
  Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
    InvKind, DispParams, nil, @ExcepInfo, nil);
  if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
end;

procedure TOleControl.SetShortintProp(Index: Integer; Value: ShortInt);
begin
  SetIntegerProp(Index, Value);
end;

procedure TOleControl.SetSingleProp(Index: Integer; const Value: Single);
var
  Temp: TVarData;
begin
  Temp.VType := varSingle;
  Temp.VSingle := Value;
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetSmallintProp(Index: Integer; Value: Smallint);
var
  Temp: TVarData;
begin
  Temp.VType := varSmallint;
  Temp.VSmallint := Value;
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetStringProp(Index: Integer; const Value: string);
var
  Temp: TVarData;
begin
  Temp.VType := varOleStr;
  Temp.VOleStr := StringToOleStr(Value);
  try
    SetProperty(Index, Temp);
  finally
    SysFreeString(Temp.VOleStr);
  end;
end;

procedure TOleControl.SetUIActive(Active: Boolean);
var
  Form: TCustomForm;
begin
  Form := GetParentForm(Self);
  if Form <> nil then
    if Active then
    begin
      if (Form.ActiveOleControl <> nil) and
        (Form.ActiveOleControl <> Self) then
        Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
      Form.ActiveOleControl := Self;
    end else
      if Form.ActiveOleControl = Self then Form.ActiveOleControl := nil;
end;

procedure TOleControl.SetVariantProp(Index: Integer; const Value: Variant);
begin
  SetOleVariantProp(Index, Value);
end;

procedure TOleControl.SetWideStringProp(Index: Integer; const Value: WideString);
var
  Temp: TVarData;
begin
  Temp.VType := varOleStr;
  if Value <> '' then
    Temp.VOleStr := PWideChar(Value)
  else
    Temp.VOleStr := nil;
  SetProperty(Index, Temp);
end;

procedure TOleControl.SetWordProp(Index: Integer; Value: Word);
begin
  SetIntegerProp(Index, Value);
end;

procedure TOleControl._SetColorProp(Index: Integer; Value: TColor);
begin
  SetColorProp(Index, Value);
end;

procedure TOleControl._SetTColorProp(Index: Integer; Value: TColor);
begin
  SetTColorProp(Index, Value);
end;

procedure TOleControl._SetTOleEnumProp(Index: Integer; Value: TOleEnum);
begin
  SetTOleEnumProp(Index, Value);
end;

procedure TOleControl._SetTFontProp(Index: Integer; Value: TFont);
begin
  SetTFontProp(Index, Value);
end;

procedure TOleControl._SetTPictureProp(Index: Integer; Value: TPicture);
begin
  SetTPictureProp(Index, Value);
end;


procedure TOleControl.ShowAboutBox;
const
  DispInfo: array[0..7] of Byte = ($D8,$FD,$FF,$FF,$00,$01,$00,$00);
begin
  InvokeMethod(DispInfo, nil);
end;

procedure TOleControl.StandardEvent(DispID: TDispID; var Params: TDispParams);
type
  PVarDataList = ^TVarDataList;
  TVarDataList = array[0..3] of TVarData;
const
  ShiftMap: array[0..7] of TShiftState = (
    [],
    [ssShift],
    [ssCtrl],
    [ssShift, ssCtrl],
    [ssAlt],
    [ssShift, ssAlt],
    [ssCtrl, ssAlt],
    [ssShift, ssCtrl, ssAlt]);
  MouseMap: array[0..7] of TShiftState = (
    [],
    [ssLeft],
    [ssRight],
    [ssLeft, ssRight],
    [ssMiddle],
    [ssLeft, ssMiddle],
    [ssRight, ssMiddle],
    [ssLeft, ssRight, ssMiddle]);
  ButtonMap: array[0..7] of TMouseButton = (
    mbLeft, mbLeft, mbRight, mbLeft, mbMiddle, mbLeft, mbRight, mbLeft);
var
  Args: PVarDataList;
  Shift: TShiftState;
  Button: TMouseButton;
  X, Y: Integer;
  Key: Word;
  Ch: Char;
begin
  Args := PVarDataList(Params.rgvarg);
  try
    case DispID of
      DISPID_CLICK:
        Click;
      DISPID_DBLCLICK:
        DblClick;
      DISPID_KEYDOWN, DISPID_KEYUP:
        if Params.cArgs >= 2 then
        begin
          Key := Variant(Args^[1]);
          X := Variant(Args^[0]);
          case DispID of
            DISPID_KEYDOWN: KeyDown(Key, ShiftMap[X and 7]);
            DISPID_KEYUP:   KeyUp(Key, ShiftMap[X and 7]);
          end;
          if ((Args^[1].vType and varByRef) <> 0) then
            Word(Args^[1].VPointer^) := Key;
        end;
      DISPID_KEYPRESS:
        if Params.cArgs > 0 then
        begin
          Ch := Char(Integer(Variant(Args^[0])));
          KeyPress(Ch);
          if ((Args^[0].vType and varByRef) <> 0) then
            Char(Args^[0].VPointer^) := Ch;
        end;
      DISPID_MOUSEDOWN, DISPID_MOUSEMOVE, DISPID_MOUSEUP:
        if Params.cArgs >= 4 then
        begin
          X := Integer(Variant(Args^[3])) and 7;
          Y := Integer(Variant(Args^[2])) and 7;
          Button := ButtonMap[X];
          Shift := ShiftMap[Y] + MouseMap[X];
          X := Variant(Args^[1]);
          Y := Variant(Args^[0]);
          case DispID of
            DISPID_MOUSEDOWN:
              MouseDown(Button, Shift, X, Y);
            DISPID_MOUSEMOVE:
              MouseMove(Shift, X, Y);
            DISPID_MOUSEUP:
              MouseUp(Button, Shift, X, Y);
          end;
        end;
    end;
  except
    Application.HandleException(Self);
  end;
end;

procedure TOleControl.WndProc(var Message: TMessage);
var
  WinMsg: TMsg;
begin
  if (Message.Msg >= CN_BASE + W