unit AddInObj;

interface

uses
  ComServ, ComObj, ActiveX, SysUtils, Windows, AddInLib, DataImportExport1C;

const
  __AddInName = 'Data';

const
  __PropCount = 0;
  __MethCount = 2;

type
  TAddInObject = class(TComObject, IDispatch, IInitDone, ILanguageExtender)
  private
    FData: TDataImportExport1C;
    F1Cv7: IDispatch;
    FStatusIntf: IStatusLine;
    FExtWindowsIntf: IExtWndsSupport;
    FErrorIntf: IErrorLog;
    FEventIntf: IAsyncEvent;
  protected
    { IInitDone implementation }
    function Init(AConnection: IDispatch): HResult; stdcall;
    function Done: HResult; stdcall;
    function GetInfo(var AInfo: PSafeArray): HResult; stdcall;

    { ILanguageExtender implementation }
    function RegisterExtensionAs(var AExtensionName: WideString): HResult; stdcall;
    function GetNProps(var AProps: Integer): HResult; stdcall;
    function FindProp(const APropName: WideString; var APropNum: Integer): HResult; stdcall;
    function GetPropName(APropNum, APropAlias: Integer; var APropName: WideString): HResult; stdcall;
    function GetPropVal(APropNum: Integer; var APropVal: OleVariant): HResult; stdcall;
    function SetPropVal(APropNum: Integer; var APropVal: OleVariant): HResult; stdcall;
    function IsPropReadable(APropNum: Integer; var APropRead: Integer): HResult; stdcall;
    function IsPropWritable(APropNum: Integer; var APropWrite: Integer): HResult; stdcall;
    function GetNMethods(var AMethods: Integer): HResult; stdcall;
    function FindMethod(const AMethodName: WideString; var AMethodNum: Integer): HResult; stdcall;
    function GetMethodName(AMethodNum, AMethodAlias: Integer; var AMethodName: WideString): HResult; stdcall;
    function GetNParams(AMethodNum: Integer; var AParams: Integer): HResult; stdcall;
    function GetParamDefValue(AMethodNum, AParamNum: Integer; var AParamDefValue: OleVariant): HResult; stdcall;
    function HasRetVal(AMethodNum: Integer; var ARetValue: Integer): HResult; stdcall;
    function CallAsProc(AMethodNum: Integer; var AParams: PSafeArray): HResult; stdcall;
    function CallAsFunc(AMethodNum: Integer; var ARetValue: OleVariant; var AParams: PSafeArray): HResult; stdcall;

    { IStatusLine }
    function SetStatusLine(const bstrSource: WideString): HResult; safecall;
    function ResetStatusLine(): HResult; safecall;

    { IDispatch }
    function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
    function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;

    procedure ShowErrorLog(fMessage: WideString);
  end;

implementation

uses StrUtils, Variants;

{ IInitDone implementation }

function TAddInObject.Init(AConnection: IDispatch): HResult; stdcall;
begin
  FData := TDataImportExport1C.Create;

  F1Cv7 := AConnection;
  if F1Cv7 <> nil then
  begin
    OleCheck(AConnection.QueryInterface(IID_IErrorLog, FErrorIntf));
    OleCheck(AConnection.QueryInterface(IID_IStatusLine, FStatusIntf));
    OleCheck(AConnection.QueryInterface(IID_IAsyncEvent, FEventIntf));
    OleCheck(AConnection.QueryInterface(IID_IExtWndsSupport, FExtWindowsIntf));
  end;

  Init := S_OK;
end;

function TAddInObject.Done: HResult; stdcall;
begin
  FStatusIntf := nil;
  FExtWindowsIntf := nil;
  FErrorIntf := nil;
  FEventIntf := nil;
  FreeAndNil(FData);
  Result := S_OK;
end;

function TAddInObject.GetInfo(var AInfo: PSafeArray): HResult; stdcall;
var
  LVarInfo: OleVariant;
  LVarIndex: Integer;
begin
  LVarIndex := 0;
  LVarInfo := '2000';
  SafeArrayPutElement(AInfo, LVarIndex, LVarInfo);
  Result := S_OK;
end;

{ ILanguageExtender implementation }

function TAddInObject.RegisterExtensionAs(var AExtensionName: WideString): HResult; stdcall;
begin
  AExtensionName := __AddinName;
  RegisterExtensionAs := S_OK;
end;

function TAddInObject.GetNProps(var AProps: Integer): HResult; stdcall;
begin
  AProps := __PropCount;
  Result := S_OK;
end;

function TAddInObject.FindProp(const APropName: WideString; var APropNum: Integer): HResult; stdcall;
begin
  APropNum := -1;
  FindProp := S_FALSE;
end;

function TAddInObject.GetPropName(APropNum, APropAlias: Integer; var APropName: WideString): HResult; stdcall;
begin
  APropName := '';
  GetPropName := S_OK;
end;

function TAddInObject.GetPropVal(APropNum: Integer; var APropVal: OleVariant): HResult; stdcall;
begin
  Result := S_FALSE;
end;

function TAddInObject.SetPropVal(APropNum: Integer; var APropVal: OleVariant): HResult; stdcall;
begin
  Result := S_FALSE;
end;

function TAddInObject.IsPropReadable(APropNum: Integer; var APropRead: Integer): HResult; stdcall;
begin
  Result := S_OK;
end;

function TAddInObject.IsPropWritable(APropNum: Integer; var APropWrite: Integer): HResult; stdcall;
begin
  Result := S_OK;
end;

function TAddInObject.GetNMethods(var AMethods: Integer): HResult; stdcall;
begin
  AMethods := __MethCount;
  Result := S_OK;
end;

function TAddInObject.FindMethod(const AMethodName: WideString; var AMethodNum: Integer): HResult; stdcall;
begin
  AMethodNum := IndexText(AMethodName, ['GetData', 'GetDataStr']);
  if AMethodNum >= 0 then
    Result := S_OK
  else
    Result := S_FALSE;
end;

function TAddInObject.GetMethodName(AMethodNum, AMethodAlias: Integer; var AMethodName: WideString): HResult; stdcall;
begin
  Result := S_OK;
  case AMethodNum of
    0: AMethodName := 'GetData';
    1: AMethodName := 'GetDataStr';
  else
    Result := E_NOTIMPL;
  end;
end;

function TAddInObject.GetNParams(AMethodNum: Integer; var AParams: Integer): HResult; stdcall;
begin
  case AMethodNum of
    0, 1: begin
      AParams := 1;
      REsult := S_OK;
    end;
  else
    Result := S_FALSE;
  end;
end;

function TAddInObject.GetParamDefValue(AMethodNum, AParamNum: Integer; var AParamDefValue: OleVariant): HResult; stdcall;
begin
  VarClear(AParamDefValue);
  GetParamDefValue := S_OK;
end;

function TAddInObject.HasRetVal(AMethodNum: Integer; var ARetValue: Integer): HResult; stdcall;
begin
  ARetValue := 1;
  HasRetVal := S_OK;
end;

function TAddInObject.CallAsProc(AMethodNum: Integer; var AParams: PSafeArray): HResult; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TAddInObject.CallAsFunc(AMethodNum: Integer; var ARetValue: OleVariant; var AParams: PSafeArray): HResult; stdcall;
var
  Index: Integer;
  LParam: OleVariant;
  Data: TBytes;
  Hash: TBytes;
  LVarData: Pointer;
begin
  try
    ARetValue := 0;
    Result := S_OK;
    Index := 0;
    OleCheck(SafeArrayGetElement(AParams, Index, LParam));
    case AMethodNum of
      0: begin
        Hash := FData.GetData(LParam);
      end;
      1: begin
        Data := LParam;
        Hash := FData.GetDataStr(Data);
      end
    else
      Result := E_NOTIMPL;
    end; // case

    if Result = S_OK then
    begin
      ARetValue := VarArrayCreate([0, Length(Hash) - 1], varByte);
      LVarData := VarArrayLock(ARetValue);
      try
        Move(Pointer(Hash)^, LVarData^, Length(Hash));
      finally
        VarArrayUnlock(ARetValue);
      end;
    end;
  except
    on E: Exception do
    begin
      ShowErrorLog(E.Message);
      Result := ERROR_INVALID_DATA;
    end;
  end;
end;

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

/// /////////////////////////////////////////////////////////////////////
function TAddInObject.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  Result := E_NOTIMPL;
end;

/// /////////////////////////////////////////////////////////////////////
function TAddInObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TAddInObject.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params;
  VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

procedure TAddInObject.ShowErrorLog(fMessage: WideString);
var
  ErrInfo: PExcepInfo;
begin
  If (Trim(fMessage) = '') or (FErrorIntf = nil) then
    Exit;

  New(ErrInfo);
  ErrInfo^.bstrSource := __AddinName;
  ErrInfo^.bstrDescription := fMessage;
  ErrInfo^.wCode := 1006;
  ErrInfo^.sCode := E_FAIL;
  FErrorIntf.AddError(nil, ErrInfo);
end;

{ IStatusLine }

function TAddInObject.SetStatusLine(const bstrSource: WideString): HResult;
begin
  Result := S_FALSE;
end;

function TAddInObject.ResetStatusLine: HResult;
begin
  Result := S_FALSE;
end;

begin
  ComServer.SetServerName('AddIn');
  TComObjectFactory.Create(ComServer, TAddInObject, CLSID_AddInObject, __AddInName, 'Data AddIn for 1C V7 2.0', ciMultiInstance);
end.