Carlos,
Si, es correcto puesto que esa información no la expone Harbour.
Puedes probar a construirlo con la versión más reciente de Harbour. No funciona bien.
De momento lo he corregido asi, pero sigue estando mal:
#include "FiveWin.ch"
#include "Splitter.ch"
static aClasses := {}, oSplit1, oSplit2, oLbxDatas, oLbxMethods
//----------------------------------------------------------------------------//
function Main()
local oWnd, o := TDialog(), x := TObject()
DEFINE WINDOW oWnd TITLE "Classes hierarchy" ;
MENU BuildMenu()
ACTIVATE WINDOW oWnd ;
ON INIT BuildClassesTree( oWnd ) ;
ON RESIZE ( If( oSplit1 != nil, oSplit1:AdjLeft(),),;
If( oSplit2 != nil, oSplit2:AdjRight(),) )
return nil
//----------------------------------------------------------------------------//
function BuildMenu()
local oMenu
MENU oMenu
MENUITEM "About"
ENDMENU
return oMenu
//----------------------------------------------------------------------------//
function BuildClassesTree( oWnd )
local oTree := TTreeView():New( 0, 0, oWnd )
local oClass, cData, cMethod
oTree:nWidth = 180
// oTree:SetImageList( oImageList )
oTree:Expand()
@ 0, 186 LISTBOX oLbxDatas VAR cData ITEMS { "one", "two", "three" } ;
SIZE 200, 200 PIXEL OF oWnd
@ 0, 391 LISTBOX oLbxMethods VAR cMethod ITEMS { "one", "two", "three" } ;
SIZE 200, 200 PIXEL OF oWnd
@ 0, 181 SPLITTER oSplit1 ;
VERTICAL ;
PREVIOUS CONTROLS oTree ;
HINDS CONTROLS oLbxDatas ;
LEFT MARGIN 150 ;
RIGHT MARGIN oSplit2:nLast + 100 ;
SIZE 4, 300 PIXEL ;
OF oWnd STYLE
@ 0, 386 SPLITTER oSplit2 ;
VERTICAL ;
PREVIOUS CONTROLS oLbxDatas ;
HINDS CONTROLS oLbxMethods ;
LEFT MARGIN oSplit1:nFirst + 120 ;
RIGHT MARGIN 80 ;
SIZE 4, 300 PIXEL ;
OF oWnd STYLE
GetClasses()
for each oClass in aClasses
if Empty( oClass:cSuper )
// oClass:cSuper = oClass:ClassName()
AddChilds( oTree:Add( oClass:cName ), oClass:aChilds )
if oClass:Cargo == nil
// oClass:Cargo = oClass // TObject()
endif
endif
next
oTree:bChanged = { || ShowClassInfo( oTree ) }
return nil
//----------------------------------------------------------------------------//
function ShowClassInfo( oTree )
local oItem := oTree:GetSelected()
if oItem != nil .and. oItem:Cargo != nil
oLbxDatas:SetItems( oItem:Cargo:aDatas )
oLbxMethods:SetItems( oItem:Cargo:aMethods )
else
oLbxDatas:SetItems( {} )
oLbxMethods:SetItems( {} )
endif
return nil
//----------------------------------------------------------------------------//
function AddChilds( oItem, aChilds )
local oChild, oSubItem
for each oChild in aChilds
oSubItem = oItem:Add( oChild:cName )
oSubItem:Cargo = oChild
AddChilds( oSubItem, oChild:aChilds )
next
return nil
//----------------------------------------------------------------------------//
function GetClasses()
local n := 1, oClass
while ! Empty( __ClassName( n++ ) )
AAdd( aClasses, TClass():New( __ClassName( n++ ) ) )
end
for each oClass in aClasses
oClass:GetSuper()
next
for each oClass in aClasses
oClass:GetChilds()
next
return nil
//----------------------------------------------------------------------------//
CLASS TClass
DATA cName
DATA cSuper
DATA aChilds INIT {}
DATA aDatas
DATA aMethods
METHOD New( cName )
METHOD GetSuper()
METHOD GetChilds()
ENDCLASS
//----------------------------------------------------------------------------//
METHOD New( cName ) CLASS TClass
::cName = cName
::cSuper = ""
return Self
//----------------------------------------------------------------------------//
METHOD GetSuper() CLASS TClass
local oClass, oInstance
try
oInstance := &( ::cName + "()" )
end
if ! hb_IsObject( oInstance )
return nil
endif
if ::aDatas == nil
::aDatas = __objGetMsgList( oInstance, .T. )
::aMethods = __objGetMsgList( oInstance, .F. )
endif
for each oClass in aClasses
try
if oInstance:IsDerivedFrom( oClass:cName ) .and. ::cName != oClass:cName
::cSuper = oClass:cName
endif
end
next
return nil
//----------------------------------------------------------------------------//
METHOD GetChilds() CLASS TClass
local oClass
for each oClass in aClasses
if oClass:cSuper == ::cName
AAdd( ::aChilds, oClass )
endif
next
return nil
//----------------------------------------------------------------------------//
function Error()
return ErrorNew()
//----------------------------------------------------------------------------//
CLASS TObject FROM HBObject // To expose its datas and methods
ENDCLASS
//----------------------------------------------------------------------------//
