DLL/COM抛出内部异常的解决方法

使用DLL封装类时，内部异常会提示错误发生在XXX.DLL之类无用的信息，而COM就可以正确处理，通过重载TObject的SafeCallException并使用safecall关键字声明调用，如：
uTest_inf.pas

const
 C lass_Test = TGUID = '{xxxx-xxxx-xxxx-xxxx}';

type
ITest = interface
  ['{xxxx-xxxx-xxxx-xxxx}']
  procedure test;  safecall;  //不能用stdcall;
end;

uTest.pas
type
TTest = class(TInterfacedObject,ITest)
public
  procedure test;  safecall;
  function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override;
end;

implementation

procedure TTest.Test;
begin
  raise Exception.Create('TEST 错误');
end;

function TTest.SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult;
begin
    Result := ComObj.HandleSafeCallException(ExceptObject, ExceptAddr,GUID_NULL, '', '');

end;
end.

或是直接将DLL封装成COM，在项目文件中作如下修改：
Uses
   ComServ,  //新增引用

//新增导出四个函数
exports
  DllGetClassObject,
  DllCanUnloadNow,
  DllRegisterServer,
  DllUnregisterServer;

然后保存项目，IDE会自动增加一个 项目名_LTB.pas 的单元，如Test_LTB.pas，这样DLL就从普通DLL变成了COM DLL。

接口单元uTest_Inf.pas不必修改，类单元做以下修改：
uTest.pas

TTest = class(TComObject,ITest)  //由TInterfacedObject改成TComObject
public
  procedure test;  safecall; 
  //function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override;end; //这个不需要了，TComObject已经实现。

//增加初始化节
initialization
 TComObjectFactory.Create(ComServer,TTest,CLASS_Test,'Test','Test',ciMultiInstance,tmApartment);  

将TTest.Create中的代码移到TTest.Initialize中，删除Create，这样原来的类就变成COM对象了，COM注册后，就可以使用以下方法调用：
   aTest := CreateCOMObject(Class_Test);

如果不想注册，则可以通过手动加载DLL的方式进行访问:

function CreateComObjectFromDll(CLSID: TGUID; DllHandle: THandle): IUnknown;
var
  Factory: IClassFactory;
  DllGetClassObject: function(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
  hr: HRESULT;
begin
  DllGetClassObject := GetProcAddress(DllHandle, 'DllGetClassObject');
  if Assigned(DllGetClassObject) then
  begin
    hr := DllGetClassObject(CLSID, IClassFactory, Factory);
    if hr = S_OK then
    try
      hr := Factory.CreateInstance(nil, IUnknown, Result);
      if hr = S_OK then begin
      end;
    except
      ShowMessage(IntToStr(GetLastError));
    end;
  end;
end;

调用时要注意，DLL不能马上释放，必须是生成的接口的生命期结束后，才能释放DLL，例如：
var
   aTest: ITest;
   h: Cardinal;
begin
   h := LoadLibrary('Test.dll');
   if h < 32 then
  begin
      showmessage('加载错误');
      exit;
  end;
  atest := CreateComObjectFromDll(CLSID,h) as ITest;
  atest.test;  // 出错误提示
  atest := nil;
  FreeLibrary(h);  //如果是需要一直驻留的，就不必管它，由主程序自动FREE
end
   
不想使用COM的话，当普通DLL封装也一样有效，例如在DLL的项目文件中加上：
function MyGetDllInterface: IInterface; safecall;
begin
    Result := TTest.Create;
end; 

exports
   MyGetDllInterface;