I made property handler extension (Like a "Title" property column) for some file types but when I want to register Shell extension for real types like avi or 3gp extension wont work but another types like avi1 or 3gp1 works like a charm.
I search regisrery and PropertyHandler added for avi and avi1 but for avi found a key named "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\PropertySystem\SystemPropertyHandlers" that contain values for 3gp and avi and it has a different value than my handler and I cant change or delete this value.
I want to ask how can I change these type property handler in SystemPropertyHandlers?For example add Title property for avi file.
EDIT:
This is the code if help to solve problem :
type
TPropertyStoreExtension6 = class(TdecShellPropertyStoreExtension)
protected
class function GetClassID: TCLSID; override;
class function GetDescription: UnicodeString; override;
procedure FillProgIDList(AList: TStrings); override;
procedure Clear; override;
function GetPropertyCount: Integer; override;
function GetPropertyKey(AIndex: Integer): TPropertyKey; override;
function GetPropertyName(AIndex: Integer): UnicodeString; override;
procedure LoadDataFromFile(const AFileName: UnicodeString;
AOpenMode: DWORD); override;
procedure LoadDataFromFolder(const AFolderName: UnicodeString); override;
function GetAvailablePropertyCount: Integer; override;
function AvailableIndexToIndex(AIndex: Integer): Integer; override;
function GetPropertyValue(AIndex: Integer): OleVariant; override;
procedure CommitToFile(const AFileName: UnicodeString;
AOpenMode: DWORD); override;
private
Filename: UnicodeString;
end;
implementation
uses SysUtils, Variants;
class function TPropertyStoreExtension6.GetClassID: TCLSID;
begin
Result := SID_TPropertyStoreExtension6;
end;
class function TPropertyStoreExtension6.GetDescription: UnicodeString;
begin
Result := 'Your handler description';
end;
procedure TPropertyStoreExtension6.FillProgIDList(AList: TStrings);
begin
AList.Add(UnicodeStringToString('.avi'));
AList.Add(UnicodeStringToString('.avi1'));
end;
procedure TPropertyStoreExtension6.Clear;
begin
inherited Clear;
end;
function TPropertyStoreExtension6.GetPropertyCount: Integer;
begin
Result := 3;
end;
function TPropertyStoreExtension6.GetPropertyKey(AIndex: Integer): TPropertyKey;
begin
ZeroMemory(#Result, SizeOf(Result));
case AIndex of
0:
Result := PKEY_Title;
end;
end;
function TPropertyStoreExtension6.GetPropertyName(AIndex: Integer)
: UnicodeString;
begin
Result := '';
case AIndex of
0:
Result := 'Title';
end;
end;
procedure TPropertyStoreExtension6.LoadDataFromFile(const AFileName
: UnicodeString; AOpenMode: DWORD);
begin
end;
procedure TPropertyStoreExtension6.LoadDataFromFolder(const AFolderName
: UnicodeString);
begin
end;
function TPropertyStoreExtension6.GetAvailablePropertyCount: Integer;
begin
Result := 1
end;
function TPropertyStoreExtension6.AvailableIndexToIndex
(AIndex: Integer): Integer;
begin
Result := AIndex
end;
function TPropertyStoreExtension6.GetPropertyValue(AIndex: Integer): OleVariant;
begin
case AIndex of
0:
Result := 'Title is here';
end;
end;
procedure TPropertyStoreExtension6.CommitToFile(const AFileName: UnicodeString;
AOpenMode: DWORD);
begin
end;
initialization
TPropertyStoreExtension6.Register;
end.
EDIT :
I just test this way but this error happen:
Unable to save permission changes on SystemPropertyHandlers.
EDIT :
I change permission like here and change key value but still my property handler wont work for avi.
EDIT :
I solved problem with deleting .avi from "SystemPropertyHandlers" and now everything works.But I still have question how can I done this without deleting and most important how done this in user PC?
Related
I built a Class Library (in the .NET Framework) in C# that enables the extraction of information from the following json file:
{
"Class2": {
"array_1_class2":[1603924965, 1603925021],
"array_2_class2":[1603925041,1603925054]
},
"Class3":{
"array_1_class3":[1,2,3,4],
"array_2_class3":[5,6,8,9,10]
}
}
Here is the code developed in C#:
using System;
using System.IO;
using Newtonsoft.Json;
namespace dll
{
public class Class1
{
public Class2 class2;
public Class3 class3;
}
public class Class2
{
public int[] array_1_class2;
public int[] array_2_class2;
}
public class Class3
{
public int[] array_1_class3;
public int[] array_2_class3;
}
public class Class4
{
public Class1 LoadJson(string filePath)
{
using (StreamReader r = new StreamReader(filePath))
{
string json = r.ReadToEnd();
Class1 Data = JsonConvert.DeserializeObject<Class1>(json);
return Data;
}
}
}
}
I built another C# program in order to test the code developed and I came to the conclusion that it works.
Then, I tried to do the same in Delphi. I called the .NET DLL from a console application in Delphi by turning the library COM visible and importing it as a Type Library. Accordingly, code was generated in the resultant TypeLibName_TLB unit, as specified in Code Generated When You Import Type Library Information. Consequently, array_1_class2, array_2_class2, array_1_class3, array_2_class3 became PSafeArrays.
My goal is to write all the arrays in the console. However, in the following example, I will only attempt to print array_1_class2. Here is the code that I wrote in Delphi:
program dllTester;
{$APPTYPE CONSOLE} {$POINTERMATH ON}
{$R *.res}
uses
System.SysUtils,
Variants,
Classes,
ActiveX,
FMX.Memo,
dll_TLB in 'dll_TLB.pas';
var
filePath : WideString;
V_class1: _Class1;
V_class2: TClass2;
V_class3: TClass3;
V_class4: TClass4;
Class2_SafeArray: PSafeArray;
Class2_LBound, Class2_UBound, I: LongInt;
Index: LongInt;
LData: array[0..1] of integer;
begin
CoInitialize(nil);
V_class4:= TClass4.Create(nil);
V_class2:= TClass2.Create(nil);
try
filePath:='C:\Users\Documents\file.json';
V_class1 := V_class4.LoadJson(filePath);
finally
V_class4.Free;
end;
//get the PSafeArray
Class2_SafeArray := V_class2.array_1_class2;
//get the bounds
SafeArrayGetLBound(Class2_SafeArray, 1, Class2_LBound);
SafeArrayGetUBound(Class2_SafeArray, 1, Class2_UBound);
WriteLn('Class2 array_1:');
for I := Class2_LBound to Class2_UBound do
begin
Index:=I;
SafeArrayGetElement(Class2_SafeArray, Index , LData);
end;
WriteLn(LData[0]) ;
WriteLn(LData[1]) ;
ReadLn;
SafeArrayDestroy(Class2_SafeArray);
CoUninitialize();
end.
When I run the code, the following text is written in the console:
Class2 array_1:
0
0
This means that LData doesn't have the correct information. It should have 1603924965 and 1603925021, but it has 0 and 0 instead.
Additionally, I cannot finish debugging my code. The debugger gets stuck at ReadLn.
Here is the code of the dll_TLB unit:
unit dll_TLB;
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}
{$ALIGN 4}
interface
uses Winapi.Windows, mscorlib_TLB, System.Classes, System.Variants, System.Win.StdVCL, Vcl.Graphics, Vcl.OleServer, Winapi.ActiveX;
// *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:
// Type Libraries : LIBID_xxxx
// CoClasses : CLASS_xxxx
// DISPInterfaces : DIID_xxxx
// Non-DISP interfaces: IID_xxxx
// *********************************************************************//
const
// TypeLibrary Major and minor versions
dllMajorVersion = 1;
dllMinorVersion = 0;
LIBID_dll: TGUID = '{E4D3D725-8DFA-4EFE-8729-D412EC40D6FF}';
IID__Class1: TGUID = '{E2C374EE-FAC0-38E2-B188-925F1A47CAA2}';
IID__Class2: TGUID = '{70E4C4D8-1C96-337C-A3B1-90217021B4D7}';
IID__Class3: TGUID = '{4C6F2CFA-C886-3B6F-90ED-0EBBAC07E3F6}';
IID__Class4: TGUID = '{7FBDFC4C-887D-3891-81F6-AD1D99057826}';
CLASS_Class1: TGUID = '{465A4623-BB3D-3C8C-8D86-663855D180CD}';
CLASS_Class2: TGUID = '{7FF9F5CF-1C3B-3234-B5B1-F7EF39E18356}';
CLASS_Class3: TGUID = '{F412CD3D-4246-3970-A46A-3830175F5775}';
CLASS_Class4: TGUID = '{6C78853D-D584-35FF-8CD9-7C7214DFCA8F}';
type
// *********************************************************************//
// Forward declaration of types defined in TypeLibrary
// *********************************************************************//
_Class1 = interface;
_Class1Disp = dispinterface;
_Class2 = interface;
_Class2Disp = dispinterface;
_Class3 = interface;
_Class3Disp = dispinterface;
_Class4 = interface;
_Class4Disp = dispinterface;
// *********************************************************************//
// Declaration of CoClasses defined in Type Library
// (NOTE: Here we map each CoClass to its Default Interface)
// *********************************************************************//
Class1 = _Class1;
Class2 = _Class2;
Class3 = _Class3;
Class4 = _Class4;
// *********************************************************************//
// Interface: _Class1
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {E2C374EE-FAC0-38E2-B188-925F1A47CAA2}
// *********************************************************************//
_Class1 = interface(IDispatch)
['{E2C374EE-FAC0-38E2-B188-925F1A47CAA2}']
function Get_ToString: WideString; safecall;
function Equals(obj: OleVariant): WordBool; safecall;
function GetHashCode: Integer; safecall;
function GetType: _Type; safecall;
function Get_Class2: _Class2; safecall;
procedure _Set_Class2(const pRetVal: _Class2); safecall;
function Get_Class3: _Class3; safecall;
procedure _Set_Class3(const pRetVal: _Class3); safecall;
property ToString: WideString read Get_ToString;
property Class2: _Class2 read Get_Class2 write _Set_Class2;
property Class3: _Class3 read Get_Class3 write _Set_Class3;
end;
// *********************************************************************//
// DispIntf: _Class1Disp
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {E2C374EE-FAC0-38E2-B188-925F1A47CAA2}
// *********************************************************************//
_Class1Disp = dispinterface
['{E2C374EE-FAC0-38E2-B188-925F1A47CAA2}']
property ToString: WideString readonly dispid 0;
function Equals(obj: OleVariant): WordBool; dispid 1610743809;
function GetHashCode: Integer; dispid 1610743810;
function GetType: _Type; dispid 1610743811;
property Class2: _Class2 dispid 1610743812;
property Class3: _Class3 dispid 1610743814;
end;
// *********************************************************************//
// Interface: _Class2
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {70E4C4D8-1C96-337C-A3B1-90217021B4D7}
// *********************************************************************//
_Class2 = interface(IDispatch)
['{70E4C4D8-1C96-337C-A3B1-90217021B4D7}']
function Get_ToString: WideString; safecall;
function Equals(obj: OleVariant): WordBool; safecall;
function GetHashCode: Integer; safecall;
function GetType: _Type; safecall;
function Get_array_1_class2: PSafeArray; safecall;
procedure Set_array_1_class2(pRetVal: PSafeArray); safecall;
function Get_array_2_class2: PSafeArray; safecall;
procedure Set_array_2_class2(pRetVal: PSafeArray); safecall;
property ToString: WideString read Get_ToString;
property array_1_class2: PSafeArray read Get_array_1_class2 write Set_array_1_class2;
property array_2_class2: PSafeArray read Get_array_2_class2 write Set_array_2_class2;
end;
// *********************************************************************//
// DispIntf: _Class2Disp
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {70E4C4D8-1C96-337C-A3B1-90217021B4D7}
// *********************************************************************//
_Class2Disp = dispinterface
['{70E4C4D8-1C96-337C-A3B1-90217021B4D7}']
property ToString: WideString readonly dispid 0;
function Equals(obj: OleVariant): WordBool; dispid 1610743809;
function GetHashCode: Integer; dispid 1610743810;
function GetType: _Type; dispid 1610743811;
property array_1_class2: {NOT_OLEAUTO(PSafeArray)}OleVariant dispid 1610743812;
property array_2_class2: {NOT_OLEAUTO(PSafeArray)}OleVariant dispid 1610743814;
end;
// *********************************************************************//
// Interface: _Class3
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {4C6F2CFA-C886-3B6F-90ED-0EBBAC07E3F6}
// *********************************************************************//
_Class3 = interface(IDispatch)
['{4C6F2CFA-C886-3B6F-90ED-0EBBAC07E3F6}']
function Get_ToString: WideString; safecall;
function Equals(obj: OleVariant): WordBool; safecall;
function GetHashCode: Integer; safecall;
function GetType: _Type; safecall;
function Get_array_1_class3: PSafeArray; safecall;
procedure Set_array_1_class3(pRetVal: PSafeArray); safecall;
function Get_array_2_class3: PSafeArray; safecall;
procedure Set_array_2_class3(pRetVal: PSafeArray); safecall;
property ToString: WideString read Get_ToString;
property array_1_class3: PSafeArray read Get_array_1_class3 write Set_array_1_class3;
property array_2_class3: PSafeArray read Get_array_2_class3 write Set_array_2_class3;
end;
// *********************************************************************//
// DispIntf: _Class3Disp
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {4C6F2CFA-C886-3B6F-90ED-0EBBAC07E3F6}
// *********************************************************************//
_Class3Disp = dispinterface
['{4C6F2CFA-C886-3B6F-90ED-0EBBAC07E3F6}']
property ToString: WideString readonly dispid 0;
function Equals(obj: OleVariant): WordBool; dispid 1610743809;
function GetHashCode: Integer; dispid 1610743810;
function GetType: _Type; dispid 1610743811;
property array_1_class3: {NOT_OLEAUTO(PSafeArray)}OleVariant dispid 1610743812;
property array_2_class3: {NOT_OLEAUTO(PSafeArray)}OleVariant dispid 1610743814;
end;
// *********************************************************************//
// Interface: _Class4
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {7FBDFC4C-887D-3891-81F6-AD1D99057826}
// *********************************************************************//
_Class4 = interface(IDispatch)
['{7FBDFC4C-887D-3891-81F6-AD1D99057826}']
function Get_ToString: WideString; safecall;
function Equals(obj: OleVariant): WordBool; safecall;
function GetHashCode: Integer; safecall;
function GetType: _Type; safecall;
function LoadJson(const filePath: WideString): _Class1; safecall;
property ToString: WideString read Get_ToString;
end;
// *********************************************************************//
// DispIntf: _Class4Disp
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {7FBDFC4C-887D-3891-81F6-AD1D99057826}
// *********************************************************************//
_Class4Disp = dispinterface
['{7FBDFC4C-887D-3891-81F6-AD1D99057826}']
property ToString: WideString readonly dispid 0;
function Equals(obj: OleVariant): WordBool; dispid 1610743809;
function GetHashCode: Integer; dispid 1610743810;
function GetType: _Type; dispid 1610743811;
function LoadJson(const filePath: WideString): _Class1; dispid 1610743812;
end;
// *********************************************************************//
// The Class CoClass1 provides a Create and CreateRemote method to
// create instances of the default interface _Class1 exposed by
// the CoClass Class1. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoClass1 = class
class function Create: _Class1;
class function CreateRemote(const MachineName: string): _Class1;
end;
// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object : TClass1
// Help String :
// Default Interface: _Class1
// Def. Intf. DISP? : No
// Event Interface:
// TypeFlags : (2) CanCreate
// *********************************************************************//
TClass1 = class(TOleServer)
private
FIntf: _Class1;
function GetDefaultInterface: _Class1;
protected
procedure InitServerData; override;
function Get_ToString: WideString;
function Get_Class2: _Class2;
procedure _Set_Class2(const pRetVal: _Class2);
function Get_Class3: _Class3;
procedure _Set_Class3(const pRetVal: _Class3);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Connect; override;
procedure ConnectTo(svrIntf: _Class1);
procedure Disconnect; override;
function Equals(obj: OleVariant): WordBool;
function GetHashCode: Integer;
function GetType: _Type;
property DefaultInterface: _Class1 read GetDefaultInterface;
property ToString: WideString read Get_ToString;
property Class2: _Class2 read Get_Class2 write _Set_Class2;
property Class3: _Class3 read Get_Class3 write _Set_Class3;
published
end;
// *********************************************************************//
// The Class CoClass2 provides a Create and CreateRemote method to
// create instances of the default interface _Class2 exposed by
// the CoClass Class2. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoClass2 = class
class function Create: _Class2;
class function CreateRemote(const MachineName: string): _Class2;
end;
// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object : TClass2
// Help String :
// Default Interface: _Class2
// Def. Intf. DISP? : No
// Event Interface:
// TypeFlags : (2) CanCreate
// *********************************************************************//
TClass2 = class(TOleServer)
private
FIntf: _Class2;
function GetDefaultInterface: _Class2;
protected
procedure InitServerData; override;
function Get_ToString: WideString;
function Get_array_1_class2: PSafeArray;
procedure Set_array_1_class2(pRetVal: PSafeArray);
function Get_array_2_class2: PSafeArray;
procedure Set_array_2_class2(pRetVal: PSafeArray);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Connect; override;
procedure ConnectTo(svrIntf: _Class2);
procedure Disconnect; override;
function Equals(obj: OleVariant): WordBool;
function GetHashCode: Integer;
function GetType: _Type;
property DefaultInterface: _Class2 read GetDefaultInterface;
property ToString: WideString read Get_ToString;
property array_1_class2: PSafeArray read Get_array_1_class2 write Set_array_1_class2;
property array_2_class2: PSafeArray read Get_array_2_class2 write Set_array_2_class2;
published
end;
// *********************************************************************//
// The Class CoClass3 provides a Create and CreateRemote method to
// create instances of the default interface _Class3 exposed by
// the CoClass Class3. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoClass3 = class
class function Create: _Class3;
class function CreateRemote(const MachineName: string): _Class3;
end;
// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object : TClass3
// Help String :
// Default Interface: _Class3
// Def. Intf. DISP? : No
// Event Interface:
// TypeFlags : (2) CanCreate
// *********************************************************************//
TClass3 = class(TOleServer)
private
FIntf: _Class3;
function GetDefaultInterface: _Class3;
protected
procedure InitServerData; override;
function Get_ToString: WideString;
function Get_array_1_class3: PSafeArray;
procedure Set_array_1_class3(pRetVal: PSafeArray);
function Get_array_2_class3: PSafeArray;
procedure Set_array_2_class3(pRetVal: PSafeArray);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Connect; override;
procedure ConnectTo(svrIntf: _Class3);
procedure Disconnect; override;
function Equals(obj: OleVariant): WordBool;
function GetHashCode: Integer;
function GetType: _Type;
property DefaultInterface: _Class3 read GetDefaultInterface;
property ToString: WideString read Get_ToString;
property array_1_class3: PSafeArray read Get_array_1_class3 write Set_array_1_class3;
property array_2_class3: PSafeArray read Get_array_2_class3 write Set_array_2_class3;
published
end;
// *********************************************************************//
// The Class CoClass4 provides a Create and CreateRemote method to
// create instances of the default interface _Class4 exposed by
// the CoClass Class4. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoClass4 = class
class function Create: _Class4;
class function CreateRemote(const MachineName: string): _Class4;
end;
// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object : TClass4
// Help String :
// Default Interface: _Class4
// Def. Intf. DISP? : No
// Event Interface:
// TypeFlags : (2) CanCreate
// *********************************************************************//
TClass4 = class(TOleServer)
private
FIntf: _Class4;
function GetDefaultInterface: _Class4;
protected
procedure InitServerData; override;
function Get_ToString: WideString;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Connect; override;
procedure ConnectTo(svrIntf: _Class4);
procedure Disconnect; override;
function Equals(obj: OleVariant): WordBool;
function GetHashCode: Integer;
function GetType: _Type;
function LoadJson(const filePath: WideString): _Class1;
property DefaultInterface: _Class4 read GetDefaultInterface;
property ToString: WideString read Get_ToString;
published
end;
procedure Register;
resourcestring
dtlServerPage = 'ActiveX';
dtlOcxPage = 'ActiveX';
implementation
uses System.Win.ComObj;
class function CoClass1.Create: _Class1;
begin
Result := CreateComObject(CLASS_Class1) as _Class1;
end;
class function CoClass1.CreateRemote(const MachineName: string): _Class1;
begin
Result := CreateRemoteComObject(MachineName, CLASS_Class1) as _Class1;
end;
procedure TClass1.InitServerData;
const
CServerData: TServerData = (
ClassID: '{465A4623-BB3D-3C8C-8D86-663855D180CD}';
IntfIID: '{E2C374EE-FAC0-38E2-B188-925F1A47CAA2}';
EventIID: '';
LicenseKey: nil;
Version: 500);
begin
ServerData := #CServerData;
end;
procedure TClass1.Connect;
var
punk: IUnknown;
begin
if FIntf = nil then
begin
punk := GetServer;
Fintf:= punk as _Class1;
end;
end;
procedure TClass1.ConnectTo(svrIntf: _Class1);
begin
Disconnect;
FIntf := svrIntf;
end;
procedure TClass1.DisConnect;
begin
if Fintf <> nil then
begin
FIntf := nil;
end;
end;
function TClass1.GetDefaultInterface: _Class1;
begin
if FIntf = nil then
Connect;
Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call "Connect" or "ConnectTo" before this operation');
Result := FIntf;
end;
constructor TClass1.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TClass1.Destroy;
begin
inherited Destroy;
end;
function TClass1.Get_ToString: WideString;
begin
Result := DefaultInterface.ToString;
end;
function TClass1.Get_Class2: _Class2;
begin
Result := DefaultInterface.Class2;
end;
procedure TClass1._Set_Class2(const pRetVal: _Class2);
begin
DefaultInterface.Class2 := pRetVal;
end;
function TClass1.Get_Class3: _Class3;
begin
Result := DefaultInterface.Class3;
end;
procedure TClass1._Set_Class3(const pRetVal: _Class3);
begin
DefaultInterface.Class3 := pRetVal;
end;
function TClass1.Equals(obj: OleVariant): WordBool;
begin
Result := DefaultInterface.Equals(obj);
end;
function TClass1.GetHashCode: Integer;
begin
Result := DefaultInterface.GetHashCode;
end;
function TClass1.GetType: _Type;
begin
Result := DefaultInterface.GetType;
end;
class function CoClass2.Create: _Class2;
begin
Result := CreateComObject(CLASS_Class2) as _Class2;
end;
class function CoClass2.CreateRemote(const MachineName: string): _Class2;
begin
Result := CreateRemoteComObject(MachineName, CLASS_Class2) as _Class2;
end;
procedure TClass2.InitServerData;
const
CServerData: TServerData = (
ClassID: '{7FF9F5CF-1C3B-3234-B5B1-F7EF39E18356}';
IntfIID: '{70E4C4D8-1C96-337C-A3B1-90217021B4D7}';
EventIID: '';
LicenseKey: nil;
Version: 500);
begin
ServerData := #CServerData;
end;
procedure TClass2.Connect;
var
punk: IUnknown;
begin
if FIntf = nil then
begin
punk := GetServer;
Fintf:= punk as _Class2;
end;
end;
procedure TClass2.ConnectTo(svrIntf: _Class2);
begin
Disconnect;
FIntf := svrIntf;
end;
procedure TClass2.DisConnect;
begin
if Fintf <> nil then
begin
FIntf := nil;
end;
end;
function TClass2.GetDefaultInterface: _Class2;
begin
if FIntf = nil then
Connect;
Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call "Connect" or "ConnectTo" before this operation');
Result := FIntf;
end;
constructor TClass2.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TClass2.Destroy;
begin
inherited Destroy;
end;
function TClass2.Get_ToString: WideString;
begin
Result := DefaultInterface.ToString;
end;
function TClass2.Get_array_1_class2: PSafeArray;
begin
Result := DefaultInterface.array_1_class2;
end;
procedure TClass2.Set_array_1_class2(pRetVal: PSafeArray);
begin
DefaultInterface.array_1_class2 := pRetVal;
end;
function TClass2.Get_array_2_class2: PSafeArray;
begin
Result := DefaultInterface.array_2_class2;
end;
procedure TClass2.Set_array_2_class2(pRetVal: PSafeArray);
begin
DefaultInterface.array_2_class2 := pRetVal;
end;
function TClass2.Equals(obj: OleVariant): WordBool;
begin
Result := DefaultInterface.Equals(obj);
end;
function TClass2.GetHashCode: Integer;
begin
Result := DefaultInterface.GetHashCode;
end;
function TClass2.GetType: _Type;
begin
Result := DefaultInterface.GetType;
end;
class function CoClass3.Create: _Class3;
begin
Result := CreateComObject(CLASS_Class3) as _Class3;
end;
class function CoClass3.CreateRemote(const MachineName: string): _Class3;
begin
Result := CreateRemoteComObject(MachineName, CLASS_Class3) as _Class3;
end;
procedure TClass3.InitServerData;
const
CServerData: TServerData = (
ClassID: '{F412CD3D-4246-3970-A46A-3830175F5775}';
IntfIID: '{4C6F2CFA-C886-3B6F-90ED-0EBBAC07E3F6}';
EventIID: '';
LicenseKey: nil;
Version: 500);
begin
ServerData := #CServerData;
end;
procedure TClass3.Connect;
var
punk: IUnknown;
begin
if FIntf = nil then
begin
punk := GetServer;
Fintf:= punk as _Class3;
end;
end;
procedure TClass3.ConnectTo(svrIntf: _Class3);
begin
Disconnect;
FIntf := svrIntf;
end;
procedure TClass3.DisConnect;
begin
if Fintf <> nil then
begin
FIntf := nil;
end;
end;
function TClass3.GetDefaultInterface: _Class3;
begin
if FIntf = nil then
Connect;
Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call "Connect" or "ConnectTo" before this operation');
Result := FIntf;
end;
constructor TClass3.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TClass3.Destroy;
begin
inherited Destroy;
end;
function TClass3.Get_ToString: WideString;
begin
Result := DefaultInterface.ToString;
end;
function TClass3.Get_array_1_class3: PSafeArray;
begin
Result := DefaultInterface.array_1_class3;
end;
procedure TClass3.Set_array_1_class3(pRetVal: PSafeArray);
begin
DefaultInterface.array_1_class3 := pRetVal;
end;
function TClass3.Get_array_2_class3: PSafeArray;
begin
Result := DefaultInterface.array_2_class3;
end;
procedure TClass3.Set_array_2_class3(pRetVal: PSafeArray);
begin
DefaultInterface.array_2_class3 := pRetVal;
end;
function TClass3.Equals(obj: OleVariant): WordBool;
begin
Result := DefaultInterface.Equals(obj);
end;
function TClass3.GetHashCode: Integer;
begin
Result := DefaultInterface.GetHashCode;
end;
function TClass3.GetType: _Type;
begin
Result := DefaultInterface.GetType;
end;
class function CoClass4.Create: _Class4;
begin
Result := CreateComObject(CLASS_Class4) as _Class4;
end;
class function CoClass4.CreateRemote(const MachineName: string): _Class4;
begin
Result := CreateRemoteComObject(MachineName, CLASS_Class4) as _Class4;
end;
procedure TClass4.InitServerData;
const
CServerData: TServerData = (
ClassID: '{6C78853D-D584-35FF-8CD9-7C7214DFCA8F}';
IntfIID: '{7FBDFC4C-887D-3891-81F6-AD1D99057826}';
EventIID: '';
LicenseKey: nil;
Version: 500);
begin
ServerData := #CServerData;
end;
procedure TClass4.Connect;
var
punk: IUnknown;
begin
if FIntf = nil then
begin
punk := GetServer;
Fintf:= punk as _Class4;
end;
end;
procedure TClass4.ConnectTo(svrIntf: _Class4);
begin
Disconnect;
FIntf := svrIntf;
end;
procedure TClass4.DisConnect;
begin
if Fintf <> nil then
begin
FIntf := nil;
end;
end;
function TClass4.GetDefaultInterface: _Class4;
begin
if FIntf = nil then
Connect;
Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call "Connect" or "ConnectTo" before this operation');
Result := FIntf;
end;
constructor TClass4.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TClass4.Destroy;
begin
inherited Destroy;
end;
function TClass4.Get_ToString: WideString;
begin
Result := DefaultInterface.ToString;
end;
function TClass4.Equals(obj: OleVariant): WordBool;
begin
Result := DefaultInterface.Equals(obj);
end;
function TClass4.GetHashCode: Integer;
begin
Result := DefaultInterface.GetHashCode;
end;
function TClass4.GetType: _Type;
begin
Result := DefaultInterface.GetType;
end;
function TClass4.LoadJson(const filePath: WideString): _Class1;
begin
Result := DefaultInterface.LoadJson(filePath);
end;
procedure Register;
begin
RegisterComponents(dtlServerPage, [TClass1, TClass2, TClass3, TClass4]);
end;
end.
Class2.array_1_class2 is blank by default. If you create a Class2 object directly, your C# code does not assign any data to its array_1_class2 member.
Class4.LoadJson() returns a Class1 object, which you are ignoring. Class1 contains a Class2 object whose array_1_class2 member will be populated by LoadJson(). So, in your Delphi code, you should be accessing V_class1.Class2.array_1_class2 instead of V_class2.array_1_class2.
Also, you are using the 3rd parameter of SafeArrayGetElement() incorrectly. Every integer you extract gets saved in LData[0] only, you are never assigning any value to LData[1].
Try something more like this instead:
program dllTester;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
Variants,
Classes,
ActiveX,
ComObj,
dll_TLB in 'dll_TLB.pas';
var
filePath : WideString;
V_class1: _Class1;
V_class4: _Class4;
Class2_SafeArray: PSafeArray;
Class2_LBound, Class2_UBound, Index: LongInt;
LData: array of Int32;
//ptr: Pointer;
begin
OleCheck(CoInitialize(nil));
try
try
V_class4 := CoClass4.Create;
try
filePath := 'C:\Users\Documents\file.json';
V_class1 := V_class4.LoadJson(filePath);
finally
V_class4 := nil;
end;
//get the PSafeArray
Class2_SafeArray := V_class1.Class2.array_1_class2;
try
//get the bounds
OleCheck(SafeArrayGetLBound(Class2_SafeArray, 1, Class2_LBound));
OleCheck(SafeArrayGetUBound(Class2_SafeArray, 1, Class2_UBound));
// allocate the array
SetLength(LData, (Class2_UBound - Class2_LBound) + 1);
WriteLn('Class2 array_1:');
for Index := Class2_LBound to Class2_UBound do begin
OleCheck(SafeArrayGetElement(Class2_SafeArray, Index, LData[Index]));
end;
{ alternatively:
OleCheck(SafeArrayAccessData(Class2_SafeArray, ptr));
try
Move(ptr^, PInt32(LData)^, SizeOf(Int32) * Length(LData));
finally
OleCheck(SafeArrayUnaccessData(Class2_SafeArray));
end;
}
for Index := Low(LData) to High(LData) do begin
WriteLn(LData[Index]);
end;
finally
// note sure if this is appropriate or not here,
// since the C# code owns the original int array...
SafeArrayDestroy(Class2_SafeArray);
end;
finally
V_class1 := nil;
end;
finally
CoUninitialize();
end;
ReadLn;
end.
I call a dll "plcommpro.dll" for a specific operations on Access Controls
the following C# code is working perfect and retrieve data correctly in buffer
[DllImport("plcommpro.dll", EntryPoint = "GetDeviceData")]
public static extern int GetDeviceData(IntPtr h, ref byte buffer,
int buffersize, string tablename, string filename, string filter, string
options);
Now, I need to to write same operation from Delphi, So I tried the following:
TGetDeviceData = Function(iDevID : NativeInt; buffer : Pbyte ; iSize :
Integer;
tablename, filename, strFilter, strOptions : PAnsiChar) : Int64;stdcall;
and I call the function as follows:
var
myBuffer : TBytes;
iRetLog : Integer;
bufferSize : Integer;
sConnect : TConnect;
GetDeviceData : TGetDeviceData;
dllHandle : THandle;
iDevID : Integer;
begin
dllHandle := LoadLibrary('plcommpro.dll') ;
if dllHandle <> 0 then
begin
#sConnect := GetProcAddress(dllHandle, 'Connect');
if #sConnect <> Nil then
begin
strParams := PChar('protocol=TCP,ipaddress=' + grd_Machines.Cells[cl_Machine_IP, iLoop] + ',port=4370,timeout=2000,passwd=');
iDevID := sConnect(strParams);
strTableName := PAnsiChar(AnsiString(('user')));
strDatas := PAnsiChar(AnsiString(''));
strFileName := PAnsiChar(AnsiString(''));
strFilter := PAnsiChar(AnsiString(''));
strOptions := PAnsiChar(AnsiString(''));
#GetDeviceData := GetProcAddress(dllHandle, 'GetDeviceData');
if #GetDeviceData <> Nil then
begin
try
buffersize := 1024*1024;
//bufferSize := MaxInt - 1;
SetLength(myBuffer, 1024*1024);
mem_AttLogs.Lines.Add('buffer Size : ' + IntToStr(buffersize) );
iRetLogs := GetDeviceData(iDevID, PByte(myBuffer[0]), buffersize, strTableName, strFileName, strFilter, strOptions);
if iRetLogs > 0 then
begin
....
//Here: I need to read the returned values from the function; but it always fails
end
The code is modified to explain my case more clearly. Can you help?
The C# declaration you give is obviously flawed: ref byte buffer makes no sense. A buffer is not one byte. It should probably be something like [out] byte[] buffer (thanks to David Heffernan). Both translate an underlying pointer, but the conversion done on the C# side is different.
Since this seems to be interop code to interface with a plain Windows DLL, I can see what the original must have been: a pointer to bytes, which is best translated as PByte in Delphi (but no var, that would introduce one level of indirection too many).
So now it should be something like:
var
GetDeviceData: function(h: THandle; buffer: PByte; buffersize: Integer;
tablename, filename, filter, options: PAnsiChar): Integer stdcall;
Now you finally updated your code, the error you get is quite obvious:
iRetLog := GetDeviceData(iDevID, PByte(myBuffer[0]), buffersize,
strTableName, strFileName, strFilter, strOptions);
That is wrong. You are casting an AnsiChar (i.e. myBuffer[0]) to a pointer. You need a pointer to the first element of myBuffer, so do:
iRetLog := GetDeviceData(iDevID, #myBuffer[0], buffersize,
strTableName, strFileName, strFilter, strOptions); // Note the #
FWIW, since you seem to be using constant strings, you can just do:
iRetLog := GetDeviceData(iDevID, #myBuffer[0], buffersize, 'user', '', '', '');
And to make this easier to maintain, don't use literal numbers if you already have a variable that has this number (and must be the exact same size anyway), so do this instead:
buffersize := 1024*1024;
SetLength(myBuffer, buffersize);
I am converting some C# code to Delphi.
In c#, I have Nullabe types as:
System.Nullable<T> variable
or
T? variable
Then, I can use something as:
int?[] arr = new int?[10];
Is there some Delphi VCL equivalent to it?
I found this interesting article about Nullable types and this simplified implementation:
unit Nullable;
{$mode delphi}{$H+}
interface
uses
Classes, SysUtils;
type
TNullable<T> = record
private
FHasValue: Boolean;
FValue: T;
function GetValue: T;
procedure SetValue(AValue: T);
public
procedure Clear;
property HasValue: Boolean read FHasValue;
property Value: T read GetValue write SetValue;
class operator Implicit(A: T): TNullable<T>;
class operator Implicit(A: Pointer): TNullable<T>;
end;
implementation
{ TNullable }
function TNullable<T>.GetValue: T;
begin
if FHasValue then
Result := FValue
else
raise Exception.Create('Variable has no value');
end;
procedure TNullable<T>.SetValue(AValue: T);
begin
FValue := AValue;
FHasValue := True;
end;
procedure TNullable<T>.Clear;
begin
FHasValue := False;
end;
class operator TNullable<T>.Implicit(A: T): TNullable<T>;
begin
Result.Value := A;
end;
class operator TNullable<T>.Implicit(A: Pointer): TNullable<T>;
begin
if A = nil then Result.Clear
else raise Exception.Create('Pointer value not allowed');
end;
end.
Revised question:
We're using D7 to call a C# method that's in a COM object. The C# method returns a WideString.
Is there a risk that .NET will garbage collect the returned WideString from under our feet while we're using it in our Pascal code? If so, what alternatives do we have to safely return a string from a C# COM object?
Also, is our final Delphi line SubMan := nil the proper way to release the COM object?
C# Code
[DispId(5)]
bool Test(int var1, ref int var2, ref string var3);
public bool Test(int var1, ref int var2, ref string var3)
{
bool result;
if (var1 == 0)
{
var2 = 0;
var3 = "zero";
result = true;
}
else
{
var2 = -1;
var3 = "minus one";
result = false;
}
return result;
}
Pascal code from generated TLB in D7
function Test( var1: Integer;
var var2: Integer;
var var3: WideString): WordBool; dispid 5;
Pascal code calling the COM object. Is there a risk var3 will be GC-ed?
procedure TForm1.Button1Click(Sender: TObject);
var
SubMan: TSubMan;
Var1: Integer;
Var2: Integer;
Var3: WideString;
FunctionResult: Boolean;
begin
SubMan := COTSubMan.Create;
Var1 := 1;
FunctionResult := SubMan.Test(Var1, Var2, Var3);
// Will Var3 above be persistent in the code
// or might it be garbage collected by .NET before we can use it below or later?
ShowMessage( BoolToStr(FunctionResult, TRUE) +
' Var2 = ' + IntToStr(Var2) +
' Var3 = ' + Var3);
SubMan := nil; // Is this the right way to release the COM object?
end;
The code in your question is fine. The COM marshaller handles the lifetimes of the two ref parameters for you. There's no danger from the GC because the semantics of the parameters is clearly expressed. The objects that you work with on the Delphi side are not .net objects and so not subject to GC.
Indeed, the GC is not a factor because this is COM. The fact that there is a .net object on the other side implemented the COM server is neither here nor there. It's the responsibility of the .net COM interop layer to present a valid COM object to you.
Just to confirm, even though the string was originally allocated in the C# COM object, var3 is safe to use throughout our Delphi Button1Click method?
Yes. Remember that this is COM, a standard for binary interop. You don't need to be too concerned by the details. FWIW, a WideString is the Delphi wrapper around the COM BSTR type. That string type is a UTF-16 encoded string, reference counted, and allocated off the shared COM heap. That last point is important. The fact that BSTR instances come of the shared COM heap is what allows them to be allocated in one module, and deallocated in another.
Is SubMan := nil the proper way to release the COM object?
Yes it is. Although it is a little pointless in this code because the local variable is about to leave scope and that will have the exact same effect as your nil assignment.
Using BSTR type is the easiest way since COM will handle memory (de)allocation.
eg:
Delphi:
function ReturnString(out TheString: WideString): Boolean; stdcall;
begin
try
TheString := 'Hello World';
finally
Result := True;
end;
end;
C#:
[DllImport("mydll.dll", CallingConvention=CallingConvention.StdCall)]
public static extern bool ReturnString([MarshalAs(UnmanagedType.BStr)]out string TheString);
I am unable to translate the interface definition below from Delphi to C#:
IDCDSPFilterInterface = interface(IUnknown)
['{BD78EF46-1809-11D6-A458-EDAE78F1DF12}']
// removed functions thjat are already working
function get_FilterName(Index : integer; out Name : PChar): HRESULT; stdcall;
end;
I have tried with StringBuilder in the following way:
[ComVisible(true), ComImport, SuppressUnmanagedCodeSecurity,
Guid("BD78EF46-1809-11D6-A458-EDAE78F1DF12"),
InterfaceType(ComInterfaceType.InterfaceIsIUnknown)]
public interface IDCDSPFilterInterface : IBaseFilter
{
[PreserveSig]
int get_FilterName(int Index, [MarshalAs(UnmanagedType.LPStr)] StringBuilder Name);
}
I tried with LPStr, LPWStr, which both gives garbage characters in the string builder, and LPTStr which fails with an error message saying that this kind of marshalling combination is not allowed.
The definition of the method in Delhi is:
function TDCDSPFilter.get_FilterName(Index : integer; out Name : PChar): HRESULT; stdcall;
begin
{$IFDEF EXCEPT_DEBUG}try{$ENDIF}
FcsFilter.Lock;
try
{$IFDEF WITH_INTERNAL_DSP}
Result := S_FALSE;
if (Index < 0) or (Index > fFilters.Count -1) then Exit;
Name := PChar(fFilters.Name[Index]);
Result := S_OK;
{$ELSE}
Result := E_NOTIMPL;
{$ENDIF}
finally
FcsFilter.UnLock;
end;
{$IFDEF EXCEPT_DEBUG} except er('TDCDSPFilter.get_FilterName'); end; {$ENDIF}
end;
The fFilters.Name is declared as:
property Name[Index: integer]: String read GetName;
All my other interface methods work well with other basic types (in and ref) except this one with PChar output.
I get S_OK but the string in the StringBuilder is garbage...
I know the method is properly called because if I pass the wrong indexes I get S_FALSE (as the method body is defined to do).
Can anybody help to give the proper Marshalling for the Delphi out PChar?
That is a rather poorly designed interface. This is a COM interface and so it should use the COM string, BSTR.
However, as it stands, the C# side has to marshal the PChar as an out parameter of type IntPtr. The declaration should be:
[PreserveSig]
uint get_FilterName(int Index, out IntPtr Name);
Then the string can be recovered by calling Marshal.PtrToStringAnsi or Marshal.PtrToStringUni depending on the encoding of the string.
You cannot use StringBuilder because that is for the situation where the caller allocates the buffer. And that's not happening here.
As I said, using a COM string would be better. The code looks like this:
Delphi
function TDCDSPFilter.get_FilterName(Index: integer;
out Name : WideString): HRESULT; stdcall;
C#
[PreserveSig]
uint get_FilterName(
int Index,
[MarshalAs(UnmanagedType.BStr)]
out string Name
);
Of course, that assumes that you can modify the interface. Quite likely you cannot. In which case you are stuck with out IntPtr.
Try to use IntPtr for Name parameter then get the content of the string with Marshal.PtrToStringAnsi.
References :
Marshal "char *" in C#
char* to a string in C#