我在使用“TJclClrHost”组件时遇到了一些麻烦(参见 src 代码中的注释)。搜索后,我发现“CppHostCLR”Microsoft 示例是新的接口路径,以便在 Win32/64 应用程序中托管 .NET 运行时...
这是一个用 Delphi 编写的快速(和肮脏)示例版本(也可以在这里找到:http ://chapsandchips.com/Download/DelphiNETHost_v1.zip )
此示例代码中仅实现了 Delphi 接口(使用“OleVariant”/后期绑定)。
hth,问候。
帕斯卡
unit uDelphiNETHosting;
interface
// Juin 2018 - "CorBindToRuntime*" deprecated API alternative by Pascal Chapuis with "Delphi 10.1 Berlin" version
//
// Sample implementation with .NET 4.0 interfaces defined in "metaHost.h" SDK with Delphi header (partial) source code
// "CLRCreateInstance" (mscorlib) API with "ICLRMetaHost", "ICLRRuntimeInfo", "ICorRuntimeHost" interfaces are used.
//
// This Delphi sample provides :
// - Delphi Win32 .NET runtime advanced hosting
// - .NET class late binding interface with Delphi (OleVariant) Win32/64 application (no REGASM is needed)
// - Interfaced C# class is the same than provided in "CppHostCLR" Microsoft C++ sample available at :
// https://code.msdn.microsoft.com/windowsdesktop/CppHostCLR-e6581ee0/sourcecode?fileId=21953&pathId=1366553273
//
// This sample was inspired by "TJclClrHost" troubles with "_AppDomain.CreateInstanceFrom" with .NET 4.0 :
// - "CorBindToRuntime*" = deprecated API : "old-fashion" interfaced library vs. new interfaced COM/Interop API.
// - AppDomainSetup "ApplicationBase" property (assembly loading with custom path implementation) : no delegated resolver impl.
// - ComVisible .NET annotation is needed at least at class level or/and assembly level.
//
uses
mscorlib_TLB, // imported from C:\Windows\Microsoft.NET\Framework\v4.0.30319\mscorlib.tlb
mscoree_tlb, // imported from C:\Windows\Microsoft.NET\Framework\v4.0...\mscoree.dll
System.Classes, Vcl.Controls, Vcl.StdCtrls,
Windows, Messages, SysUtils, Variants, Graphics, Forms,
Dialogs, activeX, Vcl.ComCtrls;
Const
// ICLRMetaHost GUID
// EXTERN_GUID(IID_ICLRMetaHost, 0xD332DB9E, 0xB9B3, 0x4125, 0x82, 0x07, 0xA1, 0x48, 0x84, 0xF5, 0x32, 0x16);
IID_ICLRMetaHost : TGuid = '{D332DB9E-B9B3-4125-8207-A14884F53216}';
// EXTERN_GUID(CLSID_CLRMetaHost, 0x9280188d, 0xe8e, 0x4867, 0xb3, 0xc, 0x7f, 0xa8, 0x38, 0x84, 0xe8, 0xde);
CLSID_CLRMetaHost : TGuid = '{9280188d-0e8e-4867-b30c-7fa83884e8de}';
// ICLRRuntimeInfo GUID
// EXTERN_GUID(IID_ICLRRuntimeInfo, 0xBD39D1D2, 0xBA2F, 0x486a, 0x89, 0xB0, 0xB4, 0xB0, 0xCB, 0x46, 0x68, 0x91);
IID_ICLRRuntimeInfo : TGuid = '{BD39D1D2-BA2F-486A-89B0-B4B0CB466891}';
CLASS_ICLRRuntimeInfo : TGuid = '{BD39D1D2-BA2F-486a-89B0-B4B0CB466891}';
type
// .NET interface (defined in "metahost.h" SDK header)
ICLRRuntimeInfo = interface(IUnknown)
['{BD39D1D2-BA2F-486a-89B0-B4B0CB466891}']
function GetVersionString( pwzBuffer : PWideChar; var pcchBuffer : DWORD) : HResult; stdcall;
function GetRuntimeDirectory(pwzBuffer : PWideChar; var pcchBuffer : DWORD) : HResult; stdcall;
function IsLoaded( hndProcess : THANDLE; out bLoaded : bool): HResult; stdcall;
function LoadErrorString(iResourceID: UINT; pwzBuffer: PWideChar; var pcchBuffer : DWORD; iLocaleID :LONG): HResult; stdcall;
function LoadLibrary(pwzDllName : PWideChar; phndModule : PHMODULE): HResult; stdcall;
function GetProcAddress( pszProcName : PChar; var ppProc : Pointer) : HResult; stdcall;
function GetInterface( const rclsid : TCLSID;const riid : TIID; out ppUnk : IUnknown) : HResult; stdcall;
function IsLoadable( var pbLoadable : Bool) : HResult; stdcall;
function SetDefaultStartupFlags(dwStartupFlags : DWORD; pwzHostConfigFile : LPCWSTR) : HResult; stdcall;
function GetDefaultStartupFlags(var pdwStartupFlags : PDWORD;pwzHostConfigFile : LPWSTR;var pcchHostConfigFile : DWORD ) : HResult; stdcall;
function BindAsLegacyV2Runtime() : HResult; stdcall;
function IsStarted( var pbStarted : bool;var pdwStartupFlags : DWORD ) : HResult; stdcall;
end;
// .NET interface (defined in "metahost.h" SDK header)
ICLRMetaHost = interface(IUnknown)
['{D332DB9E-B9B3-4125-8207-A14884F53216}']
function GetRuntime(pwzVersion: LPCWSTR; const riid: TIID; out ppRuntime : IUnknown): HResult; stdcall;
function GetVersionFromFile(const pwzFilePath: PWideChar; pwzBuffer: PWideChar; var pcchBuffer: DWORD): HResult; stdcall;
function EnumerateInstalledRuntimes(out ppEnumerator: IEnumUnknown): HResult; stdcall;
function EnumerateLoadedRuntimes(const hndProcess: THandle; out ppEnumerator: IEnumUnknown): HResult; stdcall;
function RequestRuntimeLoadedNotification(out pCallbackFunction: PPointer): HResult; stdcall;
function QueryLegacyV2RuntimeBinding(const riid: TGUID;out ppUnk: PPointer): HResult; stdcall;
procedure ExitProcess(out iExitCode: Int32); stdcall;
end;
TSampleForm = class(TForm)
BtnTest: TButton;
StatusBar1: TStatusBar;
Label1: TLabel;
Label2: TLabel;
procedure BtnTestClick(Sender: TObject);
private
// CLR
FPtrClr : ICLRMetaHost;
// CLR runtime info
FPtrRunTime : ICLRRuntimeInfo;
// CLR Core runtime
FPtrCorHost : ICorRuntimeHost;
FDefaultNetInterface : ICorRuntimeHost;
//
Procedure LoadAndBindAssembly();
public
end;
// Main .NET hosting API entry point (before interfaced stuff)
function CLRCreateInstance(const clsid,iid: TIID; out ppv : IUnknown): HRESULT; stdcall; external 'MSCorEE.dll';
var
SampleForm: TSampleForm;
implementation
uses //JcldotNet // original "TJclClrHost" component unit
math,
ComObj; // COM init + uninit
{$R *.dfm}
Procedure TSampleForm.LoadAndBindAssembly();
Const
NetApp_Base_Dir : WideString = '.\Debug\';
Sample_Test_Value = 3.1415;
var
hr : HResult;
Ov : OleVariant;
ws : WideString;
iDomAppSetup : IUnknown;
iDomApp : IUnknown;
// .Net interfaces...
iDomAppSetup2 : IAppDomainSetup;
iDomApp2 : AppDomain;
objNET : ObjectHandle;
begin
// Delphi sample : https://adamjohnston.me/delphi-dotnet-interop-with-jvcl/
// DomainSetup
hr := FDefaultNetInterface.CreateDomainSetup( iDomAppSetup );
if ( hr = S_OK) then
begin
// Domain Setup Application...
iDomAppSetup2 := iDomAppSetup as IAppDomainSetup;
// NB. Set "ApplicationBase" root directory is NOT ok WITHOUT additional "ResolveEventHandler" (cf 1*)
// https://weblog.west-wind.com/posts/2009/Jan/19/Assembly-Loading-across-AppDomains
hr := iDomAppSetup2.Set_ApplicationBase( NetApp_Base_Dir );
//hr := iDomAppSetup2.Set_PrivateBinPath( NetApp_Base_Dir );
//hr := iDomAppSetup2.Set_DynamicBase( NetApp_Base_Dir );
if ( hr = S_OK ) then
begin
hr := iDomAppSetup2.Set_ConfigurationFile('CSClassLibrary.config');
if ( hr = S_OK ) then
begin
hr := FDefaultNetInterface.CreateDomainEx( PWideChar('aNETClassHostSample'), iDomAppSetup2, nil, iDomApp );
if ( hr = S_OK ) then
begin
iDomApp2 := iDomApp as AppDomain;
iDomApp2.Get_BaseDirectory(ws); // *** Check setup directory is OK
// CoBindEx... API troubles begins here... alternative (not deprecated implementation) solves them !
// CreateInstanceFrom Doc : https://msdn.microsoft.com/en-us/library/we62chk6(v=vs.110).aspx
//hr := (iDomApp as _AppDomain).CreateInstanceFrom( 'C:\Data\dev\delphi\NetHosting\Sample\CppHostCLR\C# and C++\C#,C++\CppHostCLR\CSClassLibrary\obj\Debug\CSClassLibrary.dll', 'CSClassLibrary.CSSimpleObject', objNET );
hr := iDomApp2.CreateInstanceFrom( NetApp_Base_Dir+'CSClassLibrary.dll', // (1*) : NO ResolveEventHandler => absolute path
'CSClassLibrary.CSSimpleObject', objNET );
if ( hr = S_OK ) then
begin
// *** NB. ***
// [ComVisible(true)] annotation on class definition is NEEDED (to invoke via late binding with COM)
// *** and/or ***
// .NET project option "Make assembly COM visible" (cf. AssemblyInfo.cs) : [assembly: ComVisible(true)]
ov := objNET.Unwrap;
ov.FloatProperty := Sample_Test_Value;
ShowMessage( 'Result FloatProperty=' +FloatToStr( Currency(ov.FloatProperty) ) ); // Interop data type between Delphi and C# (Currency <=> float)
end
else ShowMessage( 'CreateInstanceFrom error: ' + SysErrorMessage(hr) );
end
else ShowMessage( 'CreateDomainEx error: ' + SysErrorMessage(hr) );
end
else ShowMessage( 'Set_ConfigurationFile error: ' + SysErrorMessage(hr) );
end
else ShowMessage( 'Set_ApplicationBase error: ' + SysErrorMessage(hr) );
end
else ShowMessage( 'CreateDomainSetup error: ' + SysErrorMessage(hr) );
end;
procedure TSampleForm.BtnTestClick(Sender: TObject);
var
// CLR status flags
FLoadable : Bool; // framework is loadable ?
FStarted : Bool; // framework is started ?
FLoaded : Bool; // framework is loaded ?
arrWideChar : Array[0..30] of WChar;
lArr : Cardinal;
Flags : DWORD;
hr1,hr2,hr3 : HResult;
begin
// Part-1/2 : Host targetted .NET framework version with "CLRCreateInstance" entry point
//CoInitializeEx(nil,COINIT_APARTMENTTHREADED); //COINIT_MULTITHREADED
try
FLoadable := false;
FStarted := false;
FLoaded := false;
Flags := $ffff;
try
FPtrClr := nil;
FPtrRunTime := nil;
FPtrCorHost := nil;
hr1 := CLRCreateInstance(CLSID_CLRMetaHost, IID_ICLRMetaHost, IUnknown(FPtrClr) ); // CLSID + IID
if ( hr1 = S_OK) then
begin
FPtrRunTime := nil;
hr1 := FPtrClr.GetRuntime( PWideChar('v4.0.30319'), IID_ICLRRuntimeInfo, IUnknown(FPtrRunTime) );
if ( hr1 = S_OK ) then
begin
// Usefull to check overflow in case of wrong API prototype : call second method overflow other results...
hr1 := FPtrRunTime.IsLoadable( FLoadable );
hr2 := FPtrRunTime.IsStarted( FStarted, Flags ); // NB. OVERFLOW by defining FLoadable, FLoaded... local var. as "boolean" NOT "Bool"...
hr3 := FPtrRunTime.IsLoaded( GetCurrentProcess(), FLoaded );
if ( hr1 = S_OK ) and ( hr2 = S_OK ) and ( hr3 = S_OK ) then
begin
if ( not FLoaded ) and ( FLoadable ) and ( not FStarted ) then
begin
hr1 := FPtrRunTime.GetInterface( CLASS_CorRuntimeHost, IID_ICorRuntimeHost, IUnknown(FPtrCorHost) ); // IID_ICorRuntimeHost,
if ( hr1 = S_OK ) then
begin
if ( FPtrCorHost <> nil ) then
FDefaultNetInterface := (FPtrCorHost as Iunknown) as ICorRuntimeHost
else ; // NOT available...
end
else ShowMessage( 'GetInterface error : ' + SysErrorMessage(hr1) );
end
else
begin
if (FLoaded and FStarted) then ShowMessage( '.NET Framework version is already loaded and started...')
else ShowMessage( '.NET Framework version is N0T loadable...');
end;
end
else
begin
ShowMessage( 'IID_ICLRRuntimeInfo.IsLoadable error : ' + SysErrorMessage( Min(hr1,hr2) ) );
end;
end
else ShowMessage( 'GetRuntime error : ' + SysErrorMessage(hr1) );
end
else ShowMessage( 'CLRCreateInstance error: ' + SysErrorMessage(hr1) );
Except on e:exception do
if Assigned( e.InnerException ) then ShowMessage( e.InnerException.ToString )
else ShowMessage( e.ToString );
end;
// Check a call to an assembly...
if ( Assigned( FDefaultNetInterface )) then
begin
lArr := SizeOf( arrWideChar );
FillChar( arrWideChar, SizeOf(arrWideChar), #0);
hr1 := FPtrRunTime.GetVersionString( PWideChar(@arrWideChar[0]), lArr);;
if ( hr1 = S_OK ) then ShowMessage('Framework version '+arrWideChar+' is available...')
else ShowMessage( 'GetVersionString error: ' + SysErrorMessage(hr1));
hr1 := FDefaultNetInterface.Start();
if ( hr1 <> S_OK ) then ShowMessage( 'CLRCreateInstance error: ' + SysErrorMessage(hr1) );
end;
finally
// if (PtrClr<>nil) then
// begin
// PtrClr._Release;
// //PtrClr := nil;
// end;
// if (PtrRunTime<>nil) then
// begin
// PtrRunTime._Release;
// /// PtrRunTime := nil;
// end;
// if (PtrCorHost<>nil) then
// begin
// PtrCorHost._Release;
// //PtrCorHost := nil;
// end;
//FDefaultInterface._Release;
//CoUnInitialize();
end;
// Part-2/2 : load, bind a class call sample assembly class with loaded framework...
LoadAndBindAssembly();
end;
end.