oleauto.pas

这是不可多得的源代码

    AutoTable := GetAutoTable(ClassRef);
    if AutoTable <> nil then
    begin
      I := AutoTable^.EntryCount;
      Result := @AutoTable^.Entries;
      repeat
        if (Result^.DispID = DispID) and
          (Result^.Flags and Flags <> 0) then Exit;
        Inc(Integer(Result), SizeOf(TAutoEntry));
        Dec(I);
      until I = 0;
    end;
    ClassRef := ClassRef.ClassParent;
  until ClassRef = nil;
  Result := nil;
end;

{ Create an OLE object variant given an IDispatch }

function VarFromInterface(Unknown: IUnknown): Variant;
var
  Dispatch: IDispatch;
begin
  VarClear(Result);
  if Unknown <> nil then
  begin
    OleCheck(Unknown.QueryInterface(IID_IDispatch, Dispatch));
    TVarData(Result).VType := varDispatch;
    TVarData(Result).VDispatch := Dispatch;
  end;
end;

{ Return OLE object stored in a variant }

function VarToInterface(const V: Variant): IDispatch;
begin
  Result := nil;
  if TVarData(V).VType = varDispatch then
    Result := TVarData(V).VDispatch
  else if TVarData(V).VType = (varDispatch or varByRef) then
    Result := Pointer(TVarData(V).VPointer^);
  if Result = nil then raise EOleError.CreateRes(@SVarNotObject);
end;

{ Return TAutoObject referenced by the given variant }

function VarToAutoObject(const V: Variant): TAutoObject;
var
  Dispatch: IDispatch;
  AutoDispatch: TAutoDispatch;
begin
  Dispatch := VarToInterface(V);
  if Dispatch.QueryInterface(IID_IAutoDispatch, AutoDispatch) <> S_OK then
    raise EOleError.CreateRes(@SVarNotAutoObject);
  Result := AutoDispatch.GetAutoObject;
  AutoDispatch.Release;
end;

{ Create an OLE object variant given a class name }

function CreateOleObject(const ClassName: string): Variant;
var
  Unknown: IUnknown;
  ClassID: TCLSID;
  WideCharBuf: array[0..127] of WideChar;
begin
  StringToWideChar(ClassName, WideCharBuf, SizeOf(WideCharBuf) div 2);
  OleCheck(CLSIDFromProgID(WideCharBuf, ClassID));
  OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
    CLSCTX_LOCAL_SERVER, IID_IUnknown, Unknown));
  try
    Result := VarFromInterface(Unknown);
  finally;
    Unknown.Release;
  end;
end;

{ Get active OLE object for a given class name }

function GetActiveOleObject(const ClassName: string): Variant;
var
  Unknown: IUnknown;
  ClassID: TCLSID;
  WideCharBuf: array[0..127] of WideChar;
begin
  StringToWideChar(ClassName, WideCharBuf, SizeOf(WideCharBuf) div 2);
  OleCheck(CLSIDFromProgID(WideCharBuf, ClassID));
  OleCheck(GetActiveObject(ClassID, nil, Unknown));
  try
    Result := VarFromInterface(Unknown);
  finally;
    Unknown.Release;
  end;
end;

{ Call Invoke method on the given IDispatch interface using the given
  call descriptor, dispatch IDs, parameters, and result }

procedure DispInvoke(Dispatch: IDispatch; CallDesc: PCallDesc;
  DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
type
  PVarArg = ^TVarArg;
  TVarArg = array[0..3] of DWORD;
  TStringDesc = record
    BStr: PWideChar;
    PStr: PString;
  end;
var
  I, J, K, ArgType, ArgCount, StrCount, DispID, InvKind, Status: Integer;
  VarFlag: Byte;
  ParamPtr: ^Integer;
  ArgPtr, VarPtr: PVarArg;
  DispParams: TDispParams;
  ExcepInfo: TExcepInfo;
  Strings: array[0..MaxDispArgs - 1] of TStringDesc;
  Args: array[0..MaxDispArgs - 1] of TVarArg;
begin
  StrCount := 0;
  try
    ArgCount := CallDesc^.ArgCount;
    if ArgCount <> 0 then
    begin
      ParamPtr := Params;
      ArgPtr := @Args[ArgCount];
      I := 0;
      repeat
        Dec(Integer(ArgPtr), SizeOf(TVarData));
        ArgType := CallDesc^.ArgTypes[I] and atTypeMask;
        VarFlag := CallDesc^.ArgTypes[I] and atByRef;
        if ArgType = varError then
        begin
          ArgPtr^[0] := varError;
          ArgPtr^[2] := DWORD(DISP_E_PARAMNOTFOUND);
        end else
        begin
          if ArgType = varStrArg then
          begin
            with Strings[StrCount] do
              if VarFlag <> 0 then
              begin
                BStr := StringToOleStr(PString(ParamPtr^)^);
                PStr := PString(ParamPtr^);
                ArgPtr^[0] := varOleStr or varByRef;
                ArgPtr^[2] := Integer(@BStr);
              end else
              begin
                BStr := StringToOleStr(PString(ParamPtr)^);
                PStr := nil;
                ArgPtr^[0] := varOleStr;
                ArgPtr^[2] := Integer(BStr);
              end;
            Inc(StrCount);
          end else
          if VarFlag <> 0 then
          begin
            if (ArgType = varVariant) and
              (PVarData(ParamPtr^)^.VType = varString) then
              VarCast(PVariant(ParamPtr^)^, PVariant(ParamPtr^)^, varOleStr);
            ArgPtr^[0] := ArgType or varByRef;
            ArgPtr^[2] := ParamPtr^;
          end else
          if ArgType = varVariant then
          begin
            if PVarData(ParamPtr^)^.VType = varString then
            begin
              with Strings[StrCount] do
              begin
                BStr := StringToOleStr(string(PVarData(ParamPtr^)^.VString));
                PStr := nil;
                ArgPtr^[0] := varOleStr;
                ArgPtr^[2] := Integer(BStr);
              end;
              Inc(StrCount);
            end else
            begin
              VarPtr := PVarArg(ParamPtr^);
              ArgPtr^[0] := VarPtr^[0];
              ArgPtr^[1] := VarPtr^[1];
              ArgPtr^[2] := VarPtr^[2];
              ArgPtr^[3] := VarPtr^[3];
            end;
          end else
          begin
            ArgPtr^[0] := ArgType;
            ArgPtr^[2] := ParamPtr^;
            if (ArgType >= varDouble) and (ArgType <= varDate) then
            begin
              Inc(Integer(ParamPtr), 4);
              ArgPtr^[3] := ParamPtr^;
            end;
          end;
          Inc(Integer(ParamPtr), 4);
        end;
        Inc(I);
      until I = ArgCount;
    end;
    DispParams.rgvarg := @Args;
    DispParams.rgdispidNamedArgs := @DispIDs[1];
    DispParams.cArgs := ArgCount;
    DispParams.cNamedArgs := CallDesc^.NamedArgCount;
    DispID := DispIDs[0];
    InvKind := CallDesc^.CallType;
    if InvKind = DISPATCH_PROPERTYPUT then
    begin
      if Args[0][0] and varTypeMask = varDispatch then
        InvKind := DISPATCH_PROPERTYPUTREF;
      DispIDs[0] := DISPID_PROPERTYPUT;
      Dec(Integer(DispParams.rgdispidNamedArgs), SizeOf(Integer));
      Inc(DispParams.cNamedArgs);
    end else
      if (InvKind = DISPATCH_METHOD) and (ArgCount = 0) and (Result <> nil) then
        InvKind := DISPATCH_METHOD or DISPATCH_PROPERTYGET;
    Status := Dispatch.Invoke(DispID, GUID_NULL, LOCALE_SYSTEM_DEFAULT,
      InvKind, DispParams, Result, @ExcepInfo, nil);
    if Status <> 0 then DispInvokeError(Status, ExcepInfo);
    J := StrCount;
    while J <> 0 do
    begin
      Dec(J);
      with Strings[J] do
        if PStr <> nil then OleStrToStrVar(BStr, PStr^);
    end;
  finally
    K := StrCount;
    while K <> 0 do
    begin
      Dec(K);
      SysFreeString(Strings[K].BStr);
    end;
  end;
end;

{ Raise exception given an OLE return code and TExcepInfo structure }

procedure DispInvokeError(Status: HResult; const ExcepInfo: TExcepInfo);
var
  E: EOleException;
begin
  if Status <> DISP_E_EXCEPTION then OleError(Status);
  E := EOleException.Create(ExcepInfo);
  with ExcepInfo do
  begin
    if bstrSource <> nil then SysFreeString(bstrSource);
    if bstrDescription <> nil then SysFreeString(bstrDescription);
    if bstrHelpFile <> nil then SysFreeString(bstrHelpFile);
  end;
  raise E;
end;

{ Call GetIDsOfNames method on the given IDispatch interface }

procedure GetIDsOfNames(Dispatch: IDispatch; Names: PChar;
  NameCount: Integer; DispIDs: PDispIDList);
var
  I, N: Integer;
  Ch: WideChar;
  P: PWideChar;
  NameRefs: array[0..MaxDispArgs - 1] of PWideChar;
  WideNames: array[0..1023] of WideChar;
begin
  I := 0;
  N := 0;
  repeat
    P := @WideNames[I];
    if N = 0 then NameRefs[0] := P else NameRefs[NameCount - N] := P;
    repeat
      Ch := WideChar(Names[I]);
      WideNames[I] := Ch;
      Inc(I);
    until Char(Ch) = #0;
    Inc(N);
  until N = NameCount;
  if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
    LOCALE_SYSTEM_DEFAULT, DispIDs) <> 0 then
    raise EOleError.CreateResFmt(@SNoMethod, [Names]);
end;

{ Central call dispatcher }

procedure VarDispInvoke(Result: PVariant; const Instance: Variant;
  CallDesc: PCallDesc; Params: Pointer); cdecl;
var
  Dispatch: IDispatch;
  DispIDs: array[0..MaxDispArgs - 1] of Integer;
begin
  Dispatch := VarToInterface(Instance);
  GetIDsOfNames(Dispatch, @CallDesc^.ArgTypes[CallDesc^.ArgCount],
    CallDesc^.NamedArgCount + 1, @DispIDs);
  if Result <> nil then VarClear(Result^);
  DispInvoke(Dispatch, CallDesc, @DispIDs, @Params, Result);
end;

function DllGetClassObject(const CLSID: TCLSID; const IID: TIID;
  var Obj): HResult;
var
  RegistryClass: TRegistryClass;
  ClassFactory: TClassFactory;
begin
  RegistryClass := Automation.FRegistryList;
  ClassFactory := nil;
  while RegistryClass <> nil do
  begin
    if IsEqualCLSID(RegistryClass.FClassID, CLSID) then
    begin
      try
        ClassFactory := TClassFactory.Create(RegistryClass.FAutoClass);
      except
        Result := E_UNEXPECTED;
        Exit;
      end;
      Result := ClassFactory.QueryInterface(IID, Obj);
      ClassFactory.Release;
      Exit;
    end;
    RegistryClass := RegistryClass.FNext;
  end;
  Pointer(Obj) := nil;
  Result := CLASS_E_CLASSNOTAVAILABLE;
end;

function DllCanUnloadNow: HResult;
begin
  Result := S_FALSE;
  if (Automation.FAutoObjectCount = 0) and
    (Automation.FClassFactoryCount = 0) then Result := S_OK;
end;

function DllRegisterServer: HResult;
begin
  Automation.UpdateRegistry(True);
  Result := S_OK;
end;

function DllUnregisterServer: HResult;
begin
  Automation.UpdateRegistry(False);
  Result := S_OK;
end;

{ EOleSysError }

constructor EOleSysError.Create(ErrorCode: Integer);
var
  Message: string;
begin
  Message := SysErrorMessage(ErrorCode);
  if Message = '' then FmtStr(Message, SOleError, [ErrorCode]);
  inherited Create(Message);
  FErrorCode := ErrorCode;
end;

{ EOleException }

constructor EOleException.Create(const ExcepInfo: TExcepInfo);
var
  Message: string;
  Len: Integer;
begin
  with ExcepInfo do
  begin
    if bstrDescription <> nil then
    begin
      WideCharToStrVar(bstrDescription, Message);
      Len := Length(Message);
      while (Len > 0) and (Message[Len] in [#0..#32, '.']) do Dec(Len);
      SetLength(Message, Len);
    end;
    inherited CreateHelp(Message, dwHelpContext);
    if scode <> 0 then FErrorCode := scode else FErrorCode := wCode;
    if bstrSource <> nil then WideCharToStrVar(bstrSource, FSource);
    if bstrHelpFile <> nil then WideCharToStrVar(bstrHelpFile, FHelpFile);
  end;
end;

{ TAutoDispatch }

constructor TAutoDispatch.Create(AutoObject: TAutoObject);
begin
  FAutoObject := AutoObject;
end;

function TAutoDispatch.QueryInterface(const iid: TIID; var obj): HResult;
begin
  Result := FAutoObject.QueryInterface(iid, obj);
end;

function TAutoDispatch.AddRef: Longint;
begin
  Result := FAutoObject.AddRef;
end;

function TAutoDispatch.Release: Longint;
begin
  Result := FAutoObject.Release;
end;

function TAutoDispatch.GetTypeInfoCount(var ctinfo: Integer): HResult;
begin
  ctinfo := 0;
  Result := S_OK;
end;

function TAutoDispatch.GetTypeInfo(itinfo: Integer; lcid: TLCID;
  var tinfo: ITypeInfo): HResult;
begin
  tinfo := nil;
  Result := E_NOTIMPL;
end;

function TAutoDispatch.GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
  cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult;
begin
  Result := FAutoObject.GetIDsOfNames(rgszNames, cNames, rgdispid);
end;

function TAutoDispatch.Invoke(dispIDMember: TDispID; const iid: TIID;
  lcid: TLCID; flags: Word; var dispParams: TDispParams; varResult: PVariant;
  excepInfo: PExcepInfo; argErr: PInteger): HResult;
begin
  Result := FAutoObject.Invoke(dispIDMember, flags, dispParams,
    varResult, excepInfo, argErr);
end;

function TAutoDispatch.GetAutoObject: TAutoObject;
begin
  Result := FAutoObject;
end;

{ TAutoObject }

constructor TAutoObject.Create;
begin
  Automation.CountAutoObject(True);
  FRefCount := 1;
  FAutoDispatch := CreateAutoDispatch;
end;

destructor TAutoObject.Destroy;
begin
  FAutoDispatch.Free;
  Automation.CountAutoObject(False);
end;

function TAutoObject.AddRef: Integer;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function TAutoObject.CreateAutoDispatch: TAutoDispatch;
begin
  Result := TAutoDispatch.Create(Self);
end;

procedure TAutoObject.GetExceptionInfo(ExceptObject: TObject;
  var ExcepInfo: TExcepInfo);
begin
  with ExcepInfo do
  begin
    bstrSource := StringToOleStr(ClassName);
    if ExceptObject is Exception then
      bstrDescription := StringToOleStr(Exception(ExceptObject).Message);
    scode := E_FAIL;
  end;
end;

function TAutoObject.GetIDsOfNames(Names: POleStrList;
  Count: Integer; DispIDs: PDispIDList): HResult;
var
  I, DispID: Integer;
  Name: ShortString;
begin
  WideCharToShortString(Names^[0], Name);
  DispID := GetDispIDOfName(ClassType, Name);
  DispIDs^[0] := DispID;
  if Count > 1 then
    for I := 1 to Count - 1 do DispIDs^[I] := -1;
  if (DispID = -1) or (Count > 1) then
    Result := DISP_E_UNKNOWNNAME else
    Result := S_OK;
end;

function TAutoObject.GetOleObject: Variant;
begin
  VarClear(Result);
  TVarData(Result).VType := varDispatch;
  TVarData(Result).VDispatch := FAutoDispatch;
  AddRef;
end;

function TAutoObject.Invoke(DispID: TDispID; Flags: Integer;
  var Params: TDispParams; VarResult: PVariant; ExcepInfo: PExcepInfo;
  ArgErr: PInteger): HResult;
type
  TVarStrDesc = record
    PStr: Pointer;
    BStr: PBStr;
  end;
var
  AutoEntry: PAutoEntry;
  ArgCount, NamedArgCount, ArgIndex, StrCount, I, J, K: Integer;
  ParamPtr, ArgPtr: PVarData;
  ArgType, VarFlag: Byte;
  StringPtr: Pointer;
  OleStr: TBStr;
  ResVar: TVarData;
  Strings: array[0..MaxDispArgs - 1] of TVarStrDesc;
  Args: array[0..MaxDispArgs - 1] of TVarData;
begin
  if Flags = DISPATCH_PROPERTYPUTREF then Flags := DISPATCH_PROPERTYPUT;
  AutoEntry := GetAutoEntry(ClassType, DispID, Flags);
  if (AutoEntry = nil) or (AutoEntry^.Params^.ResType = 0) and
    (VarResult <> nil) then
  begin
    Result := DISP_E_MEMBERNOTFOUND;
    Exit;
  end;
  NamedArgCount := Params.cNamedArgs;
  if Flags = DISPATCH_PROPERTYPUT then Dec(NamedArgCount);