I'm no longer certain that a Tree-based navigation system is worth writing in Harbour, since there are full-featured applications already available, as other posters have indicated. Building a simple tree is certainly feasible, but adding all the frills would take years.
Here is the source code for the Lotus-style navigator. This will be updated.
Code: Select all
/* Rewrite of SLOTUSMENU from Super.lib */
#include "inkey.ch"
#ifndef K_LBUTTONDOWN
#define K_LBUTTONDOWN 1002 // mouse left key press
#define K_RBUTTONDOWN 1004 // mouse right key press
#endif
#define K_FORWARD_SLASH 47
#define K_MOUSELEFT K_LBUTTONDOWN
#define K_MOUSERIGHT K_RBUTTONDOWN
static Current_a
static Element_n := 1
static Stack_a := {}
/*
ÕìÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ
³ FUNCTION Lotus_Menu()
* Modification of SuperLib's SLOTUSMENU()
ÆÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ
³
³ Short:
³ ------
³ Lotus_Menu() 1-2-3 style menu
³
³ Returns:
³ --------
³ <expReturn> => depends on several factors
³
³ Syntax:
³ -------
³ Lotus_Menu(nTop,nLeft,nBottom,nRight,Options_a,[lBox],;
³ [lSaveRest],[lReset])
³
³ Description:
³ ------------
³ Draws a 1-2-3 style menu from <nTop>,<nLeft> to
³ <nTop+1>,<nRight>.
³
³ <nTop> is the menu option line. <nTop+1> is the
³ message line.
³
³ <Options_a> is an array of arrays in the format:
³
³ { {cOption,Message_s,expAction},
³ {cOption,Message_s,expAction},... }
³
³ where <cOption> is the option prompt, <Message_s> is
³ the option message, and <expAction> is the option action.
³
³ <expAction> may be of three types:
³
³ 1. a codeblock, in which case it is executed on
³ ENTER
³
³ 2. a submenu array of the form:
³
³ { {cOption,Message_s,expAction}, ;
³ {cOption,Message_s,expAction},... }
³ which is displayed on ENTER. Pressing ESCAPE
³ from the submenu returns to the prior menu.
³
³ The submenu <expaction> may be a codeblock,
³ another subarray, or any other value, etc.
³ Thus nesting can go as deep as you like.
³
³ 3. any other value, which is returned to the
³ calling program on ENTER.
³
³ Pressing ESCAPE from the main menu returns 0
³
³ [lBox] If True, the menu is drawn inside of a popup
³ box. Actual dimensions of the menu area then become
³ <nTop>+1,<nLeft>+1 to <nTop>+2,<nRight>-1. Default is False - no box.
³
³ [lSaveRest] If True, the underlying screen is saved
³ and restored on entrance/exit. Default is False - no restore.
³
³ [lReset] If True, the menu is reset to first option
³ on exit. Default is False - menu remembers where it was.
³
³ Lotus_Clear() resets the menu.
³
³ Examples:
³ ---------
³
³ proc test
³ local nReturn := 0
³ local aMain := {}
³ local aSub1 := {{"Pizza", "Eat Pizza", {||pizza()}},;
³ {"Spaghetti", "Eat Spaghetti", {||spagett()}},;
³ {"Tortellini","Eat Tortellini", {||tortellini()}} }
³
³ local aSub2 := {{"Steak", "Eat Steak", {||steak()}},;
³ {"Hamburger", "Eat Hamburger", {||burgers()}},;
³ {"Chili Dog", "Eat Chili Dog", {||burntwice()}} }
³
³ aadd(aMain,{"Italian","Eat Italian food",aSub1})
³ aadd(aMain,{"American","Eat American food",aSub2})
³ aadd(aMain,{"Quit","Just not hungry - Quit",0})
³ aadd(aMain,{"Relief","Already ate - need Alka Seltzer",{||alka()} })
³
³ Lotus_Menu(0,0,0,79,aMain,.t.,.t.,.t.)
³
³ Lotus_Clear() // !! always use this to clear the menu
³
³ Notes:
³ -------
³
³ Always use Lotus_Clear() after calling SLOTUSMENU()
³
³ Source:
³ -------
³ S_LOTMEN.PRG
³
ÔíÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ
*/
FUNCTION Lotus_Menu(nTop,nLeft,nbottom,nRight,Options_a,lBox,lSaveRest,lReset)
LOCAL oTb,cBox,nColumn
LOCAL nTbTop,nTbLeft,nTbBottom,nTbRight,nWidth
LOCAL expReturn := 0
LOCAL nLastkey,cLastkey,nFirstLetter
LOCAL nMouseR, nMouseC
Local Col_n := 0
lBox := iif(lBox#nil,lBox,.f.)
lSaveRest := iif(lSaveRest#nil,lSaveRest,.f.)
lReset := iif(lReset#nil,lReset,.f.)
if lBox
nBottom := nTop+3
nTbTop := nTop+1
nTbLeft := nLeft+1
nTbRight := nRight-1
else
nBottom := nTop+1
nTbTop := nTop
nTbLeft := nLeft
nTbRight := nRight
endif
if lSaveRest
if lBox
cBox := Makebox(nTop,nLeft,nBottom,nRight)
else
cBox := Savescreen(nTop,nLeft,nBottom,nRight)
endif
ELSEIF lBox
Makebox(nTop,nLeft,nBottom,nRight)
endif
nWidth := nTbRight-nTbLeft+1
if len(Stack_a)=0
Current_a := Options_a
endif
oTb := BuildTb(nTbTop,nTbLeft,nTbTop,nTbRight,nWidth)
oTb:colpos := Element_n
while .t.
dispbegin()
while !oTb:stabilize()
end
if Current_a[oTb:colpos,2]#nil
@nTbTop+1,nTbLeft say padr(Current_a[oTb:colpos,2],nWidth)
else
scroll(nTbTop+1,nTbLeft,ntbTop+1,nTbRight,0)
endif
dispend()
nMouseR := 0; nMouseC := 0
nLastKey := rat_event(0,.f.,.f.,@nMouseR,@nMouseC)
do case
// ENTER on a folder, will enter that folder.
// ENTER on a filename, will exit.
case nLastKey == K_ENTER
if valtype(Current_a[oTb:colpos,3])=="A"
aadd(Stack_a,{Current_a,oTb:colpos})
Current_a := Current_a[oTb:colpos,3]
oTb := BuildTb(nTbTop,nTbLeft,nTbTop,nTbRight,nWidth)
oTb:colpos := 1
elseif valtype(Current_a[oTb:colpos,3])=="B"
Col_n := oTb:colpos
expReturn := eval(Current_a[oTb:colpos,3], Col_n )
Return expReturn
else
expReturn := Current_a[oTb:colpos,3]
exit
endif
case nLastKey == K_FORWARD_SLASH // Popup menu
Load_Program_Menu( oTb )
expReturn := Current_a[oTb:colpos,3]
Return expReturn
case nLastKey == K_ESC // Back
if len(Stack_a)>0
Current_a := atail(Stack_a)[1]
oTb := BuildTb(nTbTop,nTbLeft,nTbTop,nTbRight,nWidth)
oTb:colpos := atail(Stack_a)[2]
aSize(Stack_a,len(Stack_a)-1)
else
exit
endif
case nLastKey == K_LEFT // allow movement (left)
IF oTb:colpos > 1
oTb:left()
ELSE
oTb:colpos := len(Current_a)
oTb:refreshall()
ENDIF
case nLastKey == K_RIGHT // allow movement (right)
IF oTb:colpos < len(Current_a)
oTb:right()
ELSE
oTb:colpos := 1
oTb:refreshall()
ENDIF
CASE (cLastkey := upper(chr(nLastkey)))$"ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
if cLastkey == upper(left(Current_a[oTb:colpos,1],1))
keyboard chr(13)
elseif (nFirstLetter := ascan(Current_a,{|e|e[1]#nil.and.upper(left(e[1],1))==cLastKey },oTb:colpos+1)) > 0 ;
.or. (nFirstLetter := ascan(Current_a,{|e|e[1]#nil.and.upper(left(e[1],1))==cLastKey },1,oTb:colpos)) > 0
oTb:colpos := nFirstLetter
oTb:refreshall()
endif
case MBRZMOVE(oTb,nMouseR,nMouseC)
keyboard chr(K_ENTER)
case MBRZCLICK(oTb,nMouseR,nMouseC)
keyboard chr(K_ENTER)
endcase
end
Element_n := oTb:colpos
if lSaveRest
if lBox
unbox(cBox)
else
restscreen(nTop,nLeft,nBottom,nRight,cBox)
endif
endif
if lReset
Lotus_Clear()
endif
return expReturn
//----------------------------------------------------------------------
FUNCTION Lotus_Clear
Stack_a := {}
Element_n := 1
return nil
//-----------------------------------------------------------------
static function BuildTb(ntop,nLeft,nbottom,nRight,nWidth)
local oTb,nColumn
local ntotWidth := ttlwidth()
scroll(nTop,nLeft,nBottom,nRight,0)
if ntotWidth >= nWidth
oTb := tbrowsenew(nTop,nLeft,nbottom,nRight)
else
oTb := tbrowsenew(nTop,nLeft,nbottom,nLeft+nTotWidth-1)
endif
for nColumn = 1 to len(Current_a)
oTb:addcolumn(tbColumnNew(nil,lmblock(nColumn)))
next
otb:skipblock := {|n|0}
return oTb
//-----------------------------------------------------------------
static function lmblock(i)
return {||Current_a[i,1]}
//-----------------------------------------------------------------
static function ttlwidth
local nWidth := 0
aeval(Current_a,{|e|nWidth+=len(e[1])+1})
return nWidth
// TODO
Function Load_Program_Menu( oTb )
Local Program_Menu_a := {}
Program_Menu_a := { { "File", "New Open Exit", { || Alert( "File menu" ) } }, ;
{ "Preview", "As Text As Binary As OutLine", { || Alert( "Preview menu" ) } } ;
}
SLOTUSMENU(23,0,24,MaxCol(),Program_Menu_a,.t.,.t.,.t.)
Return Nil
Code: Select all
#include "FILEIO.CH"
#INCLUDE "COMMON.CH"
#INCLUDE "i_pseudofunc.CH"
#INCLUDE "hbcompat.CH"
#define ISARRAY(x) (valtype(x)=='A')
#define ISLOGIC(x) (valtype(x)=='L')
#define ISNUMERIC(x) (valtype(x)=='N')
#define ISCHAR(x) (valtype(x)=='C')
#define ISDATE(x) (valtype(x)=='D')
#define ISOBJECT(x) (valtype(x)=='O')
#define ISNIL(x) x=NIL
#define NTrim( n ) LTRIM( STR( n,20, IF( n == INT( n ), 0, set(_SET_DECIMALS) ) ))
Function Directory_Menu( Current_Directory_s )
Local Directory_a := {}
Local Names_a := {}
Local Name_s := "" // Directory names with brackets e.g. "[ProgramData]"
Local Name_without_Brackets_s := ""
Local Attr_a := {}
Local Attr_s := ""
Local Main_Menu_a := {}
Local DirectoryEntries_n := 0
Local Nth_Directory_Entry_n := 0
Local Nth_Directory_Entry_s := ""
Local Message_s // String list of subfolders & files in the parent directory.
Local SubDirectory_s := ""
Local SubDirectory_Path_s := ""
Local SubDirectory_Files_a := {}
Local SubDirectory_Files_n := 0
Local Nth_SubDirectory_File_n := 0
Local Nth_SubDirectory_FileNames_a := 0
Local Nth_SubDirectory_File_s := ""
Local Nth_SubDirectory_FileNames_s := ""
If Current_Directory_s == Nil
Current_Directory_s := CurDir()
End If
Directory_a := DIRECTORY( "*.*", "HSD" )
Names_a := A2TOSING(Directory_a,1)
Attr_a := A2TOSING(Directory_a,5)
AEVAL(Names_a,;
{|cValue,nIndex| IF( Attr_a[nIndex] == "D",;
Names_a[nIndex] := "[" + Names_a[nIndex] + "]",)})
DirectoryEntries_n := Len( Names_a )
For Nth_Directory_Entry_n := 1 To DirectoryEntries_n
Nth_Directory_Entry_s := Names_a[ Nth_Directory_Entry_n ]
Name_s := ""
Attr_s := Attr_a[ Nth_Directory_Entry_n ]
Message_s := Nth_Directory_Entry_s
// If pointing to a directory, then obtain list of subdirectories and files within that directory
If Attr_s == "D"
Name_without_Brackets_s := StrTran( Nth_Directory_Entry_s, "[", "" )
Name_without_Brackets_s := StrTran( Name_without_Brackets_s, "]", "" )
SubDirectory_Path_s := CurDrive() + ":\" + Current_Directory_s + "\" + Name_without_Brackets_s + "\*.*"
SubDirectory_Files_a := DIRECTORY( SubDirectory_Path_s, "HSD" )
Nth_SubDirectory_FileNames_a := A2TOSING(SubDirectory_Files_a,1)
Nth_SubDirectory_FileNames_s := Array_to_List( Nth_SubDirectory_FileNames_a, " " )
// Message line will contain list of filenames and subdirectories, within the directory currently selected.
Message_s := Nth_SubDirectory_FileNames_s
EndIf
AAdd( Main_Menu_a, { Nth_Directory_Entry_s, Message_s, ;
{ | Col_n | DoSomething( Current_Directory_s, Names_a[ Col_n ], Attr_a[ Col_n ] ) } } )
Next
cls(23, chr(177))
SETCOLOR( "W+/B,B/W,,W+/B")
Lotus_Menu(0,0,0,MaxCol(),Main_Menu_a,.t.,.t.,.t.)
Lotus_Clear()
Return Nil
// Execute this, when the user presses <ENTER>
Function DoSomething( Current_Directory_s, Name_s, Attr_s )
Local ErrorCode_n
If "D" $ Attr_s
Name_s = StrTran( Name_s, "[", "" )
Name_s = StrTran( Name_s, "]", "" )
ErrorCode_n := DirChange( Name_s )
If ErrorCode_n <> 0
? "Error Code from changing directory: "
? ErrorCode_n
Wait
Else
Current_Directory_s := DirName()
Directory_Menu( Current_Directory_s )
End If
End If
Return Nil
FUNC Array_to_List( aArray, Delimiter_s )
LOCA cRVal := ''
DEFAULT aArray TO {}
DEFAULT Delimiter_s TO ','
AEVAL( aArray, { | x1, i1 | cRVal += Any2Strg( x1 ) + IF( i1 < LEN( aArray ), Delimiter_s, "" ) } )
RETU cRVal // Array_to_List()
// Forgot where we found this routine
*-----------------------------------------------------------------------------*
FUNCTION Any2Strg( xAny )
*-----------------------------------------------------------------------------*
Local cRVal := '???', nType ;
,aCases := { { "A", { | | "{...}" } },;
{ "B", { | | "{||}" } },;
{ "C", { | x | x }},;
{ "M", { | x | x } },;
{ "D", { | x | DTOC( x ) } },;
{ "L", { | x | IF( x,"On","Off") } },;
{ "N", { | x | NTrim( x ) } },;
{ "O", { | | ":Object:" } },;
{ "U", { | | "<NIL>" } } }
IF (nType := ASCAN( aCases, { | a1 | VALTYPE( xAny ) == a1[ 1 ] } ) ) > 0
cRVal := EVAL( aCases[ nType, 2 ], xAny )
Endif
Return cRVal
Function print( row, col, str, attr )
prnt( row, col, str, attr )
Return nil
// From SuperLib
Function prnt(nRow,nColumn,cString,nAttribute)
local cColor
if valtype(nAttribute)=="C"
cColor := nAttribute
elseif valtype(nAttribute)=="N"
cColor := at2char(nAttribute)
else
cColor := setcolor()
endif
@nRow,nColumn say cString color cColor
return nil
