From 1b46bf32b937ffcb82159eaeca49a21180e88a43 Mon Sep 17 00:00:00 2001 From: Viktor Szakats Date: Fri, 7 Sep 2007 02:00:07 +0000 Subject: [PATCH] 2007-09-07 03:38 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) * tests/Makefile * tests/rto_get.prg + tests/rto_tb.prg * include/button.ch * include/hbextern.ch * common.mak * source/rtl/Makefile - source/rtl/mssgline.prg + source/rtl/gui.prg + source/rtl/menusys.prg + source/rtl/tmenusys.prg * source/rtl/checkbox.prg * source/rtl/einstvar.prg * source/rtl/getlist.prg * source/rtl/getsys.prg * source/rtl/listbox.prg * source/rtl/memoedit.prg * source/rtl/pushbtn.prg * source/rtl/radiobtn.prg * source/rtl/radiogrp.prg * source/rtl/scrollbr.prg * source/rtl/tbcolumn.prg * source/rtl/tbrowse.prg * source/rtl/teditor.prg * source/rtl/tget.prg * source/rtl/tgetlist.prg * source/rtl/tlabel.prg * source/rtl/tmenuitm.prg * source/rtl/tpopup.prg * source/rtl/treport.prg * source/rtl/ttopbar.prg ; These changes mainly targeted the .prg level UI classes of Harbour. + Code standardization, cleanup, formatting. (formatting is not fully complete yet) ! Lots of compatibility fixes. ! Lots of bugfixes (crashes, wrongly passed parameters, etc). ! Minor fix in one of the methods of HBReportForm() - Non-Clipper classes removed (the MENUSYS/msgline related ones). ! Some fixes adapted from xHarbour's TBrowse() + Class VARs properly scoped. + TBColumn() is now fully compatible. * The mess in the TTopBar and related classes was cleaned up, some small non-Clipper compatible classes were removed and a new TMenuSys class was created of the related parts. % Optimizations. + TBrowse/TBColumn regression test suite added (far from complete at this point). ; NOTE: No C5.3 GUI support is implemented in Harbour. ; NOTE: Harbour uses Disp*() functions in UI functions to update screen. C5.x uses a mixture of Dev*(), Q?Out() and Disp*(). ; NOTE: TBrowse() fixing is still a work in progress. ; Please test. --- harbour/ChangeLog | 59 + harbour/common.mak | 13 +- harbour/include/button.ch | 11 +- harbour/include/hbextern.ch | 18 + harbour/source/rtl/Makefile | 4 +- harbour/source/rtl/checkbox.prg | 426 +++--- harbour/source/rtl/einstvar.prg | 10 +- harbour/source/rtl/getlist.prg | 10 +- harbour/source/rtl/getsys.prg | 237 ++-- harbour/source/rtl/gui.prg | 106 ++ harbour/source/rtl/listbox.prg | 1951 +++++++++++++------------- harbour/source/rtl/memoedit.prg | 222 ++- harbour/source/rtl/menusys.prg | 166 +++ harbour/source/rtl/mssgline.prg | 205 --- harbour/source/rtl/pushbtn.prg | 462 ++++--- harbour/source/rtl/radiobtn.prg | 445 +++--- harbour/source/rtl/radiogrp.prg | 925 +++++++------ harbour/source/rtl/scrollbr.prg | 717 +++++----- harbour/source/rtl/tbcolumn.prg | 202 ++- harbour/source/rtl/tbrowse.prg | 2274 ++++++++++++++++++------------- harbour/source/rtl/teditor.prg | 1261 ++++++++--------- harbour/source/rtl/tget.prg | 1742 +++++++++++------------ harbour/source/rtl/tgetlist.prg | 511 +++---- harbour/source/rtl/tlabel.prg | 57 +- harbour/source/rtl/tmenuitm.prg | 205 ++- harbour/source/rtl/tmenusys.prg | 660 +++++++++ harbour/source/rtl/tpopup.prg | 1074 ++++++++++----- harbour/source/rtl/treport.prg | 154 +-- harbour/source/rtl/ttopbar.prg | 1271 +++++------------ harbour/tests/Makefile | 1 + harbour/tests/rto_get.prg | 47 +- harbour/tests/rto_tb.prg | 710 ++++++++++ 32 files changed, 9100 insertions(+), 7056 deletions(-) create mode 100644 harbour/source/rtl/gui.prg create mode 100644 harbour/source/rtl/menusys.prg delete mode 100644 harbour/source/rtl/mssgline.prg create mode 100644 harbour/source/rtl/tmenusys.prg create mode 100644 harbour/tests/rto_tb.prg diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 12e1f61840..8a83105adc 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,65 @@ 2002-12-01 13:30 UTC+0100 Foo Bar */ +2007-09-07 03:38 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) + * tests/Makefile + * tests/rto_get.prg + + tests/rto_tb.prg + * include/button.ch + * include/hbextern.ch + * common.mak + * source/rtl/Makefile + - source/rtl/mssgline.prg + + source/rtl/gui.prg + + source/rtl/menusys.prg + + source/rtl/tmenusys.prg + * source/rtl/checkbox.prg + * source/rtl/einstvar.prg + * source/rtl/getlist.prg + * source/rtl/getsys.prg + * source/rtl/listbox.prg + * source/rtl/memoedit.prg + * source/rtl/pushbtn.prg + * source/rtl/radiobtn.prg + * source/rtl/radiogrp.prg + * source/rtl/scrollbr.prg + * source/rtl/tbcolumn.prg + * source/rtl/tbrowse.prg + * source/rtl/teditor.prg + * source/rtl/tget.prg + * source/rtl/tgetlist.prg + * source/rtl/tlabel.prg + * source/rtl/tmenuitm.prg + * source/rtl/tpopup.prg + * source/rtl/treport.prg + * source/rtl/ttopbar.prg + ; These changes mainly targeted the .prg + level UI classes of Harbour. + + Code standardization, cleanup, formatting. + (formatting is not fully complete yet) + ! Lots of compatibility fixes. + ! Lots of bugfixes (crashes, wrongly passed + parameters, etc). + ! Minor fix in one of the methods of HBReportForm() + - Non-Clipper classes removed (the MENUSYS/msgline + related ones). + ! Some fixes adapted from xHarbour's TBrowse() + + Class VARs properly scoped. + + TBColumn() is now fully compatible. + * The mess in the TTopBar and related classes was + cleaned up, some small non-Clipper compatible + classes were removed and a new TMenuSys class + was created of the related parts. + % Optimizations. + + TBrowse/TBColumn regression test suite + added (far from complete at this point). + ; NOTE: No C5.3 GUI support is implemented in Harbour. + ; NOTE: Harbour uses Disp*() functions in UI functions + to update screen. C5.x uses a mixture of Dev*(), + Q?Out() and Disp*(). + ; NOTE: TBrowse() fixing is still a work in progress. + ; Please test. + 2007-09-06 13:40 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) * harbour/source/rtl/set.c ! fixed typo in SET name diff --git a/harbour/common.mak b/harbour/common.mak index 0366e197d3..44f84222d0 100644 --- a/harbour/common.mak +++ b/harbour/common.mak @@ -97,6 +97,7 @@ GTCRS_DIR = source\rtl\gtcrs GTSLN_DIR = source\rtl\gtsln GTXWC_DIR = source\rtl\gtxwc +HBDOT_DIR = utils\hbdot HBPP_DIR = utils\hbpp HBPPTEST_DIR = utils\hbpptest HBRUN_DIR = utils\hbrun @@ -146,6 +147,7 @@ $(GTSLN_DIR);\ $(GTXWC_DIR)\ ALL_EXE_SRC_DIRS_TMP=\ +$(HBDOT_DIR);\ $(HBPPTEST_DIR);\ $(HBRUN_DIR);\ $(HBDOT_DIR);\ @@ -207,6 +209,7 @@ GTXWC_LIB = $(LIB_DIR)\$(LIBPREF)gtxwc$(LIBEXT) HARBOUR_EXE = $(BIN_DIR)\harbour$(EXEEXT) # required (intermediate) utility # to generate pptable.c +HBDOT_EXE = $(BIN_DIR)\hbdot$(EXEEXT) HBPPGEN_EXE = $(BIN_DIR)\ppgen$(EXEEXT) HBPP_EXE = $(BIN_DIR)\hbpp$(EXEEXT) HBPPTEST_EXE = $(BIN_DIR)\hbpptest$(EXEEXT) @@ -544,13 +547,14 @@ RTL_LIB_OBJS = \ $(OBJ_DIR)\fieldbl$(OBJEXT) \ $(OBJ_DIR)\getlist$(OBJEXT) \ $(OBJ_DIR)\getsys$(OBJEXT) \ + $(OBJ_DIR)\gui$(OBJEXT) \ $(OBJ_DIR)\input$(OBJEXT) \ $(OBJ_DIR)\listbox$(OBJEXT) \ $(OBJ_DIR)\logical$(OBJEXT) \ $(OBJ_DIR)\memoedit$(OBJEXT) \ $(OBJ_DIR)\memvarbl$(OBJEXT) \ $(OBJ_DIR)\menuto$(OBJEXT) \ - $(OBJ_DIR)\mssgline$(OBJEXT) \ + $(OBJ_DIR)\menusys$(OBJEXT) \ $(OBJ_DIR)\nil$(OBJEXT) \ $(OBJ_DIR)\numeric$(OBJEXT) \ $(OBJ_DIR)\objfunc$(OBJEXT) \ @@ -577,6 +581,7 @@ RTL_LIB_OBJS = \ $(OBJ_DIR)\tgetlist$(OBJEXT) \ $(OBJ_DIR)\tlabel$(OBJEXT) \ $(OBJ_DIR)\tmenuitm$(OBJEXT) \ + $(OBJ_DIR)\tmenusys$(OBJEXT) \ $(OBJ_DIR)\tobject$(OBJEXT) \ $(OBJ_DIR)\tpopup$(OBJEXT) \ $(OBJ_DIR)\treport$(OBJEXT) \ @@ -908,6 +913,11 @@ HARBOUR_EXE_OBJS = \ #********************************************************** +HBDOT_EXE_OBJS = \ + $(OBJ_DIR)\hbdot$(OBJEXT) \ + +#********************************************************** + HBPP_EXE_OBJS = \ $(OBJ_DIR)\hbpp$(OBJEXT) \ $(OBJ_DIR)\hbpptbl$(OBJEXT) \ @@ -1079,6 +1089,7 @@ HB_BUILD_TARGETS = \ $(USRRDD_LIB) \ $(HB_GT_LIBS) \ \ + $(HBDOT_EXE) \ $(HBRUN_EXE) \ $(HBDOT_EXE) \ $(HBTEST_EXE) \ diff --git a/harbour/include/button.ch b/harbour/include/button.ch index 87c5db3a29..470415c9fc 100644 --- a/harbour/include/button.ch +++ b/harbour/include/button.ch @@ -59,13 +59,10 @@ #define SCROLL_HORIZONTAL 2 /* menu separators strings */ -#define MENU_SEPARATOR Chr(196) -#define SEPARATOR_DOUBLE ( Chr(204) + Chr(205) + Chr(185) ) /* double line left and right and double separator for popup menu */ -#define SEPARATOR_SINGLE ( Chr(195) + MENU_SEPARATOR + Chr(180) ) /* single separator for popup menu */ -#define SEPARATOR_DOUBLE_SINGLE ( Chr(199) + MENU_SEPARATOR + Chr(182) ) /* double line left and right and single separator for popup menu */ - -/* string constants for menuitems display */ -#define HB_TMENUITEM_STYLE ( Chr(251) + Chr(16) ) +#define MENU_SEPARATOR Chr( 196 ) +#define SEPARATOR_DOUBLE ( Chr( 204 ) + Chr( 205 ) + Chr( 185 ) ) /* double line left and right and double separator for popup menu */ +#define SEPARATOR_SINGLE ( Chr( 195 ) + MENU_SEPARATOR + Chr( 180 ) ) /* single separator for popup menu */ +#define SEPARATOR_DOUBLE_SINGLE ( Chr( 199 ) + MENU_SEPARATOR + Chr( 182 ) ) /* double line left and right and single separator for popup menu */ /* return values for HitTest methods */ #define HTNOWHERE 0 diff --git a/harbour/include/hbextern.ch b/harbour/include/hbextern.ch index 52d52ca14f..5530eb8600 100644 --- a/harbour/include/hbextern.ch +++ b/harbour/include/hbextern.ch @@ -832,6 +832,12 @@ EXTERNAL SETTYPEAHEAD EXTERNAL __CAPTION EXTERNAL __GUICOLOR +EXTERNAL __CAPLENGTH +EXTERNAL __CAPMETRICS +EXTERNAL __MICOLUMN +EXTERNAL __MIROW +EXTERNAL _ISGRAPHIC +EXTERNAL _SETVIDEOMODE EXTERNAL _CHECKBOX_ EXTERNAL _LISTBOX_ EXTERNAL _PUSHBUTT_ @@ -856,6 +862,7 @@ EXTERNAL GUIGETPREVALIDATE EXTERNAL GUIREADER EXTERNAL ISDEFCOLOR EXTERNAL ISDISK +EXTERNAL LISTBOX EXTERNAL MAKEDIR EXTERNAL MCOL EXTERNAL MDBLCLK @@ -886,9 +893,14 @@ EXTERNAL ORDCUSTOM EXTERNAL ORDFINDREC EXTERNAL ORDKEYRELPOS EXTERNAL POPUP +EXTERNAL PUSHBUTTON EXTERNAL RADIOBUTTO +#ifdef HB_EXTENSION +EXTERNAL RADIOBUTTON +#endif EXTERNAL RADIOGROUP EXTERNAL TOPBAR +EXTERNAL TBMOUSE EXTERNAL GETCLRPAIR EXTERNAL SETCLRPAIR @@ -905,9 +917,15 @@ EXTERNAL BUTTNDEFCO EXTERNAL MENUDEFCOL EXTERNAL APPLYDEFAU +EXTERNAL ISQUICK +EXTERNAL ISSHORTCUT EXTERNAL ACCELERATOR EXTERNAL HITTEST +EXTERNAL READSTATS +EXTERNAL SHOWGETMSG +EXTERNAL ERASEGETMSG EXTERNAL _GETNUMCOL +EXTERNAL SHOWMSG #endif /* HB_COMPAT_C53 */ diff --git a/harbour/source/rtl/Makefile b/harbour/source/rtl/Makefile index 16ce08193d..de1e1f9f8d 100644 --- a/harbour/source/rtl/Makefile +++ b/harbour/source/rtl/Makefile @@ -156,13 +156,14 @@ PRG_SOURCES=\ fieldbl.prg \ getlist.prg \ getsys.prg \ + gui.prg \ input.prg \ listbox.prg \ logical.prg \ memoedit.prg \ memvarbl.prg \ menuto.prg \ - mssgline.prg \ + menusys.prg \ nil.prg \ numeric.prg \ objfunc.prg \ @@ -189,6 +190,7 @@ PRG_SOURCES=\ tgetlist.prg \ tlabel.prg \ tmenuitm.prg \ + tmenusys.prg \ tobject.prg \ tpopup.prg \ treport.prg \ diff --git a/harbour/source/rtl/checkbox.prg b/harbour/source/rtl/checkbox.prg index 48520430c9..b46e338601 100644 --- a/harbour/source/rtl/checkbox.prg +++ b/harbour/source/rtl/checkbox.prg @@ -51,238 +51,328 @@ */ #include "hbclass.ch" -#include "common.ch" + #include "button.ch" +#include "color.ch" +#include "common.ch" +#include "setcurs.ch" + +/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but + it has all related variables and methods. */ + +/* NOTE: CA-Cl*pper 5.3 uses a mixture of QQOut(), DevOut(), Disp*() + functions to generate screen output. Harbour uses Disp*() + functions only. [vszakats] */ #ifdef HB_COMPAT_C53 -CREATE CLASS CHECKBOX FUNCTION HBCHECKBOX +CREATE CLASS CHECKBOX FUNCTION HBCheckBox - VAR Buffer INIT .f. - VAR Caption - VAR CapRow - VAR CapCol - VAR Cargo - VAR Col - VAR colorspec - VAR FBlock - VAR HasFocus INIT .f. - VAR Message INIT "" - VAR Row - VAR SBlock - VAR Style INIT "[û ]" - VAR lCursor - VAR Typeout INIT .f. + EXPORT: - METHOD New( nRow, nCol, cCaption ) - METHOD SetFocus() - MESSAGE Select( lState ) METHOD _Select( lState ) - METHOD KillFocus() - METHOD Display() - METHOD HitTest( nMouseRow, nMouseCol ) + VAR cargo + + METHOD display() + METHOD hitTest( nMouseRow, nMouseCol ) + METHOD killFocus() + METHOD select() + METHOD setFocus() + + METHOD bitmaps( aBitmaps ) SETGET + METHOD buffer() SETGET + METHOD capCol( nCapCol ) SETGET + METHOD capRow( nCapRow ) SETGET + METHOD caption( cCaption ) SETGET + METHOD col( nCol ) SETGET + METHOD colorSpec( cColorSpec ) SETGET + METHOD fBlock( bFBlock ) SETGET + METHOD hasFocus() SETGET + METHOD message( cMessage ) SETGET + METHOD row( nRow ) SETGET + METHOD sBlock( bSBlock ) SETGET + METHOD style( cStyle ) SETGET + METHOD typeOut() SETGET + + METHOD New( nRow, nCol, cCaption ) /* NOTE: This method is a Harbour extension [vszakats] */ + + PROTECTED: + + VAR aBitmaps INIT { "check_f.bmu", "check_e.bmu" } + VAR lBuffer INIT .F. + VAR nCapCol + VAR nCapRow + VAR cCaption + VAR nCol + VAR cColorSpec + VAR bFBlock + VAR lHasFocus INIT .F. + VAR cMessage INIT "" + VAR nRow + VAR bSBlock + VAR cStyle INIT "[" + Chr( 251 ) + " ]" + + VAR nCursor ENDCLASS -METHOD New( nRow, nCol, cCaption ) CLASS CHECKBOX +METHOD setFocus() CLASS CHECKBOX - LOCAL cColor := "" + IF !::lHasFocus + ::nCursor := SetCursor( SC_NONE ) + ::lHasFocus := .T. + ::display() - ::Buffer := .f. - ::Caption := cCaption - ::CapRow := nRow - ::CapCol := nCol + 3 + 1 - ::Col := nCol - - IF IsDefColor() - ::ColorSpec:="W/N,W+/N,W/N,W+/N" - ELSE - cColor := SetColor() - ::ColorSpec := __guicolor( cColor, 5 ) + "," + ; - __guicolor( cColor, 2 ) + "," + ; - __guicolor( cColor, 1 ) + "," + ; - __guicolor( cColor, 4 ) - ENDIF - - ::HasFocus := .f. - ::Message := "" - ::Row := nRow - - ::Style := "[û ]" - - ::Typeout := .f. - -RETURN Self - -METHOD SetFocus() CLASS CHECKBOX - - IF !::HasFocus - ::lCursor := SetCursor( 0 ) - ::HasFocus := .T. - ::Display() - IF ISBLOCK( ::FBlock ) - Eval( ::FBlock ) + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) ENDIF ENDIF -RETURN Self + RETURN Self -METHOD _Select( lState ) CLASS CHECKBOX +METHOD select( lState ) CLASS CHECKBOX - LOCAL lStatus := ::Buffer + LOCAL lOldState := ::lBuffer - IF ISLOGICAL( lState ) - ::Buffer := lState - ELSE - ::Buffer := !::Buffer - ENDIF + ::lBuffer := iif( ISLOGICAL( lState ), lState, !::lBuffer ) - IF lStatus != ::Buffer - ::Display() - IF ISBLOCK( ::SBlock ) - Eval( ::SBlock ) + IF lOldState != ::lBuffer + ::display() + + IF ISBLOCK( ::bSBlock ) + Eval( ::bSBlock ) ENDIF ENDIF -RETURN Self + RETURN Self -METHOD KillFocus() CLASS CHECKBOX +METHOD killFocus() CLASS CHECKBOX - IF ::HasFocus - ::HasFocus := .F. + IF ::lHasFocus + ::lHasFocus := .F. - IF ISBLOCK( ::FBlock ) - Eval( ::FBlock ) + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) ENDIF - ::Display() - SetCursor( ::lCursor ) + ::display() + SetCursor( ::nCursor ) ENDIF -RETURN Self + RETURN Self -METHOD HitTest( nMouseRow, nMouseCol ) CLASS CHECKBOX +METHOD hitTest( nMouseRow, nMouseCol ) CLASS CHECKBOX - LOCAL nPosAccel, nLenCaption + LOCAL nPosAccel + LOCAL nLenCaption - IF nMouseRow == ::Row .AND. ; - nMouseCol >= ::Col .AND. nMouseCol < ::Col + 3 + IF nMouseRow == ::nRow .AND. ; + nMouseCol >= ::nCol .AND. ; + nMouseCol < ::nCol + 3 RETURN HTCLIENT ENDIF - - IF ISCHARACTER( ::Caption ) - nLenCaption := Len( ::Caption ) - IF ( nPosAccel := At( "&", ::Caption ) ) != 0 .AND. ; - nPosAccel < nLenCaption - nLenCaption-- - ENDIF - - IF nMouseRow == ::CapRow .AND. ; - nMouseCol >= ::CapCol .AND. nMouseCol < ::CapCol + nLenCaption - RETURN HTCAPTION - ENDIF + + nLenCaption := Len( ::cCaption ) + + IF ( nPosAccel := At( "&", ::cCaption ) ) > 0 .AND. ; + nPosAccel < nLenCaption + nLenCaption-- ENDIF -RETURN HTNOWHERE + IF nMouseRow == ::nCapRow .AND. ; + nMouseCol >= ::nCapCol .AND. ; + nMouseCol < ::nCapCol + nLenCaption + RETURN HTCAPTION + ENDIF -METHOD Display() CLASS CHECKBOX + RETURN HTNOWHERE - LOCAL cColor := SetColor(), ; - nCurRow := Row(), nCurCol := Col(), ; - cOldStyle := ::Style, ; - cCaption, nPos +METHOD display() CLASS CHECKBOX + + LOCAL cOldColor := SetColor() + LOCAL nOldRow := Row() + LOCAL nOldCol := Col() + LOCAL lOldMCur := MSetCursor( .F. ) + + LOCAL cStyle := ::cStyle + LOCAL cCaption + LOCAL nPos DispBegin() - IF ::HasFocus - SET COLOR TO ( __GuiColor( ::ColorSpec, 2 ) ) - ELSE - SET COLOR TO ( __GuiColor( ::ColorSpec, 1 ) ) - ENDIF + DispOutAt( ::nRow, ::nCol + 1, iif( ::lBuffer, SubStr( cStyle, 2, 1 ), SubStr( cStyle, 3, 1 ) ),; + __GUIColor( ::cColorSpec, iif( ::lHasFocus, 2, 1 ) ) ) - SetPos(::Row, ::Col + 1) - IF ::Buffer - ?? Substr( cOldStyle, 2, 1 ) - ELSE - ?? Substr( cOldStyle, 3, 1 ) - ENDIF + SetColor( __GUIColor( ::cColorSpec, 3 ) ) + DispOutAt( ::nRow, ::nCol, Left( cStyle, 1 ) ) + DispOutAt( ::nRow, ::nCol + 2, Right( cStyle, 1 ) ) - SET COLOR TO ( __GuiColor( ::ColorSpec, 3 ) ) - SetPos( ::Row, ::Col ) - ?? Left( cOldStyle, 1 ) - SetPos( ::Row, ::Col + 2 ) - ?? Right( cOldStyle, 1 ) + IF !Empty( cCaption := ::cCaption ) - IF !Empty( cCaption := ::Caption ) - IF ( nPos := At( "&", cCaption ) ) != 0 - IF nPos == Len( cCaption ) - nPos := 0 - ELSE - cCaption := Stuff( cCaption, nPos, 1, "" ) - ENDIF + IF ( nPos := At( "&", cCaption ) ) == 0 + ELSEIF nPos == Len( cCaption ) + nPos := 0 + ELSE + cCaption := Stuff( cCaption, nPos, 1, "" ) ENDIF - IF ::HasFocus - SET COLOR TO ( __GuiColor( ::ColorSpec, 4 ) ) + IF ::lHasFocus + SetColor( __GUIColor( ::cColorSpec, 4 ) ) ENDIF - SetPos( ::CapRow, ::CapCol ) - ?? cCaption + DispOutAt( ::nCapRow, ::nCapCol, cCaption ) - IF !::HasFocus .and. nPos != 0 - SET COLOR TO ( __GuiColor( ::ColorSpec, 4 ) ) - SetPos( ::CapRow, ::CapCol + nPos - 1 ) - ?? SubStr( cCaption, nPos, 1 ) + IF !::lHasFocus .AND. nPos != 0 + DispOutAt( ::nCapRow, ::nCapCol + nPos - 1, SubStr( cCaption, nPos, 1 ), __GUIColor( ::cColorSpec, 4 ) ) ENDIF ENDIF DispEnd() - SET COLOR TO ( cColor ) - SetPos( nCurRow, nCurCol ) + MSetCursor( lOldMCur ) + SetColor( cOldColor ) + SetPos( nOldRow, nOldCol ) -RETURN Self + RETURN Self +METHOD bitmaps( aBitmaps ) CLASS CHECKBOX -FUNCTION _CHECKBOX_( lState, cCaption, cMessage, cColor, FBlock, SBlock, cStyle ) - - LOCAL oCheck - - oCheck := hbCheckBox():New( Row(), Col(), cCaption ) - - IF !ISNIL( oCheck ) - - oCheck:Select( lState ) - oCheck:Caption := cCaption - - IF cColor != NIL - oCheck:ColorSpec := cColor - ENDIF - - oCheck:Message := cMessage - - IF cStyle != NIL - oCheck:Style := cStyle - ENDIF - - oCheck:FBlock := FBlock - oCheck:SBlock := SBlock - + IF aBitmaps != NIL + ::aBitmaps := _eInstVar( Self, "BITMAPS", aBitmaps, "A", 1001 ) ENDIF -RETURN oCheck + RETURN ::aBitmaps -FUNCTION Checkbox( nRow, nCol, cCaption ) +METHOD buffer() CLASS CHECKBOX + RETURN ::lBuffer - Default cCaption to '' +METHOD capCol( nCapCol ) CLASS CHECKBOX -RETURN hbCheckBox():New( nRow, nCol, cCaption ) + IF nCapCol != NIL + ::nCapCol := _eInstVar( Self, "CAPCOL", nCapCol, "N", 1001 ) + ENDIF -FUNCTION __GuiColor( cPair, nPos ) -RETURN hb_colorindex( cpair, npos - 1 ) + RETURN ::nCapCol -FUNCTION IsDefColor() -RETURN UPPER( SetColor() ) == "W/N,N/W,N/N,N/N,N/W" +METHOD capRow( nCapRow ) CLASS CHECKBOX + + IF nCapRow != NIL + ::nCapRow := _eInstVar( Self, "CAPROW", nCapRow, "N", 1001 ) + ENDIF + + RETURN ::nCapRow + +METHOD caption( cCaption ) CLASS CHECKBOX + + IF cCaption != NIL + ::cCaption := _eInstVar( Self, "CAPTION", cCaption, "C", 1001 ) + ENDIF + + RETURN ::cCaption + +METHOD col( nCol ) CLASS CHECKBOX + + IF nCol != NIL + ::nCol := _eInstVar( Self, "COL", nCol, "N", 1001 ) + ENDIF + + RETURN ::nCol + +METHOD colorSpec( cColorSpec ) CLASS CHECKBOX + + IF cColorSpec != NIL + ::cColorSpec := _eInstVar( Self, "COLORSPEC", cColorSpec, "C", 1001,; + {|| !Empty( __GUIColor( cColorSpec, 4 ) ) .AND. Empty( __GUIColor( cColorSpec, 5 ) ) } ) + ENDIF + + RETURN ::cColorSpec + +METHOD fBlock( bFBlock ) CLASS CHECKBOX + + IF PCount() > 0 + ::bFBlock := iif( bFBlock == NIL, NIL, _eInstVar( Self, "FBLOCK", bFBlock, "B", 1001 ) ) + ENDIF + + RETURN ::bFBlock + +METHOD hasFocus() CLASS CHECKBOX + RETURN ::lHasFocus + +METHOD message( cMessage ) CLASS CHECKBOX + + IF cMessage != NIL + ::cMessage := _eInstVar( Self, "MESSAGE", cMessage, "C", 1001 ) + ENDIF + + RETURN ::cMessage + +METHOD row( nRow ) CLASS CHECKBOX + + IF nRow != NIL + ::nRow := _eInstVar( Self, "ROW", nRow, "N", 1001 ) + ENDIF + + RETURN ::nRow + +METHOD sBlock( bSBlock ) CLASS CHECKBOX + + IF PCount() > 0 + ::bSBlock := iif( bSBlock == NIL, NIL, _eInstVar( Self, "SBLOCK", bSBlock, "B", 1001 ) ) + ENDIF + + RETURN ::bSBlock + +METHOD style( cStyle ) CLASS CHECKBOX + + IF cStyle != NIL + ::cStyle := _eInstVar( Self, "STYLE", cStyle, "C", 1001, {|| Len( cStyle ) == 0 .OR. Len( cStyle ) == 4 } ) + ENDIF + + RETURN ::cStyle + +METHOD typeOut() CLASS CHECKBOX + RETURN .F. + +METHOD New( nRow, nCol, cCaption ) CLASS CHECKBOX + + LOCAL cColor + + DEFAULT cCaption TO "" + + ::caption := cCaption + ::capRow := nRow + ::capCol := nCol + 3 + 1 + ::row := nRow + ::col := nCol + + IF IsDefColor() + ::cColorSpec := "W/N,W+/N,W/N,W+/N" + ELSE + cColor := SetColor() + ::cColorSpec := __GUIColor( cColor, CLR_UNSELECTED + 1 ) + "," +; + __GUIColor( cColor, CLR_ENHANCED + 1 ) + "," +; + __GUIColor( cColor, CLR_STANDARD + 1 ) + "," +; + __GUIColor( cColor, CLR_BACKGROUND + 1 ) + ENDIF + + RETURN Self + +FUNCTION _CHECKBOX_( lState, cCaption, cMessage, cColorSpec, bFBlock, bSBlock, cStyle, aBitmaps ) + LOCAL o := HBCheckBox():New( Row(), Col(), cCaption ) + + o:select( lState ) + o:caption := cCaption + o:message := cMessage + o:colorSpec := cColorSpec + o:fBlock := bFBlock + o:sBlock := bSBlock + o:style := cStyle + o:bitmaps := aBitmaps + + RETURN o + +FUNCTION CheckBox( nRow, nCol, cCaption ) + RETURN HBCheckBox():New( nRow, nCol, cCaption ) #endif diff --git a/harbour/source/rtl/einstvar.prg b/harbour/source/rtl/einstvar.prg index 6ae6521915..d6847ef034 100644 --- a/harbour/source/rtl/einstvar.prg +++ b/harbour/source/rtl/einstvar.prg @@ -53,13 +53,21 @@ #include "common.ch" +/* NOTE: In CA-Cl*pper 5.2 the 6th and 7th arguments are a minimum and + maximum limit for a (numerical) value. In CA-Cl*pper 5.3 and + in Harbour there is no 7th argument and 6th is a generic + validation codeblock. In other words, in case of _eInstVar() + Harbour is compatible with CA-Cl*pper 5.3, not with 5.2. */ + +/* NOTE: In CA-Cl*pper 5.2/5.3 the cMethod argument seems to be ignored. */ + FUNCTION _eInstVar( oVar, cMethod, xValue, cType, nSubCode, bValid ) LOCAL oError IF VALTYPE( xValue ) != cType .OR. ; ( bValid != NIL .AND. !EVAL( bValid, oVar, xValue ) ) - oError := errornew() + oError := ErrorNew() oError:description := HB_LANGERRMSG( 1 ) oError:gencode := 1 oError:severity := 2 diff --git a/harbour/source/rtl/getlist.prg b/harbour/source/rtl/getlist.prg index 3543b84b41..af3624e229 100644 --- a/harbour/source/rtl/getlist.prg +++ b/harbour/source/rtl/getlist.prg @@ -58,13 +58,13 @@ STATIC s_oGetListLast PROCEDURE __GetListSetActive( oGetList ) IF s_oGetListActive != NIL - s_oGetListActive:lHasFocus := .F. + s_oGetListActive:HasFocus := .F. ENDIF s_oGetListActive := oGetList IF s_oGetListActive != NIL - s_oGetListActive:lHasFocus := .T. + s_oGetListActive:HasFocus := .T. ENDIF RETURN @@ -76,8 +76,8 @@ FUNCTION __GetListActive() FUNCTION __GetListLast( oGetListLast ) - if oGetListLast != NIL + IF oGetListLast != NIL s_oGetListLast := oGetListLast - endif - RETURN s_oGetListLast + ENDIF + RETURN s_oGetListLast diff --git a/harbour/source/rtl/getsys.prg b/harbour/source/rtl/getsys.prg index 6ecb998329..9f2d4b88b1 100644 --- a/harbour/source/rtl/getsys.prg +++ b/harbour/source/rtl/getsys.prg @@ -69,13 +69,12 @@ FUNCTION ReadModal( GetList, nPos, nMsgRow, nMsgLeft, nMsgRight, cMsgColor ) FUNCTION ReadModal( GetList, nPos ) #endif - LOCAL oGetList, oSaveGetList + LOCAL oGetList + LOCAL oSaveGetList #ifdef HB_COMPAT_C53 LOCAL lMsgFlag - LOCAL cSaveColor LOCAL cOldMsg - LOCAL lColorFlag LOCAL oGet #endif @@ -97,20 +96,10 @@ FUNCTION ReadModal( GetList, nPos ) ENDIF #ifdef HB_COMPAT_C53 - if ( ! ValType( nMsgRow ) == "N" ) - lMsgFlag := .f. - - elseif ( ! ValType( nMsgLeft ) == "N" ) - lMsgFlag := .f. - - elseif ( ! ValType( nMsgRight ) == "N" ) - lMsgFlag := .f. - - else - lMsgFlag := .t. + if ( lMsgFlag := ISNUMBER( nMsgRow ) .AND. ; + ISNUMBER( nMsgLeft ) .AND. ; + ISNUMBER( nMsgRight ) ) cOldMsg := SaveScreen( nMsgRow, nMsgLeft, nMsgRow, nMsgRight ) - lColorFlag := ( ValType( cMsgColor ) == "C" ) - endif #endif @@ -120,29 +109,16 @@ FUNCTION ReadModal( GetList, nPos ) oGetList:PostActiveGet() #ifdef HB_COMPAT_C53 - if ( lMsgFlag ) + if lMsgFlag oGet := oGetList:aGetList[ oGetList:nPos ] - if ( lColorFlag ) - cSaveColor := SetColor( cMsgColor ) - endif - if ( ValType( oGet:Control ) == "O" ) - @ nMsgRow, nMsgLeft ; - say PadC( oGet:Control:Message, nMsgRight - nMsgLeft + 1 ) - else - @ nMsgRow, nMsgLeft ; - say PadC( oGet:Message, nMsgRight - nMsgLeft + 1 ) - endif - - if ( lColorFlag ) - SetColor( cSaveColor ) - endif + DispOutAt( nMsgRow, nMsgLeft, PadC( iif( ISOBJECT( oGet:Control ), oGet:Control:Message, oGet:Message ), nMsgRight - nMsgLeft + 1 ), iif( ISCHARACTER( cMsgColor ), cMsgColor, NIL ) ) endif #endif IF ISBLOCK( oGetList:oGet:Reader ) #ifdef HB_COMPAT_C53 - Eval( oGetList:oGet:Reader, oGetList:oGet ,oGetlist) + Eval( oGetList:oGet:Reader, oGetList:oGet, oGetlist) #else Eval( oGetList:oGet:Reader, oGetList:oGet ) #endif @@ -155,7 +131,7 @@ FUNCTION ReadModal( GetList, nPos ) ENDDO #ifdef HB_COMPAT_C53 - if ( lMsgFlag ) + if lMsgFlag RestScreen( nMsgRow, nMsgLeft, nMsgRow, nMsgRight, cOldMsg ) endif #endif @@ -175,7 +151,7 @@ FUNCTION GetActive( oGet ) LOCAL oGetList := __GetListActive() IF oGetList != NIL - IF PCount() >= 1 + IF PCount() > 0 RETURN oGetList:GetActive( oGet ) ELSE RETURN oGetList:GetActive() @@ -235,17 +211,16 @@ FUNCTION GetPostValidate( oGet ) RETURN .F. FUNCTION ReadExit( lExit ) - RETURN IF( ISLOGICAL( lExit ), Set( _SET_EXIT, lExit ), Set( _SET_EXIT ) ) + RETURN iif( ISLOGICAL( lExit ), Set( _SET_EXIT, lExit ), Set( _SET_EXIT ) ) FUNCTION ReadInsert( lInsert ) - RETURN IF( ISLOGICAL( lInsert ), Set( _SET_INSERT, lInsert ), Set( _SET_INSERT ) ) + RETURN iif( ISLOGICAL( lInsert ), Set( _SET_INSERT, lInsert ), Set( _SET_INSERT ) ) FUNCTION ReadUpdated( lUpdated ) -/* LOCAL oGetList := __GetListActive() */ LOCAL oGetList := __GetListLast() IF oGetList != NIL - IF PCount() >= 1 + IF PCount() > 0 RETURN oGetList:ReadUpdated( lUpdated ) ELSE RETURN oGetList:ReadUpdated() @@ -255,7 +230,6 @@ FUNCTION ReadUpdated( lUpdated ) RETURN .F. FUNCTION Updated() -/* LOCAL oGetList := __GetListActive() */ LOCAL oGetList := __GetListLast() IF oGetList != NIL @@ -268,7 +242,7 @@ FUNCTION ReadKill( lKill ) LOCAL oGetList := __GetListActive() IF oGetList != NIL - IF PCount() >= 1 + IF PCount() > 0 RETURN oGetList:KillRead( lKill ) ELSE RETURN oGetList:KillRead() @@ -303,7 +277,7 @@ FUNCTION ReadFormat( bFormat ) LOCAL oGetList := __GetListActive() IF oGetList != NIL - IF PCount() >= 1 + IF PCount() > 0 RETURN oGetList:SetFormat( bFormat ) ELSE RETURN oGetList:SetFormat() @@ -321,7 +295,8 @@ FUNCTION ReadFormat( bFormat ) FUNCTION RangeCheck( oGet, xDummy, xLow, xHigh ) LOCAL xValue LOCAL cMessage - LOCAL nOldRow, nOldCol + LOCAL nOldRow + LOCAL nOldCol HB_SYMBOL_UNUSED( xDummy ) @@ -358,57 +333,50 @@ FUNCTION RangeCheck( oGet, xDummy, xLow, xHigh ) #ifdef HB_COMPAT_C53 -PROCEDURE GUIReader( oGet, oGetlist, a, b ) +PROCEDURE TBReader( oGet, oGetList, oMenu, aMsg ) + + IF !ISOBJECT( oGetList ) + oGetList := __GetListActive() + ENDIF + + oGetlist:TBReader( oGet, oMenu, aMsg ) + + RETURN + +PROCEDURE GUIReader( oGet, oGetlist, oMenu, aMsg ) + + IF !ISOBJECT( oGetList ) + oGetList := __GetListActive() + ENDIF - oGetlist:GuiReader( oGet, oGetList, a, b ) + oGetlist:GUIReader( oGet, oMenu, aMsg ) RETURN -PROCEDURE TBReader( oGet, oGetList, aMsg ) +PROCEDURE GUIApplyKey( oGet, oGUI, oGetList, nKey, oMenu, aMsg ) - oGetlist:TBReader( oGet, oGetList, aMsg ) - - RETURN - -PROCEDURE TBApplyKey( oGet, oTB, GetList, nKey, aMsg ) - LOCAL oGetList := __GetListActive() - - IF oGetList != NIL - IF oGet != NIL - oGetList:oGet := oGet - ENDIF - oGetList:Tbapplykey( oGet, oTB, GetList, nKey, aMsg ) - ENDIF - RETURN - -PROCEDURE GuiApplyKey(oGet,nKey) - LOCAL oGetList := __GetListActive() - - IF oGetList != NIL - IF oGet != NIL - oGetList:oGet := oGet - ENDIF - oGetList:GUIApplyKey(oGet, nKey ) + IF !ISOBJECT( oGetList ) + oGetList := __GetListActive() ENDIF + oGetList:GUIApplyKey( oGet, oGUI, nKey, oMenu, aMsg ) + RETURN -FUNCTION GuiGetPreValidate( oGet, oGUI ) +FUNCTION GUIPreValidate( oGet, oGUI, aMsg ) LOCAL oGetList := __GetListActive() - HB_SYMBOL_UNUSED( oGUI ) - IF oGetList != NIL IF oGet != NIL oGetList:oGet := oGet ENDIF - RETURN oGetList:GetPreValidate() + RETURN oGetList:GUIPreValidate( oGUI, aMsg ) ENDIF RETURN .F. -FUNCTION GuiGetPostValidate( oGet, oGUI ) +FUNCTION GUIPostValidate( oGet, oGUI, aMsg ) LOCAL oGetList := __GetListActive() IF oGetList != NIL @@ -416,34 +384,117 @@ FUNCTION GuiGetPostValidate( oGet, oGUI ) oGetList:oGet := oGet ENDIF - RETURN oGetList:GuiGetPostValidate( oGUI ) + RETURN oGetList:GUIPostValidate( oGUI, aMsg ) ENDIF RETURN .F. +PROCEDURE TBApplyKey( oGet, oTB, oGetList, nKey, aMsg ) -FUNCTION HitTest( aGetList, MouseRow, MouseCol, aMsg ) // Removed STATIC - LOCAL oGetList := __GetListActive() - - IF oGetList != NIL - RETURN oGetlist:Hittest( aGetList, MouseRow, MouseCol, aMsg ) // Removed STATIC + IF !ISOBJECT( oGetList ) + oGetList := __GetListActive() ENDIF - RETURN 0 -/*** -* -* Accelerator( , , ) --> 0 -* -* Identify the Accelerator key -* -***/ -FUNCTION Accelerator( aGetList, nKey, aMsg ) // Removed STATIC - LOCAL oGetList := __GetListActive() + oGetList:TBApplyKey( oGet, oTB, nKey, aMsg ) - IF oGetList != NIL - RETURN oGetlist:Accelerator( aGetList, nKey, aMsg ) // Removed STATIC + RETURN + +FUNCTION Accelerator( oGetList, nKey, aMsg ) + + IF !ISOBJECT( oGetList ) + oGetList := __GetListActive() ENDIF - RETURN 0 + + RETURN iif( oGetList != NIL, oGetlist:Accelerator( nKey, aMsg ), 0 ) + +FUNCTION HitTest( oGetList, MouseRow, MouseCol, aMsg ) + + IF !ISOBJECT( oGetList ) + oGetList := __GetListActive() + ENDIF + + RETURN iif( oGetList != NIL, oGetlist:Hittest( MouseRow, MouseCol, aMsg ), 0 ) + +#define SLUPDATED 1 +#define SBFORMAT 2 +#define SLKILLREAD 3 +#define SLBUMPTOP 4 +#define SLBUMPBOT 5 +#define SNLASTEXIT 6 +#define SNLASTPOS 7 +#define SOACTIVEGET 8 +#define SXREADVAR 9 +#define SCREADPROCNAME 10 +#define SNREADPROCLINE 11 +#define SNNEXTGET 12 +#define SNHITCODE 13 +#define SNPOS 14 +#define SCSCRSVMSG 15 +#define SNMENUID 16 +#define SNSVCURSOR 17 + +FUNCTION ReadStats( nElement, xNewValue ) + LOCAL xRetVal + + DO CASE + CASE nElement == SLUPDATED ; xRetVal := __GetListActive():lUpdated + CASE nElement == SBFORMAT ; xRetVal := __GetListActive():bFormat + CASE nElement == SLKILLREAD ; xRetVal := __GetListActive():lKillRead + CASE nElement == SLBUMPTOP ; xRetVal := __GetListActive():lBumpTop + CASE nElement == SLBUMPBOT ; xRetVal := __GetListActive():lBumpBot + CASE nElement == SNLASTEXIT ; xRetVal := __GetListActive():nLastExitState + CASE nElement == SNLASTPOS ; xRetVal := __GetListActive():nLastPos + CASE nElement == SOACTIVEGET ; xRetVal := __GetListActive():oActiveGet + CASE nElement == SXREADVAR ; xRetVal := __GetListActive():cVarName + CASE nElement == SCREADPROCNAME ; xRetVal := __GetListActive():cReadProcName + CASE nElement == SNREADPROCLINE ; xRetVal := __GetListActive():nReadProcLine + CASE nElement == SNNEXTGET ; xRetVal := __GetListActive():nNextGet + CASE nElement == SNHITCODE ; xRetVal := __GetListActive():nHitCode + CASE nElement == SNPOS ; xRetVal := __GetListActive():nPos + CASE nElement == SCSCRSVMSG ; xRetVal := "" + CASE nElement == SNMENUID ; xRetVal := 0 + CASE nElement == SNSVCURSOR ; xRetVal := 0 + OTHERWISE ; xRetVal := NIL + ENDCASE + + IF PCount() > 1 + + DO CASE + CASE nElement == SLUPDATED ; __GetListActive():lUpdated := xNewValue + CASE nElement == SBFORMAT ; __GetListActive():bFormat := xNewValue + CASE nElement == SLKILLREAD ; __GetListActive():lKillRead := xNewValue + CASE nElement == SLBUMPTOP ; __GetListActive():lBumpTop := xNewValue + CASE nElement == SLBUMPBOT ; __GetListActive():lBumpBot := xNewValue + CASE nElement == SNLASTEXIT ; __GetListActive():nLastExitState := xNewValue + CASE nElement == SNLASTPOS ; __GetListActive():nLastPos := xNewValue + CASE nElement == SOACTIVEGET ; __GetListActive():oActiveGet := xNewValue + CASE nElement == SXREADVAR ; __GetListActive():cVarName := xNewValue + CASE nElement == SCREADPROCNAME ; __GetListActive():cReadProcName := xNewValue + CASE nElement == SNREADPROCLINE ; __GetListActive():nReadProcLine := xNewValue + CASE nElement == SNNEXTGET ; __GetListActive():nNextGet := xNewValue + CASE nElement == SNHITCODE ; __GetListActive():nHitCode := xNewValue + CASE nElement == SNPOS ; __GetListActive():nPos := xNewValue + ENDCASE + ENDIF + + RETURN xRetVal + +FUNCTION ShowGetMsg( oGet, aMsg ) + + /* Dummy function */ + + HB_SYMBOL_UNUSED( oGet ) + HB_SYMBOL_UNUSED( aMsg ) + + RETURN NIL + +FUNCTION EraseGetMsg( oGet, aMsg ) + + /* Dummy function */ + + HB_SYMBOL_UNUSED( oGet ) + HB_SYMBOL_UNUSED( aMsg ) + + RETURN NIL #endif - diff --git a/harbour/source/rtl/gui.prg b/harbour/source/rtl/gui.prg new file mode 100644 index 0000000000..f047248c6f --- /dev/null +++ b/harbour/source/rtl/gui.prg @@ -0,0 +1,106 @@ +/* + * $Id: checkbox.prg 7155 2007-04-14 10:41:54Z vszakats $ + */ + +/* + * Harbour Project source code: + * GUI helper functions + * + * Copyright 2000 Luiz Rafael Culik + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#include "common.ch" + +#ifdef HB_COMPAT_C53 + +#define LLG_VIDEO_TXT 3 + +FUNCTION _IsGraphic() + RETURN Set( _SET_VIDEOMODE ) != NIL .AND. ; + Set( _SET_VIDEOMODE ) != 0 .AND. ; + Set( _SET_VIDEOMODE ) != LLG_VIDEO_TXT + +FUNCTION _SetVideoMode( nMode ) + + HB_SYMBOL_UNUSED( nMode ) + + RETURN 0 + +FUNCTION _GetNumCol( cColor ) + LOCAL nPos + + IF ( nPos := At( "/", cColor ) ) > 0 + cColor := Left( cColor, nPos - 1 ) + ENDIF + IF ( nPos := At( ",", cColor ) ) > 0 + cColor := Left( cColor, nPos - 1 ) + ENDIF + #ifndef HB_C52_STRICT + cColor := Upper( cColor ) + #endif + + RETURN AScan( { "B", "G", "BG", "R", "RB", "GR", "W", "N+", "B+", "G+", "BG+", "R+", "RB+", "GR+", "W+" }, {| tmp | tmp == cColor } ) + +FUNCTION __GUIColor( cColor, nPos ) + RETURN hb_ColorIndex( cColor, nPos - 1 ) + +FUNCTION IsDefColor() + RETURN SetColor() == "W/N,N/W,N/N,N/N,N/W" /* NOTE: Color must match with the one in set.c */ + +/* Removes the accelerator marker from a caption string */ +FUNCTION __Caption( cCaption ) + LOCAL nPos + + RETURN iif( ( nPos := At( "&", cCaption ) ) > 0, Stuff( cCaption, nPos, 1, "" ), cCaption ) + +FUNCTION __CapLength( cCaption ) + LOCAL nCaptionLen := Len( cCaption ) + LOCAL nPos + + RETURN iif( ( nPos := At( "&", cCaption ) ) > 0 .AND. nPos < nCaptionLen, nCaptionLen - 1, nCaptionLen ) + +FUNCTION __CapMetrics( o ) + RETURN __CapLength( o:caption ) + iif( o:isPopup(), 3, 2 ) + +#endif diff --git a/harbour/source/rtl/listbox.prg b/harbour/source/rtl/listbox.prg index 37a483182c..66e956dc5a 100644 --- a/harbour/source/rtl/listbox.prg +++ b/harbour/source/rtl/listbox.prg @@ -9,7 +9,7 @@ * Copyright 2000 Luiz Rafael Culik * www - http://www.harbour-project.org * - * This program is free software; you can redistribute it and/or modify + * This program is free software; you can redistribute it and/or modIFy * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. @@ -20,14 +20,14 @@ * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to + * along with this software; see the file COPYING. IF not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). * * As a special exception, the Harbour Project gives permission for * additional uses of the text contained in its release of Harbour. * - * The exception is that, if you link the Harbour libraries with other + * The exception is that, IF you link the Harbour libraries with other * files to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of @@ -37,1172 +37,1121 @@ * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the Harbour - * Project under the name Harbour. If you copy code from other + * Project under the name Harbour. IF you copy code from other * Harbour Project or Free Software Foundation releases into a copy of * Harbour, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete + * anyone as to the status of such modIFied files, you must delete * this exception notice from them. * - * If you write modifications of your own for Harbour, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. + * IF you write modIFications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modIFications. + * IF you do not wish that, delete this exception notice. * */ #include "hbclass.ch" -#include "common.ch" + #include "box.ch" -#include "inkey.ch" #include "button.ch" +#include "color.ch" +#include "common.ch" +#include "inkey.ch" +#include "setcurs.ch" + +/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but + it has all related variables and methods. */ + +/* NOTE: CA-Cl*pper 5.3 uses a mixture of QQOut(), DevOut(), Disp*() + functions to generate screen output. Harbour uses Disp*() + functions only. [vszakats] */ #ifdef HB_COMPAT_C53 + +#define _ITEM_cTEXT 1 +#define _ITEM_cDATA 2 + +#define _LISTBOX_ITEMDATA( aItem ) iif( aItem[ _ITEM_cDATA ] == NIL, aItem[ _ITEM_cTEXT ], aItem[ _ITEM_cDATA ] ) + CREATE CLASS LISTBOX FUNCTION HBListBox -Exported: + EXPORT: - Method New( nTop, nLeft, nBottom, nRight, lDrop ) + VAR cargo - MESSAGE Select( nPos ) Method SELECTS( nPos ) - Method AddItem( cText, xValue ) - Method Close() - Method DelItem( nPos ) - Method Display() - Method FindText( cText, nPos, lCaseSensitive, lExact ) - Method FindData( cText, nPos, lCaseSensitive, lExact ) - Method GetData( xItem ) - Method GetItem( nPos ) - Method GetText( nPos ) - Method HitTest( n, p ) - Method InsItem( nPos, cText, xVal ) - Method KillFocus() - Method NextItem() - Method Open() - Method PrevItem() - MESSAGE Scroll( n ) Method _Scroll( n ) + METHOD addItem( cText, cData ) + METHOD close() + METHOD delItem( nPos ) + METHOD display() + METHOD findText( cText, nPos, lCaseSensitive, lExact ) + METHOD findData( cData, nPos, lCaseSensitive, lExact ) /* NOTE: Undocumented CA-Cl*pper method. */ + METHOD getData( nPos ) + METHOD getItem( nPos ) + METHOD getText( nPos ) + METHOD hitTest( nMouseRow, nMouseCol ) + METHOD insItem( nPos, cText, cData ) + METHOD killFocus() + METHOD nextItem() + METHOD open() + METHOD prevItem() + METHOD scroll( n ) + METHOD select( nValue ) + METHOD setData( nPos, cData ) + METHOD setFocus() + METHOD setItem( nPos, aItem ) + METHOD setText( nPos, cText ) - Method SetData( nPos, xValue ) - Method SetFocus() - Method SetItem( nPos, aitem ) - Method SetText( nPos, xValue ) - Data Buffer - Data CapCol - Data CapRow - Data Cargo Init NIL - Data HasFocus Init .T. - Data ItemCount Init 0 - Data Left Init 0 - Data Message Init '' - Data TextValue Init '' - Data Style Init "" - Data sBlock Init NIL - Data fBlock Init Nil - Data Hotbox Init "" - Data ColorSpec Init "" - Data ColdBox - Data ISOPEN Init .f. - Data aItems Init {} - Data vScrolls + METHOD bitmap( cBitmap ) SETGET + METHOD bottom( nBottom ) SETGET + METHOD buffer() SETGET + METHOD capCol( nCapCol ) SETGET + METHOD capRow( nCapRow ) SETGET + METHOD caption( cCaption ) SETGET + METHOD coldBox( cColdBox ) SETGET + METHOD colorSpec( cColorSpec ) SETGET + METHOD dropDown( lDropDown ) SETGET + METHOD fBlock( bFBlock ) SETGET + METHOD hasFocus() SETGET + METHOD hotBox( cHotBox ) SETGET + METHOD isOpen() SETGET + METHOD itemCount() SETGET + METHOD left( nLeft ) SETGET + METHOD message( cMessage ) SETGET + METHOD right( nRight ) SETGET + METHOD sBlock( bSBlock ) SETGET + METHOD style( cStyle ) SETGET /* NOTE: Undocumented CA-Cl*pper method. */ + METHOD textValue() SETGET /* NOTE: Undocumented CA-Cl*pper method. */ + METHOD top( nTop ) SETGET + METHOD topItem( nTopItem ) SETGET + METHOD typeOut() SETGET + METHOD value() SETGET /* NOTE: Undocumented CA-Cl*pper method. */ + METHOD vScroll( oVScroll ) SETGET - Data Value Init 0 - Data Top Init 0 - Data right Init 0 - Data Bottom Init 0 - Data TopItem Init 1 - Data dropdown Init .f. - ACCESS nTop inline ::SetTop() - ASSIGN nTop( xData ) inline ::SetTop( xData ) - ACCESS vScroll inline ::vScrolls - ASSIGN vScroll( xData ) inline ::SetScroll( xData ) - ACCESS nRight inline ::SetRight() - ASSIGN nRight( xData ) inline ::SetRight( xData ) - ACCESS lDropDown inline ::SetDropDown() - ASSIGN lDropDown( xData ) inline ::SetDropDown( xData ) - ACCESS caption inline ::SetCaption() - ASSIGN caption( xData ) inline ::SetCaption( xData ) - ACCESS nBottom inline ::SetBottom() - ASSIGN nBottom( xData ) inline ::SetBottom( xData ) - ACCESS nTopItem inline ::SetTopItem() - ASSIGN nTopItem( xTop ) inline ::SetTopItem( xTop ) - ACCESS TypeOut inline ::itemCount == 0 - ASSIGN TypeOut( x ) inline IIF( x != nil, x, ::itemCount == 0 ) + METHOD New( nTop, nLeft, nBottom, nRight, lDrop ) /* NOTE: This method is a Harbour extension [vszakats] */ -Hidden: + PROTECTED: - Method SetScroll( xData ) - Data xTop Init 0 - Method SetTop( xData ) - Data xRight Init 0 - Method SetRight( xData ) - Data xDropDown Init .f. - Method SetDropDown( xData ) - Data cCaption Init '' - Method SetCaption( xData ) - Data xBottom Init 0 - Method SetBottom( xData ) - Data nCursor Init 0 - Data xtopItem Init 0 - Method SetTopItem( xTop ) - Data cSaveScreen Init NIL - Data nSaveTop, nSaveLeft, nSaveBottom, nSaveRight + VAR cBitmap INIT "dropbox.bmu" + VAR nBottom + VAR xBuffer + VAR nCapCol + VAR nCapRow + VAR cCaption INIT "" + VAR cColdBox INIT Chr( 218 ) + Chr( 196 ) + Chr( 191 ) + Chr( 179 ) + Chr( 217 ) + Chr( 196 ) + Chr( 192 ) + Chr( 179 ) + VAR cColorSpec + VAR lDropDown + VAR bFBlock + VAR lHasFocus INIT .F. + VAR cHotBox INIT Chr( 201 ) + Chr( 205 ) + Chr( 187 ) + Chr( 186 ) + Chr( 188 ) + Chr( 205 ) + Chr( 200 ) + Chr( 186 ) + VAR lIsOpen + VAR nItemCount INIT 0 + VAR nLeft + VAR cMessage INIT "" + VAR nRight + VAR bSBlock + VAR cStyle INIT Chr( 31 ) + VAR cTextValue INIT "" + VAR nTop + VAR nTopItem INIT 0 + VAR nValue INIT 0 + VAR oVScroll + + VAR aItems INIT {} + VAR aSaveScr + VAR nCursor + + METHOD changeItem( nOldPos, nNewPos ) + METHOD scrollbarPos() ENDCLASS -Method New( nTop, nLeft, nBottom, nRight, lDrop ) +METHOD addItem( cText, cData ) CLASS LISTBOX - Local cColor + IF ISCHARACTER( cText ) .AND. Valtype( cData ) $ "CU" - ::ClassName := 'LISTBOX' - ::Bottom := nBottom - ::nBottom := nBottom - ::right := nRight - ::nright := nRight - ::Top := nTop - ::ntop := nTop - ::left := nleft - ::Buffer := Nil - ::Caption := "" - ::CapCol := nleft - ::CapRow := nTop - ::Cargo := Nil - ::ColdBox := B_SINGLE + AAdd( ::aItems, { cText, cData } ) - IF Isdefcolor() - ::Colorspec := "W/N,W+/N,W+/N,N/W,W/N,W/N,W+/N,W/N" + ::nItemCount++ + + IF ::nItemCount == 1 + ::nTopItem := 1 + IF ::oVScroll != NIL + ::oVScroll:total := ( ::nItemCount - ( ::nBottom - ::nTop - 2 ) ) + ENDIF + ENDIF + ENDIF + + RETURN Self + +METHOD close() CLASS LISTBOX + + IF ::lIsOpen + RestScreen( ::aSaveScr[ 1 ], ::aSaveScr[ 2 ], ::aSaveScr[ 3 ], ::aSaveScr[ 4 ], ::aSaveScr[ 5 ] ) + ::lIsOpen := .F. + ::aSaveScr := NIL + ENDIF + + RETURN Self + +METHOD delItem( nPos ) + + IF nPos >= 1 .AND. nPos <= ::nItemCount + + ADel( ::aItems, nPos ) + ASize( ::aItems, --::nItemCount ) + + IF ::nValue > ::nItemCount + ::nValue := ::nItemCount + + ::cTextValue := iif( ::nValue == 0, "", _LISTBOX_ITEMDATA( ::aItems[ ::nItemCount ] ) ) + + IF ::xBuffer == NIL + ELSEIF ISNUMBER( ::xBuffer ) + ::xBuffer := ::nItemCount + ELSEIF ::nValue > 0 + ::xBuffer := ::cTextValue + ENDIF + + ENDIF + + IF ::nTopItem > ::nItemCount + ::nTopItem := ::nItemCount + ENDIF + + IF ::oVScroll != NIL + ::oVScroll:total := ::nItemCount - ( ::nBottom - ::nTop - 2 ) + ENDIF + ENDIF + + RETURN Self + +METHOD display() CLASS LISTBOX + + LOCAL cOldColor := SetColor() + LOCAL nOldRow := Row() + LOCAL nOldCol := Col() + LOCAL lOldMCur := MSetCursor( .F. ) + + LOCAL nItem + LOCAL nEnd + LOCAL cColor4 + LOCAL cColor3 + LOCAL cColorAny + LOCAL nTop := ::nTop + LOCAL nLeft := ::nLeft + LOCAL nSize + LOCAL cHotBox + LOCAL cCaption + LOCAL nPos + + nSize := ::nRight - nLeft + 1 + + IF ::lHasFocus + cHotBox := ::cHotBox + cColor3 := __GUIColor( ::cColorSpec, 3 ) + cColor4 := __GUIColor( ::cColorSpec, 4 ) + cColorAny := iif( ::lIsOpen, __GUIColor( ::cColorSpec, 2 ), __GUIColor( ::cColorSpec, 4 ) ) ELSE - cColor := Setcolor() - ::Colorspec := __guiColor( cColor, 5 ) +","+; - __guiColor( cColor, 5 ) +","+; - __guiColor( cColor, 5 ) +","+; - __guiColor( cColor, 2 ) +","+; - __guiColor( cColor, 3 ) +","+; - __guiColor( cColor, 1 ) +","+; - __guiColor( cColor, 4 ) + cHotBox := ::cColdBox + cColor3 := __GUIColor( ::cColorSpec, 1 ) + cColor4 := __GUIColor( ::cColorSpec, 2 ) + cColorAny := __GUIColor( ::cColorSpec, 2 ) ENDIF - ::isopen := !lDrop - ::aItems := {} - ::dropdown := lDrop - ::ldropdown := lDrop - ::fBlock := Nil - ::hasfocus := .F. + DispBegin() - ::hotbox := B_DOUBLE - ::itemCount := 0 + nEnd := ::nTopItem + ::nBottom - ::nTop - ::message := "" + IF ::lDropDown - ::nSaveTop := nTop + 1 - ::nSaveLeft := nLeft - ::nSaveBottom := nBottom - ::nSaveRight := nRight - ::cSaveScreen := Savescreen( nTop + 1, nleft, nBottom, nRight ) + DispOutAt( nTop++, nLeft,; + iif( ::nValue == 0, Space( nSize - 1 ), PadR( ::aItems[ ::nValue ][ _ITEM_cTEXT ], nSize - 1 ) ),; + cColorAny ) - ::sBlock := Nil - ::nCursor := Nil - ::Style := Chr( 240 ) - ::TextValue := "" + DispOut( ::cStyle, __GUIColor( ::cColorSpec, 8 ) ) - ::Topitem := 0 - ::nTopItem := 0 - ::vScroll := Nil - ::Value := 0 - -RETURN SELF - -/**** Get/Set Datas ****/ - -Method SetScroll( xData ) Class ListBox - - IF ISOBJECT( xData ) /*.and. xData:Classname=="SCROLLBAR" .and. xData:orient==1)*/ - ::vScrolls := xData - xData:total := ::iTemCount + nEnd-- ENDIF -RETURN ::vScrolls - -Method SetTop( xData ) Class ListBox - - IF ISNUMBER( ::xTop := xData ) .and. ISOBJECT( ::vScroll ) - ::vScroll:start := xData + 1 - ENDIF - -RETURN ::xTop - -Method SetRight( xData ) Class ListBox - - IF !( ISNIL( xData ) ) .and. ISOBJECT( ( ::xRight := xData, ::vScroll ) ) - ::vScroll:offset := xData - ENDIF - -RETURN ::xRight - -Method SetDropDown( xData ) Class ListBox - - IF ISLOGICAL( xData ) - ::xDropDown := xData - - IF xData - ELSEIF !::isOpen - ::isOpen := .T. - ENDIF - - ENDIF - -RETURN ::xDropDown - -Method SetCaption( xData ) Class ListBox - - IF ISCHARACTER( xData ) .and. ISNIL( ::Capcol ) - ::cCaption := xData - ::Caprow := ::top - ::Capcol := ::left - Len( xData ) - ENDIF - -RETURN ::cCaption - -Method SetBottom( xData ) Class ListBox - - Local nBottom - - IF ISNUMBER( ::xBottom := xData ) .and. ISOBJECT( ::vScroll ) - nBottom := ::xBottom - ::vScroll:end := xData - 1 - ENDIF - -RETURN ::xBottom - -/*** Class Methods ***/ - -Method ADDITEM( cText, xValue ) Class ListBox - - IF ! ISCHARACTER( cText ) - ELSEIF Valtype( xValue ) $ "CUN" - Aadd( ::aItems, { cText, xValue } ) - ::iTemCount++ - - IF ::iTemCount == 1 .and. ; - ISOBJECT( ( ::Topitem := 1, ::nTopItem := 1, ::vScroll ) ) - ::vScroll:total := ( ::iTemCount - ( ::bottom - ::top - 2 ) ) - ENDIF - - ENDIF - -RETURN SELF - -Method Close() Class ListBox - - IF ::isOpen - - Restscreen( ::nSaveTop, ; - ::nSaveLeft, ; - ::nSaveBottom, ; - ::nSaveRight, ::cSaveScreen ) - ::isOpen := .F. - ::cSaveScreen := Nil - - ENDIF - -RETURN SELF - -Method DELITEM( xitem ) - - IF xitem < 1 - ELSEIF xitem <= ::iTemCount - Adel( ::aItems[ xitem ] ) - Asize( ::aItems, -- ::iTemCount ) - - IF ::Value > ::iTemCount - - ::Value := ::iTemCount - IF ::Value == 0 - ::TextValue := "" - ELSE - ::TextValue := _Getdata( ::aItems[ ::iTemCount ] ) - ENDIF - - IF ISNIL( ::Buffer ) - ELSEIF ISNUMBER( ::Buffer ) - ::Buffer := ::iTemCount - ELSEIF ::Value > 0 - ::Buffer := ::TextValue - ENDIF - - ENDIF - - IF ::Topitem > ::iTemCount - ::Topitem := ::iTemCount - ::nTopitem := ::iTemCount - ENDIF - - IF ISOBJECT( ::vScroll ) - ::vScroll:total := ::iTemCount - ( ::Bottom - ::top - 2 ) - ENDIF - - ENDIF - -RETURN SELF - -Method Getdata( xData ) Class ListBox - - Local xRet := Nil - - IF xData < 1 - ELSEIF xData <= ::itemCount - xRet := ::aitems[ xData, 2 ] - ENDIF - -RETURN xRet - -Method FindData( cText, nPos, lCaseSensitive, lExact ) Class ListBox - - Local nPosFound - Local lOldExact - Local nStart - Local nEnd - Local nSize - - IF ISLOGICAL( lExact ) - lOldExact := Set( _SET_EXACT, lExact ) - ENDIF - - nEnd := 1 - - IF ISNUMBER( nPos ) - nEnd ++ - ELSE - nPos := 1 - ENDIF - - nSize := Len( ::aitems ) - nPos + 1 - - IF ! ISLOGICAL( lCaseSensitive ) - lCaseSensitive := .T. - ENDIF - - FOR nStart := 1 TO nEnd - - IF lCaseSensitive - - IF Set( _SET_EXACT ) - nPosFound := Ascan( ::aitems, ; - { | _1 | _Getdata( _1 ) == cText }, nPos, nSize ) - ELSE - nPosFound := Ascan( ::aitems, ; - { | _1 | _Getdata( _1 ) = cText }, nPos, nSize ) - ENDIF - - ELSEIF Set( _SET_EXACT ) - nPosFound := Ascan( ::aitems, ; - { | _1 | Lower( _Getdata( _1 ) ) == Lower( cText ) }, ; - nPos, nSize ) - ELSE - nPosFound := Ascan( ::aitems, ; - { | _1 | Lower( _Getdata( _1 ) ) = Lower( cText ) }, ; - nPos, nSize ) - ENDIF - - IF nPosFound > 0 - EXIT - ENDIF - - nSize := nPos - 1 - nPos := 1 - NEXT - - IF ! ISNIL( lOldExact ) - Set Exact ( lOldExact ) - ENDIF - -RETURN nPosFound - -Method FindText( cText, nPos, lCaseSensitive, lExact ) Class ListBox - - Local nPosFound - Local lOldExact - Local nStart - Local nEnd - Local nSize - - IF ISLOGICAL( lExact ) - lOldExact := Set( _SET_EXACT, lExact ) - ENDIF - - nEnd := 1 - - IF ISNUMBER( nPos ) - nEnd ++ - ELSE - nPos := 1 - ENDIF - - nSize := Len( ::aitems ) - nPos + 1 - - IF ! ISLOGICAL( lCaseSensitive ) - lCaseSensitive := .T. - ENDIF - - FOR nStart := 1 TO nEnd - IF lCaseSensitive - - IF Set( _SET_EXACT ) - nPosFound := Ascan( ::aitems, ; - { | _1 | _1[ 1 ] == cText }, nPos, nSize ) - - ELSE - nPosFound := Ascan( ::aitems, ; - { | _1 | _1[ 1 ] = cText }, nPos, nSize ) - ENDIF - - ELSEIF Set( _SET_EXACT ) - nPosFound := Ascan( ::aitems, ; - { | _1 | Lower( _1[ 1 ] ) == Lower( cText ) }, ; - nPos, nSize ) - ELSE - nPosFound := Ascan( ::aitems, ; - { | _1 | Lower( _1[ 1 ] ) = Lower( cText ) }, ; - nPos, nSize ) - ENDIF - - IF nPosFound > 0 - EXIT - ENDIF - - nSize := nPos - 1 - nPos := 1 - NEXT - - IF ! ISNIL( lOldExact ) - Set Exact ( lOldExact ) - ENDIF - -RETURN nPosFound - -Method NEXTITEM() Class ListBox - - Local nCurValue - Local nValue - - IF ! ::hasfocus - ELSEIF ::itemCount > 0 - - IF ( nCurValue := ::value ) == ::itemCount - nValue := nCurValue - ELSE - nValue := nCurValue + 1 - ENDIF - - changeitem( SELF, nCurValue, nValue ) - - ENDIF - -RETURN SELF - -Method PREVITEM() Class ListBox - - Local nCurValue - Local nValue - - IF ! ::hasfocus - ELSEIF ::itemCount > 0 - - IF ( nCurValue := ::value ) == 0 - nValue := 1 - ELSEIF nCurValue == 1 - nValue := nCurValue - ELSE - nValue := nCurValue - 1 - ENDIF - - changeitem( SELF, nCurValue, nValue ) - - ENDIF - -RETURN SELF - -Method _SCROLL( nMethod ) Class ListBox - - Local nPos - Local nTopItem - Local nCount - Local nThumbPos - Local nCurrent - Local nBarLength - Local nTotal - Local nSize - Local nMouRow - Local nMouseRow - Local nKey - Local nStart - - Switch nMethod - CASE HTSCROLLTHUMBDRAG - nMouseRow := MRow() - Do While ( ( nKey := Inkey( 0 ) ) != K_LBUTTONUP ) - IF nKey == K_MOUSEMOVE - nMouRow := MRow() - IF nMouRow <=::vScroll:start() - nMouRow :=::vScroll:start() + 1 - ENDIF - IF nMouRow >=::vScroll:end() - nMouRow :=::vScroll:end() - 1 - ENDIF - IF nMouRow != nMouseRow - nThumbPos := ::vScroll:thumbpos() + ( nMouRow - nMouseRow ) - nBarLength := ::vScroll:barlength() - nTotal := ::vScroll:total() - nSize := ( nThumbPos * ( nTotal - nBarLength - 2 ) + 2 * ; - nBarLength + 1 - nTotal ) / ( nBarLength - 1 ) - IF nSize < 1 - nSize := 1 - ENDIF - IF nSize > nTotal - nSize := nTotal - ENDIF - nCurrent :=::vScroll:current() - IF nSize - nCurrent > 0 - FOR nStart := 1 TO nSize - nCurrent - SELF:scroll( HTSCROLLUNITINC ) - NEXT - ELSE - FOR nStart := 1 TO nCurrent - nSize - SELF:scroll( HTSCROLLUNITDEC ) - NEXT - ENDIF - nMouseRow := nMouRow - ENDIF - ENDIF - Enddo - EXIT - - CASE HTSCROLLUNITDEC - IF ::topitem > 1 - ::topitem -- - ::vScroll:current := SetColumn( SELF ) - SELF:display() - ENDIF - EXIT - - CASE HTSCROLLUNITINC - IF ( ::topitem + ::bottom - ::top ) <= ::itemCount + 1 - ::topitem ++ - ::vScroll:current( SetColumn( SELF ) ) - SELF:display() - ENDIF - EXIT - - CASE HTSCROLLBLOCKDEC - nPos := ::bottom - ::top - IIF( ::bitmap, 2, 1 ) - nCount := ::itemCount - nTopItem := ::topitem - nPos - IF ::topitem > 1 - IF nTopItem < 1 - nTopItem := 1 - ENDIF - ::topitem := nTopItem - ::ntopitem := nTopItem - ::vScroll:current( SetColumn( SELF ) ) - SELF:display() - ENDIF - EXIT - - CASE HTSCROLLBLOCKINC - nPos := ::bottom - ::top - 1 - nCount := ::itemCount - nTopItem := ::topitem + nPos - IF ::topitem < nCount - nPos + 1 - IF nTopItem + nPos - 1 > nCount - nTopItem := nCount - nPos + 1 - ENDIF - ::topitem := nTopItem - ::ntopitem := nTopItem - ::vScroll:current( SetColumn( SELF ) ) - SELF:display() - ENDIF - EXIT - - End -RETURN SELF - -Method SELECTS( nPosition ) Class ListBox - - Local nValue - Local nPos - Local xType := Valtype( nPosition ) - - Do CASE - CASE xType == "C" - nPos := SELF:finddata( nPosition ) - IF !( Valtype( ::buffer ) $ "CU" ) - ::buffer := nPos - ELSEIF ::value == 0 - ::buffer := nPosition - ELSE - ::buffer := _Getdata( ::aitems[ nPos ] ) - ENDIF - CASE !( xType == "N" ) - RETURN ::value - CASE nPosition < 1 - RETURN ::value - CASE nPosition > ::itemCount - RETURN ::value - CASE nPosition == ::value - RETURN ::value - Otherwise - nPos := nPosition - IF Valtype( ::buffer ) $ "NU" - ::buffer := nPos - ELSEIF nPos == 0 - ::buffer := "" - ELSE - ::buffer := _Getdata( ::aitems[ nPos ] ) - ENDIF - ENDCASE - ::value := nPos - - IF nPos == 0 - ::textvalue := "" - ELSE - ::textvalue := _Getdata( ::aitems[ nPos ] ) - ENDIF - - IF Empty( ::hotbox + ::coldbox ) - nPos := 0 - ELSE - nPos := 2 - ENDIF - - nValue := ::value - ( ::bottom - ::top - nPos ) - IF ::topitem <= nValue - ::topitem := nValue - ::ntopitem := nValue - IF ISOBJECT( ::vScroll ) - ::vScroll:current := SetColumn( SELF ) - ENDIF - ELSEIF ::value == 0 - ELSEIF ::topitem > ::value .and. ISOBJECT( ( ; - ::topitem := ::value, ::ntopitem := ::value, ::vScroll ) ) - ::vScroll:current := SetColumn( SELF ) - ENDIF - SELF:display() - IF ISBLOCK( ::sBlock ) - Eval( ::sBlock ) - ENDIF - -RETURN ::value - -Method SetTOPITEM( xData ) Class ListBox - - Local nSize - Local nPos - IF ! ISNIL( xData ) .and. xData > 0 .and. xData <= ::itemCount - - IF Empty( ::hotbox + ::coldbox ) - nPos := 0 - ELSE - nPos := 2 - ENDIF - nSize := ::itemCount - ( ::bottom - ::top - nPos ) - IF xData > nSize - xData := nSize - ENDIF - IF ::topitem != xData - ::xtopitem := xData - IF ISOBJECT( ::vScroll ) - ::vScroll:current := SetColumn( SELF ) - ENDIF - SELF:display() - ENDIF - ENDIF -RETURN ::xtopitem - -Method Display() Class ListBox - - Local nCurRow := Row() - Local nCurCol := Col() - Local cCurrentColor := Setcolor() - Local nStart - Local nEnd - Local cColor3 - Local cColor4 - Local cColorAny - Local nTop := ::top - Local nLeft := ::left - Local nSize - Local cHotBox - Local cCaption - Local nAmpPos - nSize := ::right - nLeft + 1 - - IF ::hasfocus - cHotBox := ::hotbox - cColor3 := __guicolor( ::colorspec, 3 ) - cColor4 := __guicolor( ::colorspec, 4 ) - - IF ::isopen - cColorAny := __guicolor( ::colorspec, 2 ) - ELSE - cColorAny := __guicolor( ::colorspec, 4 ) - ENDIF - - ELSE - cHotBox := ::coldbox - cColor3 := __guicolor( ::colorspec, 1 ) - cColor4 := __guicolor( ::colorspec, 2 ) - cColorAny := __guicolor( ::colorspec, 2 ) - - ENDIF - - Dispbegin() - nEnd := ::topitem + ::bottom - ::top - - IF ::dropdown - SET COLOR TO (cColorAny) - Setpos( nTop ++, nLeft ) - - IF ::value == 0 - ?? Space( nSize - 1 ) - ELSE - ?? Padr( ::aitems[ ::value, 1 ], nSize - 1 ) - ENDIF - - SET COLOR TO (__guicolor(::colorspec, 8)) - ?? Left( ::style, 1 ) - nEnd -- - - ENDIF - - IF ::isopen + IF ::lIsOpen IF !Empty( cHotBox ) - SET COLOR TO (__guicolor(::colorspec, 5)) - @ nTop, nLeft clear TO ::bottom, ::right - @ nTop, nLeft, ::bottom, ::right Box cHotBox + SetColor( __GUIColor( ::cColorSpec, 5 ) ) + Scroll( nTop, nLeft, ::nBottom, ::nRight ) + DispBox( nTop, nLeft, ::nBottom, ::nRight, cHotBox ) - IF ISOBJECT( ::vScroll ) - ::vScroll:display() + IF ::oVScroll != NIL + ::oVScroll:display() ENDIF - nTop ++ - nLeft ++ + nTop++ + nLeft++ nSize -= 2 - nEnd -= 2 + nEnd -= 2 ENDIF - IF nEnd > ::itemCount - nEnd := ::itemCount + IF nEnd > ::nItemCount + nEnd := ::nItemCount ENDIF - FOR nStart := ::topitem TO nEnd - - IF nStart == ::value - SET COLOR TO (cColor4) - ELSE - SET COLOR TO (cColor3) - ENDIF - - Setpos( nTop ++, nLeft ) - ?? Padr( ::aitems[ nStart, 1 ], nSize ) - + FOR nItem := ::nTopItem TO nEnd + DispOutAt( nTop++, nLeft, PadR( ::aItems[ nItem ][ _ITEM_cTEXT ], nSize ), iif( nItem == ::nValue, cColor4, cColor3 ) ) NEXT - ENDIF - IF !Empty( cCaption := ::caption ) + IF !Empty( cCaption := ::cCaption ) - IF ( nAmpPos := At( "&", cCaption ) ) == 0 - ELSEIF nAmpPos == Len( cCaption ) - nAmpPos := 0 + IF ( nPos := At( "&", cCaption ) ) == 0 + ELSEIF nPos == Len( cCaption ) + nPos := 0 ELSE - cCaption := Stuff( cCaption, nAmpPos, 1, "" ) + cCaption := Stuff( cCaption, nPos, 1, "" ) ENDIF - SET COLOR TO (__guicolor(::colorspec, 6)) - Setpos( ::caprow, ::capcol - 1 ) - ?? cCaption + DispOutAt( ::nCapRow, ::nCapCol - 1, cCaption, __GUIColor( ::cColorSpec, 6 ) ) - IF nAmpPos != 0 - SET COLOR TO (__guicolor(::colorspec, 7)) - Setpos( ::caprow, ::capcol + nAmpPos - 2 ) - ?? Substr( cCaption, nAmpPos, 1 ) + IF nPos != 0 + DispOutAt( ::nCapRow, ::nCapCol + nPos - 2, SubStr( cCaption, nPos, 1 ), __GUIColor( ::cColorSpec, 7 ) ) ENDIF ENDIF - Dispend() + DispEnd() - SET COLOR TO (cCurrentColor) - Setpos( nCurRow, nCurCol ) + MSetCursor( lOldMCur ) + SetColor( cOldColor ) + SetPos( nOldRow, nOldCol ) -RETURN SELF + RETURN Self -Method GetItem( xItem ) Class ListBox +METHOD findText( cText, nPos, lCaseSensitive, lExact ) CLASS LISTBOX - Local xRet := Nil + LOCAL nPosFound + LOCAL nPass + LOCAL nPasses + LOCAL nSize + LOCAL lOldExact - IF xItem < 1 - ELSEIF xItem <= ::itemCount - xRet := ::aitems[ xItem ] + IF !ISCHARACTER( cText ) + RETURN 0 + ENDIF + IF !ISNUMBER( nPos ) + nPos := 1 + ENDIF + IF !ISLOGICAL( lCaseSensitive ) + lCaseSensitive := .T. + ENDIF + IF !lCaseSensitive + cText := Lower( cText ) + ENDIF + IF ISLOGICAL( lExact ) + lOldExact := Set( _SET_EXACT, lExact ) ENDIF -RETURN xRet + nSize := Len( ::aItems ) - nPos + 1 + nPasses := iif( nPos > 1, 2, 1 ) -Method GetText( xItem ) Class ListBox + FOR nPass := 1 TO nPasses - Local xRet := Nil - - IF xItem < 1 - ELSEIF xItem <= ::itemCount - xRet := ::aitems[ xItem, 1 ] - ENDIF - -RETURN xRet - -Method InsItem( nPosition, cText, xExp ) - - IF ! ISCHARACTER( cText ) - ELSEIF ! ISNUMBER( nPosition ) - ELSEIF nPosition < ::itemCount - Asize( ::aitems, ++ ::itemCount ) - Ains( ::aitems, nPosition ) - ::aitems[ nPosition ] := { cText, xExp } - - IF ::itemCount == 1 - ::topitem := 1 - ::ntopitem := 1 + /* NOTE: Intentionally using "=" comparison to honor the _SET_EXACT setting. */ + IF ( nPosFound := AScan( ::aItems, iif( lCaseSensitive,; + { | aItem | aItem[ _ITEM_cTEXT ] = cText },; + { | aItem | Lower( aItem[ _ITEM_cTEXT ] ) = cText } ), nPos, nSize ) ) > 0 + EXIT ENDIF - IF ISOBJECT( ::vScroll ) - ::vScroll:total := ::itemCount - ( ::bottom - ::top - 2 ) + nSize := nPos - 1 + nPos := 1 + NEXT + + IF lOldExact != NIL + Set( _SET_EXACT, lOldExact ) + ENDIF + + RETURN nPosFound + +METHOD findData( cData, nPos, lCaseSensitive, lExact ) CLASS LISTBOX + + LOCAL nPosFound + LOCAL nPass + LOCAL nPasses + LOCAL nSize + LOCAL lOldExact + + IF !ISCHARACTER( cData ) + RETURN 0 + ENDIF + IF !ISNUMBER( nPos ) + nPos := 1 + ENDIF + IF !ISLOGICAL( lCaseSensitive ) + lCaseSensitive := .T. + ENDIF + IF !lCaseSensitive + cData := Lower( cData ) + ENDIF + IF ISLOGICAL( lExact ) + lOldExact := Set( _SET_EXACT, lExact ) + ENDIF + + nSize := Len( ::aItems ) - nPos + 1 + nPasses := iif( nPos > 1, 2, 1 ) + + FOR nPass := 1 TO nPasses + + /* NOTE: Intentionally using "=" comparison to honor the _SET_EXACT setting. */ + IF ( nPosFound := AScan( ::aItems, iif( lCaseSensitive,; + { | aItem | _LISTBOX_ITEMDATA( aItem ) = cData },; + { | aItem | Lower( _LISTBOX_ITEMDATA( aItem ) ) = cData } ), nPos, nSize ) ) > 0 + EXIT ENDIF + nSize := nPos - 1 + nPos := 1 + NEXT + + IF lOldExact != NIL + Set( _SET_EXACT, lOldExact ) ENDIF -RETURN SELF -Method HitTest( nMouseRow, nMouseCol ) Class ListBox + RETURN nPosFound - Local nRet, nTop - Local nHit := 0 +METHOD getData( nPos ) CLASS LISTBOX + RETURN iif( nPos >= 1 .AND. nPos <= ::nItemCount, ::aItems[ nPos ][ _ITEM_cDATA ], NIL ) + +METHOD getItem( nPos ) CLASS LISTBOX + RETURN iif( nPos >= 1 .AND. nPos <= ::nItemCount, ::aItems[ nPos ], NIL ) + +METHOD getText( nPos ) CLASS LISTBOX + RETURN iif( nPos >= 1 .AND. nPos <= ::nItemCount, ::aItems[ nPos ][ _ITEM_cTEXT ], NIL ) + +METHOD hitTest( nMouseRow, nMouseCol ) CLASS LISTBOX + + LOCAL nRet + LOCAL nTop + LOCAL nHit := 0 + + /* Check hit on the scrollbar */ + IF ::lIsOpen .AND. ; + ::oVScroll != NIL .AND. ; + ( nHit := ::oVScroll:hittest( nMouseRow, nMouseCol ) ) != 0 - IF ::isopen .AND. ISOBJECT( ::vScroll ) .AND. ; - ( nHit := ::vScroll:hittest( nMouseRow, nMouseCol ) ) != 0 RETURN nHit ENDIF - IF ! ::isopen .or. Empty( ::hotbox + ::coldbox ) + IF ! ::lIsOpen .OR. Empty( ::cHotBox + ::cColdBox ) nRet := 0 ELSE - nTop := ::top - IF ::DropDown - nTop ++ + nTop := ::nTop + IF ::lDropDown + nTop++ ENDIF - Do CASE - CASE nMouseRow == nTop - IF nMouseCol == ::left - RETURN HTTOPLEFT - ELSEIF nMouseCol == ::right - RETURN HTTOPRIGHT - ELSEIF nMouseCol >= ::left .and. nMouseCol <= ::right - RETURN HTTOP - ENDIF - CASE nMouseRow == ::bottom - IF nMouseCol == ::left - RETURN HTBOTTOMLEFT - ELSEIF nMouseCol == ::right - RETURN HTBOTTOMRIGHT - ELSEIF nMouseCol >= ::left .and. nMouseCol <= ::right - RETURN HTBOTTOM - ENDIF - CASE nMouseCol == ::left - IF nMouseRow >= ::top .and. nMouseRow <= ::bottom - RETURN HTLEFT - ELSE - RETURN HTNOWHERE - ENDIF - CASE nMouseCol == ::right - IF nMouseRow >= ::top .and. nMouseRow <= ::bottom - RETURN HTRIGHT - ELSE - RETURN HTNOWHERE - ENDIF + DO CASE + CASE nMouseRow == nTop + IF nMouseCol == ::nLeft + RETURN HTTOPLEFT + ELSEIF nMouseCol == ::nRight + RETURN HTTOPRIGHT + ELSEIF nMouseCol >= ::nLeft .AND. nMouseCol <= ::nRight + RETURN HTTOP + ENDIF + CASE nMouseRow == ::nBottom + IF nMouseCol == ::nLeft + RETURN HTBOTTOMLEFT + ELSEIF nMouseCol == ::nRight + RETURN HTBOTTOMRIGHT + ELSEIF nMouseCol >= ::nLeft .AND. nMouseCol <= ::nRight + RETURN HTBOTTOM + ENDIF + CASE nMouseCol == ::nLeft + IF nMouseRow >= ::nTop .AND. nMouseRow <= ::nBottom + RETURN HTLEFT + ELSE + RETURN HTNOWHERE + ENDIF + CASE nMouseCol == ::nRight + IF nMouseRow >= ::nTop .AND. nMouseRow <= ::nBottom + RETURN HTRIGHT + ELSE + RETURN HTNOWHERE + ENDIF ENDCASE nRet := 1 ENDIF - Do CASE - CASE ! ::isopen - CASE nMouseRow < nTop + nRet - CASE nMouseRow > ::bottom - nRet - CASE nMouseCol < ::left + nRet - CASE nMouseCol <= ::right - nRet - RETURN ::topitem + nMouseRow - ( nTop + nRet ) + DO CASE + CASE ! ::lIsOpen + CASE nMouseRow < nTop + nRet + CASE nMouseRow > ::nBottom - nRet + CASE nMouseCol < ::nLeft + nRet + CASE nMouseCol <= ::nRight - nRet + RETURN ::nTopItem + nMouseRow - ( nTop + nRet ) ENDCASE - Do CASE - CASE ! ::dropdown - CASE nMouseRow != ::top - CASE nMouseCol < ::left - CASE nMouseCol < ::right - RETURN HTCLIENT - CASE nMouseCol == ::right - RETURN HTDROPBUTTON + DO CASE + CASE ! ::lDropDown + CASE nMouseRow != ::nTop + CASE nMouseCol < ::nLeft + CASE nMouseCol < ::nRight + RETURN HTCLIENT + CASE nMouseCol == ::nRight + RETURN HTDROPBUTTON ENDCASE - Do CASE - CASE Empty( ::caption ) - CASE nMouseRow != ::caprow - CASE nMouseCol < ::capcol - CASE nMouseCol < ::capcol + __CapLength( ::caption ) - RETURN HTCAPTION + DO CASE + CASE Empty( ::cCaption ) + CASE nMouseRow != ::nCapRow + CASE nMouseCol < ::nCapCol + CASE nMouseCol < ::nCapCol + __CapLength( ::cCaption ) + RETURN HTCAPTION ENDCASE -RETURN 0 + RETURN 0 -Method KillFocus() Class ListBox +METHOD insItem( nPos, cText, cData ) - IF ::hasfocus - ::hasfocus := .F. + IF ISCHARACTER( cText ) .AND. ; + ISNUMBER( nPos ) .AND. ; + nPos < ::nItemCount - IF ISBLOCK( ::fblock ) - Eval( ::fblock ) + ASize( ::aItems, ++::nItemCount ) + AIns( ::aItems, nPos ) + ::aItems[ nPos ] := { cText, cData } + + IF ::nItemCount == 1 + ::nTopItem := 1 ENDIF - Dispbegin() + IF ::oVScroll != NIL + ::oVScroll:total := ::nItemCount - ( ::nBottom - ::nTop - 2 ) + ENDIF + ENDIF - IF ::dropdown .and. ::isopen + RETURN Self + +METHOD killFocus() CLASS LISTBOX + LOCAL nCurMCur + + IF ::lHasFocus + ::lHasFocus := .F. + + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) + ENDIF + + nCurMCur := MSetCursor( .F. ) + DispBegin() + + IF ::lDropDown .AND. ::lIsOpen ::close() ENDIF + ::display() + + DispEnd() + MSetCursor( nCurMCur ) + + SetCursor( ::nCursor ) + ENDIF + + RETURN Self + +METHOD nextItem() CLASS LISTBOX + + LOCAL nOldValue + + IF ::lHasFocus .AND. ::nItemCount > 0 + ::changeItem( nOldValue := ::nValue, iif( nOldValue == ::nItemCount, nOldValue, nOldValue + 1 ) ) + ENDIF + + RETURN Self + +METHOD open() CLASS LISTBOX + + IF ! ::lIsOpen + + ::aSaveScr := { ::nTop + 1,; + ::nLeft,; + ::nBottom,; + ::nRight,; + Savescreen( ::nTop + 1, ::nLeft, ::nBottom, ::nRight ) } + ::lIsOpen := .T. + ::display() + ENDIF + + RETURN Self + +METHOD prevItem() CLASS LISTBOX + + LOCAL nOldValue + + IF ::lHasFocus .AND. ::nItemCount > 0 + + IF ( nOldValue := ::nValue ) == 0 + ::changeItem( nOldValue, 1 ) + ELSEIF nOldValue > 1 + ::changeItem( nOldValue, nOldValue - 1 ) + ENDIF + ENDIF + + RETURN Self + +METHOD scroll( nMethod ) CLASS LISTBOX + + LOCAL nPos + LOCAL nTopItem + LOCAL nItemCount + LOCAL nThumbPos + LOCAL nCurrent + LOCAL nBarLength + LOCAL nTotal + LOCAL nSize + LOCAL nMRow + LOCAL nPrevMRow + LOCAL nKey + LOCAL nCount + + DO CASE + CASE nMethod == HTSCROLLTHUMBDRAG + + nPrevMRow := MRow() + + DO WHILE ( ( nKey := Inkey( 0 ) ) != K_LBUTTONUP ) + + IF nKey == K_MOUSEMOVE + + nMRow := MRow() + + IF nMRow <= ::oVScroll:start() + nMRow := ::oVScroll:start() + 1 + ENDIF + IF nMRow >= ::oVScroll:end() + nMRow := ::oVScroll:end() - 1 + ENDIF + + IF nMRow != nPrevMRow + nThumbPos := ::oVScroll:thumbPos() + ( nMRow - nPrevMRow ) + nBarLength := ::oVScroll:barLength() + nTotal := ::oVScroll:total() + nSize := Min( Max( ( nThumbPos * ( nTotal - nBarLength - 2 ) + 2 * nBarLength + 1 - nTotal ) / ( nBarLength - 1 ), 1 ), nTotal ) + nCurrent := ::oVScroll:current() + IF nSize - nCurrent > 0 + FOR nCount := 1 TO nSize - nCurrent + ::scroll( HTSCROLLUNITINC ) + NEXT + ELSE + FOR nCount := 1 TO nCurrent - nSize + ::scroll( HTSCROLLUNITDEC ) + NEXT + ENDIF + + nPrevMRow := nMRow + ENDIF + ENDIF + ENDDO + + CASE nMethod == HTSCROLLUNITDEC + + IF ::nTopItem > 1 + ::nTopItem-- + ::oVScroll:current := ::scrollbarPos() + ::display() + ENDIF + + CASE nMethod == HTSCROLLUNITINC + + IF ( ::nTopItem + ::nBottom - ::nTop ) <= ::nItemCount + 1 + ::nTopItem++ + ::oVScroll:current := ::scrollbarPos() + ::display() + ENDIF + + CASE nMethod == HTSCROLLBLOCKDEC + + nPos := ::nBottom - ::nTop - iif( ::lDropDown, 2, 1 ) + nTopItem := ::nTopItem - nPos + IF ::nTopItem > 1 + ::nTopItem := Max( nTopItem, 1 ) + ::oVScroll:current := ::scrollbarPos() + ::display() + ENDIF + + CASE nMethod == HTSCROLLBLOCKINC + + nPos := ::nBottom - ::nTop - 1 + nItemCount := ::nItemCount + nTopItem := ::nTopItem + nPos + IF ::nTopItem < nItemCount - nPos + 1 + IF nTopItem + nPos - 1 > nItemCount + nTopItem := nItemCount - nPos + 1 + ENDIF + ::nTopItem := nTopItem + ::oVScroll:current := ::scrollbarPos() + ::display() + ENDIF + + ENDCASE + + RETURN Self + +METHOD select( xPos ) CLASS LISTBOX + + LOCAL nValue + LOCAL nPos + LOCAL cType := Valtype( xPos ) + + DO CASE + CASE cType == "C" + nPos := ::findData( xPos ) + IF !( Valtype( ::xBuffer ) $ "CU" ) + ::xBuffer := nPos + ELSEIF ::nValue == 0 + ::xBuffer := xPos + ELSE + ::xBuffer := _LISTBOX_ITEMDATA( ::aItems[ nPos ] ) + ENDIF + CASE !( cType == "N" ) + RETURN ::nValue + CASE xPos < 1 + RETURN ::nValue + CASE xPos > ::nItemCount + RETURN ::nValue + CASE xPos == ::nValue + RETURN ::nValue + Otherwise + nPos := xPos + IF Valtype( ::xBuffer ) $ "NU" + ::xBuffer := nPos + ELSEIF nPos == 0 + ::xBuffer := "" + ELSE + ::xBuffer := _LISTBOX_ITEMDATA( ::aItems[ nPos ] ) + ENDIF + ENDCASE + ::nValue := nPos + + ::cTextValue := iif( nPos == 0, "", _LISTBOX_ITEMDATA( ::aItems[ nPos ] ) ) + + nPos := iif( Empty( ::cHotBox + ::cColdBox ), 0, 2 ) + + nValue := ::nValue - ( ::nBottom - ::nTop - nPos ) + IF ::nTopItem <= nValue + ::nTopItem := nValue + IF ::oVScroll != NIL + ::oVScroll:current := ::scrollbarPos() + ENDIF + ELSEIF ::nValue != 0 .AND. ::nTopItem > ::nValue + ::nTopItem := ::nValue + IF ::oVScroll != NIL + ::oVScroll:current := ::scrollbarPos() + ENDIF + ENDIF + + ::display() + + IF ISBLOCK( ::bSBlock ) + Eval( ::bSBlock ) + ENDIF + + RETURN ::nValue + +METHOD setData( nPos, cData ) CLASS LISTBOX + + IF nPos >= 1 .AND. nPos <= ::nItemCount + ::aItems[ nPos ][ _ITEM_cDATA ] := cData + ENDIF + + RETURN Self + +METHOD setFocus() CLASS LISTBOX + + IF ! ::lHasFocus + + ::nCursor := SetCursor( SC_NONE ) + ::lHasFocus := .T. + + ::display() + + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) + ENDIF + + ENDIF + + RETURN Self + +METHOD setItem( nPos, aItem ) CLASS LISTBOX + + IF nPos >= 1 .AND. nPos <= ::nItemCount .AND. ; + Len( aItem ) == 2 .AND. ; + ISCHARACTER( aItem[ _ITEM_cTEXT ] ) + + ::aItems[ nPos ] := aItem + ENDIF + + RETURN Self + +METHOD setText( nPos, cText ) CLASS LISTBOX + + IF nPos >= 1 .AND. nPos <= ::nItemCount + ::aItems[ nPos ][ _ITEM_cTEXT ] := cText + ENDIF + + RETURN Self + +/* -------------------------------------------- */ + +METHOD changeItem( nOldPos, nNewPos ) CLASS LISTBOX + + LOCAL nValue + + IF nOldPos != nNewPos + + ::nValue := nNewPos + ::cTextValue := iif( ::nValue == 0, "", _LISTBOX_ITEMDATA( ::aItems[ ::nValue ] ) ) + + IF ::xBuffer == NIL + ELSEIF ISNUMBER( ::xBuffer ) + ::xBuffer := ::nValue + ELSEIF ::nValue > 0 + ::xBuffer := ::cTextValue + ENDIF + + IF ::nTopItem > ::nValue + ::nTopItem := ::nValue + IF ::oVScroll != NIL + ::oVScroll:current := ::scrollbarPos() + ENDIF + ELSE + nValue := ::nValue - ( ::nBottom - ::nTop - iif( Empty( ::cHotBox + ::cColdBox ), 0, 2 ) + iif( ::lDropDown, 1, 0 ) ) + + IF ::nTopItem <= nValue + ::nTopItem := nValue + IF ::oVScroll != NIL + ::oVScroll:current := ::scrollbarPos() + ENDIF + ENDIF + ENDIF ::display() - Dispend() - - Setcursor( ::nCursor ) + IF ISBLOCK( ::bSBlock ) + Eval( ::bSBlock ) + ENDIF ENDIF -RETURN SELF + RETURN Self -Method Open() Class ListBox +METHOD scrollbarPos() CLASS LISTBOX - IF ! ::isopen + LOCAL nSize := ::nBottom - ::nTop - iif( ::lDropDown, 2, 1 ) + LOCAL nCount := ::nItemCount + LOCAL nLength := ::oVScroll:barLength - ::nSaveTop := ::top + 1 - ::nSaveLeft := ::left - ::nSaveBottom := ::bottom - ::nSaveRight := ::right - ::cSaveScreen := Savescreen( ::top + 1, ::left, ::bottom, ::right ) - ::isopen := .T. - SELF:display() + RETURN ( ( nCount - nLength ) * ::nTopItem + nLength - nSize ) / ( nCount - nSize ) - ENDIF -RETURN SELF +/* -------------------------------------------- */ -Method SetText( nPos, cText ) Class ListBox - - IF nPos < 1 - ELSEIF nPos <= ::itemCount - ::aitems[ nPos, 1 ] := cText - ENDIF -RETURN SELF - -Method SetItem( nPos, cText ) Class ListBox - - Do CASE - CASE nPos < 1 - CASE nPos > ::itemCount - CASE Len( cText ) != 2 - CASE ISCHARACTER( cText[ 1 ] ) - ::aitems[ nPos ] := cText - ENDCASE -RETURN SELF - -Method SetFocus() Class ListBox - - IF ! ::hasfocus - ::nCursor := Setcursor( 0 ) - ::hasfocus := .T. - Dispbegin() - ::display() - Dispend() - - IF ISBLOCK( ::fblock ) - Eval( ::fblock ) - ENDIF +METHOD bitmap( cBitmap ) CLASS LISTBOX + IF cBitmap != NIL .AND. ::lDropDown + ::cBitmap := _eInstVar( Self, "BITMAP", cBitmap, "C", 1001 ) ENDIF -RETURN SELF + RETURN ::cBitmap -Method SetData( nPos, xData ) Class ListBox +METHOD bottom( nBottom ) CLASS LISTBOX - IF nPos >= 1 .and. nPos <= ::itemCount - ::aitems[ nPos, 2 ] := xData + IF nBottom != NIL + ::nBottom := _eInstVar( Self, "BOTTOM", nBottom, "N", 1001 ) + IF ::oVScroll != NIL + ::oVScroll:end := ::nBottom - 1 + ENDIF ENDIF -RETURN SELF + RETURN ::nBottom -Static Function ChangeItem( oList, nPos, nItem ) +METHOD buffer() CLASS LISTBOX + RETURN ::xBuffer - Local nValue - Local nRet +METHOD capCol( nCapCol ) CLASS LISTBOX - IF nPos != nItem - oList:value := nItem + IF nCapCol != NIL + ::nCapCol := _eInstVar( Self, "CAPCOL", nCapCol, "N", 1001 ) + ENDIF - IF oList:value == 0 - oList:Textvalue := "" - ELSE - oList:Textvalue := _Getdata( oList:aItems[ oList:value ] ) + RETURN ::nCapCol + +METHOD capRow( nCapRow ) CLASS LISTBOX + + IF nCapRow != NIL + ::nCapRow := _eInstVar( Self, "CAPROW", nCapRow, "N", 1001 ) + ENDIF + + RETURN ::nCapRow + +METHOD caption( cCaption ) CLASS LISTBOX + + IF cCaption != NIL + ::cCaption := _eInstVar( Self, "CAPTION", cCaption, "C", 1001 ) + IF ::nCapCol == NIL + ::nCapRow := ::nTop + ::nCapCol := ::nLeft - Len( ::cCaption ) + ENDIF + ENDIF + + RETURN ::cCaption + +METHOD coldBox( cColdBox ) CLASS LISTBOX + + IF cColdBox != NIL + ::cColdBox := _eInstVar( Self, "COLDBOX", cColdBox, "C", 1001, {|| Len( cColdBox ) == 0 .OR. Len( cColdBox ) == 8 } ) + ENDIF + + RETURN ::cColdBox + +METHOD colorSpec( cColorSpec ) CLASS LISTBOX + + IF cColorSpec != NIL + ::cColorSpec := _eInstVar( Self, "COLORSPEC", cColorSpec, "C", 1001,; + iif( ::lDropDown,; + {|| !Empty( __GUIColor( cColorSpec, 8 ) ) .AND. Empty( __GUIColor( cColorSpec, 9 ) ) },; + {|| !Empty( __GUIColor( cColorSpec, 7 ) ) .AND. Empty( __GUIColor( cColorSpec, 8 ) ) } ) ) + ENDIF + + RETURN ::cColorSpec + +METHOD dropDown( lDropDown ) CLASS LISTBOX + + IF lDropDown != NIL + + ::lDropDown := _eInstVar( Self, "DROPDOWN", lDropDown, "L", 1001 ) + + IF !::lDropDown .AND. !::lIsOpen + ::lIsOpen := .T. ENDIF - IF ISNIL( oList:Buffer ) - ELSEIF ISNUMBER( oList:Buffer ) - oList:Buffer := oList:value - ELSEIF oList:value > 0 - oList:Buffer := oList:Textvalue + ::display() + ENDIF + + RETURN ::lDropDown + +METHOD fBlock( bFBlock ) CLASS LISTBOX + + IF PCount() > 0 + ::bFBlock := iif( bFBlock == NIL, NIL, _eInstVar( Self, "FBLOCK", bFBlock, "B", 1001 ) ) + ENDIF + + RETURN ::bFBlock + +METHOD hasFocus() CLASS LISTBOX + RETURN ::lHasFocus + +METHOD hotBox( cHotBox ) CLASS LISTBOX + + IF cHotBox != NIL + ::cHotBox := _eInstVar( Self, "HOTBOX", cHotBox, "C", 1001, {|| Len( cHotBox ) == 0 .OR. Len( cHotBox ) == 8 } ) + ENDIF + + RETURN ::cHotBox + +METHOD isOpen() CLASS LISTBOX + RETURN ::lIsOpen + +METHOD itemCount() CLASS LISTBOX + RETURN ::nItemCount + +METHOD left( nLeft ) CLASS LISTBOX + + IF nLeft != NIL + ::nLeft := _eInstVar( Self, "LEFT", nLeft, "N", 1001 ) + ENDIF + + RETURN ::nLeft + +METHOD message( cMessage ) CLASS LISTBOX + + IF cMessage != NIL + ::cMessage := _eInstVar( Self, "MESSAGE", cMessage, "C", 1001 ) + ENDIF + + RETURN ::cMessage + +METHOD right( nRight ) CLASS LISTBOX + + IF nRight != NIL + ::nRight := _eInstVar( Self, "RIGHT", nRight, "N", 1001 ) + IF ::oVScroll != NIL + ::oVScroll:offset := ::nRight ENDIF + ENDIF - IF Empty( oList:hotbox + oList:coldbox ) - nRet := 0 - ELSE - nRet := 2 + RETURN ::nRight + +METHOD sBlock( bSBlock ) CLASS LISTBOX + + IF PCount() > 0 + ::bSBlock := iif( bSBlock == NIL, NIL, _eInstVar( Self, "SBLOCK", bSBlock, "B", 1001 ) ) + ENDIF + + RETURN ::bSBlock + +METHOD style( cStyle ) CLASS LISTBOX + + IF cStyle != NIL + ::cStyle := _eInstVar( Self, "STYLE", cStyle, "C", 1001, {|| Len( cStyle ) == 1 } ) + ENDIF + + RETURN ::cStyle + +METHOD textValue() CLASS LISTBOX + RETURN ::cTextValue + +METHOD top( nTop ) CLASS LISTBOX + + IF nTop != NIL + ::nTop := _eInstVar( Self, "TOP", nTop, "N", 1001 ) + IF ::oVScroll != NIL + ::oVScroll:start := ::nTop + 1 ENDIF + ENDIF - IF oList:Dropdown - nRet ++ - ENDIF + RETURN ::nTop - nValue := oList:value - ( oList:Bottom - oList:top - nRet ) +METHOD topItem( nTopItem ) CLASS LISTBOX - IF oList:Topitem > oList:value - oList:topitem := oList:value + IF nTopItem != NIL - IF ISOBJECT( oList:vScroll ) - oList:vScroll:current := SetColumn( oList ) + _eInstVar( Self, "TOPITEM", nTopItem, "N", 1001, {|| nTopItem > 0 .AND. nTopItem <= ::nItemCount } ) + + nTopItem := Min( nTopItem, ::nItemCount - ( ::nBottom - ::nTop - iif( Empty( ::cHotBox + ::cColdBox ), 0, 2 ) ) ) + + IF ::nTopItem != nTopItem + ::nTopItem := nTopItem + + IF ::oVScroll != NIL + ::oVScroll:current := ::scrollbarPos() ENDIF - ELSEIF oList:topitem <= nValue .and. ; - ISOBJECT( ( oList:topitem := nValue, oList:vScroll ) ) - oList:vScroll:current := SetColumn( oList ) - ENDIF - - oList:display() - - IF ISBLOCK( oList:sBlock ) - Eval( oList:sBlock ) + ::display() ENDIF ENDIF -RETURN oList + RETURN ::nTopItem -Static Function SetColumn( oList ) +METHOD typeOut() CLASS LISTBOX + RETURN ::nItemCount == 0 - Local nSize - Local nCount - Local nLength - Local nTopItem - Local nNewSize +METHOD value() CLASS LISTBOX + RETURN ::nValue - nSize := oList:Bottom - oList:top - IIF( oList:dropdown, 2, 1 ) - nCount := oList:itemCount - nLength := oList:vScroll:barlength - nTopItem := oList:Topitem - nNewSize := ( ( nCount - nLength ) * nTopItem + nLength - nSize ) / ; - ( nCount - nSize ) -RETURN nNewSize - -Function Listbox( nTop, nLeft, nBottom, nRight, lDrop ) - - IF ISNUMBER( nTop ) .and. ISNUMBER( nleft ) .and. ; - ISNUMBER( nBottom ) .and. ISNUMBER( nRight ) - - RETURN HBListBox():New( nTop, nLeft, nBottom, nRight, lDrop ) +METHOD vScroll( oVScroll ) CLASS LISTBOX + IF PCount() > 0 + IF oVScroll == NIL + ::oVScroll := NIL + ELSE + ::oVScroll := _eInstVar( Self, "VSCROLL", oVScroll, "O", 1001, {|| oVScroll:ClassName() == "SCROLLBAR" .AND. oVScroll:orient == SCROLL_VERTICAL } ) + ::oVScroll:total := ::nItemCount + ENDIF ENDIF -RETURN nil + RETURN ::oVScroll -Static Function _Getdata( xItem ) +/* -------------------------------------------- */ - IF ISNIL( xItem[ 2 ] ) - RETURN xItem[ 1 ] +METHOD New( nTop, nLeft, nBottom, nRight, lDropDown ) + + LOCAL cColor + + IF !ISNUMBER( nTop ) .OR. ; + !ISNUMBER( nLeft ) .OR. ; + !ISNUMBER( nBottom ) .OR. ; + !ISNUMBER( nRight ) + RETURN NIL ENDIF -RETURN xItem[ 2 ] + DEFAULT lDropDown TO .F. -Function _LISTBOX_( nTop, nLeft, nBottom, nRight, nSelect, aList, cCaption, ; - cMessage, cColor, FBlock, SBlock, lDrop, lOpen ) + ::nBottom := nBottom + ::nRight := nRight + ::nTop := nTop + ::nLeft := nLeft + ::nCapCol := nLeft + ::nCapRow := nTop + ::lIsOpen := !lDropDown + ::lDropDown := lDropDown + ::aSaveScr := { nTop + 1, nleft, nBottom, nRight, SaveScreen( nTop + 1, nLeft, nBottom, nRight ) } - Local oScroll - Local nPos - Local nLen - Local xCurPos + IF IsDefColor() + ::cColorSpec := "W/N,W+/N,W+/N,N/W,W/N,W/N,W+/N,W/N" + ELSE + cColor := SetColor() + ::cColorSpec := __GUIColor( cColor, CLR_UNSELECTED + 1 ) + "," +; + __GUIColor( cColor, CLR_UNSELECTED + 1 ) + "," +; + __GUIColor( cColor, CLR_UNSELECTED + 1 ) + "," +; + __GUIColor( cColor, CLR_ENHANCED + 1 ) + "," +; + __GUIColor( cColor, CLR_BORDER + 1 ) + "," +; + __GUIColor( cColor, CLR_STANDARD + 1 ) + "," +; + __GUIColor( cColor, CLR_BACKGROUND + 1 ) + ENDIF - Default nSelect To 1 - Default lDrop To .f. - Default lOpen To .f. - Default cCaption To '' + RETURN Self - oScroll := Listbox( nTop, nLeft, nBottom, nRight, lDrop ) +FUNCTION ListBox( nTop, nLeft, nBottom, nRight, lDropDown ) + RETURN HBListBox():New( nTop, nLeft, nBottom, nRight, lDropDown ) - IF ! ISNIL( oScroll ) +FUNCTION _LISTBOX_( nTop, nLeft, nBottom, nRight, nSelect, aItems, cCaption,; + cMessage, cColorSpec, bFBlock, bSBlock, lDropDown, lIsOpen, cBitmap ) + + LOCAL o := HBListBox():New( nTop, nLeft, nBottom, nRight, lDropDown ) + + LOCAL nPos + LOCAL nLen + LOCAL xItem + + IF o != NIL IF ISCHARACTER( cCaption ) - oScroll:caption := cCaption - oScroll:capcol := nLeft - __CapLength( cCaption ) + o:caption := cCaption + o:capCol := nLeft - __CapLength( cCaption ) ENDIF - IF cColor != nil - oScroll:colorspec := cColor - ENDIF - - oScroll:message := cMessage - oScroll:fblock := FBlock - oScroll:sblock := SBlock - oScroll:isopen := lOpen - nLen := Len( aList ) + o:colorSpec := cColorSpec + o:message := cMessage + o:fBlock := bFBlock + o:sBlock := bSBlock + o:isOpen := lIsOpen + nLen := Len( aItems ) FOR nPos := 1 TO nLen - xCurPos := aList[ nPos ] - IF ! ISARRAY( xCurPos ) - oScroll:additem( xCurPos ) - ELSEIF Len( xCurPos ) == 1 - oScroll:additem( xCurPos[ 1 ] ) + xItem := aItems[ nPos ] + + IF ! ISARRAY( xItem ) + o:addItem( xItem ) + ELSEIF Len( xItem ) == _ITEM_cTEXT + o:addItem( xItem[ _ITEM_cTEXT ] ) ELSE - oScroll:additem( xCurPos[ 1 ], xCurPos[ 2 ] ) + o:addItem( xItem[ _ITEM_cTEXT ], xItem[ _ITEM_cDATA ] ) ENDIF - NEXT - IF ISLOGICAL( lOpen ) .and. lOpen - - IF ISLOGICAL( lDrop ) .and. lDrop - nTop ++ + IF ISLOGICAL( lIsOpen ) .AND. lIsOpen + IF ISLOGICAL( lDropDown ) .AND. lDropDown + nTop++ ENDIF - - oScroll:vscroll := Scrollbar( nTop + 1, nBottom - 1, nRight,, 1 ) - + o:VScroll := ScrollBar( nTop + 1, nBottom - 1, nRight,, 1 ) ENDIF - oScroll:select( nSelect ) - - ENDIF - -RETURN oScroll - -Function __CapLength( cCaption ) - Local nRet := 0, nPos - - IF !ISNIL( cCaption ) - nRet := Len( cCaption ) - IF ( nPos := At( "&", cCaption ) ) > 0 .and. nPos < nRet - --nRet + IF ISCHARACTER( cBitmap ) + o:bitmap := cBitmap ENDIF + + o:select( nSelect ) ENDIF -RETURN nRet + RETURN o #endif diff --git a/harbour/source/rtl/memoedit.prg b/harbour/source/rtl/memoedit.prg index fea5a95d87..27f8875edc 100644 --- a/harbour/source/rtl/memoedit.prg +++ b/harbour/source/rtl/memoedit.prg @@ -50,70 +50,65 @@ * */ +#include "hbclass.ch" #include "common.ch" -#include "hbclass.ch" -#include "memoedit.ch" #include "inkey.ch" - +#include "memoedit.ch" // A specialized HBEditor which can simulate MemoEdit() behaviour -CLASS TMemoEditor FROM HBEditor +CREATE CLASS HBMemoEditor FROM HBEditor - DATA xUserFunction // User Function called to change default MemoEdit() behaviour + VAR xUserFunction // User Function called to change default MemoEdit() behaviour - METHOD MemoInit(cUserFunction) // This method is called after ::New() returns to perform ME_INIT actions + METHOD MemoInit( cUserFunction ) // This method is called after ::New() returns to perform ME_INIT actions METHOD Edit() // Calls super:Edit(nKey) but is needed to handle configurable keys - METHOD KeyboardHook(nKey) // Gets called every time there is a key not handled directly by HBEditor + METHOD KeyboardHook( nKey ) // Gets called every time there is a key not handled directly by HBEditor METHOD IdleHook() // Gets called every time there are no more keys to hanlde - METHOD HandleUserKey(nKey, nUserKey) // Handles keys returned to MemoEdit() by user function - METHOD xDo(nStatus) // Calls xUserFunction saving and restoring cursor position and shape + METHOD HandleUserKey( nKey, nUserKey ) // Handles keys returned to MemoEdit() by user function + METHOD xDo( nStatus ) // Calls xUserFunction saving and restoring cursor position and shape METHOD MoveCursor( nKey ) // Redefined to properly managed CTRL-W ENDCLASS +METHOD MemoInit( cUserFunction ) CLASS HBMemoEditor -METHOD MemoInit(cUserFunction) CLASS TMemoEditor - - local nKey - - default cUserFunction to nil + LOCAL nKey // Save/Init object internal representation of user function ::xUserFunction := cUserFunction - if ISCHARACTER(::xUserFunction) + if ISCHARACTER( ::xUserFunction ) // Keep calling user function until it returns 0 - while (nKey := ::xDo(ME_INIT)) <> ME_DEFAULT + do while ( nKey := ::xDo( ME_INIT ) ) != ME_DEFAULT // At this time there is no input from user of MemoEdit() only handling // of values returned by ::xUserFunction, so I pass these value on both // parameters of ::HandleUserKey() - ::HandleUserKey(nKey, nKey) + ::HandleUserKey( nKey, nKey ) enddo endif -return Self + RETURN Self +METHOD Edit() CLASS HBMemoEditor -METHOD Edit() CLASS TMemoEditor - - local nKey, nUserKey + LOCAL nKey // NOTE: K_ALT_W is not compatible with clipper exit memo and save key, but I cannot discriminate // K_CTRL_W and K_CTRL_END from harbour code. - local aConfigurableKeys := {K_CTRL_Y, K_CTRL_T, K_CTRL_B, K_CTRL_V, K_ALT_W, K_ESC } - local bKeyBlock + LOCAL aConfigurableKeys := { K_CTRL_Y, K_CTRL_T, K_CTRL_B, K_CTRL_V, K_ALT_W, K_ESC } + LOCAL bKeyBlock // If I have an user function I need to trap configurable keys and ask to // user function if handle them the standard way or not - if ::lEditAllow .AND. ISCHARACTER(::xUserFunction) + if ::lEditAllow .AND. ISCHARACTER( ::xUserFunction ) - while ! ::lExitEdit + do while ! ::lExitEdit // I need to test this condition here since I never block inside HBEditor:Edit() // if there is an user function @@ -121,161 +116,152 @@ METHOD Edit() CLASS TMemoEditor ::IdleHook() endif - nKey := Inkey(0) + nKey := Inkey( 0 ) - if (bKeyBlock := Setkey( nKey )) <> NIL + if ( bKeyBlock := SetKey( nKey ) ) != NIL Eval( bKeyBlock ) - Loop + loop endif // Is it a configurable key ? - if AScan(aConfigurableKeys, nKey) > 0 - nUserKey := ::xDo(iif(::lDirty, ME_UNKEYX, ME_UNKEY)) - ::HandleUserKey(nKey, nUserKey) - + if AScan( aConfigurableKeys, nKey ) > 0 + ::HandleUserKey( nKey, ::xDo( iif( ::lDirty, ME_UNKEYX, ME_UNKEY ) ) ) else - ::super:Edit(nKey) - + ::super:Edit( nKey ) endif - enddo - else // If I can't edit text buffer or there is not a user function enter standard HBEditor // ::Edit() method which is able to handle everything ::super:Edit() - endif -return Self - + RETURN Self // I come here if I have an unknown key and it is not a configurable key // if there is an user function I leave to it its handling -METHOD KeyboardHook(nKey) CLASS TMemoEditor +METHOD KeyboardHook( nKey ) CLASS HBMemoEditor - local nUserKey, nYesNoKey, cBackScr, nRow, nCol + LOCAL nYesNoKey + LOCAL cBackScr + LOCAL nRow + LOCAL nCol if nKey == K_ESC + cBackScr = SaveScreen( ::nTop, ::nRight - 18, ::nTop, ::nRight ) + nRow = Row() nCol = Col() @ ::nTop, ::nRight - 18 SAY "Abort Edit? (Y/N)" - nYesNoKey = InKey( 0 ) + + nYesNoKey = Inkey( 0 ) + RestScreen( ::nTop, ::nRight - 18, ::nTop, ::nRight, cBackScr ) SetPos( nRow, nCol ) + if Upper( Chr( nYesNoKey ) ) == "Y" ::lSaved := .F. ::lExitEdit := .T. endif endif - if ISCHARACTER(::xUserFunction) - - nUserKey := ::xDo(iif(::lDirty, ME_UNKEYX, ME_UNKEY)) - ::HandleUserKey(nKey, nUserKey) - + if ISCHARACTER( ::xUserFunction ) + ::HandleUserKey( nKey, ::xDo( iif( ::lDirty, ME_UNKEYX, ME_UNKEY ) ) ) endif -return Self + RETURN Self +METHOD IdleHook() CLASS HBMemoEditor -METHOD IdleHook() CLASS TMemoEditor - - if ISCHARACTER(::xUserFunction) - ::xDo(ME_IDLE) - + if ISCHARACTER( ::xUserFunction ) + ::xDo( ME_IDLE ) endif -return Self + RETURN Self - -METHOD HandleUserKey(nKey, nUserKey) CLASS TMemoEditor +METHOD HandleUserKey( nKey, nUserKey ) CLASS HBMemoEditor // HBEditor does not handle these keys and would call ::KeyboardHook() causing infinite loop - local aUnHandledKeys := {K_CTRL_J, K_CTRL_K, K_CTRL_L, K_CTRL_N, K_CTRL_O, K_CTRL_P, K_CTRL_Q, K_CTRL_T,; - K_CTRL_U, K_F1 } + LOCAL aUnHandledKeys := { K_CTRL_J, K_CTRL_K, K_CTRL_L, K_CTRL_N, K_CTRL_O,; + K_CTRL_P, K_CTRL_Q, K_CTRL_T, K_CTRL_U, K_F1 } do case - // I won't reach this point during ME_INIT since ME_DEFAULT ends initialization phase of MemoEdit() - case nUserKey == ME_DEFAULT + // I won't reach this point during ME_INIT since ME_DEFAULT ends initialization phase of MemoEdit() + case nUserKey == ME_DEFAULT - // HBEditor is not able to handle keys with a value higher than 256, but I have to tell him - // that user wants to save text - if (nKey <= 256 .OR. nKey == K_ALT_W) .AND. AScan(aUnHandledKeys, nKey) == 0 - ::super:Edit(nKey) - endif + // HBEditor is not able to handle keys with a value higher than 256, but I have to tell him + // that user wants to save text + if ( nKey <= 256 .OR. nKey == K_ALT_W ) .AND. AScan( aUnHandledKeys, nKey ) == 0 + ::super:Edit( nKey ) + endif - // TOFIX: Not clipper compatible, see teditor.prg - case (nUserKey >= 1 .AND. nUserKey <= 31) .OR. nUserKey == K_ALT_W - if AScan(aUnHandledKeys, nUserKey) == 0 - ::super:Edit(nUserKey) - endif + // TOFIX: Not clipper compatible, see teditor.prg + case ( nUserKey >= 1 .AND. nUserKey <= 31 ) .OR. nUserKey == K_ALT_W + if AScan( aUnHandledKeys, nUserKey ) == 0 + ::super:Edit( nUserKey ) + endif - case nUserKey == ME_DATA - if nKey <= 256 .AND. AScan(aUnHandledKeys, nKey) == 0 - ::super:Edit(nKey) - endif + case nUserKey == ME_DATA + if nKey <= 256 .AND. AScan( aUnHandledKeys, nKey ) == 0 + ::super:Edit( nKey ) + endif - case nUserKey == ME_TOGGLEWRAP - ::lWordWrap := !::lWordWrap + case nUserKey == ME_TOGGLEWRAP + ::lWordWrap := !::lWordWrap - case nUserKey == ME_TOGGLESCROLL - // TODO: HBEditor does not support vertical scrolling of text inside window without moving cursor position + case nUserKey == ME_TOGGLESCROLL + // TODO: HBEditor does not support vertical scrolling of text inside window without moving cursor position - case nUserKey == ME_WORDRIGHT - ::MoveCursor(K_CTRL_RIGHT) + case nUserKey == ME_WORDRIGHT + ::MoveCursor( K_CTRL_RIGHT ) - case nUserKey == ME_BOTTOMRIGHT - ::MoveCursor(K_CTRL_END) - - otherwise - // Do nothing + case nUserKey == ME_BOTTOMRIGHT + ::MoveCursor( K_CTRL_END ) + otherwise + // Do nothing endcase -return Self + RETURN Self +METHOD xDo( nStatus ) CLASS HBMemoEditor -METHOD xDo(nStatus) CLASS TMemoEditor + LOCAL nOldRow := ::Row() + LOCAL nOldCol := ::Col() + LOCAL nOldCur := SetCursor() + + LOCAL xResult := Do( ::xUserFunction, nStatus, ::nRow, ::nCol - 1 ) - LOCAL nCurRow := ::Row() - LOCAL nCurCol := ::Col() - LOCAL nCurCur := SetCursor() - LOCAL xRes + ::SetPos( nOldRow, nOldCol ) + SetCursor( nOldCur ) - xRes := Do(::xUserFunction, nStatus, ::nRow, ::nCol - 1) + RETURN xResult - ::SetPos(nCurRow, nCurCol) - SetCursor(nCurCur) - -return xRes - -METHOD MoveCursor(nKey) CLASS TMemoEditor +METHOD MoveCursor( nKey ) CLASS HBMemoEditor if nKey == K_CTRL_END // same value as CTRL-W ::lSaved = .t. ::lExitEdit := .T. else - return ::Super:MoveCursor( nKey ) + RETURN ::Super:MoveCursor( nKey ) endif -return .f. + RETURN .f. /*----------------------------------------------------------------------------------------*/ - -FUNCTION MemoEdit(cString,; - nTop, nLeft,; - nBottom, nRight,; - lEditMode,; - cUserFunction,; - nLineLength,; - nTabSize,; - nTextBuffRow,; - nTextBuffColumn,; - nWindowRow,; - nWindowColumn) +FUNCTION MemoEdit( cString,; + nTop, nLeft,; + nBottom, nRight,; + lEditMode,; + cUserFunction,; + nLineLength,; + nTabSize,; + nTextBuffRow,; + nTextBuffColumn,; + nWindowRow,; + nWindowColumn ) LOCAL oEd @@ -290,17 +276,16 @@ FUNCTION MemoEdit(cString,; DEFAULT nTextBuffColumn TO 0 DEFAULT nWindowRow TO 0 DEFAULT nWindowColumn TO nTextBuffColumn - DEFAULT cUserFunction TO nil DEFAULT cString TO "" // Original MemoEdit() converts Tabs into spaces; - oEd := TMemoEditor():New(StrTran(cString, Chr(K_TAB), Space(1)), nTop, nLeft, nBottom, nRight, lEditMode, nLineLength, nTabSize) - oEd:MemoInit(cUserFunction) + oEd := HBMemoEditor():New( StrTran( cString, Chr( K_TAB ), Space( 1 ) ), nTop, nLeft, nBottom, nRight, lEditMode, nLineLength, nTabSize ) + oEd:MemoInit( cUserFunction ) oEd:RefreshWindow() - if ! ISLOGICAL(cUserFunction) .OR. cUserFunction == .T. + if ! ISLOGICAL( cUserFunction ) .OR. cUserFunction == .T. oEd:Edit() - if oEd:lSaved + if oEd:Saved() cString := oEd:GetText() // dbu tests for LastKey() == K_CTRL_END, so I try to make it happy KEYBOARD Chr(K_CTRL_END) @@ -308,5 +293,4 @@ FUNCTION MemoEdit(cString,; endif endif -RETURN cString - + RETURN cString diff --git a/harbour/source/rtl/menusys.prg b/harbour/source/rtl/menusys.prg new file mode 100644 index 0000000000..b3197733c5 --- /dev/null +++ b/harbour/source/rtl/menusys.prg @@ -0,0 +1,166 @@ +/* + * $Id: mssgline.prg 7155 2007-04-14 10:41:54Z vszakats $ + */ + +/* + * Harbour Project source code: + * MENUSYS parts + * + * Copyright 2002 Larry Sevilla + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#include "hbclass.ch" + +#include "common.ch" +#include "getexit.ch" +#include "inkey.ch" +#include "setcurs.ch" + +/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but + it has all related variables and methods. */ + +#ifdef HB_COMPAT_C53 + +/* Standard Menu System Modal handling for Menu Items */ +FUNCTION MenuModal( oTopMenu, nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) + RETURN HBMenuSys():New( oTopMenu ):modal( nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) + +/* Dummy function */ +FUNCTION ShowMsg( aMsg, lMode ) + + HB_SYMBOL_UNUSED( aMsg ) + HB_SYMBOL_UNUSED( lMode ) + + RETURN .F. + +/*** +* +* ShortCut processing for initial Get or Menu Item. +* +***/ +FUNCTION IsShortCut( oMenu, nKey, nID ) + LOCAL nItem + LOCAL nTotal + LOCAL nShortCut + LOCAL oItem + LOCAL i + + // Test for top menu item not a TopBar Menu: + IF !( oMenu:ClassName() == "TOPBARMENU" ) + RETURN IsQuick( oMenu, nKey, @nID ) + + // Test and assign top menu item shortCut, enabled, and !PopUp: + // Changed by enclosing assignment before ':Enabled': + ELSEIF ( nShortCut := oMenu:GetShortCt( nKey ) ) > 0 .AND. ; + ( oItem := oMenu:GetItem( nShortcut ) ):Enabled .AND. ; + !oItem:IsPopUp() + oMenu:Select( nShortCut ) + Eval( oItem:Data, oItem ) + nID := oItem:ID + RETURN .T. + + // Test and assignment for TopBar MenuItem: + ELSEIF nShortCut == 0 + nTotal := oMenu:ItemCount() + nItem := oMenu:Current + IF nItem == 0 + nItem := 1 + ENDIF + + // Loop to wrap around through TopMenu from Current Item: + FOR i := 1 TO nTotal + IF ( oItem := oMenu:GetItem( nItem ) ):Enabled .AND. ; + oItem:IsPopUp() .AND. ; + IsQuick( oItem:Data, nKey, @nID ) + + RETURN .T. + ENDIF + + IF ++nItem > nTotal + nItem := 1 + ENDIF + NEXT + + ENDIF + + RETURN .F. + +/*** +* +* Navigates to the next Get or Menu Item from the +* Current if more than one uses the same ShortCut. +* +***/ +FUNCTION IsQuick( oMenu, nKey, nID ) + LOCAL nItem + LOCAL nTotal + LOCAL nShortCut + LOCAL oItem + + IF ( nShortCut := oMenu:GetShortCt( nKey ) ) == 0 + + nTotal := oMenu:ItemCount() + + FOR nItem := 1 TO nTotal + IF ( oItem := oMenu:GetItem( nItem ) ):Enabled .AND. ; + oItem:IsPopUp() .AND. ; + IsQuick( oItem:Data, nKey, @nID ) + + RETURN .T. + ENDIF + NEXT + + ELSEIF !( oItem := oMenu:GetItem( nShortCut ) ):IsPopUp() .AND. oItem:Enabled + + oMenu:Select( nShortCut ) + Eval( oItem:Data, oItem ) + nID := oItem:ID + + RETURN .T. + + ENDIF + + RETURN .F. + +#endif diff --git a/harbour/source/rtl/mssgline.prg b/harbour/source/rtl/mssgline.prg deleted file mode 100644 index 0628b9c3ce..0000000000 --- a/harbour/source/rtl/mssgline.prg +++ /dev/null @@ -1,205 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * Message Line Class - * - * Copyright 2002 Larry Sevilla - * www - http://www.harbour-project.org - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). - * - * As a special exception, the Harbour Project gives permission for - * additional uses of the text contained in its release of Harbour. - * - * The exception is that, if you link the Harbour libraries with other - * files to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the Harbour library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the Harbour - * Project under the name Harbour. If you copy code from other - * Harbour Project or Free Software Foundation releases into a copy of - * Harbour, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for Harbour, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - */ - -#include "hbclass.ch" - -#ifdef HB_COMPAT_C53 - -CLASS MssgLine - - DATA Flag - DATA Row - DATA Left - DATA Right - DATA Color - DATA aMsg // for backwards compatibility - -/* -// Graphics support - not yet implemented - DATA Back1 - DATA Back2 - DATA Fore - DATA FontCol - DATA FontRow -*/ - DATA ScreenSaved PROTECTED - - METHOD New( nRow, nLeft, nRight, cColor ) - METHOD SaveScreen() - METHOD Show( cMsg ) - METHOD RestScreen() - MESSAGE Erase() METHOD RestScreen() - -ENDCLASS - -METHOD New( nRow, nLeft, nRight, cColor ) CLASS MssgLine - - ::Row := nRow - ::Left := nLeft - ::Right := nRight - ::Color := cColor - - ::Flag := ( VALTYPE(nRow) + VALTYPE(nLeft) + VALTYPE(nRight) == "NNN" ) - - IF !( VALTYPE(cColor) == "C" ) - ::Color := GetClrPair( SetColor(), 1 ) - ENDIF - - ::aMsg := { ::Flag, nRow, nLeft, nRight, ::Color ,,,,, } - // GUI not yet supported - -return Self - -METHOD SaveScreen() CLASS MssgLine - - ::ScreenSaved := saveScreen( ::row, ::left, ::row, ::right ) - -return Self - -METHOD RestScreen() CLASS MssgLine - - restScreen( ::row, ::left, ::row, ::right, ::ScreenSaved ) - -return Self - -/*** -* -* ShowMsg() --> NIL -* -***/ -METHOD Show( cMsg ) CLASS MssgLine - - local nRow, nCol - - IF ::Right == NIL - RETURN Self - ENDIF - - nRow := row() - nCol := col() - - @ ::row, ::left SAY PadC( cMsg, ::right - ::left + 1 ) COLOR ::Color - - setPos( nRow, nCol ) - -return Self - - -CLASS GetMssgLine FROM MssgLine - - METHOD Show( oGet ) - -ENDCLASS - -/*** -* -* ShowGetMsg() --> NIL -* -***/ -METHOD Show( oGet ) CLASS GetMssgLine - - local cMsg := IIF( VALTYPE( oGet:Control ) == "O", ; - oGet:Control:Message, oGet:Message ) - - IF !EMPTY( cMsg ) - ::super:Show( cMsg ) - ENDIF - -return Self - - -CLASS MenuMssgLine FROM MssgLine - - METHOD Show( oMenu, lMode ) - -ENDCLASS - -/*** -* -* ShowMsg( , ) --> .T. -* -* Erase and Show Messages. -* Erase Message then ShowMsg() if lMode is .T. -* Only erases Menu Message if lMode is .F. -* SaveScreen()/RestScreen() is used for the -* Message area in both text or graphics mode. -* -***/ -METHOD Show( oMenu, lMode ) CLASS MenuMssgLine - - LOCAL nCurrent, cMsg := NIL - LOCAL cSaveColor := SetColor() - LOCAL mlOldState := MSetCursor( .F. ) - - IF ( ValType( oMenu:lOldMsgFlag ) == "L" .AND. oMenu:lOldMsgFlag ) - ::RestScreen() - ENDIF - - IF lMode - IF ( ::Flag .AND. ; - ( nCurrent := oMenu:oMenu:Current ) != 0 ) - - IF !EMPTY( cMsg := oMenu:oMenu:GetItem( nCurrent ):Message ) - ::super:show( cMsg ) - ENDIF - ENDIF - - oMenu:cOldMessage := cMsg - oMenu:lOldMsgFlag := ::Flag - - ENDIF - MSetCursor( mlOldState ) - - RETURN ( .T. ) - -#endif - diff --git a/harbour/source/rtl/pushbtn.prg b/harbour/source/rtl/pushbtn.prg index cd60dba9d5..398c39a498 100644 --- a/harbour/source/rtl/pushbtn.prg +++ b/harbour/source/rtl/pushbtn.prg @@ -51,333 +51,347 @@ */ #include 'hbclass.ch' -#include "common.ch" + #include "button.ch" +#include "color.ch" +#include "common.ch" +#include "setcurs.ch" + +/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but + it has all related variables and methods. */ + +/* NOTE: CA-Cl*pper 5.3 uses a mixture of QQOut(), DevOut(), Disp*() + functions to generate screen output. Harbour uses Disp*() + functions only. [vszakats] */ #ifdef HB_COMPAT_C53 + CREATE CLASS PUSHBUTTON FUNCTION HBPushButton EXPORT: - DATA Buffer - DATA Caption - DATA Cargo - DATA Col - DATA fBlock - DATA HasFocus - DATA Message - DATA Row - DATA sBlock - DATA TypeOut INIT .F. + VAR cargo /* NOTE: CA-Clipper 5.3 has a bug, where this var cannot be assigned NIL. */ - METHOD DISPLAY() - METHOD HitTest( nRow, nCol ) - METHOD KillFocus() - MESSAGE SELECT() METHOD _Select() - METHOD SetFocus() - METHOD New( nRow, nCol, cCaption ) - ACCESS ColorSpec INLINE ::GetColor() - ASSIGN ColorSpec( xColor ) INLINE IIF( xColor != Nil, ::GetColor( xColor ), ) - ACCESS Style INLINE ::GetStyle() - ASSIGN Style( cStyle ) INLINE IIF( cStyle != Nil, ::GetStyle( cStyle ), ) + VAR bmpXOff INIT -1 /* NOTE: Fully compatible behaviour not implemented. */ + VAR bmpYOff INIT -1 /* NOTE: Fully compatible behaviour not implemented. */ + VAR capXOff INIT -1 /* NOTE: Fully compatible behaviour not implemented. */ + VAR capYOff INIT -1 /* NOTE: Fully compatible behaviour not implemented. */ + VAR sizeX INIT 0 /* NOTE: Fully compatible behaviour not implemented. */ + VAR sizeY INIT 0 /* NOTE: Fully compatible behaviour not implemented. */ - Hidden: + METHOD display() + METHOD hitTest( nRow, nCol ) + METHOD killFocus() + METHOD select() + METHOD setFocus() - DATA CurStyle - DATA COLOR - DATA lCursor - METHOD Getcolor( xColor ) - METHOD GetStyle( xStyle ) + METHOD bitmap( cBitmap ) SETGET + METHOD buffer() SETGET + METHOD caption( cCaption ) SETGET + METHOD col( nCol ) SETGET + METHOD colorSpec( cColorSpec ) SETGET + METHOD fBlock( bFBlock ) SETGET + METHOD hasFocus() SETGET + METHOD message( cMessage ) SETGET + METHOD row( nRow ) SETGET + METHOD sBlock( bSBlock ) SETGET + METHOD typeOut() SETGET + METHOD style( cStyle ) SETGET + + METHOD New( nRow, nCol, cCaption ) /* NOTE: This method is a Harbour extension [vszakats] */ + + PROTECTED: + + VAR cBitmap INIT "" + VAR lBuffer INIT .F. + VAR cCaption + VAR nCol + VAR cColorSpec + VAR bFBlock + VAR lHasFocus INIT .F. + VAR cMessage INIT "" + VAR nRow + VAR bSBlock + VAR cStyle INIT "<>" + VAR lTypeOut INIT .F. ENDCLASS -METHOD GetColor( xColor ) CLASS PushButton +METHOD setFocus() CLASS PUSHBUTTON - IF ! ISNIL( xColor ) - ::Color := IIF( Valtype( xColor ) == "C" .and. ; - !Empty( __GuiColor( xColor, 4 ) ) .and. ; - Empty( __GuiColor( xColor, 6 ) ), xColor, ) - - ENDIF - -RETURN ::Color - -METHOD GetStyle( cStyle ) CLASS PushButton - - IF ! ISNIL( cStyle ) - ::curStyle := IIF( Valtype( cStyle ) == "C" .and. ; - Ltrim( Str( Len( cStyle ) ) ) $ "0ù2ù8", cStyle, ) - ENDIF - -RETURN ::curStyle - -METHOD New( nRow, nCol, cCaption ) CLASS PushButton - - LOCAL cColor - DEFAULT cCaption TO "" - - ::Buffer := .F. - ::Caption := cCaption - ::Cargo := Nil - ::Col := nCol - ::fBlock := Nil - ::sBlock := Nil - ::HasFocus := .F. - ::Message := "" - ::Row := nRow - ::lCursor := Nil - ::Style := "<>" - - IF Isdefcolor() - ::ColorSpec := "W/N,N/W,W+/N,W+/N" - ELSE - cColor := Setcolor() - ::ColorSpec := __GuiColor( cColor, 5 ) + "," + ; - __GuiColor( cColor, 2 ) + "," + ; - __GuiColor( cColor, 1 ) + "," + ; - __GuiColor( cColor, 4 ) - ENDIF - -RETURN Self - -METHOD SetFocus() CLASS PushButton - - IF !::HasFocus - ::lCursor := Setcursor( 0 ) - ::HasFocus := .T. + IF !::lHasFocus + ::lHasFocus := .T. ::display() - IF ISBLOCK( ::fBlock ) - Eval( ::fBlock ) + + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) ENDIF ENDIF -RETURN Self + RETURN Self -METHOD _Select( nPos ) CLASS PushButton +METHOD select( nPos ) CLASS PUSHBUTTON LOCAL nCurPos := nPos - IF ::HasFocus - ::Buffer := .T. + IF ::lHasFocus + ::lbuffer := .T. ::display() - IF Isnumber( nPos ) + IF ISNUMBER( nPos ) IF nPos == 32 - Inkey( 0.4 ) + Inkey( 0.4 ) DO WHILE nCurPos == 32 nCurPos := Inkey( 0.1 ) ENDDO - ELSE - DO WHILE nPos == Inkey( 0 ) ENDDO - ENDIF - ENDIF - IF ISBLOCK( ::sBlock ) - Eval( ::sBlock ) + IF ISBLOCK( ::bSBlock ) + Eval( ::bSBlock ) ENDIF - ::Buffer := .F. + ::lBuffer := .F. ::display() ENDIF -RETURN Self + RETURN Self -METHOD KillFocus() CLASS PushButton +METHOD killFocus() CLASS PUSHBUTTON - IF ::HasFocus + IF ::lHasFocus + ::lHasFocus := .F. - ::HasFocus := .F. - - IF ISBLOCK( ::fBlock ) - Eval( ::fBlock ) + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) ENDIF ::display() - Setcursor( ::lCursor ) ENDIF -RETURN Self + RETURN Self -METHOD HitTest( nRow, nCol ) CLASS PushButton +METHOD hitTest( nRow, nCol ) CLASS PUSHBUTTON LOCAL nCurrentPos := 1 - LOCAL nLen := Len( ::Caption ) - LOCAL cStyle - LOCAL nAmpPos + LOCAL nLen := Len( ::cCaption ) + LOCAL nStyleLen + LOCAL nAccelPos - IF ( nAmpPos := At( "&", ::Caption ) ) != 0 .AND. nAmpPos < nLen + IF ( nAccelPos := At( "&", ::cCaption ) ) > 0 .AND. nAccelPos < nLen nLen-- ENDIF - IF ( cStyle := Len( ::Style ) ) == 2 + IF ( nStyleLen := Len( ::cStyle ) ) == 2 nLen += 2 - ELSEIF cStyle == 8 + ELSEIF nStyleLen == 8 nCurrentPos := 3 - nLen += 2 + nLen += 2 ENDIF - IF nRow >= ::Row .AND. nCol >= ::Col .AND. ; - nRow < ::Row + nCurrentPos .AND. nCol < ::Col + nLen + IF nRow >= ::Row .AND. ; + nCol >= ::Col .AND. ; + nRow < ::Row + nCurrentPos .AND. ; + nCol < ::Col + nLen RETURN HTCLIENT ENDIF -RETURN HTNOWHERE + RETURN HTNOWHERE -METHOD DISPLAY() CLASS PushButton +METHOD display() CLASS PUSHBUTTON - LOCAL cOldColor := Setcolor() - LOCAL cStyle - LOCAL nCurCol - LOCAL cCaption - LOCAL nRow := Row() - LOCAL nCol := Col() - LOCAL nCurRow - LOCAL nAmpPos - LOCAL cColor4 - LOCAL nColorNum - LOCAL nBuffer + LOCAL cOldColor := SetColor() + LOCAL nOldRow := Row() + LOCAL nOldCol := Col() + LOCAL lOldMCur := MSetCursor( .F. ) - cStyle := ::Style + LOCAL cStyle := ::cStyle + LOCAL cCaption := ::cCaption + LOCAL nRow := ::nRow + LOCAL nCol := ::nCol + LOCAL nPos - Dispbegin() - - IF ::Buffer - SET COLOR TO (__GuiColor(::ColorSpec, 3)) - cColor4 := __GuiColor( ::ColorSpec, 4 ) - - IF Len( cColor4 ) == 0 - nColorNum := 0 - ELSE - nColorNum := _getnumcol( cColor4 ) - ENDIF - - ELSEIF ::HasFocus - SET COLOR TO (__GuiColor(::ColorSpec, 2)) - cColor4 := __GuiColor( ::ColorSpec, 4 ) - - IF Len( cColor4 ) == 0 - nColorNum := 0 - ELSE - nColorNum := _getnumcol( cColor4 ) - ENDIF + DispBegin() + IF ::lBuffer + SetColor( __GUIColor( ::cColorSpec, 3 ) ) + ELSEIF ::lHasFocus + SetColor( __GUIColor( ::cColorSpec, 2 ) ) ELSE - SET COLOR TO (__GuiColor(::ColorSpec, 1)) - cColor4 := __GuiColor( ::ColorSpec, 4 ) - - IF Len( cColor4 ) == 0 - nColorNum := 0 - ELSE - nColorNum := _getnumcol( cColor4 ) - ENDIF - + SetColor( __GUIColor( ::cColorSpec, 1 ) ) ENDIF - nCurRow := ::Row - nCurCol := ::Col - cCaption := ::Caption - - IF ( nAmpPos := At( "&", cCaption ) ) != 0 - IF nAmpPos == Len( cCaption ) - nAmpPos := 0 - ELSE - cCaption := Stuff( cCaption, nAmpPos, 1, "" ) - ENDIF + IF ( nPos := At( "&", cCaption ) ) == 0 + ELSEIF nPos == Len( cCaption ) + nPos := 0 + ELSE + cCaption := Stuff( cCaption, nPos, 1, "" ) ENDIF IF !Empty( cStyle ) - nCurCol ++ + + nCol++ IF Len( cStyle ) == 2 - Setpos( ::Row, ::Col ) - ?? Substr( cStyle, 1, 1 ) - Setpos( ::Row, ::Col + Len( cCaption ) + 1 ) - ?? Substr( cStyle, 2, 1 ) + DispOutAt( ::nRow, ::nCol, SubStr( cStyle, 1, 1 ) ) + DispOutAt( ::nRow, ::nCol + Len( cCaption ) + 1, SubStr( cStyle, 2, 1 ) ) ELSE - nCurRow ++ - Dispbox( ::Row, ::Col, ::Row + 2, ::Col + Len( cCaption ) + 1, cStyle ) + nRow++ + DispBox( ::nRow, ::nCol, ::nRow + 2, ::nCol + Len( cCaption ) + 1, cStyle ) ENDIF - - ENDIF - - IF ::Buffer - nBuffer := 1 - ELSE - nBuffer := 0 ENDIF IF !Empty( cCaption ) - Setpos( nCurRow, nCurCol ) - ?? cCaption + DispOutAt( nRow, nCol, cCaption ) - IF nAmpPos != 0 - Set COLOR TO (cColor4) - Setpos( nCurRow, nCurCol + nAmpPos - 1 ) - ?? Substr( cCaption, nAmpPos, 1 ) + IF nPos != 0 + DispOutAt( nRow, nCol + nPos - 1, SubStr( cCaption, nPos, 1 ), __GUIColor( ::cColorSpec, 4 ) ) ENDIF ENDIF - Dispend() + DispEnd() - SET COLOR TO (cOldColor) - Setpos( nRow, nCol ) + MSetCursor( lOldMCur ) + SetColor( cOldColor ) + SetPos( nOldRow, nOldCol ) -RETURN Self + RETURN Self -FUNCTION PushButton( nRow, nCol, cCaption ) +METHOD bitmap( cBitmap ) CLASS PUSHBUTTON - IF ISNUMBER( nRow ) .AND. ISNUMBER( nCol ) - DEFAULT cCaption TO "" - RETURN HBPushButton():New( nRow, nCol, cCaption ) + IF cBitmap != NIL + ::cBitmap := _eInstVar( Self, "BITMAP", cBitmap, "C", 1001 ) ENDIF -RETURN Nil + RETURN ::cBitmap -FUNCTION _PUSHBUTT_( cCaption, cMessage, cColor, bFBlock, bSBlock, cStyle ) +METHOD buffer() CLASS PUSHBUTTON + RETURN ::lBuffer + +METHOD caption( cCaption ) CLASS PUSHBUTTON + + IF cCaption != NIL + ::cCaption := _eInstVar( Self, "CAPTION", cCaption, "C", 1001 ) + ENDIF + + RETURN ::cCaption + +METHOD col( nCol ) CLASS PUSHBUTTON + + IF nCol != NIL + ::nCol := _eInstVar( Self, "COL", nCol, "N", 1001 ) + ENDIF + + RETURN ::nCol + +METHOD colorSpec( cColorSpec ) CLASS PUSHBUTTON + + IF cColorSpec != NIL + ::cColorSpec := _eInstVar( Self, "COLORSPEC", cColorSpec, "C", 1001,; + {|| !Empty( __GUIColor( cColorSpec, 4 ) ) .AND. Empty( __GUIColor( cColorSpec, 6 ) ) } ) + ENDIF + + RETURN ::cColorSpec + +METHOD fBlock( bFBlock ) CLASS PUSHBUTTON + + IF PCount() > 0 + ::bFBlock := iif( bFBlock == NIL, NIL, _eInstVar( Self, "FBLOCK", bFBlock, "B", 1001 ) ) + ENDIF + + RETURN ::bFBlock + +METHOD hasFocus() CLASS PUSHBUTTON + RETURN ::lHasFocus + +METHOD message( cMessage ) CLASS PUSHBUTTON + + IF cMessage != NIL + ::cMessage := _eInstVar( Self, "MESSAGE", cMessage, "C", 1001 ) + ENDIF + + RETURN ::cMessage + +METHOD row( nRow ) CLASS PUSHBUTTON + + IF nRow != NIL + ::nRow := _eInstVar( Self, "ROW", nRow, "N", 1001 ) + ENDIF + + RETURN ::nRow + +METHOD sBlock( bSBlock ) CLASS PUSHBUTTON + + IF PCount() > 0 + ::bSBlock := iif( bSBlock == NIL, NIL, _eInstVar( Self, "SBLOCK", bSBlock, "B", 1001 ) ) + ENDIF + + RETURN ::bSBlock + +METHOD typeOut() CLASS PUSHBUTTON + RETURN .F. + +METHOD style( cStyle ) CLASS PUSHBUTTON + + IF cStyle != NIL + ::cStyle := _eInstVar( Self, "STYLE", cStyle, "C", 1001, {|| Len( cStyle ) == 0 .OR. Len( cStyle ) == 2 .OR. Len( cStyle ) == 8 } ) + ENDIF + + RETURN ::cStyle + +METHOD New( nRow, nCol, cCaption ) CLASS PUSHBUTTON + + LOCAL cColor + + IF !ISNUMBER( nRow ) .OR. ; + !ISNUMBER( nCol ) + RETURN NIL + ENDIF - LOCAL oPushButton DEFAULT cCaption TO "" - oPushButton := Pushbutton( Row(), Col(), cCaption ) + ::caption := cCaption + ::nCol := nCol + ::nRow := nRow - IF ! ISNIL( oPushButton ) - oPushButton:Caption := cCaption - oPushButton:ColorSpec := cColor - oPushButton:Message := cMessage - oPushButton:Style := cStyle - oPushButton:fBlock := bFBlock - oPushButton:sBlock := bSBlock + IF IsDefColor() + ::cColorSpec := "W/N,N/W,W+/N,W+/N" + ELSE + cColor := SetColor() + ::cColorSpec := __GUIColor( cColor, CLR_UNSELECTED + 1 ) + "," +; + __GUIColor( cColor, CLR_ENHANCED + 1 ) + "," +; + __GUIColor( cColor, CLR_STANDARD + 1 ) + "," +; + __GUIColor( cColor, CLR_BACKGROUND + 1 ) ENDIF -RETURN oPushButton + RETURN Self -FUNCTION _GETNUMCOL( cColor ) +FUNCTION PushButton( nRow, nCol, cCaption ) + RETURN HBPushButton():New( nRow, nCol, cCaption ) - STATIC s_aColors := { { "N+", 8 }, { "B+", 9 }, { "G+", 10 }, ; - { "BG+", 11 }, { "R+", 12 }, { "RB+", 13 }, ; - { "GR+", 14 }, { "W+", 15 }, { "BG", 3 }, ; - { "RB", 5 }, { "GR", 6 }, { "B", 1 }, ; - { "G", 2 }, { "R", 4 }, { "W", 7 } } - LOCAL nPos +FUNCTION _PUSHBUTT_( cCaption, cMessage, cColorSpec, bFBlock, bSBlock, cStyle, nSizeX, nSizeY, nCapXOff, nCapYOff, cBitmap, nBmpXOff, nBmpYOff ) + LOCAL o := HBPushButton():New( Row(), Col(), cCaption ) - IF ( nPos := At( "/", cColor ) ) > 0 - cColor := LEFT( cColor, nPos - 1 ) - ENDIF + o:message := cMessage + o:colorSpec := cColorSpec + o:fBlock := bFBlock + o:sBlock := bSBlock + o:style := cStyle + o:sizeX := nSizeX + o:sizeY := nSizeY + o:capXOff := nCapXOff + o:capYOff := nCapYOff + o:bitmap := cBitmap + o:bmpXOff := nBmpXOff + o:bmpYOff := nBmpYOff - nPos := AScan( s_aColors, { | a | a[ 1 ] == cColor } ) + RETURN o - IF nPos > 0 - RETURN s_aColors[ nPos, 2 ] - ENDIF - -RETURN 0 #endif diff --git a/harbour/source/rtl/radiobtn.prg b/harbour/source/rtl/radiobtn.prg index 435139b1b4..90f35f0b45 100644 --- a/harbour/source/rtl/radiobtn.prg +++ b/harbour/source/rtl/radiobtn.prg @@ -50,250 +50,331 @@ * */ - #include "hbclass.ch" -#include "common.ch" + #include "button.ch" +#include "color.ch" +#include "common.ch" + +/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but + it has all related variables and methods. */ + +/* NOTE: CA-Cl*pper 5.3 uses a mixture of QQOut(), DevOut(), Disp*() + functions to generate screen output. Harbour uses Disp*() + functions only. [vszakats] */ #ifdef HB_COMPAT_C53 -CREATE CLASS RADIOBUTTON FUNCTION HBRadioButton + +CREATE CLASS RADIOBUTTN FUNCTION HBRadioButton EXPORT: - DATA Buffer - DATA CapRow - DATA CapCol - DATA Caption - DATA Cargo - DATA Col - DATA pData - DATA ColorSpec - DATA fBlock - DATA HasFocus - DATA Row - DATA sBlock - DATA Style + VAR cargo /* NOTE: CA-Clipper 5.3 has a bug, where this var is filled with NIL everytime its value is read ( cargo := o:cargo ). */ + + METHOD display() + METHOD hitTest( nRow, nCol ) + METHOD isAccel( xKey ) + METHOD killFocus() + METHOD select( lState ) + METHOD setFocus() + + METHOD bitmaps( aBitmaps ) SETGET + METHOD buffer() SETGET + METHOD data( cData ) SETGET /* NOTE: Undocumented CA-Cl*pper 5.3 method. */ + METHOD capCol( nCapCol ) SETGET + METHOD capRow( nCapRow ) SETGET + METHOD caption( cCaption ) SETGET + METHOD col( nCol ) SETGET + METHOD colorSpec( cColorSpec ) SETGET + METHOD fBlock( bFBlock ) SETGET + METHOD hasFocus() SETGET + METHOD row( nRow ) SETGET + METHOD sBlock( bSBlock ) SETGET + METHOD style( cStyle ) SETGET + + METHOD New( nRow, nCol, cCaption, cData ) /* NOTE: This method is a Harbour extension [vszakats] */ + + PROTECTED: + + VAR aBitmaps INIT { "radio_f.bmu", "radio_e.bmu" } + VAR lBuffer INIT .F. + VAR cData + VAR nCapCol + VAR nCapRow + VAR cCaption + VAR nCol + VAR cColorSpec + VAR bFBlock + VAR lHasFocus INIT .F. + VAR nRow + VAR bSBlock + VAR cStyle INIT "(* )" - METHOD SetData(xData) - ACCESS Data inline ::SetData() - ASSIGN Data(xData) inline if(xData!=NIL,::SetData(xData),) - METHOD Display() - METHOD HitTest(nrow,nCol) - METHOD IsAccel(xVal) - METHOD KillFocus() - MESSAGE Select(lVal) METHOD _Select(LVal) - METHOD SetFocus() - METHOD New( nRow, nCol, cCaption, xData ) ENDCLASS -METHOD NEW( nRow, nCol, cCaption, xData ) CLASS RadioButton +METHOD setFocus() CLASS RADIOBUTTN - LOCAL cColor - - ::Buffer := .f. - ::CapRow := nRow - ::CapCol := nCol+3+1 - ::Caption := cCaption - ::Cargo := NIL - ::Col := nCol - - IF IsDefColor() - ::ColorSpec:="W/N,W+/N,W+/N,N/W,W/N,W/N,W+/N" - ELSE - cColor := SetColor() - ::ColorSpec := __guicolor(cColor, 5) + "," + ; - __guicolor(cColor, 5) + "," + ; - __guicolor(cColor, 2) + "," + ; - __guicolor(cColor, 2) + "," + ; - __guicolor(cColor, 1) + "," + ; - __guicolor(cColor, 1) + "," + ; - __guicolor(cColor, 4) - ENDIF - - ::fBlock := NIL - - ::HasFocus := .f. - ::Row := nRow - ::sBlock := nil - - ::Style := "(* )" - ::Data := xData - -RETURN Self - -METHOD SETFOCUS() CLASS RadioButton - - IF ! ::hasfocus - ::hasfocus := .T. + IF !::lHasFocus + ::lHasFocus := .T. ::display() - IF ISBLOCK( ::fblock ) - Eval(::fblock) + + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) ENDIF ENDIF -RETURN Self + RETURN Self -METHOD _SELECT(lStatus) CLASS RadioButton +METHOD select( lState ) CLASS RADIOBUTTN - local lOldBuffer := ::Buffer - if ISLOGICAL( lStatus ) - ::Buffer := lStatus - else - ::Buffer := !::Buffer - endif + LOCAL lOldState := ::lBuffer - if lOldBuffer != ::Buffer .AND. ISBLOCK( ::sBlock ) - Eval( ::sBlock ) - endif + ::lBuffer := iif( ISLOGICAL( lState ), lState, !::lBuffer ) -RETURN self + IF lOldState != ::lBuffer .AND. ; + ISBLOCK( ::bSBlock ) -METHOD KILLFOCUS() CLASS RadioButton + Eval( ::bSBlock ) + ENDIF + + RETURN Self + +METHOD killFocus() CLASS RADIOBUTTN - if ::HasFocus - ::HasFocus := .F. - if ISBLOCK( ::fBlock ) - eval(::fBlock) - endif + IF ::lHasFocus + ::lHasFocus := .F. + + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) + ENDIF + ::display() - endif + ENDIF -RETURN Self + RETURN Self -METHOD DISPLAY() CLASS RadioButton +METHOD display() CLASS RADIOBUTTN - local cColor := SetColor(), cCurStyle, nCurRow := Row(), nCurCol := Col(),; - nPos, cPairs4, cOldCaption + LOCAL cOldColor := SetColor() + LOCAL nOldRow := Row() + LOCAL nOldCol := Col() + LOCAL lOldMCur := MSetCursor( .F. ) - cPairs4 := __guicolor( ::colorspec, IIF( ::hasfocus, 7, 6 ) ) + LOCAL cStyle := ::cStyle + LOCAL nPos + LOCAL cOldCaption - cCurStyle := ::Style + DispBegin() - dispbegin() + SetColor( iif( ::lBuffer, __GUIColor( ::cColorSpec, 4 ), __GUIColor( ::cColorSpec, 2 ) ) ) + SetPos( ::nRow, ::nCol ) + DispOut( Left( cStyle, 1 ) ) + DispOut( iif( ::lBuffer, SubStr( cStyle, 2, 1 ), SubStr( cStyle, 3, 1 ) ) ) + DispOut( Right( cStyle, 1 ) ) - set color to ( __guicolor( ::colorspec, IIF( ::Buffer, 4, 2 ) ) ) + IF !Empty( cOldCaption := ::cCaption ) - SetPos(::Row, ::Col) - ?? Left(cCurStyle, 1) - - if ::Buffer - ?? SubStr(cCurStyle, 2, 1) - else - ?? SubStr(cCurStyle, 3, 1) - endif - - ?? right(cCurStyle, 1) - - if !Empty(cOldCaption := ::Caption) - if ( nPos := At("&", cOldCaption) ) == 0 - elseif nPos == Len(cOldCaption) + IF ( nPos := At( "&", cOldCaption ) ) == 0 + ELSEIF nPos == Len( cOldCaption ) nPos := 0 - else - cOldCaption := stuff(cOldCaption, nPos, 1, "") - endif - set color to (__guicolor(::ColorSpec, 5)) - SetPos(::CapRow, ::CapCol) - ?? cOldCaption - if nPos != 0 - set color to (cPairs4) - SetPos(::CapRow, ::CapCol + nPos - 1) - ?? SubStr(cOldCaption, nPos, 1) - endif - endif - dispend() - set color to (cColor) - SetPos(nCurRow, nCurCol) + ELSE + cOldCaption := Stuff( cOldCaption, nPos, 1, "" ) + ENDIF -RETURN Self + DispOutAt( ::nCapRow, ::nCapCol, cOldCaption, __GUIColor( ::cColorSpec, 5 ) ) -METHOD ISACCEL( xValue ) CLASS RadioButton + IF nPos != 0 + DispOutAt( ::nCapRow, ::nCapCol + nPos - 1, SubStr( cOldCaption, nPos, 1 ), iif( ::lHasfocus, __GUIColor( ::cColorSpec, 7 ), __GUIColor( ::cColorSpec, 6 ) ) ) + ENDIF + ENDIF + + DispEnd() + + MSetCursor( lOldMCur ) + SetColor( cOldColor ) + SetPos( nOldRow, nOldCol ) + + RETURN Self + +METHOD isAccel( xKey ) CLASS RADIOBUTTN - LOCAL nPos, cCaption, xResult + LOCAL nPos + LOCAL cCaption - IF ISNUMBER( xValue ) - xValue := Chr(xValue) - ELSEIF ! ISCHARACTER( xValue ) + IF ISNUMBER( xKey ) + xKey := Chr( xKey ) + ELSEIF !ISCHARACTER( xKey ) RETURN .F. ENDIF - xValue := Lower(xValue) - cCaption := ::Caption + cCaption := ::cCaption - IF ( nPos := At("&", cCaption) ) != 0 - xResult := Lower( SubStr( cCaption, nPos + 1, 1 ) ) - IF nPos < Len( cCaption ) .AND. xResult == xValue - RETURN .T. - ENDIF - ENDIF + RETURN ( nPos := At( "&", cCaption ) ) > 0 .AND. ; + Lower( SubStr( cCaption, nPos + 1, 1 ) ) == Lower( xKey ) -RETURN .F. +METHOD hitTest( nRow, nCol ) CLASS RADIOBUTTN -METHOD HITTEST( nRow, nCol ) CLASS RadioButton + LOCAL nPos + LOCAL nLen - LOCAL nPos, nLen - - IF nRow == ::Row .AND. nCol >= ::Col .AND. nCol < ::Col + 3 + IF nRow == ::Row .AND. ; + nCol >= ::Col .AND. ; + nCol < ::Col + 3 RETURN HTCLIENT ENDIF - nLen := Len(::Caption) + nLen := Len( ::cCaption ) - IF ( nPos := At("&", ::Caption) ) != 0 .AND. nPos < nLen + IF ( nPos := At( "&", ::cCaption ) ) == 0 .AND. nPos < nLen nLen-- ENDIF - IF nRow == ::CapRow .AND. nCol >= ::CapCol .AND. nCol < ::CapCol + nLen + IF nRow == ::CapRow .AND. ; + nCol >= ::CapCol .AND. ; + nCol < ::CapCol + nLen RETURN HTCLIENT ENDIF -RETURN HTNOWHERE + RETURN HTNOWHERE -METHOD SETDATA( xData ) CLASS RadioButton +METHOD bitmaps( aBitmaps ) CLASS RADIOBUTTN + + IF aBitmaps != NIL + ::aBitmaps := _eInstVar( Self, "BITMAPS", aBitmaps, "A", 1001, {|| Len( aBitmaps ) == 2 } ) + ENDIF + + RETURN ::aBitmaps + +METHOD buffer() CLASS RADIOBUTTN + RETURN ::lBuffer + +METHOD data( cData ) CLASS RADIOBUTTN - IF PCount() != 0 - IF ISNIL( xData ) - ::pData := xData - ELSE - ::pData := iif( valtype( xData ) == "C", xData, "" ) - ENDIF - ENDIF - IF ISNIL( ::pData ) - RETURN __caption( ::Caption ) + IF PCount() > 0 + ::cData := iif( cData == NIL, NIL, _eInstVar( Self, "DATA", cData, "C", 1001 ) ) ENDIF -RETURN ::pData + RETURN iif( ::cData == NIL, __Caption( ::Caption ), ::cData ) -FUNCTION RADIOBUTTO( nRow, nCol, cCaption, xData ) +METHOD capCol( nCapCol ) CLASS RADIOBUTTN - DEFAULT cCaption TO "" - - IF ISNUMBER( nRow ) .and. ISNUMBER( nCol ) - RETURN HBRadioButton():New( nRow, nCol, cCaption, xData ) + IF nCapCol != NIL + ::nCapCol := _eInstVar( Self, "CAPCOL", nCapCol, "N", 1001 ) ENDIF -RETURN NIL + RETURN ::nCapCol + +METHOD capRow( nCapRow ) CLASS RADIOBUTTN + + IF nCapRow != NIL + ::nCapRow := _eInstVar( Self, "CAPROW", nCapRow, "N", 1001 ) + ENDIF + + RETURN ::nCapRow + +METHOD caption( cCaption ) CLASS RADIOBUTTN + + IF cCaption != NIL + ::cCaption := _eInstVar( Self, "CAPTION", cCaption, "C", 1001 ) + ENDIF + + RETURN ::cCaption + +METHOD col( nCol ) CLASS RADIOBUTTN + + IF nCol != NIL + ::nCol := _eInstVar( Self, "COL", nCol, "N", 1001 ) + ENDIF + + RETURN ::nCol + +METHOD colorSpec( cColorSpec ) CLASS RADIOBUTTN + + IF cColorSpec != NIL + ::cColorSpec := _eInstVar( Self, "COLORSPEC", cColorSpec, "C", 1001,; + {|| !Empty( __GUIColor( cColorSpec, 7 ) ) .AND. Empty( __GUIColor( cColorSpec, 8 ) ) } ) + ENDIF + + RETURN ::cColorSpec + +METHOD fBlock( bFBlock ) CLASS RADIOBUTTN + + IF PCount() > 0 + ::bFBlock := iif( bFBlock == NIL, NIL, _eInstVar( Self, "FBLOCK", bFBlock, "B", 1001 ) ) + ENDIF + + RETURN ::bFBlock + +METHOD hasFocus() CLASS RADIOBUTTN + RETURN ::lHasFocus + +METHOD row( nRow ) CLASS RADIOBUTTN + + IF nRow != NIL + ::nRow := _eInstVar( Self, "ROW", nRow, "N", 1001 ) + ENDIF + + RETURN ::nRow + +METHOD sBlock( bSBlock ) CLASS RADIOBUTTN + + IF PCount() > 0 + ::bSBlock := iif( bSBlock == NIL, NIL, _eInstVar( Self, "SBLOCK", bSBlock, "B", 1001 ) ) + ENDIF + + RETURN ::bSBlock + +METHOD style( cStyle ) CLASS RADIOBUTTN + + IF cStyle != NIL + ::cStyle := _eInstVar( Self, "STYLE", cStyle, "C", 1001, {|| Len( cStyle ) == 0 .OR. Len( cStyle ) == 4 } ) + ENDIF + + RETURN ::cStyle + +METHOD New( nRow, nCol, cCaption, cData ) CLASS RADIOBUTTN + + LOCAL cColor + + IF !ISNUMBER( nRow ) .OR. ; + !ISNUMBER( nCol ) + RETURN NIL + ENDIF + + IF !ISCHARACTER( cCaption ) + cCaption := "" + ENDIF + + ::nCapRow := nRow + ::nCapCol := nCol + 3 + 1 + ::cCaption := cCaption + ::nCol := nCol + ::nRow := nRow + ::cData := cData /* NOTE: Every type is allowed here to be fully compatible */ + + IF IsDefColor() + ::cColorSpec := "W/N,W+/N,W+/N,N/W,W/N,W/N,W+/N" + ELSE + cColor := SetColor() + ::cColorSpec := __GUIColor( cColor, CLR_UNSELECTED + 1 ) + "," +; + __GUIColor( cColor, CLR_UNSELECTED + 1 ) + "," +; + __GUIColor( cColor, CLR_ENHANCED + 1 ) + "," +; + __GUIColor( cColor, CLR_ENHANCED + 1 ) + "," +; + __GUIColor( cColor, CLR_STANDARD + 1 ) + "," +; + __GUIColor( cColor, CLR_STANDARD + 1 ) + "," +; + __GUIColor( cColor, CLR_BACKGROUND + 1 ) + ENDIF + + RETURN Self + +FUNCTION RadioButto( nRow, nCol, cCaption, cData ) /* NOTE: cData argument is undocumented */ + RETURN HBRadioButton():New( nRow, nCol, cCaption, cData ) #ifdef HB_EXTENSION -FUNCTION RADIOBUTTON( nRow, nCol, cCaption, xData ) - DEFAULT cCaption TO "" - - IF ISNUMBER( nRow ) .and. ISNUMBER( nCol ) - RETURN HBRadioButton():New( nRow, nCol, cCaption, xData ) - ENDIF - -RETURN NIL -#endif - -/** Return the Caption Letter of an Given Caption String */ -FUNCTION __CAPTION( cCaption ) - - local nPos - - if ( nPos := At("&", cCaption) ) > 0 - cCaption := stuff(cCaption, nPos, 1, "") - endif - -RETURN cCaption +FUNCTION RadioButton( nRow, nCol, cCaption, cData ) /* NOTE: cData argument is undocumented */ + RETURN HBRadioButton():New( nRow, nCol, cCaption, cData ) + +#endif #endif diff --git a/harbour/source/rtl/radiogrp.prg b/harbour/source/rtl/radiogrp.prg index b3691022a3..e578d5fdc3 100644 --- a/harbour/source/rtl/radiogrp.prg +++ b/harbour/source/rtl/radiogrp.prg @@ -9,7 +9,7 @@ * Copyright 2000 Luiz Rafael Culik * www - http://www.harbour-project.org * - * This program is free software; you can redistribute it and/or modify + * This program is free software; you can redistribute it and/or modIFy * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. @@ -20,14 +20,14 @@ * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to + * along with this software; see the file COPYING. IF not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). * * As a special exception, the Harbour Project gives permission for * additional uses of the text contained in its release of Harbour. * - * The exception is that, if you link the Harbour libraries with other + * The exception is that, IF you link the Harbour libraries with other * files to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of @@ -37,470 +37,637 @@ * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the Harbour - * Project under the name Harbour. If you copy code from other + * Project under the name Harbour. IF you copy code from other * Harbour Project or Free Software Foundation releases into a copy of * Harbour, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete + * anyone as to the status of such modIFied files, you must delete * this exception notice from them. * - * If you write modifications of your own for Harbour, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. + * IF you write modIFications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modIFications. + * IF you do not wish that, delete this exception notice. * */ #include "hbclass.ch" -#include "common.ch" + #include "button.ch" +#include "color.ch" +#include "common.ch" +#include "setcurs.ch" + +/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but + it has all related variables and methods. */ + +/* NOTE: CA-Cl*pper 5.3 uses a mixture of QQOut(), DevOut(), Disp*() + functions to generate screen output. Harbour uses Disp*() + functions only. [vszakats] */ #ifdef HB_COMPAT_C53 + CREATE CLASS RADIOGROUP FUNCTION HBRadioGroup -exported: + EXPORT: - METHOD AddItem( xItem ) - METHOD DelItem( xItem ) - METHOD Display() - METHOD GetAccel( xItem ) - METHOD GetItem( Xitem ) - METHOD HitTest( nRow, nCol ) - METHOD InsItem( nPos, oButtom ) - METHOD KillFocus( ) - METHOD NextItem( ) - METHOD PrevItem( ) - MESSAGE Select( xItem ) METHOD _Select( xItem ) - MESSAGE SetColor( xItem ) METHOD _SetColor( xItem ) - METHOD SetFocus( ) - METHOD SetStyle( xItem ) - METHOD New( nTop, nLeft, nBottom, nRight ) -// METHOD GetColor( xColor ) - DATA Bottom + VAR cargo - DATA Buffer INIT NIL - DATA CapCol - DATA CapRow - DATA Caption - DATA Cargo INIT NIL - DATA ColdBox INIT "ÚÄ¿³ÙÄÀ³" - DATA fBlock INIT NIL - DATA HasFocus INIT .F. - DATA HotBox INIT "ÉÍ»º¼ÍȺ" - DATA ItemCount INIT 0 - DATA Left - DATA Message INIT "" + METHOD addItem( oRadioButton ) + METHOD delItem( oRadioButton ) + METHOD display() + METHOD getAccel( oRadioButton ) + METHOD getItem( oRadioButton ) + METHOD hitTest( nMouseRow, nMouseCol ) + METHOD insItem( nPos, oRadioButton ) + METHOD killFocus() + METHOD nextItem() + METHOD prevItem() + METHOD select( xPos ) + METHOD setColor( cColorSpec ) + METHOD setFocus() + METHOD setStyle( cStyle ) - DATA Right - DATA aItems INIT {} - DATA lCursor INIT 0 + METHOD bottom( nBottom ) SETGET + METHOD buffer() SETGET + METHOD capCol( nCapCol ) SETGET + METHOD capRow( nCapRow ) SETGET + METHOD caption( cCaption ) SETGET + METHOD coldBox( cColdBox ) SETGET + METHOD colorSpec( cColorSpec ) SETGET + METHOD fBlock( bFBlock ) SETGET + METHOD hasFocus() SETGET + METHOD hotBox( cHotBox ) SETGET + METHOD itemCount() SETGET + METHOD left( nLeft ) SETGET + METHOD message( cMessage ) SETGET + METHOD right( nRight ) SETGET + METHOD textValue() SETGET /* NOTE: Undocumented CA-Cl*pper var. */ + METHOD top( nTop ) SETGET + METHOD typeOut() SETGET + METHOD value() SETGET /* NOTE: Undocumented CA-Cl*pper var. */ - DATA TextValue INIT "" + METHOD New( nTop, nLeft, nBottom, nRight ) /* NOTE: This method is a Harbour extension [vszakats] */ - DATA Top - DATA TypeOut INIT .F. + PROTECTED: - DATA Value INIT 0 - DATA Color - Data colorspec INIT "" -// ASSIGN Colorspec( xColor ) inline IIF( xColor != NIL, ::GetColor( xColor ), ) + VAR nBottom + VAR xBuffer + VAR nCapCol + VAR nCapRow + VAR cCaption INIT "" + VAR cColdBox INIT Chr( 218 ) + Chr( 196 ) + Chr( 191 ) + Chr( 179 ) + Chr( 217 ) + Chr( 196 ) + Chr( 192 ) + Chr( 179 ) + VAR cColorSpec + VAR bFBlock + VAR lHasFocus INIT .F. + VAR cHotBox INIT Chr( 201 ) + Chr( 205 ) + Chr( 187 ) + Chr( 186 ) + Chr( 188 ) + Chr( 205 ) + Chr( 200 ) + Chr( 186 ) + VAR nItemCount INIT 0 + VAR nLeft + VAR cMessage INIT "" + VAR nRight + VAR cTextValue INIT "" + VAR nTop + VAR nValue INIT 0 + + VAR aItems INIT {} + VAR nCursor INIT 0 + + METHOD changeButton( xVal, nPos ) ENDCLASS -METHOD New( nTop, nLeft, nBottom, nRight ) CLASS RadioGroup +METHOD addItem( oRadioButton ) CLASS RADIOGROUP - LOCAL cColor + IF ISOBJECT( oRadioButton ) .AND. oRadioButton:ClassName() == "RADIOBUTTN" + AAdd( ::aItems, oRadioButton ) + ::nItemCount++ + ENDIF - IF IsDefColor() - ::ColorSpec := "W/N,W/N,W+/N" + RETURN Self + +METHOD delItem( nPos ) CLASS RADIOGROUP + + IF nPos >= 1 .AND. nPos <= ::nItemCount + Adel( ::aItems[ nPos ] ) + ASize( ::aItems, --::nItemCount ) + ENDIF + + IF ::lHasFocus .AND. ::nItemCount < ::nValue + ::nValue := ::nItemCount + ::cTextValue := ::aItems[ ::nValue ]:data + ::xBuffer := iif( ISNUMBER( ::xBuffer ), ::nValue, ::cTextValue ) + ENDIF + + RETURN Self + +METHOD display() CLASS RADIOGROUP + + LOCAL cOldColor := SetColor() + LOCAL nOldRow := Row() + LOCAL nOldCol := Col() + LOCAL lOldMCur := MSetCursor( .F. ) + + LOCAL cSelBox + LOCAL cUnSelBox + LOCAL cCaption + LOCAL nPos + + DispBegin() + + IF ::lHasFocus + cSelBox := ::cHotBox + cUnSelBox := ::cColdbox ELSE - cColor := SetColor() - ::ColorSpec := __guicolor(cColor, 3) + "," + ; - __guicolor(cColor, 1) + "," + ; - __guicolor(cColor, 4) + cSelBox := ::cColdbox + cUnSelBox := ::cHotBox ENDIF - ::Bottom := nBottom - ::CapCol := nLeft+2 - ::CapRow := nTop - ::Left := nLeft - ::right := nRight - ::top := nTop + SetColor( __GUIColor( ::cColorSpec, 1 ) ) -RETURN Self - -METHOD ADDITEM( xItem ) CLASS RadioGroup - - IF ISOBJECT( xItem ) .AND. xItem:classname() == "RADIOBUTTON" - AAdd( ::aItems, xItem ) - ::ItemCount++ + IF !Empty( cSelBox ) + DispBox( ::nTop, ::nLeft, ::nBottom, ::nRight, cSelBox ) + ELSEIF !Empty( cUnSelBox ) + DispBox( ::nTop, ::nLeft, ::nBottom, ::nRight, cUnSelBox ) ENDIF -RETURN Self + IF !Empty( cCaption := ::cCaption ) -METHOD SETSTYLE( xStyle ) CLASS RadioGroup - - LOCAL oItems - - FOR EACH oItems IN ::aItems - oItems:style( xStyle ) - NEXT - -RETURN Self - -METHOD SETFOCUS() CLASS RadioGroup - - LOCAL oItem - - IF ! ::HasFocus - ::lCursor := setcursor(0) - ::HasFocus := .T. - - dispbegin() - - FOR EACH oItem IN ::aItems - oItem:SetFocus() - NEXT - - ::display() - dispend() - - IF ISBLOCK( ::fBlock ) - Eval( ::fBlock ) - ENDIF - - ENDIF - -RETURN Self - -METHOD _SETCOLOR( cColor ) CLASS RadioGroup - - LOCAL oItem - - FOR EACH oItem IN ::aItems - oItem:ColorSpec := cColor - NEXT - -RETURN Self - -METHOD _SELECT( xValue ) CLASS RadioGroup - - LOCAL nPos, nLen, cType := ValType( xValue ) - - IF cType == "C" - nLen := ::ItemCount - FOR nPos := 1 to nLen - IF ::aItems[ nPos ]:data == xValue - default ::Buffer to "" - changebutt( self, ::Value, nPos ) - EXIT + IF !( ( nPos := At( "&", cCaption ) ) == 0 ) + IF nPos == Len( cCaption ) + nPos := 0 + ELSE + cCaption := Stuff( cCaption, nPos, 1, "" ) ENDIF - NEXT - - IF nPos > nLen - ::Buffer := xValue ENDIF - ELSEIF cType != "U" .AND. xValue >= 1 .AND. xValue <= ::ItemCount + DispOutAt( ::nCapRow, ::nCapCol, cCaption, __GUIColor( ::cColorSpec, 2 ) ) - default ::Buffer to 0 - changebutt( self, ::Value, xValue ) - - ENDIF - -RETURN Self - -METHOD PREVITEM() CLASS RadioGroup - - LOCAL nPos, xValue - - IF ::HasFocus .AND. ::ItemCount > 0 - SWITCH ( xValue := ::Value ) - CASE 0 - nPos := 1 - CASE 1 - nPos := ::ItemCount - OTHERWISE - nPos := xValue - 1 - END - changebutt( self, xValue, nPos ) - ENDIF - -RETURN self - -METHOD NEXTITEM() CLASS RadioGroup - - LOCAL xValue, nPos - - IF ::HasFocus .AND. ::ItemCount > 0 - IF ( xValue := ::Value ) == ::ItemCount - nPos := 1 - ELSE - nPos := xValue + 1 - ENDIF - changebutt( self, xValue, nPos ) - ENDIF - -RETURN Self - -METHOD KILLFOCUS() CLASS RadioGroup - - LOCAL oItem - - IF ::HasFocus - - ::HasFocus := .F. - IF ISBLOCK( ::fBlock ) - Eval( ::fBlock ) + IF nPos != 0 + DispOutAt( ::nCapRow, ::nCapCol + nPos - 1, SubStr( cCaption, nPos, 1 ), __GUIColor( ::cColorSpec, 3 ) ) ENDIF - dispbegin() - FOR EACH oItem IN ::aItems - oItem:killfocus() - NEXT - ::display() - dispend() - - setcursor( ::lCursor ) ENDIF -RETURN self + AEval( ::aItems, {| o | o:display() } ) -METHOD INSITEM( nPos, oButtom ) CLASS RadioGroup + DispEnd() - IF ISOBJECT( oButtom ) .AND. oButtom:classname() == "RADIOBUTTON" .AND. ; - nPos < ::ItemCount + MSetCursor( lOldMCur ) + SetColor( cOldColor ) + SetPos( nOldRow, nOldCol ) - ASize( ::aItems, ++::ItemCount ) - AIns( ::aItems, nPos ) - ::aItems[ nPos ] := oButtom + RETURN Self - ENDIF +METHOD getAccel( xValue ) CLASS RADIOGROUP -RETURN ::aItems[ nPos ] - -METHOD HITTEST( nRow, nCol ) CLASS RadioGroup - - LOCAL nPos, nCount, aItem := ::aItems, nLen, nPosition - - nCount := ::ItemCount DO CASE - CASE Empty( ::Coldbox + ::HotBox ) - CASE nRow == ::Top - IF nCol == ::Left + CASE ISNUMBER( xValue ) + xValue := Chr( xValue ) + CASE !ISCHARACTER( xValue ) + RETURN 0 + ENDCASE + + xValue := Lower( xValue ) + + RETURN AScan( ::aItems, {| o | o:isAccel( xValue ) } ) + +METHOD getItem( nPos ) CLASS RADIOGROUP + RETURN iif( nPos >= 1 .AND. nPos <= ::nItemCount, ::aItems[ nPos ], NIL ) + +METHOD hitTest( nMouseRow, nMouseCol ) CLASS RADIOGROUP + + LOCAL nLen + LOCAL nPos + LOCAL aItems + + DO CASE + CASE Empty( ::cColdbox + ::cHotBox ) + CASE nMouseRow == ::nTop + IF nMouseCol == ::nLeft RETURN HTTOPLEFT - ELSEIF nCol == ::Right + ELSEIF nMouseCol == ::nRight RETURN HTTOPRIGHT - ELSEIF nCol >= ::Left .AND. nCol <= ::Right + ELSEIF nMouseCol >= ::nLeft .AND. nMouseCol <= ::nRight RETURN HTTOP ENDIF - CASE nRow == ::Bottom - IF nCol == ::Left + CASE nMouseRow == ::nBottom + IF nMouseCol == ::nLeft RETURN HTBOTTOMLEFT - ELSEIF nCol == ::Right - RETURN HTBOTTOMRIGHT - ELSEIF nCol >= ::Left .AND. nCol <= ::Right + ELSEIF nMouseCol == ::nRight RETURN HTBOTTOM + ELSEIF nMouseCol >= ::nLeft .AND. nMouseCol <= ::nRight + RETURN HTBOTTOMRIGHT ENDIF - CASE nCol == ::Left - IF nRow >= ::Top .AND. nRow <= ::Bottom + CASE nMouseCol == ::nLeft + IF nMouseRow >= ::nTop .AND. nMouseRow <= ::nBottom RETURN HTLEFT ELSE RETURN HTNOWHERE ENDIF - CASE nCol == ::Right - IF nRow >= ::Top .AND. nRow <= ::Bottom + CASE nMouseCol == ::nRight + IF nMouseRow >= ::nTop .AND. nMouseRow <= ::nBottom RETURN HTRIGHT ELSE RETURN HTNOWHERE ENDIF ENDCASE - nLen := Len( ::Caption ) - IF ( nPosition := AT( "&", ::Caption ) ) != 0 .AND. nPosition < nLen + nLen := Len( ::cCaption ) + + IF ( nPos := At( "&", ::cCaption ) ) == 0 + ELSEIF nPos < nLen nLen-- ENDIF - IF !Empty( ::Caption ) .AND. nRow == ::CapRow .AND. ; - nCol >= ::CapCol .AND. nCol < ::CapCol + nLen - + DO CASE + CASE Empty( ::cCaption ) + CASE nMouseRow != ::nCapRow + CASE nMouseCol < ::nCapCol + CASE nMouseCol < ::nCapCol + nLen RETURN HTCAPTION - ENDIF + ENDCASE - IF nRow >= ::Top .AND. nRow <= ::Bottom .AND. ; - nCol >= ::Left .AND. nCol <= ::Right - - FOR nPos := 1 to nCount - IF aItem[ nPos ]:hittest( nRow, nCol ) != 0 + DO CASE + CASE nMouseRow < ::nTop + CASE nMouseRow > ::nBottom + CASE nMouseCol < ::nLeft + CASE nMouseCol <= ::nRight + aItems := ::aItems + nLen := ::nItemCount + FOR nPos := 1 TO nLen + IF aItems[ nPos ]:hitTest( nMouseRow, nMouseCol ) != HTNOWHERE RETURN nPos ENDIF NEXT RETURN HTCLIENT + ENDCASE + + RETURN HTNOWHERE + +METHOD insItem( nPos, oRadioButtom ) CLASS RADIOGROUP + + IF ISOBJECT( oRadioButtom ) .AND. oRadioButtom:ClassName() == "RADIOBUTTN" .AND. ; + nPos < ::nItemCount + + ASize( ::aItems, ++::nItemCount ) + AIns( ::aItems, nPos, oRadioButtom ) + ::aItems[ nPos ] := oRadioButtom ENDIF -RETURN HTNOWHERE + RETURN ::aItems[ nPos ] -METHOD GETITEM( nPos ) CLASS RadioGroup +METHOD killFocus() CLASS RADIOGROUP - IF nPos >= 1 .AND. nPos <= ::ItemCount - RETURN ::aItems[ nPos ] - ENDIF + LOCAL nPos + LOCAL nLen + LOCAL aItems -RETURN NIL + LOCAL nCurMCur -METHOD GETACCEL( xValue ) CLASS RadioGroup + IF ::lHasFocus - LOCAL oItem + ::lHasFocus := .F. - IF ISNUMBER( xValue ) - xValue := Chr( xValue ) - ELSEIF !ISCHARACTER( xValue ) - RETURN 0 - ENDIF - - xValue := Lower( xValue ) - - FOR EACH oItem IN ::aItems - IF oItem:isaccel( xValue ) - RETURN oItem:__enumIndex() - ENDIF - NEXT - -RETURN 0 - -METHOD DISPLAY() CLASS RadioGroup - - LOCAL cColor := SetColor(), nCurRow := Row(), nCurCol := Col(), ; - cSelBox, cUnSelBox, cCaption, nPosition, oItem - - dispbegin() - - IF ::HasFocus - cSelBox := ::HotBox - cUnSelBox := ::Coldbox - ELSE - cSelBox := ::Coldbox - cUnSelBox := ::HotBox - ENDIF - - set color to ( __guicolor( ::ColorSpec, 1 ) ) - - IF !Empty( cSelBox ) - @ ::Top, ::Left, ::Bottom, ::Right box cSelBox - ELSEIF !Empty( cUnSelBox ) - @ ::Top, ::Left, ::Bottom, ::Right box cUnSelBox - ENDIF - - IF !Empty( cCaption := ::Caption ) - - IF ( nPosition := At("&", cCaption) ) != 0 - IF nPosition == Len( cCaption ) - nPosition := 0 - ELSE - cCaption := stuff( cCaption, nPosition, 1, "" ) - ENDIF + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) ENDIF - set color to ( __guicolor( ::ColorSpec, 2 ) ) - SetPos( ::CapRow, ::CapCol ) - ?? cCaption + aItems := ::aItems + nLen := ::nItemCount - IF nPosition != 0 - set color to ( __guicolor( ::ColorSpec, 3 ) ) - SetPos( ::CapRow, ::CapCol + nPosition - 1 ) - ?? SubStr( cCaption, nPosition, 1 ) - ENDIF - ENDIF + nCurMCur := MSetCursor( .F. ) - FOR EACH oItem IN ::aItems - oItem:Display() - NEXT + DispBegin() - dispend() - - set color to ( cColor ) - SetPos( nCurRow, nCurCol ) - -RETURN self - -METHOD DELITEM( xItem ) CLASS RadioGroup - - IF xItem >= 1 .AND. xItem <= ::ItemCount - ADel( ::aItems[ xItem ] ) - ASize( ::aItems, --::ItemCount ) - ENDIF - - IF ::HasFocus .AND. ::ItemCount < ::Value - ::Value := ::ItemCount - ::TextValue := ::aItems[ ::Value ]:data - ::Buffer := IIF( ISNUMBER( ::Buffer ), ::Value, ::TextValue ) - ENDIF - -RETURN Self - -/* -METHOD GetColor(xColor) CLASS RadioGroup - IF ! ISNIL( xColor ) - ::Color := iif( Valtype( xColor ) == "C" .and. ; - !Empty( __guicolor( xColor, 3 ) ) .AND. ; - Empty( __guicolor( xColor, 4 ) ), xColor, ) - ENDIF -RETURN ::Color -*/ - -STATIC FUNCTION CHANGEBUTT( oItems, xVal, nPos ) - - IF xVal != nPos - - dispbegin() - IF xVal > 0 - oItems:aItems[ xVal ]:select( .F. ) - oItems:aItems[ xVal ]:display() - ENDIF - IF nPos > 0 - oItems:aItems[ nPos ]:select( .T. ) - oItems:aItems[ nPos ]:display() - ENDIF - dispend() - - oItems:Value := nPos - oItems:TextValue := oItems:aItems[ nPos ]:data - oItems:Buffer := IIF( ISNUMBER( oItems:Buffer ), nPos, oItems:TextValue ) - ENDIF - -RETURN .T. - -// Radio Group Class Constructor Function -FUNCTION RADIOGROUP( nTop, nLeft, nBottom, nRight ) - - IF ISNUMBER( nTop ) .and. ; - ISNUMBER( nLeft ) .and. ; - ISNUMBER( nBottom ) .and. ; - ISNUMBER( nRight ) - RETURN HBRadioGroup():New( nTop, nLeft, nBottom, nRight ) - ENDIF - -RETURN NIL - - -FUNCTION _RADIOGRP_( nTop, nLeft, nBottom, nRight, xValue, aItems, cCaption, ; - cMessage, cColor, bFblock ) - - LOCAL oRadioGroup, xItem - - IF ! ISNIL( oRadioGroup := radiogroup( nTop, nLeft, nBottom, nRight ) ) - - oRadioGroup:caption := IIF( ISNIL( cCaption ), "", cCaption ) - oRadioGroup:colorspec := cColor - oRadioGroup:message := cMessage - oRadioGroup:fblock := bFblock - - FOR EACH xItem IN aItems - oRadioGroup:additem( xItem ) + FOR nPos := 1 TO nLen + aItems[ nPos ]:killFocus() NEXT - oRadioGroup:select( xValue ) + ::display() + + DispEnd() + + MSetCursor( nCurMCur ) + SetCursor( ::nCursor ) + ENDIF -RETURN oRadioGroup + RETURN Self + +METHOD setFocus() CLASS RADIOGROUP + + LOCAL nPos + LOCAL nLen + LOCAL aItems + + LOCAL nCurMCur + + IF !::lHasFocus + + ::nCursor := SetCursor( SC_NONE ) + ::lHasFocus := .T. + + aItems := ::aItems + nLen := ::nItemCount + + nCurMCur := MSetCursor( .F. ) + + DispBegin() + + FOR nPos := 1 TO nLen + aItems[ nPos ]:setFocus() + NEXT + + ::display() + + DispEnd() + + MSetCursor( nCurMCur ) + + IF ISBLOCK( ::bFBlock ) + Eval( ::bFBlock ) + ENDIF + ENDIF + + RETURN Self + +METHOD nextItem() CLASS RADIOGROUP + LOCAL nValue + + IF ::lHasFocus .AND. ::nItemCount > 0 + ::changeButton( nValue := ::nValue, iif( nValue == ::nItemCount, 1, nValue + 1 ) ) + ENDIF + + RETURN Self + +METHOD prevItem() CLASS RADIOGROUP + + LOCAL nValue + LOCAL nPos + + IF ::lHasFocus .AND. ::nItemCount > 0 + + nValue := ::nValue + + DO CASE + CASE nValue == 0 ; nPos := 1 + CASE nValue == 1 ; nPos := ::nItemCount + OTHERWISE ; nPos := nValue - 1 + ENDCASE + + ::changeButton( nValue, nPos ) + + ENDIF + + RETURN Self + +METHOD select( xValue ) CLASS RADIOGROUP + + LOCAL cType := ValType( xValue ) + LOCAL nPos + LOCAL nLen + + IF cType == "C" + + nLen := ::nItemCount + FOR nPos := 1 TO nLen + IF ::aItems[ nPos ]:data == xValue + + DEFAULT ::xBuffer TO "" + ::changeButton( ::nValue, nPos ) + + EXIT + ENDIF + NEXT + + IF nPos > nLen + ::xBuffer := xValue + ENDIF + + ELSEIF cType == "N" .AND. xValue >= 1 .AND. xValue <= ::nItemCount + + DEFAULT ::xBuffer TO 0 + ::changeButton( ::nValue, xValue ) + + ENDIF + + RETURN Self + +METHOD setColor( cColorSpec ) CLASS RADIOGROUP + + LOCAL nPos + LOCAL nLen := ::nItemCount + LOCAL aItems := ::aItems + + FOR nPos := 1 TO nLen + aItems[ nPos ]:colorSpec := cColorSpec + NEXT + + RETURN Self + +METHOD setStyle( cStyle ) CLASS RADIOGROUP + + LOCAL nPos + LOCAL nLen := ::nItemCount + LOCAL aItems := ::aItems + + FOR nPos := 1 TO nLen + aItems[ nPos ]:style := cStyle + NEXT + + RETURN Self + +METHOD changeButton( nUnselect, nSelect ) CLASS RADIOGROUP + LOCAL nCurMCur := MSetCursor( .F. ) + + IF nUnselect != nSelect + + DispBegin() + + IF nUnselect > 0 + ::aItems[ nUnselect ]:select( .F. ) + ::aItems[ nUnselect ]:display() + ENDIF + IF nSelect > 0 + ::aItems[ nSelect ]:select( .T. ) + ::aItems[ nSelect ]:display() + ENDIF + + DispEnd() + + ::nValue := nSelect + ::cTextValue := ::aItems[ nSelect ]:data + ::xBuffer := iif( ISNUMBER( ::xBuffer ), nSelect, ::cTextValue ) + + ENDIF + + MSetCursor( nCurMCur ) + + RETURN Self + +METHOD bottom( nBottom ) CLASS RADIOGROUP + + IF nBottom != NIL + ::nBottom := _eInstVar( Self, "BOTTOM", nBottom, "N", 1001 ) + ENDIF + + RETURN ::nBottom + +METHOD buffer() CLASS RADIOGROUP + RETURN ::xBuffer + +METHOD capCol( nCapCol ) CLASS RADIOGROUP + + IF nCapCol != NIL + ::nCapCol := _eInstVar( Self, "CAPCOL", nCapCol, "N", 1001 ) + ENDIF + + RETURN ::nCapCol + +METHOD capRow( nCapRow ) CLASS RADIOGROUP + + IF nCapRow != NIL + ::nCapRow := _eInstVar( Self, "CAPROW", nCapRow, "N", 1001 ) + ENDIF + + RETURN ::nCapRow + +METHOD caption( cCaption ) CLASS RADIOGROUP + + IF cCaption != NIL + ::cCaption := _eInstVar( Self, "CAPTION", cCaption, "C", 1001 ) + ENDIF + + RETURN ::cCaption + +METHOD coldBox( cColdBox ) CLASS RADIOGROUP + + IF cColdBox != NIL + ::cColdBox := _eInstVar( Self, "COLDBOX", cColdBox, "C", 1001, {|| Len( cColdBox ) == 0 .OR. Len( cColdBox ) == 8 } ) + ENDIF + + RETURN ::cColdBox + +METHOD colorSpec( cColorSpec ) CLASS RADIOGROUP + + IF cColorSpec != NIL + ::cColorSpec := _eInstVar( Self, "COLORSPEC", cColorSpec, "C", 1001,; + {|| !Empty( __GUIColor( cColorSpec, 3 ) ) .AND. Empty( __GUIColor( cColorSpec, 4 ) ) } ) + ENDIF + + RETURN ::cColorSpec + +METHOD fBlock( bFBlock ) CLASS RADIOGROUP + + IF PCount() > 0 + ::bFBlock := iif( bFBlock == NIL, NIL, _eInstVar( Self, "FBLOCK", bFBlock, "B", 1001 ) ) + ENDIF + + RETURN ::bFBlock + +METHOD hasFocus() CLASS RADIOGROUP + RETURN ::lHasFocus + +METHOD hotBox( cHotBox ) CLASS RADIOGROUP + + IF cHotBox != NIL + ::cHotBox := _eInstVar( Self, "HOTBOX", cHotBox, "C", 1001, {|| Len( cHotBox ) == 0 .OR. Len( cHotBox ) == 8 } ) + ENDIF + + RETURN ::cHotBox + +METHOD itemCount() CLASS RADIOGROUP + RETURN ::nItemCount + +METHOD left( nLeft ) CLASS RADIOGROUP + + IF nLeft != NIL + ::nLeft := _eInstVar( Self, "LEFT", nLeft, "N", 1001 ) + ENDIF + + RETURN ::nLeft + +METHOD message( cMessage ) CLASS RADIOGROUP + + IF cMessage != NIL + ::cMessage := _eInstVar( Self, "MESSAGE", cMessage, "C", 1001 ) + ENDIF + + RETURN ::cMessage + +METHOD right( nRight ) CLASS RADIOGROUP + + IF nRight != NIL + ::nRight := _eInstVar( Self, "RIGHT", nRight, "N", 1001 ) + ENDIF + + RETURN ::nRight + +METHOD textValue() CLASS RADIOGROUP + RETURN ::cTextValue + +METHOD top( nTop ) CLASS RADIOGROUP + + IF nTop != NIL + ::nTop := _eInstVar( Self, "TOP", nTop, "N", 1001 ) + ENDIF + + RETURN ::nTop + +METHOD typeOut() CLASS RADIOGROUP + RETURN ::nItemCount == 0 .OR. ::nValue > ::nItemCount + +METHOD value() CLASS RADIOGROUP + RETURN ::nValue + +METHOD New( nTop, nLeft, nBottom, nRight ) CLASS RADIOGROUP + + LOCAL cColor + + IF !ISNUMBER( nTop ) .OR. ; + !ISNUMBER( nLeft ) .OR. ; + !ISNUMBER( nBottom ) .OR. ; + !ISNUMBER( nRight ) + RETURN NIL + ENDIF + + ::nTop := nTop + ::nLeft := nLeft + ::nBottom := nBottom + ::nRight := nRight + ::nCapCol := nLeft + 2 + ::nCapRow := nTop + + IF IsDefColor() + ::cColorSpec := "W/N,W/N,W+/N" + ELSE + cColor := SetColor() + ::cColorSpec := __GUIColor( cColor, CLR_BORDER + 1 ) + "," + ; + __GUIColor( cColor, CLR_STANDARD + 1 ) + "," + ; + __GUIColor( cColor, CLR_BACKGROUND + 1 ) + ENDIF + + RETURN Self + +FUNCTION RadioGroup( nTop, nLeft, nBottom, nRight ) + RETURN HBRadioGroup():New( nTop, nLeft, nBottom, nRight ) + +FUNCTION _RADIOGRP_( nTop, nLeft, nBottom, nRight, xValue, aItems, cCaption, cMessage, cColorSpec, bFBlock ) + + LOCAL o := RadioGroup( nTop, nLeft, nBottom, nRight ) + + IF o != NIL + + o:caption := cCaption + o:message := cMessage + o:colorSpec := cColorSpec + o:fBlock := bFBlock + + AEval( aItems, {| aItem | o:AddItem( aItem ) } ) + + o:select( xValue ) + + ENDIF + + RETURN o #endif diff --git a/harbour/source/rtl/scrollbr.prg b/harbour/source/rtl/scrollbr.prg index b466f0b4ff..90bd785f25 100644 --- a/harbour/source/rtl/scrollbr.prg +++ b/harbour/source/rtl/scrollbr.prg @@ -1,496 +1,469 @@ - /* - * $Id$ - */ +/* + * $Id$ + */ - /* - * Harbour Project source code: - * ScrollBar class - * - * Copyright 2000 Luiz Rafael Culik - * www - http://www.harbour-project.org - * - * Copyright 2005 Alejandro de Garate - * METHOD SetStyle( cStyle ) - * METHOD SetColor( cColor ) - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). - * - * As a special exception, the Harbour Project gives permission for - * additional uses of the text contained in its release of Harbour. - * - * The exception is that, if you link the Harbour libraries with other - * files to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the Harbour library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the Harbour - * Project under the name Harbour. If you copy code from other - * Harbour Project or Free Software Foundation releases into a copy of - * Harbour, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for Harbour, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - */ +/* + * Harbour Project source code: + * ScrollBar class + * + * Copyright 2000 Luiz Rafael Culik + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ - #include "hbclass.ch" - #include "color.ch" - #include "common.ch" - #include "button.ch" +#include "hbclass.ch" +#include "button.ch" +#include "color.ch" +#include "common.ch" + +/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but + it has all related variables and methods. */ + +/* NOTE: CA-Cl*pper 5.3 uses a mixture of QQOut(), DevOut(), Disp*() + functions to generate screen output. Harbour uses Disp*() + functions only. [vszakats] */ #ifdef HB_COMPAT_C53 -// new definitions for better coding. Are screen Codepage dependent, but -// can be changed with the setStyle method. -#define SB_UPARROW CHR(24) -#define SB_TRACK CHR(178) -#define SB_THUMB CHR(254) -#define SB_DNARROW CHR(25) -#define SB_LEFTARROW CHR(27) -#define SB_RIGHTARROW CHR(26) +CREATE CLASS SCROLLBAR FUNCTION HBScrollBar -#define SB_VERT_SCROLL 1 -#define SB_HORZ_SCROLL 2 + EXPORT: -// converted to macro to speed up things... -#define __GuiColor( cPair, nPos) (hb_colorindex( cPair, nPos - 1)) + VAR ClassName INIT "SCROLLBAR" -CLASS HBScrollBar + VAR cargo - DATA BarLength INIT 1 // 1er error (no tenia INIT 1) - DATA Cargo - DATA sBlock - DATA Style - DATA ClassName INIT "HBSCROLLBAR" - DATA ColorSpec - DATA aStyle // Note: new instance var for old Harbour versions to - // speed up displaying,