olectrls.pas

这是不可多得的源代码

  Value.VType := varEmpty;
  Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
    DISPATCH_PROPERTYGET, DispParams, @Value, @ExcepInfo, nil);
  if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
end;

function TOleControl.GetShortIntProp(Index: Integer): ShortInt;
begin
  Result := GetIntegerProp(Index);
end;

function TOleControl.GetSingleProp(Index: Integer): Single;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VSingle;
end;

function TOleControl.GetSmallintProp(Index: Integer): Smallint;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VSmallint;
end;

function TOleControl.GetStringProp(Index: Integer): string;
begin
  Result := GetVariantProp(Index);
end;

function TOleControl.GetVariantProp(Index: Integer): Variant;
begin
  Result := GetOleVariantProp(Index);
end;

function TOleControl.GetWideStringProp(Index: Integer): WideString;
var
  Temp: TVarData;
begin
  Result := '';
  GetProperty(Index, Temp);
  Pointer(Result) := Temp.VOleStr;
end;

function TOleControl.GetWordProp(Index: Integer): Word;
begin
  Result := GetIntegerProp(Index);
end;

procedure TOleControl.HookControlWndProc;
var
  WndHandle: HWnd;
begin
  if (FOleInPlaceObject <> nil) and (WindowHandle = 0) then
  begin
    WndHandle := 0;
    FOleInPlaceObject.GetWindow(WndHandle);
    if WndHandle = 0 then raise EOleError.CreateRes(@SNoWindowHandle);
    WindowHandle := WndHandle;
    DefWndProc := Pointer(GetWindowLong(WindowHandle, GWL_WNDPROC));
    CreationControl := Self;
    SetWindowLong(WindowHandle, GWL_WNDPROC, Longint(@InitWndProc));
    SendMessage(WindowHandle, WM_NULL, 0, 0);
  end;
end;

procedure CallEventMethod(const EventInfo: TEventInfo);
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EBP
        MOV     EBP,ESP
        MOV     EBX,EAX
        MOV     EDX,[EBX].TEventInfo.ArgCount
        TEST    EDX,EDX
        JE      @@5
        XOR     EAX,EAX
        LEA     ESI,[EBX].TEventInfo.Args
@@1:    MOV     AL,[ESI].TEventArg.Kind
        CMP     AL,1
        JA      @@2
        JE      @@3
        TEST    AH,AH
        JNE     @@3
        MOV     ECX,[ESI].Integer[4]
        MOV     AH,1
        JMP     @@4
@@2:    PUSH    [ESI].Integer[8]
@@3:    PUSH    [ESI].Integer[4]
@@4:    ADD     ESI,12
        DEC     EDX
        JNE     @@1
@@5:    MOV     EDX,[EBX].TEventInfo.Sender
        MOV     EAX,[EBX].TEventInfo.Method.Data
        CALL    [EBX].TEventInfo.Method.Code
        MOV     ESP,EBP
        POP     EBP
        POP     ESI
        POP     EBX
end;

type
  PVarArg = ^TVarArg;
  TVarArg = array[0..3] of DWORD;

procedure TOleControl.D2InvokeEvent(DispID: TDispID; var Params: TDispParams);
type
  TStringDesc = record
    PStr: Pointer;
    BStr: PBStr;
  end;
var
  I, J, K, ArgType, ArgCount, StrCount: Integer;
  ArgPtr: PEventArg;
  ParamPtr: PVarArg;
  Strings: array[0..MaxDispArgs - 1] of TStringDesc;
  EventInfo: TEventInfo;
begin
  GetEventMethod(DispID, EventInfo.Method);
  if Integer(EventInfo.Method.Code) >= $10000 then
  begin
    StrCount := 0;
    try
      ArgCount := Params.cArgs;
      EventInfo.Sender := Self;
      EventInfo.ArgCount := ArgCount;
      if ArgCount <> 0 then
      begin
        ParamPtr := @Params.rgvarg^[EventInfo.ArgCount];
        ArgPtr := @EventInfo.Args;
        I := 0;
        repeat
          Dec(Integer(ParamPtr), SizeOf(TVarArg));
          ArgType := ParamPtr^[0] and $0000FFFF;
          if ArgType and varTypeMask = varOleStr then
          begin
            ArgPtr^.Kind := akDWord;
            with Strings[StrCount] do
            begin
              PStr := nil;
              if ArgType and varByRef <> 0 then
              begin
                OleStrToStrVar(PBStr(ParamPtr^[2])^, string(PStr));
                BStr := PBStr(ParamPtr^[2]);
                ArgPtr^.Data[0] := Integer(@PStr);
              end else
              begin
                OleStrToStrVar(TBStr(ParamPtr^[2]), string(PStr));
                BStr := nil;
                ArgPtr^.Data[0] := Integer(PStr);
              end;
            end;
            Inc(StrCount);
          end else
          begin
            case ArgType of
              varSingle:
                begin
                  ArgPtr^.Kind := akSingle;
                  ArgPtr^.Data[0] := ParamPtr^[2];
                end;
              varDouble..varDate:
                begin
                  ArgPtr^.Kind := akDouble;
                  ArgPtr^.Data[0] := ParamPtr^[2];
                  ArgPtr^.Data[1] := ParamPtr^[3];
                end;
              varDispatch:
                begin
                  ArgPtr^.Kind := akDWord;
                  ArgPtr^.Data[0] := Integer(ParamPtr)
                end;
            else
              ArgPtr^.Kind := akDWord;
              if (ArgType and varArray) <> 0 then
                ArgPtr^.Data[0] := Integer(ParamPtr)
              else
                ArgPtr^.Data[0] := ParamPtr^[2];
            end;
          end;
          Inc(Integer(ArgPtr), SizeOf(TEventArg));
          Inc(I);
        until I = EventInfo.ArgCount;
      end;
      CallEventMethod(EventInfo);
      J := StrCount;
      while J <> 0 do
      begin
        Dec(J);
        with Strings[J] do
          if BStr <> nil then BStr^ := StringToOleStr(string(PStr));
      end;
    except
      Application.HandleException(Self);
    end;
    K := StrCount;
    while K <> 0 do
    begin
      Dec(K);
      string(Strings[K].PStr) := '';
    end;
  end;
end;

procedure TOleControl.InvokeEvent(DispID: TDispID; var Params: TDispParams);
var
  EventMethod: TMethod;
begin
  if ControlData.Version < 300 then
    D2InvokeEvent(DispID, Params)
  else
  begin
    GetEventMethod(DispID, EventMethod);
    if Integer(EventMethod.Code) < $10000 then Exit;

    try
      asm
                PUSH    EBX
                PUSH    ESI
                MOV     ESI, Params
                MOV     EBX, [ESI].TDispParams.cArgs
                TEST    EBX, EBX
                JZ      @@7
                MOV     ESI, [ESI].TDispParams.rgvarg
                MOV     EAX, EBX
                SHL     EAX, 4                         // count * sizeof(TVarArg)
                XOR     EDX, EDX
                ADD     ESI, EAX                       // EDI = Params.rgvarg^[ArgCount]
        @@1:    SUB     ESI, 16                        // Sizeof(TVarArg)
                MOV     EAX, dword ptr [ESI]
                CMP     AX, varSingle                  // 4 bytes to push
                JA      @@3
                JE      @@5                            
        @@2:    TEST    DL,DL
                JNE     @@2a
                MOV     ECX, ESI
                INC     DL
                TEST    EAX, varArray
                JNZ     @@6
                MOV     ECX, dword ptr [ESI+8]
                JMP     @@6
        @@2a:   TEST    EAX, varArray
                JZ      @@5
                PUSH    ESI
                JMP     @@6
        @@3:    CMP     AX, varDate                    // 8 bytes to push
                JA      @@2
        @@4:    PUSH    dword ptr [ESI+12]
        @@5:    PUSH    dword ptr [ESI+8]
        @@6:    DEC     EBX
                JNE     @@1
        @@7:    MOV     EDX, Self
                MOV     EAX, EventMethod.Data
                CALL    EventMethod.Code
                POP     ESI
                POP     EBX
      end;
    except
      Application.HandleException(Self);
    end;
  end;
end;

procedure GetStringResult(BStr: TBStr; var Result: string);
begin
  try
    OleStrToStrVar(BStr, Result);
  finally
    SysFreeString(BStr);
  end;
end;

procedure TOleControl.InitControlInterface;
begin
end;

procedure TOleControl.InvokeMethod(const DispInfo; Result: Pointer); assembler;
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     EDI,ECX
        CALL    TOleControl.CreateControl
        PUSH    [ESI].TDispInfo.DispID
        MOV     ECX,ESP
        XOR     EAX,EAX
        PUSH    EAX
        PUSH    EAX
        PUSH    EAX
        PUSH    EAX
        MOV     EDX,ESP
        LEA     EAX,[EBP+16]
        CMP     [ESI].TDispInfo.ResType,varOleStr
        JE      @@1
        CMP     [ESI].TDispInfo.ResType,varVariant
        JE      @@1
        LEA     EAX,[EBP+12]
@@1:    PUSH    EAX
        PUSH    EDX
        LEA     EDX,[ESI].TDispInfo.CallDesc
        MOV     EAX,[EBX].TOleControl.FControlDispatch
        CALL    DispatchInvoke
        XOR     EAX,EAX
        MOV     AL,[ESI].TDispInfo.ResType
        JMP     @ResultTable.Pointer[EAX*4]

@ResultTable:
        DD      @ResEmpty
        DD      @ResNull
        DD      @ResSmallint
        DD      @ResInteger
        DD      @ResSingle
        DD      @ResDouble
        DD      @ResCurrency
        DD      @ResDate
        DD      @ResString
        DD      @ResDispatch
        DD      @ResError
        DD      @ResBoolean
        DD      @ResVariant

@ResSmallint:
@ResBoolean:
        MOV     AX,[ESP+8]
        MOV     [EDI],AX
        JMP     @ResDone

@ResString:
        MOV     EAX,[ESP+8]
        MOV     EDX,EDI
        CALL    GetStringResult
        JMP     @ResDone

@ResVariant:
        MOV     EAX,EDI
        CALL    System.@VarClear
        MOV     ESI,ESP
        MOV     ECX,4
        REP     MOVSD
        JMP     @ResDone

@ResDouble:
@ResCurrency:
@ResDate:
        MOV     EAX,[ESP+12]
        MOV     [EDI+4],EAX

@ResInteger:
@ResSingle:
        MOV     EAX,[ESP+8]
        MOV     [EDI],EAX

@ResEmpty:
@ResNull:
@ResDispatch:
@ResError:
@ResDone:
        ADD     ESP,20
        POP     EDI
        POP     ESI
        POP     EBX
end;

function TOleControl.IsCustomProperty(DispID: Integer): Boolean;
var
  W: WideString;
begin
  Result := (FPropBrowsing <> nil) and
    (FPropBrowsing.GetDisplayString(DispID, W) = 0);
end;

function TOleControl.IsPropPageProperty(DispID: Integer): Boolean;
var
  PPID: TCLSID;
begin
  Result := (FPropBrowsing <> nil) and
    (FPropBrowsing.MapPropertyToPage(DispID, PPID) = S_FALSE) and not
    IsEqualCLSID(PPID, GUID_NULL);
end;

function TOleControl.PaletteChanged(Foreground: Boolean): Boolean;
begin
  Result := False;
  if HandleAllocated and Foreground then
    Result := CallWindowProc(DefWndProc, Handle, WM_QUERYNEWPALETTE, 0, 0) <> 0;
  if not Result then
    Result := inherited PaletteChanged(Foreground);
end;

procedure TOleControl.PictureChanged(Sender: TObject);
var
  I: Integer;
begin
  if (FPictures = nil) or not (Sender is TPicture) then Exit;
  for I := 0 to FPictures.Count - 1 do
    if FPictures[I] = Sender then
    begin
      if (TPicture(Sender).PictureAdapter <> nil) then
        SetTPictureProp(FControlData.PictureIDs^[I], TPicture(Sender));
      Exit;
    end;
end;

procedure TOleControl.ReadData(Stream: TStream);
var
  Buffer: Pointer;
begin
  DestroyStorage;
  try
    FObjectData := GlobalAlloc(GMEM_MOVEABLE, Stream.Size);
    if FObjectData = 0 then OutOfMemoryError;
    Buffer := GlobalLock(FObjectData);
    try
      Stream.Read(Buffer^, Stream.Size);
    finally
      GlobalUnlock(FObjectData);
    end;
  except
    DestroyStorage;
  end;
end;

procedure TOleControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if ((AWidth <> Width) and (Width > 0)) or ((AHeight <> Height) and (Height > 0)) then
    if (FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) or
      ((FOleObject.SetExtent(DVASPECT_CONTENT, Point(
        MulDiv(AWidth, 2540, Screen.PixelsPerInch),
        MulDiv(AHeight, 2540, Screen.PixelsPerInch))) <> S_OK)) then
    begin
      AWidth := Width;
      AHeight := Height;
    end;
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;

procedure TOleControl.SetByteProp(Index: Integer; Value: Byte);
begin
  SetIntegerProp(Index, Value);
end;