fmmain.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

unit fmMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ExtCtrls;

type
  TForm1 = class(TForm)
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    Button7: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    Button8: TButton;
    Button9: TButton;
    Button10: TButton;
    //ListBox1: TListBox;
    Button11: TButton;
    ListBox1: TListBox;
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
    procedure Button9Click(Sender: TObject);
    procedure Button10Click(Sender: TObject);
    procedure Button11Click(Sender: TObject);
  private
    { Private declarations }
    function GetObjectTable(aObject: TObject): Integer;
    procedure ShowInterfaceMetaData(pMetaInfo: Pointer);
  public
    { Public declarations }
    procedure AppMsg(const sMsg : String);
    procedure GetGUIDMsg(aObj : TObject);
  end;

var
  Form1: TForm1;

implementation

uses uIntfClass, uInterfaces, ComObj, uDelegateClass, IntfInfo, TypInfo, Invoker;

{$R *.dfm}

procedure TForm1.AppMsg(const sMsg: String);
begin
  ListBox1.Items.Add(sMsg);
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var
  aObj : TIntfClass;
  aIntf1 : IMyInterface1;
  aIntf2 : IMyInterface2;
begin
  aObj := TIntfClass.Create;
  try
    aIntf1 := IMyInterface1(aObj);
    ListBox1.Items.Add(aIntf1.GetName('Gordon'));
//    aIntf2 := aObj;
//    ListBox1.Items.Add('Today is : ' + aIntf2.GetDate);
  finally
//    aIntf1 := nil;
//    aIntf2 := nil;
    FreeAndNil(aObj);
  end;
end;

procedure TForm1.BitBtn2Click(Sender: TObject);
var
  aPtr : Pointer;
begin
   aPtr := PPointer(Integer(Self) + vmtIntfTable)^;
   Self.Caption := IntToStr(Integer(aPtr^));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  aIntf4 : IMyInterface4;
  aObj : TIntf1Class;
begin
  aObj := TIntf1Class.Create;
  try
    aIntf4 := aObj as IMyInterface4;
    ShowMessage(aIntf4.GetGUID);
  finally // wrap up
    FreeAndNil(aObj);
  end;    // try/finally
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  aObj : TIntfClass;
  aIntf1 : IMyInterface1;
  aIntf2 : IMyInterface2;
  idx : Integer;
  aIntfEntry : TInterfaceEntry;
  pIntfTbl : PInterfaceTable;
  aClass : TClass;
  aIntf4 : IMyInterface4;
const
  IID : TGUID = '{AA884AA1-274B-4F63-B946-19D6AA354D66}';
begin
  aObj := TIntfClass.Create;
  try
    aIntf1 := IMyInterface1(aObj);
    ListBox1.Items.Add(aIntf1.GetName('Gordon'));
//    aIntf2 := aObj;
//    ListBox1.Items.Add('Today is : ' + aIntf2.GetDate);

    aObj.GetInterface(IID, aIntf4);
    ShowMessage(aIntf4.GetGUID);
    OlECheck(aObj.QueryInterface(IID, aIntf4));
    ShowMessage(aIntf4.GetGUID);
    Self.Caption := IntToStr(Integer(Self));
    pIntfTbl := Self.GetInterfaceTable;

    if (pIntfTbl <> nil) then
    begin
      for idx := 0 to pIntfTbl.EntryCount - 1 do    // Iterate
      begin
        aIntfEntry := pIntfTbl.Entries[idx];
        ListBox1.Items.Add(GUIDToString(aIntfEntry .IID));
        ListBox1.Items.Add(IntToStr(Integer(aIntfEntry.VTable)));
      end;    // for
    end;
  finally
    FreeAndNil(aObj);
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  aIntf1 : IMyInterface1;
  aIntf2 : IMyInterface2;
  aObj : TDerivedIntfClass;
begin
  aObj := TDerivedIntfClass.Create;
  try
    aIntf1 := aObj;
    Self.ListBox1.Items.Add(aIntf1.GetName('Gordon'));
    aIntf2 := aObj;
    Self.ListBox1.Items.Add(aIntf2.GetDate);
  finally // wrap up
    aIntf1 := nil;
    aIntf2 := nil;
    FreeAndNil(aObj);
  end;    // try/finally
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  aIntf : IMyInterface1;
  aDup1 : IDupInterface1;
  aDup2 : IDupInterface2;
  aObj : TDupInterface;
const
  IID : TGUID = '{00000000-0000-0000-C000-000000000046}';
begin
  aObj := TDupInterface.Create;
  try
    aIntf := aObj;
    Self.ListBox1.Items.Add(aIntf.GetName('Gordon'));
    aDup1 := aObj;
    Self.ListBox1.Items.Add(aDup1.GetName);
    aDup2 := aObj;
    Self.ListBox1.Items.Add(aDup2.GetName);
  finally // wrap up
    aIntf := nil;
    aDup1 := nil;
    aDup2 := nil;
    FreeAndNil(aObj);
  end;    // try/finally
end;

procedure TForm1.Button5Click(Sender: TObject);
var
  aObj : TGUIDClass;
  intf1 : IGUIDIntf1;
  intf2 : IGUIDIntf2;
  intf3 : IGUIDIntf3;
begin
  aObj := TGUIDClass.Create;
  try
    ListBox1.Items.Add('TGUIDClass有 : ' + IntToStr(    aObj.GetInterfaceCount) + ' 个接口');
    intf1 := IGUIDIntf1(aObj);
    ListBox1.Items.Add('IGUIDIntf1 :' + intf1.GetGUID);
    intf2 := IGUIDIntf2(aObj);
    ListBox1.Items.Add('IGUIDIntf2 :' + intf2.GetGUID);
    intf3 := IGUIDIntf3(aObj);
    ListBox1.Items.Add('IGUIDIntf3 :' + intf3.GetGUID);
  finally // wrap up
    intf1 := nil;
    intf2 := nil;
    intf3 := nil;
//    FreeAndNil(aObj);
  end;    // try/finally
end;

procedure TForm1.Button6Click(Sender: TObject);
var
  aObj : TIntfServiceClass;
  intf : IImplInterface;
  fValue : Double;
begin
//  aObj := TIntfServiceClass.Create;
  aObj := TIntfServiceClass.Create(TImplClass);
  try
    intf := aObj;
    fValue := intf.ConvertToUSD(1000000);
    Self.ListBox1.Items.Add('1000000NTD is : ' + FloatToStr(fValue) + ' USD!');
    fValue := intf.ConvertToRMB(1000000);
    Self.ListBox1.Items.Add('1000000NTD is : ' + FloatToStr(fValue) + ' RMB!');
  finally // wrap up
    intf := nil;
    FreeAndNil(aObj);
  end;    // try/finally
end;

procedure TForm1.Button7Click(Sender: TObject);
var
  aObj : TClsServiceClass;
  intf : IImplInterface;
  fValue : Double;
begin
//  aObj := TClsServiceClass.Create;
  aObj := TClsServiceClass.Create(TImplClass);
  try
    intf := aObj.MyService;
    fValue := intf.ConvertToUSD(1000000);
    Self.ListBox1.Items.Add('1000000NTD is : ' + FloatToStr(fValue) + ' USD!');
    fValue := intf.ConvertToRMB(1000000);
    Self.ListBox1.Items.Add('1000000NTD is : ' + FloatToStr(fValue) + ' RMB!');
  finally // wrap up
    intf := nil;
    FreeAndNil(aObj);
  end;    // try/finally
end;

procedure TForm1.Button8Click(Sender: TObject);
var
  aObj : TClsServiceClass;
  fValue : Double;
  intf : IImplInterface;
begin
  aObj := TClsServiceClass.Create(TImplClass);
  try
    intf := aObj.MyService;
    intf.USDRate := StrToFloat(Self.LabeledEdit1.Text);
    intf.RMBRate := StrToFloat(Self.LabeledEdit2.Text);
    fValue := intf.ConvertToUSD(1000000);
    Self.ListBox1.Items.Add('1000000NTD is : ' + FloatToStr(fValue) + ' USD!');
    fValue := intf.ConvertToRMB(1000000);
    Self.ListBox1.Items.Add('1000000NTD is : ' + FloatToStr(fValue) + ' RMB!');
  finally // wrap up
    intf := nil;
    FreeAndNil(aObj);
  end;    // try/finally
end;

procedure TForm1.Button9Click(Sender: TObject);
var
  aIntf : IGUIDIntf1;
  aObj : TIntfClass2;
begin
  aObj := TIntfClass2.Create;
  try
    aIntf := aObj;
    ListBox1.Items.Add(aIntf.GetGUID);

    GetGUIDMsg(aObj);
  finally // wrap up
    aIntf := nil;
  end;    // try/finally
end;


procedure TForm1.GetGUIDMsg(aObj : TObject);
const
  IID : TGUID = '{4A0B53A0-F33B-47A8-BD6F-9F00581E8B2A}';
var
  aIntf : IGUIDIntf1;
begin
  if (Supports(aObj, IID)) then
  begin
    aObj.GetInterface(IID, aIntf);
    ListBox1.Items.Add(aIntf.GetGUID)
  end;

  if (Supports(aObj, IID, aIntf)) then
  begin
    ListBox1.Items.Add(aIntf.GetGUID)
  end;

end;

procedure TForm1.Button10Click(Sender: TObject);
begin
  ShowInterfaceMetaData(TypeInfo(IImplInterface));
end;

procedure TForm1.ShowInterfaceMetaData(pMetaInfo: Pointer);
var
  aIntfMetaInfo : TIntfMetaData;
  aMethod : TIntfMethEntry;

  function GetTypeInfoFromPointer(pType : PTypeInfo) : String;
  begin
    Result := pType.Name;
  end;

  function GetMethodType : String;
  begin
    Result := 'Procedure ';
    if (Assigned(aMethod.ResultInfo)) then
      Result := 'Function ';
  end;

  function GetParameterPrototype : String;
  var
    idx : Integer;
    aParam : TIntfParamEntry;

    function GetParamModifier : String;
    begin
      Result := '';
      if (pfVar in aParam.Flags) then
        Result := Result + 'var';
      if (pfConst in aParam.Flags) then
        Result := Result + 'const';
      if (pfArray in aParam.Flags) then
        Result := Result + 'array';
      if (pfAddress in aParam.Flags) then
        Result := Result + 'Pointer';
      if (pfReference in aParam.Flags) then
        Result := Result + 'ref';
      if (pfOut in aParam.Flags) then
        Result := Result + 'out';
    end;

  begin
    Result := '';
    for idx := 0 to aMethod.ParamCount - 1 do    // Iterate
    begin
      aParam := aMethod.Params[idx];
      Result := Result + GetParamModifier + ' ' + aParam.Name + ' : ' +
                GetTypeInfoFromPointer(aParam.Info);
    end;    // for
  end;

  function GetResultType : String;
  begin
    Result := aMethod.ResultInfo.Name;
  end;

  function GetCallingConvention : String;
  begin
    Result := '';
    case aMethod.CC of
      ccReg : Result := 'Register';
      ccCdecl : Result := 'Cdecl';
      ccPascal : Result := 'Pascal';
      ccStdCall : Result := 'stdcall';
      ccSafeCall : Result := 'SafeCall';
    end;    // case
  end;

  function GetMethodPrototype : String;
  begin
    Result := '';
    Result := GetMethodType + aMethod.Name + '(' + GetParameterPrototype + ')';
    if (GetMethodType = 'Function ') then
      Result := Result + ' : ' +  GetResultType + ' ; ' + GetCallingConvention;
    Result := Result + ';';
  end;

  procedure ShowInterfaceMethodInfos;
  var
    idx : Integer;
  begin
    AppMsg('//==============接口方法信息==============');
    for idx := Low(aIntfMetaInfo.MDA) to High(aIntfMetaInfo.MDA) do    // Iterate
    begin
      aMethod := aIntfMetaInfo.MDA[idx];
      AppMsg('方法名称 : ' + GetMethodPrototype);
    end;    // for
  end;
begin
  GetIntfMetaData(pMetaInfo, aIntfMetaInfo);

  AppMsg('接口名称 : ' + aIntfMetaInfo.Name);
  AppMsg('接口单元名称 : ' + aIntfMetaInfo.UnitName);
  AppMsg('接口GUID : ' + GUIDToString(aIntfMetaInfo.IID));
  AppMsg('父代接口方法个数 : ' + IntToStr(aIntfMetaInfo.NumAnc));

  ShowInterfaceMethodInfos;
end;

procedure TForm1.Button11Click(Sender: TObject);
var
  idx : Integer;
  aObj : TGUIDClass;
  aIntfTbl : PInterfaceTable;
  aIntfEntry : TInterfaceEntry;
begin
  aObj := TGUIDClass.Create;
  try
    AppMsg('Object Address: ' +  IntToStr(Integer(aObj)) );
    AppMsg('Object Interface Table : ' +  IntToStr(Integer(GetObjectTable(aObj))) );
    aIntfTbl := aObj.GetInterfaceTable;
    for idx := 0 to aIntfTbl.EntryCount - 1 do    // Iterate
    begin
      aIntfEntry := aIntfTbl.Entries[idx];
      AppMsg('GUID : ' +  GUIDToString(aIntfEntry.IID));
      AppMsg('Interface VTable : ' +  IntToStr( Integer(aIntfEntry.VTable) ));
      AppMsg('Interface Offset : ' +  IntToStr( Integer(aIntfEntry.IOffset) ));
    end;    // for
  finally // wrap up

  end;    // try/finally
end;

function TForm1.GetObjectTable(aObject: TObject): Integer;
begin
  Result := Integer( PPointer(Integer(Pointer(aObject)^) + vmtIntfTable)^ );
end;

end.