unit typelib;

{$mode objfpc}{$H+}

{ Typelib import routines.

  Creates freepascal bindings for COM objects stored in .tlb, .dll, .exe or .olb files.

  Copyright (C) 2011 Ludo Brands

  This library is free software; you can redistribute it and/or modify it
  under the terms of the GNU Library General Public License as published by
  the Free Software Foundation; either version 2 of the License, or (at your
  option) any later version with the following modification:

  As a special exception, the copyright holders of this library give you
  permission to link this library with independent modules to produce an
  executable, regardless of the license terms of these independent modules,and
  to copy and distribute the resulting executable under terms of your choice,
  provided that you also meet, for each linked independent module, the terms
  and conditions of the license of that module. An independent module is a
  module which is not derived from or based on this library. If you modify
  this library, you may extend this exception to your version of the library,
  but you are not obligated to do so. If you do not wish to do so, delete this
  exception statement from your version.

  This program is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
  for more details.

  You should have received a copy of the GNU Library General Public License
  along with this library; if not, write to the Free Software Foundation,
  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}

interface

uses
  Classes, SysUtils,comobj,activex,windows;

{
Reads type information from 'FileName' and converts it in a freepascal binding unit. The
contents of the unit is returned as the function result.
Returns in 'sUnitName' the unit name with '.pas' extension.
Appends to 'slDependencies' the filenames of the additional typelibs needed.
If bActiveX is true an ActiveXContainer descendant is created with the evenual OnEvent hooks
If bActiveX is false and an event source is found an TEventSink descendant is created with the OnEvent hooks

By default, the type library is extracted from the first resource of type ITypeLib.
To load a different type of library resource, append an integer index to 'FileName'.

Example:  C:\WINDOWS\system32\msvbvm60.dll\3
}
function ImportTypelib(FileName: WideString;var sUnitName:string;var slDependencies:TStringList;
    bActiveX:boolean):string;


Type

  { TTypeLibImporter }

  TTypeLibImporter = Class(TComponent)
  private
    FActiveX: Boolean;
    FAppendVersionNumber: Boolean;
    FDependencies: TStringList;
    FUnitSource: TStringList;
    FInputFileName: WideString;
    FOutputFileName: String;
    FUnitname: string;
    FUses : TStrings;
    FHeader : TStrings;
    FInterface : TStrings;
    FImplementation : TStrings;
    FTypes : TStrings;
    FEventDisp : TStrings;
    FEventIID : TStrings;
    FEventSignatures: TStrings;
    FEventFunctions: TStrings;
    FEventProperties: TStrings;
    FEventImplementations: TStrings;
    function GetDependencies: TStrings;
    function GetUnitSource: TStrings;
    procedure SetOutputFileName(AValue: String);
    procedure SetUnitName(AValue: string);
  Protected
    bIsCustomAutomatable,bIsInterface,bIsAutomatable,bIsExternalDecl,bIsUserDefined:boolean;
    // Construct unit from header, uses, interface,
    procedure BuildUnit; virtual;
    // Add to various parts of sources
    Procedure AddToUses(Const AUnit : String); virtual;
    Procedure AddToHeader(Const ALine : String; AllowDuplicate : Boolean = False);virtual;
    Procedure AddToHeader(Const Fmt : String; Args : Array of const; AllowDuplicate : Boolean = False);
    Procedure AddToInterface(Const ALine : String);virtual;
    Procedure AddToInterface(Const Fmt : String; Args : Array of const);
    Procedure AddToImplementation(Const ALine : String);virtual;
    Procedure AddToImplementation(Const Fmt : String; Args : Array of const);
    // utility functions
    function interfacedeclaration(iName, iDoc: string; TI: ITypeInfo; TA: LPTYPEATTR;
      bIsDispatch,bCreateEvents:boolean): string;
    function VarTypeIsAutomatable(ParamType: integer): boolean; virtual;
    function VarTypeToStr(ParamType: integer): string; virtual;
    function TypeToString(TI: ITypeInfo; TD: TYPEDESC): string; virtual;
    function ValidateID(id: string): boolean; virtual;
    // The actual routines that do the work.
    procedure CreateCoClasses(const TL: ITypeLib; TICount: Integer); virtual;
    procedure CreateForwards(const TL: ITypeLib; TICount: Integer); virtual;
    procedure CreateInterfaces(const TL: ITypeLib; TICount: Integer); virtual;
    procedure CreateRecordsUnionsAliases(const TL: ITypeLib; TICount: Integer); virtual;
    procedure CreateUnitHeader(const TL: ITypeLib; const LA: lpTLIBATTR); virtual;
    procedure ImportEnums(const TL: ITypeLib; TICount: Integer); virtual;
    procedure ImportGUIDs(const TL: ITypeLib; TICount: Integer); virtual;
    Procedure DoImportTypelib;virtual;
    // For the benefit of descendents;
    Property UsesClause : TStrings read FUses;
    Property Header : TStrings read FHeader;
    Property InterfaceSection : TStrings Read FInterface;
    Property ImplementationSection : TStrings Read FImplementation;
  Public
    Constructor Create(AOwner : TComponent); override;
    Destructor Destroy; override;
    Procedure Execute;
    Property Dependencies : TStrings Read GetDependencies;
    Property UnitSource : TStrings Read GetUnitSource;
  Published
    // Create ActiveXContainer descendant: default false
    Property ActiveX : Boolean Read FActiveX write FActiveX Default False;
    // Append version number to unit name.
    Property AppendVersionNumber : Boolean Read FAppendVersionNumber Write FAppendVersionNumber Default True;
    // File to read typelib from.
    Property InputFileName : WideString Read FInputFileName Write FInputFileName;
    // If set, unit source will be written to this file.
    Property OutputFileName : String Read FOutputFileName Write SetOutputFileName;
    // Set automatically by OutputFileName or by Execute
    Property UnitName : string Read FUnitname Write SetUnitName;
  end;


implementation

Resourcestring
  SErrInvalidUnitName = 'Invalid unit name : %s';

function ImportTypelib(FileName: WideString;var sUnitName:string;var slDependencies:TStringList;
  bActiveX:boolean):string;
var i:integer;
begin
  With TTypeLibImporter.Create(Nil) do
    try
      InputFileName:=FileName;
      ActiveX:=bActiveX;
      Execute;
      Result:=UnitSource.Text;
      sUnitname:=UnitName+'.pas';
      if Assigned(slDependencies) then
        begin  //add new dependencies
        for i:=0 to Dependencies.Count-1 do
          if slDependencies.IndexOf(Dependencies[i])=-1 then
            slDependencies.Add(Dependencies[i]);
        end;
    finally
      Free;
    end;
end;

function TTypeLibImporter.VarTypeIsAutomatable(ParamType:integer): boolean;

begin
result:=ParamType in [vt_i1,vt_ui1,vt_i2,vt_ui2,vt_i4,vt_ui4,vt_uint,
            vt_i8,VT_UI8,vt_bool,vt_r4,vt_r8,vt_cy,vt_date,
            VT_BSTR,VT_VARIANT,VT_DISPATCH,VT_UNKNOWN,vt_hresult,VT_INT,
            VT_LPWSTR,VT_LPSTR];
end;

function TTypeLibImporter.VarTypeToStr(ParamType:integer): string;

begin
  case ParamType of
    vt_empty : Result := 'Empty';
    vt_null : Result := 'Null';
    vt_i2 : Result := 'Smallint';
    vt_i4 : Result := 'Integer';
    vt_r4 : Result := 'Single';
    vt_r8 : Result := 'Double';
    vt_cy : Result := 'Currency';
    vt_date : Result := 'TDateTime';
    vt_bstr : Result := 'WideString';
    vt_dispatch  : Result := 'IDispatch';
    vt_error : Result := 'SCODE';
    vt_bool : Result := 'WordBool';
    vt_variant : Result := 'Variant';
    vt_unknown : Result := 'IUnknown';
    vt_i1  : Result := 'ShortInt';
    vt_ui1 : Result := 'Byte';
    vt_ui2 : Result := 'Word';
    vt_ui4  : Result := 'LongWord';
    vt_i8 : Result := 'Int64';
    VT_UI8: Result := 'QWord';
    vt_clsid : Result := 'TGUID';
    vt_void : Result := 'pointer';
    vt_ptr : Result := 'Pointer';
    vt_uint : Result := 'UInt';
    vt_userdefined : Result := 'User defined';
    vt_hresult : Result := 'HResult';
    VT_INT:Result:='SYSINT';
    VT_SAFEARRAY:Result:='PSafeArray';
    VT_LPWSTR:Result:='PWideChar';
    VT_LPSTR:Result:='PChar';
  else
    Result := 'Unknown (' + IntToStr(ParamType) + ')';
  end;
end;

function TTypeLibImporter.ValidateID(id:string):boolean;

const
  RESERVEDCNT=111;
  RESERVED:array[1..RESERVEDCNT] of string=
  ('absolute','and','array','asm','begin','break','case','const',
  'constructor','continue','destructor','div','do','downto','else','end',
  'file','for','function','goto','if','implementation','in','inherited',
  'inline','interface','label','mod','nil','not','object','of',
  'on','operator','or','packed','procedure','program','record','reintroduce',
  'repeat','self','set','shl','shr','string','then','to',
  'type','unit','until','uses','var','while','with','xor',
  'as','class','except','exports','finalization','finally','initialization',
  'is','library','on','property','raise','threadvar','try',
  'dispose','exit','false','new','true',
  'abs','arctan','boolean','char','cos','dispose','eof','eoln',
  'exp','false','input','integer','ln','maxint','new','odd',
  'ord','output','pack','page','pred','read','readln','real',
  'reset','rewrite','round','sin','sqr','sqrt','succ','text',
  'true','trunc','write','writeln');

var
  sl:string;
  i:integer;

begin
  sl:=lowercase(id);
  result:=true;
  for i:=1 to RESERVEDCNT do
    if sl= RESERVED[i] then
      begin
      result:=false;
      break;
      end;
end;


function TTypeLibImporter.TypeToString(TI:ITypeInfo; TD:TYPEDESC):string;

var
  TIref: ITypeInfo;
  TARef:LPTYPEATTR;
  TLRef: ITypeLib;
  LARef: lpTLIBATTR;
  BstrName : WideString;
  il:LongWord;
  i,idims:integer;
  sl,sRefSrc,sKey:string;
  Handle:HKEY;
  bWasPointer:boolean;
begin
  result:='';
  bIsCustomAutomatable:=false;
  bIsInterface:=false;
  bIsExternalDecl:=false;
  bIsUserDefined:=false;
  if (TD.vt=vt_userdefined) or ((TD.vt=VT_PTR) and (TD.lptdesc^.vt=vt_userdefined)) then
    begin
    // interface references are dealt with now because they are pointers in fpc.
    // Recursive algorithm makes it difficult to remove a single preceding 'P' from the result.
    bIsUserDefined:=true;
    bWasPointer:=(TD.vt=VT_PTR);
    if bWasPointer then
      TD:=TD.lptdesc^;
    OleCheck(TI.GetRefTypeInfo(TD.hreftype,TIref));
    OleCheck(TIRef.GetDocumentation(DISPID_UNKNOWN, @BstrName, nil, nil, nil));
    result:=BstrName;
    OleCheck(TIRef.GetTypeAttr(TARef));
    bIsCustomAutomatable:=TARef^.typekind in [TKIND_DISPATCH,TKIND_INTERFACE,TKIND_ENUM];
    if TARef^.typekind=TKIND_ALIAS then
      begin
      TypeToString(TIRef,TARef^.tdescAlias); //not interested in result, only bIsCustomAutomatable and bIsInterface
      bIsCustomAutomatable:=bIsAutomatable;
      end
    else
      bIsInterface:=TARef^.typekind in [TKIND_DISPATCH,TKIND_INTERFACE] ;
    if bWasPointer and not bIsInterface then  // interfaces are pointers to interface in fpc
      result:='P'+result;
    OleCheck(TIRef.GetContainingTypeLib(TLRef,il));
    OleCheck(TLRef.GetDocumentation(-1, @BstrName, nil, nil, nil));
    OleCheck(TLRef.GetLibAttr(LARef));
    if FAppendVersionNumber then
      sl:=format('%s_%d_%d_TLB',[BstrName,LARef^.wMajorVerNum,LARef^.wMinorVerNum])
    else
      sl:=format('%s_TLB',[BstrName]);
    if (LowerCase(BstrName)='stdole') then // don't include, uses pre-defined stdole2.pas if V2
      begin
      bIsExternalDecl:=true;
      if lowercase(result)='guid' then
        result:='TGUID';
      if (LARef^.wMajorVerNum=2) and (FUses.IndexOf('stdole2')=-1) then
        begin
        AddToHeader('// Dependency: stdole v2 (stdole2.pas)');
        FUses.Add('stdole2');
        end;
      end
    else if (LowerCase(sl)<>LowerCase(UnitName)) and (FUses.IndexOf(sl)=-1) then
      begin  // add dependency
      // find source in registry key HKEY_CLASSES_ROOT\TypeLib\GUID\version\0\win32
      bIsExternalDecl:=true;
      il:=MAX_PATH;
      SetLength(sRefSrc,il);
      sKey:=format('\TypeLib\%s\%d.%d\0\win32',[GUIDToString(LARef^.GUID),LARef^.wMajorVerNum,LARef^.wMinorVerNum]);
      if (RegOpenKeyEx(HKEY_CLASSES_ROOT,pchar(sKey),0,KEY_READ,Handle) = ERROR_SUCCESS) then
        begin
        if RegQueryValue(Handle,nil,@sRefSrc[1],@il) = ERROR_SUCCESS then
          begin
          SetLength(sRefSrc,il-1);  // includes null terminator
          if not FDependencies.Find(sRefSrc,i) then
            FDependencies.Add(sRefSrc);
          end
        else
          sRefSrc:=GUIDToString(LARef^.GUID);
        RegCloseKey(Handle);
        end;
      AddToHeader('// Dependency: %s v%d.%d (%s)',[BstrName,LARef^.wMajorVerNum,LARef^.wMinorVerNum,sRefSrc]);
      FUses.Add(sl);
      TLRef.ReleaseTLibAttr(LARef);
      end;
    TIRef.ReleaseTypeAttr(TARef);
    end
  else if TD.vt=VT_PTR then //pointer type
    begin
    TD:=TD.lptdesc^;
    result:='P'+TypeToString(TI,TD);
    bIsAutomatable:=(VarTypeIsAutomatable(TD.vt) {and (TD.vt<>VT_VARIANT)}) or bIsCustomAutomatable;
    exit;
    end
  else if TD.vt=VT_CARRAY then //C type array
    begin
    // get array element type
    sl:=TypeToString(TI,TD.lpadesc^.tdescElem);
    // get dimensions
    idims:=TD.lpadesc^.cDims;
    result:='array[';
    // get boundaries for every dimension
    for i:=0 to idims-1 do
      result:=result+IntToStr(TD.lpadesc^.rgbounds[i].lLbound)+'..'+IntToStr(TD.lpadesc^.rgbounds[i].cElements - TD.lpadesc^.rgbounds[i].lLbound -1)+',';
    result[length(result)]:=']';
    result:=result + ' of '+sl;
    end
  else
    result:=VarTypeToStr(TD.vt);
  bIsAutomatable:=VarTypeIsAutomatable(TD.vt) or bIsCustomAutomatable;
end;

function TTypeLibImporter.interfacedeclaration(iName,iDoc:string;TI:ITypeInfo;TA:LPTYPEATTR;
  bIsDispatch,bCreateEvents:boolean):string;

type
  TPropertyDef=record
    idispid:integer;
    bput,bget:boolean;
    iptype,igtype:integer;
    name,
    sptype,          // only used if iptype=igtype
    sorgname,
    sdoc,
    sParam,
    sDefault:string;
  end;

var
  RTIT: HREFTYPE;
  TIref: ITypeInfo;
  BstrName,BstrNameRef,BstrDocString : WideString;
  s,sl,sPropIntfc,sPropDispIntfc,sType,sConv,sFunc,sPar,sVarName,sMethodName,sPropParam,sPropParam2:string;
  sEventSignatures,sEventFunctions,sEventProperties,sEventImplementations:string;
  i,j,k:integer;
  FD: lpFUNCDESC;
  BL : array[0..99] of TBstr;
  cnt:LongWord;
  TD: TYPEDESC;
  bPropHasParam,bIsFunction,bParamByRef:boolean;
  VD: lpVARDESC;
  aPropertyDefs:array of TPropertyDef;
  Propertycnt,iType:integer;

  function findProperty(ireqdispid:integer):integer;
  var i:integer;
  begin
    for i:=0 to Propertycnt-1 do
      if aPropertyDefs[i].idispid=ireqdispid then
        begin
        result:=i;
        exit;
        end;
    result:=Propertycnt;
    Propertycnt:=Propertycnt+1;
    with aPropertyDefs[result] do
      begin
      idispid:=ireqdispid;
      bput:=false;
      bget:=false;
      name:='';
      iptype:=vt_empty;
      igtype:=vt_empty;
      sptype:='';
      sorgname:='';
      sdoc:='';
      sParam:='';
      sDefault:='';
      end;
  end;

begin
  Propertycnt:=0;
  SetLength(aPropertyDefs,TA^.cFuncs+TA^.cVars);   // worst case, all functions getters or all setters
  sEventSignatures:='';
  sEventFunctions:='';
  sEventProperties:='';
  sEventImplementations:='';
  if not bIsDispatch then
    begin
    // find base class
    if TA^.cImplTypes>0 then
      begin
      OleCheck(TI.GetRefTypeOfImplType(0,RTIT));
      OleCheck(TI.GetRefTypeInfo(RTIT,TIref));
      OleCheck(TIRef.GetDocumentation(DISPID_UNKNOWN, @BstrNameRef, nil, nil, nil));
      s:=format(#13#10'// %s : %s'#13#10#13#10' %s = interface(%s)'#13#10,[iname,iDoc,iname,BstrNameRef]);
      end
    else // no base class
      begin
      s:=format(#13#10'// %s : %s'#13#10#13#10' %s = interface'#13#10,[iname,iDoc,iname]);
      end;
    end
  else
    if (TA^.wTypeFlags and TYPEFLAG_FDUAL)=TYPEFLAG_FDUAL then
      s:=format(#13#10'// %s : %s'#13#10#13#10' %sDisp = dispinterface'#13#10,[iname,iDoc,iname])
    else
      s:=format(#13#10'// %s : %s'#13#10#13#10' %s = dispinterface'#13#10,[iname,iDoc,iname]);
  sPropIntfc:='';
  sPropDispIntfc:='';
  s:=s+format('   [''%s'']'#13#10,[GUIDToString(TA^.GUID)]);
  for j:=0 to TA^.cFuncs-1 do
    begin
    OleCheck(TI.GetFuncDesc(j,FD));
    OleCheck(TI.GetNames(FD^.memid,@BL,length(BL),cnt));
    // skip IUnknown and IDispatch methods
    sl:=lowercase(BL[0]);
    if (sl='queryinterface') or (sl='addref') or (sl='release') then  //IUnknown
      continue;
    if bIsDispatch and
      ((sl='gettypeinfocount') or (sl='gettypeinfo') or (sl='getidsofnames') or (sl='invoke')) then  //IDispatch
      continue;
    // get return type
    if bIsDispatch and ((FD^.invkind=INVOKE_PROPERTYGET) or (FD^.invkind=INVOKE_FUNC)) then
      begin
      sType:=TypeToString(TI,FD^.elemdescFunc.tdesc);
      iType:=FD^.elemdescFunc.tdesc.vt;
      end
    else
      if FD^.cParams>0 then
        begin
        sType:=TypeToString(TI,FD^.lprgelemdescParam[FD^.cParams-1].tdesc);
        iType:=FD^.lprgelemdescParam[FD^.cParams-1].tdesc.vt;
        if ((FD^.lprgelemdescParam[FD^.cParams-1].paramdesc.wParamFlags and (PARAMFLAG_FRETVAL or PARAMFLAG_FOUT)) <>0) then
          begin
          delete(sType,1,1); //out parameters are always defined as pointer
          if assigned(FD^.lprgelemdescParam[FD^.cParams-1].tdesc.lptdesc) then
            iType:=FD^.lprgelemdescParam[FD^.cParams-1].tdesc.lptdesc^.vt;
          end;
        end;
    //get calling convention
    if FD^.callconv=CC_STDCALL then
      begin
      if lowercase(BstrNameRef)='iunknown' then
        sConv:='stdcall'
      else
        sConv:='safecall';
      end
    else
      sConv:='cdecl';
    // get info
    OleCheck(TI.GetDocumentation(FD^.memid, @BstrName, @BstrDocString, nil, nil));
    case FD^.invkind of
      // build function/procedure
      INVOKE_FUNC :
        begin
        if ValidateID(BstrName) then
          sMethodName:=BstrName
        else
          begin
          sMethodName:=BstrName+'_';
          AddToHeader('//  Warning: renamed method ''%s'' in %s to ''%s''',[BstrName,iname,sMethodName],True);
          end;
        bIsFunction:=(bIsDispatch and (FD^.elemdescFunc.tdesc.vt<>VT_VOID)) or
          (not bIsDispatch and (FD^.cParams>0) and ((FD^.lprgelemdescParam[FD^.cParams-1].paramdesc.wParamFlags and PARAMFLAG_FRETVAL ) <>0));
        if bIsFunction then
          sFunc:=format('    // %s : %s '#13#10'   function %s(',[sMethodName,BstrDocString,sMethodName])
        else
          sFunc:=format('    // %s : %s '#13#10'   procedure %s(',[sMethodName,BstrDocString,sMethodName]);
        if bIsFunction and bIsDispatch and not bIsAutomatable then
          begin
          AddToHeader('//  Warning: ''%s'' not automatable in %sdisp.%s',[stype,iname,BstrName],True);
          sType:='{!! '+sType+' !!} OleVariant';
          end;
        if bCreateEvents then
          begin
          sEventSignatures:=sEventSignatures+format('  T%s%s = procedure(Sender: TObject;',[iname,sMethodName]);
          sEventFunctions:=sEventFunctions+format('    FOn%s:T%s%s;'#13#10,[sMethodName,iname,sMethodName]);
          sEventProperties:=sEventProperties+format('    property On%s : T%s%s read FOn%s write FOn%s;'#13#10,
            [sMethodName,iname,sMethodName,sMethodName,sMethodName]);
          sEventImplementations:=sEventImplementations+
            format('    %d: if assigned(On%s) then'#13#10+
                   '          On%s(Self,',[FD^.memid,sMethodName,sMethodName]);
          end;
        // parameters
        for k:=0 to FD^.cParams-1 do
          begin
          bParamByRef:=(FD^.lprgelemdescParam[k].tdesc.vt=VT_PTR) and                         // by ref
            not((FD^.lprgelemdescParam[k].tdesc.lptdesc^.vt=VT_USERDEFINED) and bIsInterface);// but not pointer to interface
          if (FD^.lprgelemdescParam[k].paramdesc.wParamFlags and PARAMFLAG_FRETVAL ) <>0 then  //return type
            continue;
          sl:=TypeToString(TI,FD^.lprgelemdescParam[k].tdesc);
          if bParamByRef then
             delete(sl,1,1);
          if bIsDispatch and not bIsAutomatable then
            begin
            AddToHeader('//  Warning: ''%s'' not automatable in %sdisp.%s',[sl,iname,sMethodName],True);
            sl:='{!! '+sl+' !!} OleVariant';
            end;
          sPar:='';
          if bParamByRef then
            case FD^.lprgelemdescParam[k].paramdesc.wParamFlags and (PARAMFLAG_FIN or PARAMFLAG_FOUT) of
            PARAMFLAG_FIN or PARAMFLAG_FOUT:sPar:='var ';
            PARAMFLAG_FOUT:sPar:='out ';
            PARAMFLAG_FIN:sPar:='var '; //constref in safecall? TBD
            end;
          if ValidateID(BL[k+1]) then
            sVarName:=BL[k+1]
          else
            begin
            sVarName:=BL[k+1]+'_';
            AddToHeader('//  Warning: renamed parameter ''%s'' in %s.%s to ''%s'''#13#10,[BL[k+1],iname,sMethodName,sVarName],True);
            end;
          sPar:=sPar+format('%s:%s;',[sVarName,sl]);
          sFunc:=sFunc+sPar;
          if bCreateEvents then
            begin
            sEventSignatures:=sEventSignatures+sPar;
            //params are numbered last to first
            if bParamByRef and not(bIsDispatch and not bIsAutomatable) then
              begin
              case FD^.lprgelemdescParam[k].tdesc.lptdesc^.vt of
                VT_UI1:       sl:='pbVal';
                VT_UI2:       sl:='puiVal';
                VT_UI4:       sl:='pulVal';
                VT_UI8:       sl:='pullVal';
                VT_I1:        sl:='pcVal';
                VT_I2:        sl:='piVal';
                VT_I4:        sl:='plVal';
                VT_I8:        sl:='pllVal';
                VT_R4:        sl:='pfltVal';
                VT_R8:        sl:='pdblVal';
                VT_BOOL:      sl:='pbool';
                VT_ERROR:     sl:='pscode';
                VT_CY:        sl:='pcyVal';
                VT_DATE:      sl:='pdate';
                VT_BSTR:      sl:='pbstrVal';
                VT_UNKNOWN:   sl:='punkVal';
                VT_DISPATCH:  sl:='pdispVal';
                VT_ARRAY:     sl:='pparray';
                VT_VARIANT:   sl:='pvarVal';
              end;
              sEventImplementations:=sEventImplementations+format(' Params.rgvarg[%d].%s^,',[FD^.cParams-1-k,sl]);
              end
            else
              sEventImplementations:=sEventImplementations+format(' OleVariant(Params.rgvarg[%d]),',[FD^.cParams-1-k]);
            end;
          end;
        // finish interface and dispinterface
        if sFunc[length(sFunc)]=';' then
          sFunc[length(sFunc)]:=')'
        else  // no params
          delete(sFunc,length(sFunc),1);
        if bCreateEvents then
          begin
          sEventSignatures[length(sEventSignatures)]:=')';
          sEventSignatures:=sEventSignatures+' of object;'#13#10;
          sEventImplementations[length(sEventImplementations)]:=')';
          sEventImplementations:=sEventImplementations+';'#13#10;
          end;
        if bIsFunction then
          sFunc:=sFunc+format(':%s',[sType]);
        if bIsDispatch then
          s:=s+sFunc+format(';dispid %d;'#13#10,[FD^.memid])
        else
          s:=s+sFunc+format(';%s;'#13#10,[sConv]);
        end;
      INVOKE_PROPERTYGET,INVOKE_PROPERTYPUT,INVOKE_PROPERTYPUTREF :
        // build properties. Use separate string to group properties at end of interface declaration.
        begin
        if ValidateID(BstrName) then
          sMethodName:=BstrName
        else
          begin
          sMethodName:=BstrName+'_';
          AddToHeader('//  Warning: renamed property ''%s'' in %s to ''%s''',[BstrName,iname,sMethodName]);
          end;
        bPropHasParam:=(((FD^.invkind=INVOKE_PROPERTYGET) and (FD^.cParams>0)) or (FD^.cParams>1))
            and ((FD^.lprgelemdescParam[0].paramdesc.wParamFlags and PARAMFLAG_FIN) = PARAMFLAG_FIN) ;
        if (FD^.memid=0) and  bPropHasParam then sl:=' default;' else sl:='';
        sPropParam:='';
        sPropParam2:='';
        if bPropHasParam then
          begin
          sPropParam:=BL[1]+':'+TypeToString(TI,FD^.lprgelemdescParam[0].tdesc);
          end;
        if bIsDispatch then
          begin
          if (TD.vt<>VT_VOID) and not bIsAutomatable then
            begin
            AddToHeader('//  Warning: ''%s'' not automatable in %s.%s',[stype,iname,BstrName]);
            sType:='{!! '+sType+' !!} OleVariant';
            end;
          if bPropHasParam then
            sPropParam:='['+sPropParam+']';
          i:=pos(format('dispid %d;',[FD^.memid]),sPropDispIntfc);
          if i<=0 then
            begin
            if FD^.invkind=INVOKE_PROPERTYGET then
              sType:=sType+' readonly '
            else
              sType:=sType+' writeonly';
            sPropDispIntfc:=sPropDispIntfc+format('    // %s : %s '#13#10'   property %s%s:%s dispid %d;%s'#13#10,
              [BstrName,BstrDocString,sMethodName,sPropParam,sType,FD^.memid,sl]);
            end
          else //remove readonly or writeonly
            delete(sPropDispIntfc,i-11,10);   //10= length(' readonly ')
          end
        else
          begin
          //getters/setters for interface, insert in interface as they come,
          //store in aPropertyDefs to create properties at the end
          if bPropHasParam then
            begin
            sPropParam2:='('+sPropParam+')';
            sPropParam:='['+sPropParam+']';
            end;
          if FD^.invkind=INVOKE_PROPERTYGET then
            begin
            s:=s+format('   function Get_%s%s : %s; %s;'#13#10,[sMethodName,sPropParam2,sType,sConv]);
            with aPropertyDefs[findProperty(FD^.memid)] do
              begin
              bget:=true;
              name:=sMethodName;
              igtype:=itype;
              sptype:=sType;
              sorgname:=BstrName;
              sdoc:=BstrDocString;
              sParam:=sPropParam;
              sDefault:=sl;
              end;
            end
          else
            begin
            if ValidateID(BL[1]) then
              sVarName:=BL[1]
            else
              begin
              sVarName:=BL[1]+'_';
              AddToHeader('//  Warning: renamed parameter ''%s'' in %s.Set_%s to ''%s''',[BL[1],iname,sMethodName,sVarName]);
              end;
            s:=s+format('   procedure Set_%s(const %s:%s); %s;'#13#10,[sMethodName,sVarName,sType,sConv]);
            with aPropertyDefs[findProperty(FD^.memid)] do
              begin
              bput:=true;
              name:=sMethodName;
              iptype:=itype;
              sptype:=sType;
              sorgname:=BstrName;
              sdoc:=BstrDocString;
              sParam:=sPropParam;
              sDefault:=sl;
              end;
            end;
          end;
        end;
    end;
    TI.ReleaseFuncDesc(FD);
    end;
  for j:=0 to TA^.cVars-1 do
    begin  //read-write properties only
    if bIsDispatch then
      begin
      TI.GetVarDesc(j,VD);
      if assigned(VD) then
        begin
        TI.GetDocumentation(VD^.memId,@BstrName, @BstrDocString, nil, nil);
        if ValidateID(BstrName) then
          sMethodName:=BstrName
        else
          begin
          sMethodName:=BstrName+'_';
          AddToHeader('//  Warning: renamed property ''%s'' in %s to ''%s'''#13#10,[BstrName,iname,sMethodName]);
          end;
        sType:=TypeToString(TI,VD^.ElemdescVar.tdesc);
        sPropDispIntfc:=sPropDispIntfc+format('    // %s : %s '#13#10'   property %s:%s  dispid %d;'#13#10,
          [BstrName,BstrDocString,sMethodName,sType,VD^.memId]);
        end;
      end;
    end;
  if bCreateEvents then
    begin
    FEventDisp.Add(iname);
    FEventIID.Add(GUIDToString(TA^.GUID));
    FEventSignatures.Add(sEventSignatures);
    FEventFunctions.Add(sEventFunctions);
    FEventProperties.Add(sEventProperties);
    FEventImplementations.Add(sEventImplementations);
    end;
  if bIsDispatch then
    result:=s + sPropDispIntfc +'  end;'#13#10
  else
    begin
    // add interface properties
    for i:=0 to Propertycnt-1 do
      with aPropertyDefs[i] do
      if (iptype=igtype) or not bget or not bput then
        begin
        s:=s+format('    // %s : %s '#13#10'   property %s%s:%s',[sorgname,sdoc,name,sParam,sptype]);
        if bget then
          s:=s+format(' read Get_%s',[name]);
        if bput then
          s:=s+format(' write Set_%s',[name]);
        s:=s+format(';%s'#13#10,[sDefault]);
        end;
    result:=s+'  end;'#13#10;
    end;
end;

function TTypeLibImporter.GetDependencies: TStrings;
begin
  Result:=FDependencies;
end;

function TTypeLibImporter.GetUnitSource: TStrings;
begin
  Result:=FUnitSource;
end;

Procedure TTypeLibImporter.ImportGUIDs(Const TL : ITypeLib; TICount : Integer);

Var
  i : integer;
  BstrName, BstrDocString, BstrHelpFile : WideString;
  dwHelpContext: DWORD;
  TI:ITypeInfo;
  TA:LPTYPEATTR;
  TIT: TYPEKIND;

begin
  //GUIDs
  for i:=0 to TIcount-1 do
    begin
    OleCheck(TL.GetTypeInfoType(i, TIT));
    OleCheck(TL.GetTypeInfo(i, TI));
    OleCheck(TL.GetDocumentation(i, @BstrName, @BstrDocString, @dwHelpContext, @BstrHelpFile));
    OleCheck(TI.GetTypeAttr(TA));
    case TIT of
      TKIND_DISPATCH,TKIND_INTERFACE:
        begin
        AddToInterface('  IID_%s : TGUID = ''%s'';',[BstrName,GUIDToString(TA^.GUID)]);
        end;
      TKIND_COCLASS:
        begin
        AddToInterface('  CLASS_%s : TGUID = ''%s'';',[BstrName,GUIDToString(TA^.GUID)]);
        end;
      end;
    TI.ReleaseTypeAttr(TA);
    end;
end;

Procedure TTypeLibImporter.ImportEnums(Const TL : ITypeLib; TICount : Integer);

Var
  i,j : integer;
  sl : string;
  BstrName, BstrDocString, BstrHelpFile : WideString;
  dwHelpContext: DWORD;
  TI:ITypeInfo;
  TA:LPTYPEATTR;
  TIT: TYPEKIND;
  bDuplicate:boolean;
  VD: lpVARDESC;

begin
  //enums
  AddToInterface('');
  AddToInterface('//Enums');
  AddToInterface('');
  for i:=0 to TIcount-1 do
    begin
    OleCheck(TL.GetTypeInfoType(i, TIT));
    OleCheck(TL.GetTypeInfo(i, TI));
    OleCheck(TL.GetDocumentation(i, @BstrName, @BstrDocString, @dwHelpContext, @BstrHelpFile));
    OleCheck(TI.GetTypeAttr(TA));
    if TIT=TKIND_ENUM then
      begin
      bDuplicate:=false;
      if ValidateID(BstrName) then
        sl:=BstrName
      else
        begin
        sl:=BstrName+'_';
        AddToHeader('//  Warning: renamed enum type ''%s'' to ''%s''',[BstrName,sl],True);
        end;
      if (InterfaceSection.IndexOf(Format('  %s =TOleEnum;',[sl]))<>-1) then  // duplicate enums fe. AXVCL.dll 1.0
        begin
        sl:=sl+IntToStr(i); // index is unique in this typelib
        AddToHeader('//  Warning: duplicate enum ''%s''. Renamed to ''%s''. consts appended with %d',[BstrName,sl,i]);
        bDuplicate:=true;
        end;
      AddToInterface('Type');
      AddToInterface('  %s =TOleEnum;',[sl]);
      FTypes.Add(sl);
      AddToInterface('Const');
      for j:=0 to TA^.cVars-1 do
        begin
        TI.GetVarDesc(j,VD);
        if assigned(VD) then
          begin
          TI.GetDocumentation(VD^.memId,@BstrName, nil, nil, nil);
          if ValidateID(BstrName) then
            sl:=BstrName
          else
            begin
            sl:=BstrName+'_';
            AddToHeader('//  Warning: renamed enum value ''%s'' to ''%s''',[BstrName,sl],True);
            end;
          if bDuplicate then
            sl:=sl+IntToStr(i);
          if assigned(VD^.lpvarValue) then
            AddToInterface('  %s = $%s;',[sl,IntToHex(PtrInt(VD^.lpvarValue^),16)]);
          end;
        end;
      end;
    TI.ReleaseTypeAttr(TA);
    end;
end;

Procedure TTypeLibImporter.CreateForwards(Const TL : ITypeLib; TICount : Integer);

Var
  i : integer;
  BstrName, BstrDocString, BstrHelpFile : WideString;
  dwHelpContext: DWORD;
  TI:ITypeInfo;
  TA:LPTYPEATTR;
  TIT: TYPEKIND;

begin
  // Forward declarations
  AddToInterface('//Forward declarations');
  AddToInterface('');
  AddToInterface('Type');
  for i:=0 to TIcount-1 do
    begin
    OleCheck(TL.GetTypeInfoType(i, TIT));
    OleCheck(TL.GetTypeInfo(i, TI));
    OleCheck(TL.GetDocumentation(i, @BstrName, @BstrDocString, @dwHelpContext, @BstrHelpFile));
    OleCheck(TI.GetTypeAttr(TA));
    if (TIT=TKIND_DISPATCH) then
      begin
      if (TA^.wTypeFlags and TYPEFLAG_FDUAL)=TYPEFLAG_FDUAL then
        begin
        AddToInterface(' %s = interface;',[BstrName]);
        AddToInterFace(' %sDisp = dispinterface;',[BstrName]);
        end
      else
        AddToInterface(' %s = dispinterface;',[BstrName]);
      end
    else if (TIT=TKIND_INTERFACE) then
      AddToInterface(' %s = interface;',[BstrName]);
    TI.ReleaseTypeAttr(TA);
    end;
end;

Procedure TTypeLibImporter.CreateRecordsUnionsAliases(Const TL : ITypeLib; TICount : Integer);

Var
  i,j : integer;
  BstrName, BstrDocString, BstrHelpFile : WideString;
  dwHelpContext: DWORD;
  TI:ITypeInfo;
  TA:LPTYPEATTR;
  TIT: TYPEKIND;
  VD: lpVARDESC;
  slDeferredType,slDeferredPendingType,slDeferredDeclaration:TStrings;
  sl,sldeclaration,stype,smembername,srecordname:string;
  bIsDeferred:boolean;

  procedure ReleasePendingType(sPen:string);
  var k:integer;
    sDec,sTyp:string;
  begin
    k:=slDeferredPendingType.IndexOf(sPen);
    while (k>=0) do
      begin
      sDec:=slDeferredDeclaration[k];
      sTyp:=slDeferredType[k];
      slDeferredPendingType.Delete(k);
      slDeferredDeclaration.Delete(k);
      slDeferredType.Delete(k);
      // any other types pending for this declaration ? If yes, wait until all types declared.
      if slDeferredDeclaration.IndexOf(sDec)=-1 then
        begin
        AddToInterface(sDec);
        FTypes.Add(sTyp);
        ReleasePendingType(sTyp);
        end;
      k:=slDeferredPendingType.IndexOf(sPen);
      end;
  end;

begin
  //records, unions aliases
  AddToInterface('');
  AddToInterface('//records, unions, aliases');
  AddToInterface('');
  slDeferredType:=TStringList.Create;
  slDeferredPendingType:=TStringList.Create;
  slDeferredDeclaration:=TStringList.Create;
  try
  for i:=0 to TIcount-1 do
    begin
    bIsDeferred:=false;
    sldeclaration:='';
    OleCheck(TL.GetTypeInfoType(i, TIT));
    //s:=s+format('type %d'#13#10,[ord(TIT)]);
    OleCheck(TL.GetTypeInfo(i, TI));
    OleCheck(TL.GetDocumentation(i, @BstrName, @BstrDocString, @dwHelpContext, @BstrHelpFile));
    OleCheck(TI.GetTypeAttr(TA));
    case TIT of
      TKIND_RECORD,TKIND_UNION:
        begin
        if ValidateID(BstrName) then
          sRecordName:=BstrName
        else
          begin
          sRecordName:=BstrName+'_';
          AddToHeader('//  Warning: renamed record ''%s'' to ''%s''',[BstrName,sRecordName],True);
          end;
        AddToInterface(' P%s = ^%s;'#13#10,[sRecordName,sRecordName]);
        FTypes.Add('P'+sRecordName);
        ReleasePendingType('P'+sRecordName);
        if TIT=TKIND_RECORD then
          sldeclaration:=sldeclaration+format(' %s = packed record'#13#10,[sRecordName])
        else
          begin
          sldeclaration:=sldeclaration+format(' %s =  record'#13#10,[sRecordName]);
          sldeclaration:=sldeclaration+'    case Integer of'#13#10;
          end;
        for j:=0 to TA^.cVars-1 do
          begin
          TI.GetVarDesc(j,VD);
          TI.GetDocumentation(VD^.memId,@BstrName, @BstrDocString, @dwHelpContext, @BstrHelpFile);
          if ValidateID(BstrName) then
            smemberName:=BstrName
          else
            begin
            smemberName:=BstrName+'_';
            AddToHeader('//  Warning: renamed record member ''%s'' in %s to ''%s''',[BstrName,sRecordName,smemberName],True);
            end;
          stype:=TypeToString(TI, VD^.ElemdescVar.tdesc);
          if bIsUserDefined and not ValidateID(stype) then
            stype:=stype+'_';
          if bIsUserDefined and not bIsExternalDecl and (FTypes.IndexOf(stype)=-1) then //not defined yet, defer
            begin
            bIsDeferred:=true;
            slDeferredPendingType.Add(stype);
            slDeferredType.Add(sRecordName);
            end;
          if TIT=TKIND_RECORD then
            sldeclaration:=sldeclaration+format('     %s : %s;'#13#10,[smemberName,stype])
          else
            sldeclaration:=sldeclaration+format('     %d: (%s : %s);'#13#10,[j,smemberName,stype]);
          end;
        sldeclaration:=sldeclaration+' end;';
        if not bIsDeferred then
          begin
          AddToInterface(sldeclaration);
          FTypes.Add(sRecordName);
          ReleasePendingType(sRecordName);
          end
        else
          for j:=slDeferredDeclaration.Count to slDeferredType.Count-1 do  // catch up on slDeferredType
            slDeferredDeclaration.Add(sldeclaration);
        end;
      TKIND_ALIAS:
        begin
        stype:=TypeToString(TI, TA^.tdescAlias);
        if bIsUserDefined and not ValidateID(stype) then
          stype:=stype+'_';
        if ValidateID(BstrName) then
          sRecordName:=BstrName
        else
          begin
          sRecordName:=BstrName+'_';
          AddToHeader('//  Warning: renamed alias ''%s'' to ''%s''',[BstrName,sRecordName],True);
          end;
        sl:=format(' %s = %s;',[sRecordName,stype]);
        if bIsUserDefined and not bIsExternalDecl and (FTypes.IndexOf(stype)=-1) then //not defined yet, defer
          begin
          slDeferredDeclaration.Add(sl);
          slDeferredPendingType.Add(stype);
          slDeferredType.Add(sRecordName);
          end
        else
          begin
          AddToInterface(sl);
          FTypes.Add(sRecordName);
          ReleasePendingType(sRecordName);
          end;
        end;
      end;
    TI.ReleaseTypeAttr(TA);
    end;
  if slDeferredDeclaration.Count>1 then  // circular references
    begin
    AddToHeader('//  Error : the following type declarations have circular references',True);
    AddToInterface('// circular references start here');
    for j:=0 to slDeferredDeclaration.Count-1 do
      AddToHeader('//          %s',[slDeferredType[j]]);
    for j:=0 to slDeferredDeclaration.Count-1 do
      AddToInterface(slDeferredDeclaration[j]);
    end;
  finally
    slDeferredDeclaration.Free;
    slDeferredPendingType.Free;
    slDeferredType.Free;
  end;
end;

Procedure TTypeLibImporter.CreateInterfaces(Const TL : ITypeLib; TICount : Integer);

Var
  i : integer;
  BstrName, BstrDocString, BstrHelpFile : WideString;
  dwHelpContext : DWORD;
  TI,TIref : ITypeInfo;
  TA,TAref : LPTYPEATTR;
  TIT : TYPEKIND;
  RTIT : HREFTYPE;
begin
  // interface declarations
  AddToInterface('//interface declarations');
  for i:=0 to TIcount-1 do
    begin
    OleCheck(TL.GetTypeInfoType(i, TIT));
    OleCheck(TL.GetTypeInfo(i, TI));
    OleCheck(TL.GetDocumentation(i, @BstrName, @BstrDocString, @dwHelpContext, @BstrHelpFile));
    if (TIT=TKIND_DISPATCH) or (TIT=TKIND_INTERFACE) then
      begin
      OleCheck(TI.GetTypeAttr(TA));
      if (TIT=TKIND_DISPATCH) then
        begin
        // get also TKIND_INTERFACE if dual interface
        if (TA^.wTypeFlags and TYPEFLAG_FDUAL)=TYPEFLAG_FDUAL then
          begin
          OleCheck(TI.GetRefTypeOfImplType(-1,RTIT));
          OleCheck(TI.GetRefTypeInfo(RTIT,TIref));
          OleCheck(TIref.GetTypeAttr(TAref));
          AddToInterface(interfacedeclaration(BstrName,BstrDocString,TIref,TAref,false,false));
          TIref.ReleaseTypeAttr(TAref);
          AddToInterface(interfacedeclaration(BstrName,BstrDocString,TI,TA,true,false));
          end
        else
          AddToInterface(interfacedeclaration(BstrName,BstrDocString,TI,TA,true,true));
        end
      else
        AddToInterface(interfacedeclaration(BstrName,BstrDocString,TI,TA,false,false));
      TI.ReleaseTypeAttr(TA);
      end;
    end;
end;

Procedure TTypeLibImporter.CreateCoClasses(Const TL : ITypeLib; TICount : Integer);

Var
  i, j ,idx: integer;
  BstrName, BstrDocString, BstrHelpFile, BstrNameRef : WideString;
  dwHelpContext : DWORD;
  TI,TIref : ITypeInfo;
  TA : LPTYPEATTR;
  TIT : TYPEKIND;
  RTIT : HREFTYPE;
  sDefIntf, sDefEvents : string;
  ITF:WINT;
begin
  //CoClasses
  AddToInterface('//CoClasses');
  AddToImplementation('implementation');
  AddToImplementation('');
  AddToImplementation('uses comobj;');
  AddToImplementation('');
  for i:=0 to TIcount-1 do
    begin
    OleCheck(TL.GetTypeInfoType(i, TIT));
    if TIT =TKIND_COCLASS then
      begin
      OleCheck(TL.GetTypeInfo(i, TI));
      OleCheck(TL.GetDocumentation(i, @BstrName, @BstrDocString, @dwHelpContext, @BstrHelpFile));
      OleCheck(TI.GetTypeAttr(TA));
      // get default interface and events.
      sDefEvents:='';
      for j:=0 to TA^.cImplTypes-1 do
        begin
        OleCheck(TI.GetImplTypeFlags(J,ITF));
        if (ITF and IMPLTYPEFLAG_FDEFAULT)<>0 then
          begin
          OleCheck(TI.GetRefTypeOfImplType(J,RTIT));
          OleCheck(TI.GetRefTypeInfo(RTIT,TIref));
          OleCheck(TIRef.GetDocumentation(DISPID_UNKNOWN, @BstrNameRef, nil, nil, nil));
          if (ITF and IMPLTYPEFLAG_FSOURCE)<>0 then
            begin
            sDefEvents:=BstrNameRef;
            idx:=FEventDisp.IndexOf(sDefEvents);
            if idx<0 then // should not happen
              sDefEvents:='';
            end
          else
            sDefIntf:=BstrNameRef;
          end;
        end;
      if sDefEvents<>'' then //add event signatures
        begin
        AddToInterface(FEventSignatures[idx]);
        FEventSignatures[idx]:='';  // only add event signatures only once. Multiple coclasses can use same events
        AddToInterface('');
        end;
      AddToInterFace('  Co%s = Class',[BstrName]);
      AddToInterface('  Public');
      AddToInterface('    Class Function Create: %s;',[sDefIntf]);
      AddToInterFace('    Class Function CreateRemote(const MachineName: string): %s;',[sDefIntf]);
      AddToInterFace('  end;');
      AddToInterFace('');
      if FActiveX then
        begin
        if FUses.IndexOf('ActiveXContainer')<0 then
          FUses.Add('ActiveXContainer');
        AddToInterFace('  T%s = Class(TActiveXContainer)',[BstrName]);
        AddToInterface('  Private');
        AddToInterface('    FServer:%s;',[sDefIntf]);
        if (sDefEvents<>'') then //add function variables
          begin
          if FUses.IndexOf('Eventsink')<0 then
            FUses.Add('EventSink');
          AddToInterface(FEventFunctions[idx]);
          AddToInterface('    FEventSink:TEventSink;',[sDefIntf]);
          AddToInterface('    procedure EventSinkInvoke(Sender: TObject; DispID: Integer;');
          AddToInterface('          const IID: TGUID; LocaleID: Integer; Flags: Word;');
          AddToInterface('          Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr: Pointer);');
          end;
        AddToInterface('  Public');
        AddToInterface('    constructor Create(TheOwner: TComponent); override;');
        AddToInterface('    destructor Destroy; override;');
        AddToInterface('    property OleServer:%s read FServer;',[sDefIntf]);
        AddToInterFace('  Published');
        AddToInterFace('    property Align;');
        AddToInterFace('    property Anchors;');
        AddToInterFace('    property AutoSize;');
        AddToInterFace('    property BorderSpacing;');
        AddToInterFace('    property ChildSizing;');
        AddToInterFace('    property ClientHeight;');
        AddToInterFace('    property ClientWidth;');
        AddToInterFace('    property Constraints;');
        AddToInterFace('    property DockSite;');
        AddToInterFace('    property DragCursor;');
        AddToInterFace('    property DragKind;');
        AddToInterFace('    property DragMode;');
        AddToInterFace('    property Enabled;');
        AddToInterFace('    property ParentShowHint;');
        AddToInterFace('    property PopupMenu;');
        AddToInterFace('    property ShowHint;');
        AddToInterFace('    property TabOrder;');
        AddToInterFace('    property TabStop;');
        AddToInterFace('    property UseDockManager default True;');
        AddToInterFace('    property Visible;');
        AddToInterFace('    property OnContextPopup;');
        AddToInterFace('    property OnDockDrop;');
        AddToInterFace('    property OnDockOver;');
        AddToInterFace('    property OnDragDrop;');
        AddToInterFace('    property OnDragOver;');
        AddToInterFace('    property OnEndDock;');
        AddToInterFace('    property OnEndDrag;');
        AddToInterFace('    property OnEnter;');
        AddToInterFace('    property OnExit;');
        AddToInterFace('    property OnGetSiteInfo;');
        AddToInterFace('    property OnGetDockCaption;');
        AddToInterFace('    property OnResize;');
        AddToInterFace('    property OnStartDock;');
        AddToInterFace('    property OnStartDrag;');
        AddToInterFace('    property OnStatusText;');
        AddToInterFace('    property OnUnDock;');
        if (sDefEvents<>'') then
          AddToInterface(FEventProperties[idx]);
        AddToInterFace('    property Active;');
        AddToInterFace('  end;');
        AddToInterFace('');
        end
      else if (sDefEvents<>'') then //add function variables
        begin
        if FUses.IndexOf('Eventsink')<0 then
          FUses.Add('EventSink');
        AddToInterFace('  T%s = Class(TEventSink)',[BstrName]);
        AddToInterface('  Private');
        AddToInterface(FEventFunctions[idx]);
        AddToInterface('    fServer:%s;',[sDefIntf]);
        AddToInterface('    procedure EventSinkInvoke(Sender: TObject; DispID: Integer;');
        AddToInterface('          const IID: TGUID; LocaleID: Integer; Flags: Word;');
        AddToInterface('          Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr: Pointer);');
        AddToInterface('  Public');
        AddToInterface('    constructor Create(TheOwner: TComponent); override;');
        AddToInterface('    property ComServer:%s read fServer;',[sDefIntf]);
        AddToInterface(FEventProperties[idx]);
        AddToInterFace('  end;');
        AddToInterFace('');
        end;
      AddToImplementation('Class Function Co%s.Create: %s;',[BstrName,sDefIntf]);
      AddToImplementation('begin');
      AddToImplementation('  Result := CreateComObject(CLASS_%s) as %s;',[BstrName,sDefIntf]);
      AddToImplementation('end;');
      AddToImplementation('');
      AddToImplementation('Class Function Co%s.CreateRemote(const MachineName: string): %s;',[BstrName,sDefIntf]);
      AddToImplementation('begin');
      AddToImplementation('  Result := CreateRemoteComObject(MachineName,CLASS_%s) as %s;',[BstrName,sDefIntf]);
      AddToImplementation('end;');
      AddToImplementation('');
      if FActiveX then
        begin
        AddToImplementation('constructor T%s.Create(TheOwner: TComponent);',[BstrName]);
        AddToImplementation('begin');
        AddToImplementation('  inherited Create(TheOwner);');
        AddToImplementation('  FServer:=Co%s.Create;',[BstrName]);
        AddToImplementation('  ComServer:=FServer;',[BstrName]);
        if (sDefEvents<>'') then
          begin
          AddToImplementation('  FEventSink:=TEventSink.Create(Self);');
          AddToImplementation('  FEventSink.OnInvoke:=EventSinkInvoke;');
          AddToImplementation('  FEventSink.Connect(FServer,%s);',[FEventDisp[idx]]);
          end;
        AddToImplementation('end;');
        AddToImplementation('');
        AddToImplementation('destructor T%s.Destroy;',[BstrName]);
        AddToImplementation('begin');
        if (sDefEvents<>'') then
          AddToImplementation('  FEventSink.Destroy;');
        AddToImplementation('  inherited destroy;');
        AddToImplementation('end;');
        AddToImplementation('');
        if (sDefEvents<>'') then
          begin
          AddToImplementation('procedure T%s.EventSinkInvoke(Sender: TObject; DispID: Integer;',[BstrName]);
          AddToImplementation('  const IID: TGUID; LocaleID: Integer; Flags: Word; Params: tagDISPPARAMS;');
          AddToImplementation('  VarResult, ExcepInfo, ArgErr: Pointer);');
          AddToImplementation('begin');
          AddToImplementation('  case DispID of');
          AddToImplementation(FEventImplementations[idx]);
          AddToImplementation('  end;');
          AddToImplementation('end;');
          AddToImplementation('');
          end;
        end
      else if sDefEvents<>'' then //add event implementations
        begin
        AddToImplementation('constructor T%s.Create(TheOwner: TComponent);',[BstrName]);
        AddToImplementation('begin');
        AddToImplementation('  inherited Create(TheOwner);');
        AddToImplementation('  OnInvoke:=EventSinkInvoke;');
        AddToImplementation('  fServer:=Co%s.Create;',[BstrName]);
        AddToImplementation('  Connect(fServer,%s);',[FEventDisp[idx]]);
        AddToImplementation('end;');
        AddToImplementation('');
        AddToImplementation('procedure T%s.EventSinkInvoke(Sender: TObject; DispID: Integer;',[BstrName]);
        AddToImplementation('  const IID: TGUID; LocaleID: Integer; Flags: Word; Params: tagDISPPARAMS;');
        AddToImplementation('  VarResult, ExcepInfo, ArgErr: Pointer);');
        AddToImplementation('begin');
        AddToImplementation('  case DispID of');
        AddToImplementation(FEventImplementations[idx]);
        AddToImplementation('  end;');
        AddToImplementation('end;');
        AddToImplementation('');
        end;
      TI.ReleaseTypeAttr(TA);
      end;
    end;
end;

Procedure TTypeLibImporter.CreateUnitHeader(Const TL : ITypeLib; const LA: lpTLIBATTR);


Var
  BstrName, BstrDocString, BstrHelpFile : WideString;
  dwHelpContext: DWORD;

begin
  OleCheck(TL.GetDocumentation(-1, @BstrName, @BstrDocString, @dwHelpContext, @BstrHelpFile));
  if (UnitName='') then
    if FAppendVersionNumber then
      UnitName:=format('%s_%d_%d_TLB',[BstrName,LA^.wMajorVerNum,LA^.wMinorVerNum])
    else
      UnitName:=format('%s_TLB',[BstrName]);
  //header
  AddToHeader('Unit %s;',[UnitName],True);
  AddToHeader('',true);
  AddToHeader('//  Imported %s on %s from %s',[BstrName,DateTimeToStr(Now()),InputFilename],True);
  AddToHeader('',true);
  AddToHeader('{$mode delphi}{$H+}',true);
  AddToHeader('',true);
  AddToHeader('interface',true);
  AddToHeader('',true);
  FUses.Add('Windows');
  FUses.Add('ActiveX');
  FUses.Add('Classes');
  //FUses.Add('OleServer');
  FUses.Add('Variants');
  AddToInterface('Const');
  AddToInterface('  %sMajorVersion = %d;',[BstrName,LA^.wMajorVerNum]);
  AddToInterface('  %sMinorVersion = %d;',[BstrName,LA^.wMinorVerNum]);
  AddToInterface('  %sLCID = %x;',[BstrName,LA^.LCID]);
  AddToInterface('  LIBID_%s : TGUID = ''%s'';',[BstrName,GUIDToString(LA^.GUID)]);
  AddToInterface('');
end;

Procedure TTypeLibImporter.DoImportTypelib;

var
  TL: ITypelib;
  TIcount:integer;
  LA: lpTLIBATTR;

begin
  Header.Clear;
  InterfaceSection.Clear;
  OleCheck(LoadTypeLib(PWidechar(InputFileName), TL ));
  OleCheck(TL.GetLibAttr(LA));
  try
    CreateUnitHeader(TL,LA);
    TIcount:=TL.GetTypeInfoCount;
    ImportGUIDs(TL,TICount);
    ImportEnums(TL,TICount);
    CreateForwards(TL,TICount);
    CreateRecordsUnionsAliases(TL,TICount);
    CreateInterFaces(TL,TICount);
    CreateCoClasses(TL,TICount);
  finally
    TL.ReleaseTLibAttr(LA);
  end;
  BuildUnit;
end;

procedure TTypeLibImporter.BuildUnit;

Var
  l : string;
  I : Integer;

begin
  UnitSource.AddStrings(Header);
  UnitSource.Add('Uses');
  L:='  ';
  For I:=0 to FUses.Count-1 do
    begin
    L:=L+FUses[i];
    If (I<Fuses.Count-1) then
      L:=L+','
    else
      L:=L+';';
    if (Length(L)>72) then
      begin
      UnitSource.Add(L);
      L:='  ';
      end;
    end;
  if (L<>'  ') then
    UnitSource.Add(L);
  UnitSource.addStrings(InterfaceSection);
  UnitSource.addStrings(ImplementationSection);
  UnitSource.Add('end.');
end;

{ TTypeLibImporter }

procedure TTypeLibImporter.SetOutputFileName(AValue: String);

Var
  UN : String;

begin
  if FOutputFileName=AValue then Exit;
  UN:=ChangeFileExt(ExtractFileName(AValue),'');
  if not IsValidIdent(UN) then
    Raise Exception.CreateFmt(SErrInvalidUnitName,[UN]);
  FOutputFileName:=AValue;
  SetUnitName(UN)
end;

procedure TTypeLibImporter.SetUnitName(AValue: string);
begin
  if FUnitname=AValue then Exit;
  if not IsValidIdent(AVAlue) then
    Raise Exception.CreateFmt(SErrInvalidUnitName,[AValue]);
  FUnitname:=AValue;
  if (OutputFileName<>'') then
    OutputFileName:=ExtractFilePath(OutputFileName)+UnitName+'.pas';
end;

procedure TTypeLibImporter.AddToUses(const AUnit: String);
begin
  If FUses.IndexOf(AUnit)=-1 then
    FUses.add(AUnit);
end;

procedure TTypeLibImporter.AddToHeader(const ALine: String;
  AllowDuplicate: Boolean);

begin
  If (AllowDuplicate) or (FHeader.IndexOf(ALine)=-1) then
    FHeader.Add(ALine);
end;

procedure TTypeLibImporter.AddToHeader(const Fmt: String; Args: array of const;
  AllowDuplicate: Boolean);
begin
  AddToheader(Format(Fmt,Args),AllowDuplicate)
end;

procedure TTypeLibImporter.AddToInterface(const ALine: String);
begin
  FInterface.Add(ALine);
end;

procedure TTypeLibImporter.AddToInterface(const Fmt: String;
  Args: array of const);
begin
  FInterface.Add(Format(Fmt,Args));
end;

procedure TTypeLibImporter.AddToImplementation(const ALine: String);
begin
  FImplementation.Add(ALine);
end;

procedure TTypeLibImporter.AddToImplementation(const Fmt: String;
  Args: array of const);
begin
  FImplementation.Add(Format(Fmt,Args));
end;

constructor TTypeLibImporter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDependencies:=TStringList.Create;
  FUnitSource:=TStringList.Create;
  FAppendVersionNumber:=true;
end;

destructor TTypeLibImporter.Destroy;
begin
  FreeAndNil(FDependencies);
  FreeAndNil(FUnitSource);
  inherited Destroy;
end;

procedure TTypeLibImporter.Execute;
begin
  FDependencies.Clear;
  FUnitSource.Clear;
  FHeader:=TStringList.Create;
  FInterface:=TStringList.Create;
  FImplementation:=TStringList.Create;
  FUses:=TStringList.Create;
  FTypes:=TStringList.Create;
  FEventDisp:=TStringList.Create;
  FEventIID:=TStringList.Create;
  FEventSignatures:=TStringList.Create;
  FEventFunctions:=TStringList.Create;
  FEventProperties:=TStringList.Create;
  FEventImplementations:=TStringList.Create;
  try
    DoImportTypeLib;
    If (OutputFileName<>'') then
      UnitSource.SaveToFile(OutputFileName);
  finally
    FreeAndNil(FEventImplementations);
    FreeAndNil(FEventProperties);
    FreeAndNil(FEventFunctions);
    FreeAndNil(FEventSignatures);
    FreeAndNil(FEventIID);
    FreeAndNil(FEventDisp);
    FreeAndNil(FTypes);
    FreeAndNil(FUses);
    FreeAndNil(FInterface);
    FreeAndNil(FHeader);
    FreeAndNil(FImplementation);
  end;
end;

end.