1

Topic: RTTI: Interface method (dispid)

I need to enumerate interface methods at level of language, and then by means of RTTI to receive this number. If it is probably finite. Certainly VirtualIndex does not approach, as it produces method ordinal value, and arbitrary "label" is necessary to me.

{$M +}
IMyObject = interface
function GetValue: Integer; dispid 15;
end;
{$M-}
procedure TForm1.FormCreate (Sender: TObject);
var
ctx: TRttiContext;
lType: TRttiType;
Method: TRttiMethod;
begin
Memo1.Lines. Clear;
ctx: = TRttiContext. Create;
lType: = ctx. GetType (TypeInfo (IMyObject));
for Method in lType. GetMethods do
begin
Memo1.Lines. Add (Method. ToString);
end;
end;

2

Re: RTTI: Interface method (dispid)

SOFT FOR YOU;

unit Unit50;
interface
uses
Winapi. Windows, Winapi. Messages, System. SysUtils, System. Variants, System. Classes, Vcl. Graphics;
Vcl. Controls, Vcl. Forms, Vcl. Dialogs, System. Rtti, Vcl. StdCtrls;
type
MyAttribute = class (TCustomAttribute)
public
ID: Integer;
constructor Create (AID: Integer);
end;
{$M +}
IMyObject = interface
[MyAttribute (15)]
function GetValue: Integer;
end;
{$M-}
TForm50 = class (TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click (Sender: TObject);
private
{Private declarations}
public
{Public declarations}
end;
var
Form50: TForm50;
implementation
{$R *.dfm}
procedure TForm50.Button1Click (Sender: TObject);
var
ctx: TRttiContext;
lType: TRttiType;
Method: TRttiMethod;
Attribute: TCustomAttribute;
begin
Memo1.Lines. Clear;
ctx: = TRttiContext. Create;
lType: = ctx. GetType (TypeInfo (IMyObject));
for Method in lType. GetMethods do
begin
for Attribute in Method. GetAttributes do
if Attribute is MyAttribute then
Memo1.Lines. Add (Method. ToString + ' ' + IntToStr (MyAttribute (Attribute).ID));
end;
end;
constructor MyAttribute. Create (AID: Integer);
begin
ID: = AID;
end;
end.

3

Re: RTTI: Interface method (dispid)

AX-Class;
I thank!

4

Re: RTTI: Interface method (dispid)

For a long time wanted to use attributes in the projects, yes hands all somehow did not reach.
Something it is impossible to use string properties of attributes... It turns out More precisely, but only with type ShortString. Who in a subject prompt, I can not so something I do?

unit uAttrMain;
interface
uses
Winapi. Windows, Winapi. Messages, System. SysUtils, System. Variants, System. Classes, Vcl. Graphics;
Vcl. Controls, Vcl. Forms, Vcl. Dialogs, Vcl. StdCtrls, System. Rtti, System. RTLConsts;
type
TCustomAttributeClass = class of TCustomAttribute;
//the attribute declaration
Meta = class (TCustomAttribute)
strict private
fid: Integer;
fMetaName: string;
public
constructor Create (const aid: Integer; const AMetaName: string);
property id: Integer read fid;
property MetaName: string read fMetaName;
end;
TfrmMain = class (TForm)
lMemo: TMemo;
procedure FormCreate (Sender: TObject);
private
public
procedure Log (const msg: string);
[Meta (10, ' the Test method ')]
procedure Test;
end;
function MethodHasAttribute (const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass): Boolean;
function GetAttribute (const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass): TCustomAttribute;
var
frmMain: TfrmMain;
implementation
function MethodHasAttribute (const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass): Boolean;
var RttiContext: TRttiContext;
lType: TRttiType;
Method: TRttiMethod;
Attribute: TCustomAttribute;
begin
Result: = False;
RttiContext: = TRttiContext. Create;
lType: = RttiContext. GetType (AClass. ClassInfo);
for Method in lType. GetMethods do begin
if SameText (Method. Name, MethodName) then
for Attribute in Method. GetAttributes do
if Attribute is Attr then begin
Result: = True;
break;
end;
end;
end;
function GetAttribute (const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass): TCustomAttribute;
var RttiContext: TRttiContext;
lType: TRttiType;
Method: TRttiMethod;
Attribute: TCustomAttribute;
begin
Result: = nil;
RttiContext: = TRttiContext. Create;
lType: = RttiContext. GetType (AClass. ClassInfo);
for Method in lType. GetMethods do begin
if SameText (Method. Name, MethodName) then
for Attribute in Method. GetAttributes do
if Attribute is Attr then begin
Result: = Attribute;
break;
end;
end;
end;
{$R *.dfm}
{Meta}
constructor Meta. Create (const aid: Integer; const AMetaName: string);
begin
fid: = aid;
fMetaName: = AMetaName;
end;
{TfrmMain}
procedure TfrmMain. FormCreate (Sender: TObject);
var Attr: Meta;
begin
if MethodHasAttribute (TfrmMain, ' Test ', Meta) then begin
Attr: = GetAttribute (TfrmMain, ' Test ', Meta) as Meta;
Log (' id = ' + Attr.id. ToString + ', MetaName = ' + Attr. MetaName);
end;
end;
procedure TfrmMain.Log (const msg: string);
begin
lMemo. Lines. Add (msg);
end;
procedure TfrmMain. Test;
begin
ShowMessage (' Test! ');
end;
end.

5

Re: RTTI: Interface method (dispid)

In an example above all will work if type of property of attribute MethName to replace on ShortString . Types since a variable long line do not work. And it would be desirable to use them!

6

Re: RTTI: Interface method (dispid)

Virtual Student;
I suppose that it is not necessary to release a context.
[spoiler]

unit Unit51;
interface
uses
Winapi. Windows, Winapi. Messages, System. SysUtils, System. Variants, System. Classes, Vcl. Graphics;
Vcl. Controls, Vcl. Forms, Vcl. Dialogs, Vcl. StdCtrls, System. Rtti, System. RTLConsts;
type
TCustomAttributeClass = class of TCustomAttribute;
//the attribute declaration
Meta = class (TCustomAttribute)
strict private
fid: Integer;
fMetaName: string;
public
constructor Create (const aid: Integer; const AMetaName: string);
property id: Integer read fid;
property MetaName: string read fMetaName;
end;
TfrmMain = class (TForm)
lMemo: TMemo;
procedure FormCreate (Sender: TObject);
private
public
procedure Log (const msg: string);
[Meta (10, ' the Test method ')]
procedure Test;
end;
function MethodHasAttribute (const AClass: TClass; const MethodName: string;
Attr: TCustomAttributeClass): Boolean;
function GetAttribute (const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass)
: TCustomAttribute;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
var
RttiContext: TRttiContext;
function MethodHasAttribute (const AClass: TClass; const MethodName: string;
Attr: TCustomAttributeClass): Boolean;
var
lType: TRttiType;
Method: TRttiMethod;
Attribute: TCustomAttribute;
begin
Result: = False;
lType: = RttiContext. GetType (AClass. ClassInfo);
for Method in lType. GetMethods do
begin
if SameText (Method. Name, MethodName) then
for Attribute in Method. GetAttributes do
if Attribute is Attr then
begin
Result: = True;
break;
end;
end;
end;
function GetAttribute (const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass)
: TCustomAttribute;
var
lType: TRttiType;
Method: TRttiMethod;
Attribute: TCustomAttribute;
begin
Result: = nil;
lType: = RttiContext. GetType (AClass. ClassInfo);
for Method in lType. GetMethods do
begin
if SameText (Method. Name, MethodName) then
for Attribute in Method. GetAttributes do
if Attribute is Attr then
begin
Result: = Attribute;
break;
end;
end;
end;
{Meta}
constructor Meta. Create (const aid: Integer; const AMetaName: string);
begin
fid: = aid;
fMetaName: = AMetaName;
end;
{TfrmMain}
procedure TfrmMain. FormCreate (Sender: TObject);
var
Attr: Meta;
begin
RttiContext: = TRttiContext. Create;
if MethodHasAttribute (TfrmMain, ' Test ', Meta) then
begin
Attr: = GetAttribute (TfrmMain, ' Test ', Meta) as Meta;
Log (' id = ' + Attr.id. ToString + ', MetaName = ' + Attr. MetaName);
end;
RttiContext. Free;
end;
procedure TfrmMain.Log (const msg: string);
begin
lMemo. Lines. Add (msg);
end;
procedure TfrmMain. Test;
begin
ShowMessage (' Test! ');
end;
end.

[/spoiler]

7

Re: RTTI: Interface method (dispid)

AX-Class wrote:

I Suppose that it is not necessary to release a context.

Yes, quits that so! Works almost with any data types.
Thanks!

8

Re: RTTI: Interface method (dispid)

Virtual Student;
Small , but what for you double the code?

if MethodHasAttribute (TfrmMain, ' Test ', Meta) then begin
Attr: = GetAttribute (TfrmMain, ' Test ', Meta) as Meta;
Log (' id = ' + Attr.id. ToString + ', MetaName = ' + Attr. MetaName);
end;

it is possible to make

Attr: = GetAttribute (TfrmMain, ' Test ', Meta) as Meta;
if Attr <> nil then
Log (' id = ' + Attr.id. ToString + ', MetaName = ' + Attr. MetaName);

And so on-essence, the superfluous cycle is fulfilled, plus if you want to change something it is necessary to synchronize changes in both procedures...

9

Re: RTTI: Interface method (dispid)

alekcvp wrote:

Virtual Student;
Small , but what for you double the code?

if MethodHasAttribute (TfrmMain, ' Test ', Meta) then begin
Attr: = GetAttribute (TfrmMain, ' Test ', Meta) as Meta;
Log (' id = ' + Attr.id. ToString + ', MetaName = ' + Attr. MetaName);
end;

it is possible to make

Attr: = GetAttribute (TfrmMain, ' Test ', Meta) as Meta;
if Attr <> nil then
Log (' id = ' + Attr.id. ToString + ', MetaName = ' + Attr. MetaName);

And so on-essence, the superfluous cycle is fulfilled, plus if you want to change something it is necessary to synchronize changes in both procedures...

It not the working code, and is simple for learning and understanding.

10

Re: RTTI: Interface method (dispid)

.
Not to write each time

{$M +}
IMyObject = interface
{$M-}

To replace on

IMyObject = interface (IInvokable)

11

Re: RTTI: Interface method (dispid)

Virtual Student wrote:

it is passed...
Yes, quits that so! Works almost with any data types.
Thanks!

Here not in types a problem, and that you addressed to killed object.
Interpose into the old code and you will see:

destructor Meta. Destroy;
begin
frmMain.Log (' Meta. Destroy ');
inherited;
end;

12

Re: RTTI: Interface method (dispid)

How to receive dispid at function?