SUB-CLASS TFolderEx()

[Jimmy]

hi,

i can change Color of TAB "Body" and Font but not TAB Color itself

so i try to SUB-CKASS TFolderEx()

Code: Select all  Expand view

CLASS TFolderDXE FROM TFolderEx, TControl
METHOD PaintTB() CLASS TFolderDXE
METHOD SetFldColors( oThis, n ) CLASS TFolderDXE

it work so far ... but there seems no "TAB-Stop" so i can´t use TAB-Key

what i´m doing wrong

[Antonio Linares]

Dear Jimmy,

Just inherit from TFolderEx, so instead of:

CLASS TFolderDXE FROM TFolderEx, TControl

do:

CLASS TFolderDXE FROM TFolderEx

[Marc Venken]

Jimmy,

Could you please post the working result for the sub-class ? (Method detail)

I want to sub-Class Xbrowse, but never did anything with a class...

[hua]

Jimmy,

Code: Select all  Expand view

CLASS TFolderDXE FROM TFolderEx
   CLASSDATA lRegistered AS LOGICAL // this variable is compulsory for inherited controls

   METHOD PaintTB() CLASS TFolderDXE
   METHOD SetFldColors( oThis, n ) CLASS TFolderDXE  
  .
  .
  .
ENDCLASS
 

[Jimmy]

hi,

@Antonio,
have remove Control so only

Code: Select all  Expand view

   CLASS TFolderDXE FROM TFolderEx

@hua

Code: Select all  Expand view

  CLASSDATA lRegistered AS LOGICAL   // this variable is compulsory for inherited controls

but same "Problem" that i can´t use TAB-Key ... other like Fx-Key work

---
@Marc
the Benefit of OOP is to make "own" CLASS from "other" OOP CLASS where you can "add" or "override" Method and Property (DATA)

so i do copy/paste from Original CLASS TFolderEx() and began to modify new CLASS CODE

as i want to modify "painting" i use

Code: Select all  Expand view

CLASS MYCLASS FROM TFolderEx
   // tip from hua
   CLASSDATA lRegistered AS LOGICAL   // this variable is compulsory for inherited controls

   DATA BFcolor  INIT nRGB( 000, 000, 001 ) // new Foregound Color
   DATA BGcolor  INIT nRGB( 025, 254, 255 ) // new Backgound Color

   METHOD PaintTB()       //Paint Top Bottom
   METHOD SetFldColors()
ENDCLASS

METHOD PaintTB() CLASS TFolderDXE
...
METHOD SetFldColors( oThis, n ) CLASS TFolderDXE
...

possible Problem
missing Constant or missing depend Method (search for "::" Method in paste Text )

when get no more Error change TFolderEx to MYCLASS
it should work same way as SUPER-CLASS TFolderEx

now you can begin to modify your CODE for your need

[Antonio Linares]

Jimmy,

Use this:

oFolder:nDlgCode = DLGC_WANTALLKEYS

[Jimmy]

hi Antonio,

oFolder:nDlgCode = DLGC_WANTALLKEYS

no luck ... still can´t use TAB-Key to change Control

i have reduce CLASS to only 1 Method to set Bitmap (depend on Drive Type)

Code: Select all  Expand view

METHOD SetDriveIcon(cPath,nOption) CLASS TFolderDXE
LOCAL aDrives, cDrive, nPosi, cIcon
LOCAL acItem, acBitmaps

DEFAULT nOption := 1

   IF !EMPTY(cPath)
      cDrive := UPPER(SUBSTR(cPath,1,1))
      aDrives := FillDriveArray()
      acItem    := aDrives[ 1 ]
      acBitmaps := aDrives[ 2 ]

      nPosi := ASCAN(acItem,{ | x | SUBSTR(x,1,1) = cDrive })
      IF nPosi > 0
         cIcon := acBitmaps[nPosi]
         ::SetBitmap( cIcon, nOption )
         ::Update()
      ENDIF
   ENDIF
RETURN nil

but as soon i use this CLASS i can "TAB-in" but not "TAB-out"

i will try to make a small Sample

---

ok here Demo Sample for "no TAB-Key"

Code: Select all  Expand view

#include "FiveWin.ch"

function Main()
   local oDlg, oFld, oGet, cTest := "Hello world", cAnother := "Another GET"
LOCAL nWidth     := 190
LOCAL nHeight    := 120
LOCAL nTop       := 0
LOCAL nLeft      := 0
LOCAL lPixel     := .T.
LOCAL lDesign    := .F.
   // TFolderEx
LOCAL aPrompts := {"&One", "&Two", "&Three"}
LOCAL aBitmaps      := {}
   // DEFAULT
LOCAL nFolderHeight := 25
LOCAL aHelps
LOCAL nRound        := 3
LOCAL bAction
LOCAL bClrTabs
LOCAL bClrText
LOCAL aAlign
LOCAL lAdjust       := .F.
LOCAL nSeparator    := 3
LOCAL nOption       := 1
LOCAL bPopUp
LOCAL lStretch      := .F.
LOCAL cLayOut       := "TOP"
LOCAL bBmpAction
LOCAL nBright       := 0
LOCAL lAnimate      := .F.
LOCAL nSpeed
LOCAL oFont
LOCAL lTransparent  := .F.
LOCAL aDialogs
LOCAL lBorder       := .T.
LOCAL nClrPane      := CLR_WHITE
LOCAL cVarName

   DEFINE DIALOG oDlg SIZE 400, 300
* #define Original  
#ifdef Original
   @ 3, 5 FOLDEREX oFld PIXEL ;
      PROMPT "&One", "&Two", "&Three" ;
      SIZE 190, 120
#else
* #define Use_normal  
   #ifdef Use_normal
      oFld  := TFolderEx() :New( 3, 5, nWidth , nHeight , oDlg, ;
                               aBitmaps, lPixel, lDesign, aPrompts, nFolderHeight, ;
                               aHelps, nRound, bAction, bClrTabs, bClrText, aAlign, ;
                               lAdjust, nSeparator, nOption, bPopUp, lStretch, ;
                               cLayOut, bBmpAction, nBright, lAnimate, nSpeed, oFont, ;
                               lTransparent, aDialogs, lBorder, nClrPane, cVarName )
   #else
      oFld  := TFolderDXE() :New( 3, 5, nWidth , nHeight , oDlg, ;
                               aBitmaps, lPixel, lDesign, aPrompts, nFolderHeight, ;
                               aHelps, nRound, bAction, bClrTabs, bClrText, aAlign, ;
                               lAdjust, nSeparator, nOption, bPopUp, lStretch, ;
                               cLayOut, bBmpAction, nBright, lAnimate, nSpeed, oFont, ;
                               lTransparent, aDialogs, lBorder, nClrPane, cVarName )
      oFld:SetDriveIcon(,1)
      oFld:SetDriveIcon(,2)
      oFld:SetDriveIcon(,3)   
     
      oFld:nDlgCode := DLGC_WANTALLKEYS
   #endif     
#endif      

   @ 1, 1 GET oGet VAR cTest OF oFld:aDialogs[ 1 ]
   
   @ 2, 1 GET cAnother OF oFld:aDialogs[ 1 ]  
   
   @ 7.2, 14 BUTTON "Ok" ACTION oDlg:End()    
         
   ACTIVATE DIALOG oDlg CENTERED ;
      ON INIT ( oGet:SetFocus(), .F. )

return nil

Code: Select all  Expand view

CLASS TFolderDXE FROM TFolderEx
  CLASSDATA lRegistered AS LOGICAL   // this variable is compulsory for inherited controls

   DATA BFcolor  INIT nRGB( 000, 000, 001 )
   DATA BGcolor  INIT nRGB( 025, 254, 255 )

   METHOD SetDriveIcon(cPath,nOption)
ENDCLASS

METHOD SetDriveIcon(cPath,nOption) CLASS TFolderDXE
LOCAL aDrives
LOCAL cDrive
LOCAL nPosi
LOCAL cBMP := "BMPGREEN"
LOCAL acItem
LOCAL acBitmaps
LOCAL acType

DEFAULT nOption := 1

/************  
   IF !EMPTY(cPath)
      cDrive := UPPER(SUBSTR(cPath,1,1))
      aDrives := FillDriveArray()
      acItem    := aDrives[ 1 ]
      acBitmaps := aDrives[ 2 ]
      acType    := aDrives[ 3 ]

      nPosi := ASCAN(acItem,{ | x | SUBSTR(x,1,1) = cDrive })
      IF nPosi > 0
         cBMP := acBitmaps[nPosi]
************/        
         ::SetBitmap( cBMP, nOption )
         ::Update()
*      ENDIF
*   ENDIF
RETURN nil

---

Demo show 3 x TAB
on TAB 1 there are 2 x GET and you can "TAB-Key" between GET

but you can NOT "TAB-Key" to "OK" Button to leave GET
on "blank" TAB 2 and 3 "TAB-Key" troggle "OK" Button

---

it does work when use

Code: Select all  Expand view

#define Use_normal  

for use Original TFolderEx() to "TAB-Key" from GET to "OK" Button

[Antonio Linares]

Dear Jimmy,

If you look for "TFolderEx" in *.prg in FWH\source\classes you will find several places where "TFolderEx" is hardcoded and this is the reason why tab is not working

We should modify those or think about a way to change the Class name at runtime (if possible)

[richard-service]

Dear Jimmy, Antonio

Maybe we can add Paco's C5 TFolder or C5Tab show different Folder style.

[Jimmy]

hi Antonio,

If you look for "TFolderEx" in *.prg in FWH\source\classes you will find several places where "TFolderEx" is hardcoded and this is the reason why tab is not working

oooh ...

under Xbase++ i can use

Code: Select all  Expand view

  IF ::isDerivedFrom( <cClassName>|<oClassObject> ) --> lIsDerived

i thought that Fivewin use same as

Code: Select all  Expand view

  if ::oWnd:IsKindOf( "TFOLDEREX" )

---

under Xbase++ it will also work with SUB-CLASS when ask for SUPER-CLASS

when made a own

Code: Select all  Expand view

  CLASS MYABC FROM ABC

under Xbase++ i can ask

Code: Select all  Expand view

  ::isDerivedFrom("MYABC") or ::isDerivedFrom("ABC")

We should modify those or think about a way to change the Class name at runtime (if possible)

it would be nice if Fivewin can react like Xbase++ when using own CLASS made FROM fwCLASS
i like to request a new Method ::isFamilyFrom(cControl)

[Jimmy]

hi Antonio,

i do not know how Xbase++ :isDerivedFrom work
but we might can use a Workaroud which i saw in QContrib from Bedi Pritpal

Code: Select all  Expand view

METHOD XbpWindow:isDerivedFrom( cClassORoObject )
   LOCAL lTrue := .f.
   LOCAL cCls := __ObjGetClsName( Self )

   /* Compares without Xbp or Wvg prefixes  */
   IF HB_ISSTRING( cClassORoObject )
      RETURN __clsParent( Self:classH, cClassORoObject )

   ELSEIF HB_ISOBJECT( cClassORoObject )
      IF upper( substr( cClassORoObject:className,4 ) ) == upper( substr( cCls,4 ) )
         lTrue := .t.
      ENDIF
   ENDIF

   IF !( lTrue )
      IF HB_ISOBJECT( ::oParent )
         lTrue := ::oParent:isDerivedFrom( cClassORoObject )
      ENDIF
   ENDIF

RETURN lTrue

i guess ::IsKindOf get Object CLASS Name and compare it

Code: Select all  Expand view

  ( ::oWnd:oWnd:IsKindOf( "TFOLDER" ) .or. ;
     ::oWnd:oWnd:IsKindOf( "TFOLDEREX" ) )
 

but what when use "just" Part of it

Code: Select all  Expand view

METHOD isDerivedFrom( cClassORoObject ) CLASS ???
  IF upper( substr( cClassORoObject:className,1,6 ) ) == upper( substr( cCls,1,6 ) )

SUBSTR() Length depend on "shortest" Fiwewin Control CLASS Name.
i think 6 is a good length (or better use a Constant which can be easy change )

[Jimmy]

while also this Syntax is used

Code: Select all  Expand view

METHOD Update() INLINE AEval( ::aControls,;
          { | o | If( ( Upper( o:ClassName() ) $ "TFOLDER;TFOLDEREX" ), o:Update(),;
          If( o:lUpdate, o:Refresh(),)) } )

or

Code: Select all  Expand view

METHOD GotFocus( hFromWnd ) CLASS TWindow
   ...
   if Upper( GetClassName( ::hCtlFocus ) ) $ "SYSTABCONTROL32,TPAGES,TFOLDEREX"

or

Code: Select all  Expand view

METHOD GoNextCtrl( hCtrl ) CLASS TWindow
   ...
   if ::oWnd:ClassName() $ "TFOLDER,TFOLDEREX,TPAGES"

i need to check for every ClassName() ---

[Antonio Linares]

Dear Jimmy,

Instead of creating a new Class TFolderDXE inherited from TFolderEx, you could dynamically modify Class TFolderEx to add the extra DATAs and/or Methods that you may need using the functions __objAddData( oObject, cSymbol ) and __objAddMethod( oObject, cSymbol, nFuncPtr ), __objModMethod( oObject, cSymbol, nFuncPtr )

Please review https://github.com/harbour/core/blob/master/src/rtl/objfunc.prg

[Jimmy]

hi Antonio,

Instead of creating a new Class TFolderDXE inherited from TFolderEx, you could dynamically modify Class TFolderEx to add the extra DATAs and/or Methods that you may need using the functions __objAddData( oObject, cSymbol ) and __objAddMethod( oObject, cSymbol, nFuncPtr ), __objModMethod( oObject, cSymbol, nFuncPtr )

WOW
i did not know that Technique

---

but it will not help when i want to "override" Nethod, here PaintTB()

i like to use "Dark-Mode" so also TAB should have a Callback Slot for Background Color.
used Color are

Code: Select all  Expand view

METHOD SetDefColors( aGradSel, aGradUnSel, aGradOverUnSel, aGradOver, aGradDis ) CLASS TFolderEx
...
     DEFAULT aGradSel       := { { 0.25, nRGB( 255, 215, 0 ), nRGB( 205, 173, 0 ) },;
                                 { 0.75,  nRGB( 255, 255, 255 ), nRGB( 255, 255, 255 ) } }

     DEFAULT aGradUnSel     := { { 0.5, nRGB( 255, 255, 255 ), nRGB( 240, 240, 240 ) },;
                                 { 0.5,  nRGB( 240, 240, 240 ), nRGB( 200, 200, 200 ) } }

     DEFAULT aGradOverUnSel := { { 0.25, nRGB( 100, 149, 237 ), nRGB( 100, 149, 237 ) },;
                                 { 0.75,  nRGB( 255, 255, 255 ), nRGB( 200, 200, 200 ) } }

     DEFAULT aGradOver      := { { 0.5,  nRGB( 200, 200, 200), nRGB( 240, 240, 240 ) },;
                                 { 0.5, nRGB( 240, 240, 240 ), nRGB( 255, 255, 255  ) }  }

     DEFAULT aGradDis       := { { 1, nRGB( 211, 211, 211 ), nRGB( 190, 190, 190) } }

for

Code: Select all  Expand view

METHOD SetFldColors( oThis, n ) CLASS TFolderEx

called by PaintTB()

how can i enhance it to use "Dark-Mode"

[Antonio Linares]

Dear Jimmy,

If you add a method with the same name, you are in fact overriding it.

Please try it