原来代码基础上删除了一些,所以可能编译的时候也许会有一些小问题.
library F1AddIn;
uses
ComServ,
F1AddInUnit in 'F1AddInUnit.pas';
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer,
F1AddInInit;
begin
end.
unit F1AddInUnit;
interface
uses windows,dialogs,Sysutils,TTF160_TLB;
const
F1_E_NULL = $0040001
// #NULL!
F1_E_DIVZERO = $0040002
// #DIV/0!
F1_E_VALUE = $0040003
// #VALUE!
F1_E_REF = $0040004
// #REF!
F1_E_NAME = $0040005
// #NAME?
F1_E_NUM = $0040006
// #NUM!
F1_E_NA = $0040007
// #N/A
type
TOleVariantArray=array of Variant;
pOleVariantArray=TOleVariantArray;
TF1ADDIN_FUNCTION = function(var pResult: OleVariant;
nReserved: Integer;
nArgs: Integer;
pArgs: pOleVariantArray): HRESULT stdcall;
TF1AddInRegisterFunctionProc = function(pwszName: LPCWSTR;
nReserved: Integer;
pFunction: TF1ADDIN_FUNCTION;
nArgs: Integer): HRESULT stdcall;
TF1AddINRegisterInfoProc = function(pwszName,pwszDescription: LPCWSTR;
nReserved1,nReserved2: Integer): HRESULT stdcall;
function MakeErrorResult(var pResult: OleVariant
hrEval: HRESULT = S_OK): HRESULT;
function F1AddInInit(RegisterInfoProc: TF1AddInRegisterInfoProc;
RegisterFunctionProc: TF1AddInRegisterFunctionProc;
nReserved1,nReserved2: Integer): HRESULT stdcall;
function MyAdd(var pResult: OleVariant;
nReserved: Integer;
nArgs: Integer;
pArgs: pOleVariantArray): HRESULT
stdcall;
implementation
{$M+}
{$TYPEINFO ON}
function F1AddInInit(RegisterInfoProc: TF1AddInRegisterInfoProc;
RegisterFunctionProc: TF1AddInRegisterFunctionProc;
nReserved1,nReserved2: Integer): HRESULT stdcall;
var
hr: HRESULT;
begin
hr := S_OK;
if SUCCEEDED(hr) then
hr := RegisterFunctionProc('MyAdd',0,MyAdd,2);
if (SUCCEEDED(hr)) then
hr := RegisterInfoProc('Delphi F1book Add_In','',0,0);
Result := hr;
end;
function CheckReturnValue(hr: HRESULT): HRESULT;
begin
if FAILED(hr) then
Result := E_OUTOFMEMORY
else
Result := S_OK;
end;
function MyAdd(var pResult: OleVariant;
nReserved: Integer;
nArgs: Integer;
pArgs: pOleVariantArray): HRESULT
stdcall;
begin
if nArgs = 2 then begin
if (TvarData(pArgs[0]).VType = varDouble) and (TvarData(pArgs[1]).VType = varDouble) then begin
pResult := TvarData(pArgs[0]).VDouble + TvarData(pArgs[1]).VDouble;
Result := S_OK;
Exit;
end;
end;
Result := MakeErrorResult(pResult, F1_E_VALUE);
end;
function MakeErrorResult(var pResult: OleVariant
hrEval: HRESULT = S_OK): HRESULT;
begin
if hrEval <> S_OK then begin
varClear(pResult);
TvarData(pResult).vType := varError;
TvarData(pResult).vError := hrEval;
end;
Result := S_OK;
end;