fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2007-09-07 03:38 UTC+0100 Viktor Szakats (harbour.01 syenar.hu)

Browse Source 
* 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.
This commit is contained in:
Viktor Szakats
2007-09-07 02:00:07 +00:00
parent 97a50084a6
commit 1b46bf32b9
32 changed files with 9100 additions and 7056 deletions
Download Patch File Download Diff File Expand all files Collapse all files

59
harbour/ChangeLog
View File

@@ -8,6 +8,65 @@
2002-12-01 13:30 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
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

13
harbour/common.mak
View File

@@ -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) \

11
harbour/include/button.ch
View File

@@ -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

18
harbour/include/hbextern.ch
View File

@@ -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 */

4
harbour/source/rtl/Makefile
View File

@@ -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 \

426
harbour/source/rtl/checkbox.prg
View File

@@ -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

10
harbour/source/rtl/einstvar.prg
View File

@@ -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

10
harbour/source/rtl/getlist.prg
View File

@@ -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

237
harbour/source/rtl/getsys.prg
View File

@@ -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( <aGetList>, <nKey>, <aMsg> ) --> 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

106
harbour/source/rtl/gui.prg Normal file
View File

@@ -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 <culik@sl.conex.net>
* 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

1951
harbour/source/rtl/listbox.prg
View File

File diff suppressed because it is too large Load Diff

222
harbour/source/rtl/memoedit.prg
View File

@@ -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

166
harbour/source/rtl/menusys.prg Normal file
View File

@@ -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 <lsevilla@nddc.edu.ph>
* 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

205
harbour/source/rtl/mssgline.prg
View File

@@ -1,205 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Message Line Class
*
* Copyright 2002 Larry Sevilla <lsevilla@nddc.edu.ph>
* 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( <aMsg>, <lMode> ) --> .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

462
harbour/source/rtl/pushbtn.prg
View File

@@ -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

445
harbour/source/rtl/radiobtn.prg
View File

@@ -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

925
harbour/source/rtl/radiogrp.prg
View File

File diff suppressed because it is too large Load Diff

717
harbour/source/rtl/scrollbr.prg
View File

@@ -1,496 +1,469 @@
/*
* $Id$
*/
/*
* $Id$
*/
/*
* Harbour Project source code:
* ScrollBar class
*
* Copyright 2000 Luiz Rafael Culik <culik@sl.conex.net>
* www - http://www.harbour-project.org
*
* Copyright 2005 Alejandro de Garate <alex_degarate@hotmail.com>
* 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 <culik@sl.conex.net>
* 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, <Style> instance var is conserved
// for compatibility purpose. [Alejandro de Garate]
METHOD barLength() SETGET
METHOD bitmaps( aBitmaps ) SETGET
METHOD colorSpec( cColorSpec ) SETGET
METHOD current( nCurrent ) SETGET
METHOD end( nEnd ) SETGET
METHOD offset( nOffset ) SETGET
METHOD orient( nOrient ) SETGET
METHOD sBlock( bSBlock ) SETGET
METHOD start( nStart ) SETGET
METHOD style( cStyle ) SETGET
METHOD thumbPos( nThumbPos ) SETGET
METHOD total( nTotal ) SETGET
METHOD Display()
METHOD HitTest()
METHOD Update()
METHOD New( nStart, nEnd, nOffSet, bsBlock, nOrient )
ACCESS Current inline ::GetCurrent()
ASSIGN Current( nCurrent ) inline ::GetCurrent( nCurrent )
ACCESS End inline ::GetEnd()
ASSIGN End ( nEnd ) inline ::GetEnd( nEnd )
ACCESS OffSet inline ::GetOffSet()
ASSIGN OffSet( nOffSet ) inline ::GetOffSet( nOffSet )
ACCESS Orient inline ::GetOrient()
ASSIGN Orient( nOrient ) inline ::GetOrient( nOrient )
ACCESS Start inline ::GetStart()
ASSIGN Start( nStart ) inline ::GetStart( nStart )
ACCESS ThumbPos inline ::GetThumbPos()
ASSIGN ThumbPos( nPos ) inline ::GetThumbPos( nPos )
ACCESS TOTAL inline ::GetTotal()
ASSIGN TOTAL( nTotal ) inline ::GetTotal( nTotal )
METHOD display()
METHOD update()
METHOD hitTest()
DATA nCurrent INIT 0
DATA nEnd INIT 0
DATA nOffSet INIT 0
DATA nOrient INIT 0
DATA nStart INIT 0
DATA nThumbPos INIT 1
DATA nTotal INIT 100
DATA hb_p_lShow INIT .F.
METHOD New( nStart, nEnd, nOffset, bSBlock, nOrient ) /* NOTE: This method is a Harbour extension [vszakats] */
METHOD GetCurrent( nCurrent )
METHOD GetEnd( nEnd )
METHOD GetStart( nStart )
METHOD GetThumbPos( nPos )
METHOD GetTotal( nTotal )
METHOD GetOffSet( nOffSet )
METHOD GetOrient( nOrient )
METHOD SetStyle( cStyle )
METHOD SetColor( cColor )
PROTECTED:
VAR aBitmaps
VAR nBarLength
VAR cColorSpec
VAR cStyle
VAR nCurrent INIT 1
VAR nEnd INIT 0
VAR nOffset
VAR nOrient
VAR nStart INIT 0
VAR nThumbPos INIT 1
VAR nTotal INIT 100
VAR bSBlock
VAR lOverride INIT .F.
METHOD CalcThumbPos()
ENDCLASS
METHOD display() CLASS SCROLLBAR
// NEW METHOD !
METHOD SetStyle( cStyle ) CLASS HBScrollBar
IF LEN( cStyle ) == 4
::aStyle[ 1] := SUBSTR( cStyle, 1, 1)
::aStyle[ 2] := SUBSTR( cStyle, 2, 1)
::aStyle[ 3] := SUBSTR( cStyle, 3, 1)
::aStyle[ 4] := SUBSTR( cStyle, 4, 1)
::Style := cStyle
ENDIF
RETURN Self
LOCAL cOldColor
LOCAL nOldRow
LOCAL nOldCol
LOCAL lOldMCur
// NEW METHOD !
METHOD SetColor( cColor ) CLASS HBScrollBar
::ColorSpec := cColor
RETURN Self
METHOD New( nStart, nEnd, nOffSet, bsBlock, nOrient ) CLASS HBScrollBar
LOCAL cStyle, aStyle, cColor := Setcolor()
IF nOrient == SB_VERT_SCROLL
cStyle := "â–‘"
aStyle := { SB_UPARROW, SB_TRACK, SB_THUMB, SB_DNARROW }
ELSEIF nOrient == SB_HORZ_SCROLL
cStyle := "â–" + Chr(26)
aStyle := { SB_LEFTARROW, SB_TRACK, SB_THUMB, SB_RIGHTARROW }
ENDIF
::Style := aStyle[ 1] + aStyle[ 2] + aStyle[ 3] + aStyle[ 4]
::aStyle := aStyle
::BarLength := nEnd - nStart - 1
::Current := 1
::Cargo := NIL
::ColorSpec := __guicolor( cColor, CLR_UNSELECTED + 1 ) + "," + ;
__guicolor( cColor, CLR_ENHANCED + 1 )
::End := nEnd
::OffSet := nOffSet
::Orient := nOrient
::sBlock := bsBlock
::Start := nStart
::Thumbpos := 1
::Total := 1
RETURN Self
METHOD Display() CLASS HBScrollBar
LOCAL cCurColor := Setcolor()
LOCAL nCurRow := Row()
LOCAL nCurCol := Col()
LOCAL cOffSet, cColor2, cColor1
LOCAL cStyle
LOCAL nOffset
LOCAL nStart
LOCAL nEnd
LOCAL nPos
LOCAL lDisplay := .F.
IF ThumbPos( Self )
lDisplay := .T.
cOffSet := ::OffSet
IF ::CalcThumbPos()
cOldColor := SetColor()
nOldRow := Row()
nOldCol := Col()
lOldMCur := MSetCursor( .F. )
cStyle := ::cStyle
nOffset := ::nOffset
nStart := ::nStart
nEnd := ::nEnd - 1
DispBegin()
cColor1 := __guicolor( ::ColorSpec, 1 )
cColor2 := __guicolor( ::ColorSpec, 2 )
SetColor( __GUIColor( ::cColorSpec, 1 ) )
IF ::nOrient == SCROLL_VERTICAL
IF ::Orient == SB_VERT_SCROLL
nStart := ::Start
nEnd := ::End - 1
SET COLOR TO (cColor1)
FOR nPos := nStart + 1 TO nEnd
DispOutAt( nPos, cOffSet, ::aStyle[ 2 ] )
DispOutAt( nPos, nOffset, SubStr( cStyle, 2, 1 ) )
NEXT
SET COLOR TO (cColor2)
DispOutAt( nStart, cOffSet, ::aStyle[ 1 ] )
DispOutAt( nStart + ::ThumbPos, cOffSet, ::aStyle[ 3 ] )
DispOutAt( nEnd + 1, cOffSet, ::aStyle[ 4 ] )
SetColor( __GUIColor( ::cColorSpec, 2 ) )
DispOutAt( nStart, nOffset, SubStr( cStyle, 1, 1 ) )
DispOutAt( nStart + ::nThumbPos, nOffset, SubStr( cStyle, 3, 1 ) )
DispOutAt( nEnd + 1, nOffset, SubStr( cStyle, 4, 1 ) )
ELSE
nStart := ::Start
nEnd := ::End - 1
DispOutAt( nOffset, nStart + 1, Replicate( SubStr( cStyle, 2, 1 ), nEnd - nStart ) )
SetColor( __GUIColor( ::cColorSpec, 2 ) )
DispOutAt( nOffset, nStart, SubStr( cStyle, 1, 1 ) )
DispOutAt( nOffset, nStart + ::nThumbPos, SubStr( cStyle, 3, 1 ) )
DispOutAt( nOffset, nEnd + 1, SubStr( cStyle, 4, 1 ) )
DispOutAt( cOffSet, nStart +1, Replicate( ::aStyle[ 2 ], nEnd - nStart ), cColor1 )
ENDIF
DispEnd()
MSetCursor( lOldMCur )
SetColor( cOldColor )
SetPos( nOldRow, nOldCol )
SET COLOR TO (cColor2)
DispOutAt( cOffSet, nStart, ::aStyle[ 1 ] )
DispOutAt( cOffSet, nStart + ::ThumbPos, ::aStyle[ 3 ] )
DispOutAt( cOffSet, nEnd + 1, ::aStyle[ 4 ] )
RETURN .T.
ENDIF
RETURN .F.
METHOD update() CLASS SCROLLBAR
LOCAL nOldRow
LOCAL nOldCol
LOCAL lOldMCur
LOCAL nThumbPos
IF ISBLOCK( ::bSBlock )
Eval( ::bSBlock )
ENDIF
IF ::CalcThumbPos() .AND. nThumbPos != ::nThumbPos
nOldRow := Row()
nOldCol := Col()
lOldMCur := MSetCursor( .F. )
DispBegin()
nThumbPos := ::nThumbPos
IF ::nOrient == SCROLL_VERTICAL
DispOutAt( ::nStart + nThumbPos, ::nOffSet, SubStr( ::cStyle, 2, 1 ), __GUIColor( ::cColorSpec, 1 ) )
DispOutAt( ::nStart + nThumbPos, ::nOffset, SubStr( ::cStyle, 3, 1 ), __GUIColor( ::cColorSpec, 2 ) )
ELSE
DispOutAt( ::nOffset, ::nStart + nThumbPos, SubStr( ::cStyle, 2, 1 ), __GUIColor( ::cColorSpec, 1 ) )
DispOutAt( ::nOffset, ::nStart + nThumbPos, SubStr( ::cStyle, 3, 1 ), __GUIColor( ::cColorSpec, 2 ) )
ENDIF
DispEnd()
SET COLOR TO (cCurColor)
Setpos( nCurRow, nCurCol )
MSetCursor( lOldMCur )
SetPos( nOldRow, nOldCol )
RETURN .T.
ENDIF
RETURN lDisplay
RETURN .F.
METHOD hitTest( nRow, nCol ) CLASS SCROLLBAR
METHOD HitTest( nRow, nCol ) CLASS HBScrollBar
IF ::Orient == SB_VERT_SCROLL
IF ::nOrient == SCROLL_VERTICAL
DO CASE
CASE nCol != ::OffSet
CASE nRow < ::Start
CASE nRow > ::End
CASE nRow == ::Start
RETURN HTSCROLLUNITDEC
CASE nRow == ::End
RETURN HTSCROLLUNITINC
CASE nRow < ::ThumbPos + ::Start
RETURN HTSCROLLBLOCKDEC
CASE nRow > ::ThumbPos + ::Start
RETURN HTSCROLLBLOCKINC
CASE nRow == ::ThumbPos + ::Start
RETURN HTSCROLLTHUMBDRAG
CASE nCol != ::nOffset
CASE nRow < ::nStart
CASE nRow > ::nEnd
CASE nRow == ::nStart
RETURN HTSCROLLUNITDEC
CASE nRow == ::nEnd
RETURN HTSCROLLUNITINC
CASE nRow < ::nThumbPos + ::nStart
RETURN HTSCROLLBLOCKDEC
CASE nRow > ::nThumbPos + ::nStart
RETURN HTSCROLLBLOCKINC
CASE nRow == ::nThumbPos + ::nStart
RETURN HTSCROLLTHUMBDRAG
ENDCASE
IF nCol == ::OffSet + 1 .OR. nCol == ::OffSet
IF nCol == ::nOffset + 1 .OR. nCol == ::nOffset
DO CASE
CASE nCol != ::OffSet .AND. nCol != ::OffSet + 1
CASE nRow < ::Start
CASE nRow > ::End
CASE nRow == ::Start
RETURN HTSCROLLUNITDEC
CASE nRow == ::End
RETURN HTSCROLLUNITINC
CASE nRow < ::ThumbPos + ::Start
RETURN HTSCROLLBLOCKDEC
CASE nRow > ::ThumbPos + ::Start
RETURN HTSCROLLBLOCKINC
CASE nRow == ::ThumbPos + ::Start
RETURN HTSCROLLTHUMBDRAG
CASE nCol != ::nOffset .AND. nCol != ::nOffset + 1
CASE nRow < ::nStart
CASE nRow > ::nEnd
CASE nRow == ::nStart
RETURN HTSCROLLUNITDEC
CASE nRow == ::nEnd
RETURN HTSCROLLUNITINC
CASE nRow < ::nThumbPos + ::nStart
RETURN HTSCROLLBLOCKDEC
CASE nRow > ::nThumbPos + ::nStart
RETURN HTSCROLLBLOCKINC
CASE nRow == ::nThumbPos + ::nStart
RETURN HTSCROLLTHUMBDRAG
ENDCASE
ENDIF
ELSEIF ::Orient == SB_HORZ_SCROLL
ELSE
DO CASE
CASE nRow != ::OffSet
CASE nCol < ::Start
CASE nCol > ::End
CASE nCol == ::Start
RETURN HTSCROLLUNITDEC
CASE nCol == ::End
RETURN HTSCROLLUNITINC
CASE nCol < ::ThumbPos + ::Start
RETURN HTSCROLLBLOCKDEC
CASE nCol > ::ThumbPos + ::Start
RETURN HTSCROLLBLOCKINC
CASE nCol == ::ThumbPos + ::Start
RETURN HTSCROLLTHUMBDRAG
CASE nRow != ::nOffset
CASE nCol < ::nStart
CASE nCol > ::nEnd
CASE nCol == ::nStart
RETURN HTSCROLLUNITDEC
CASE nCol == ::nEnd
RETURN HTSCROLLUNITINC
CASE nCol < ::nThumbPos + ::nStart
RETURN HTSCROLLBLOCKDEC
CASE nCol > ::nThumbPos + ::nStart
RETURN HTSCROLLBLOCKINC
CASE nCol == ::nThumbPos + ::nStart
RETURN HTSCROLLTHUMBDRAG
ENDCASE
ENDIF
RETURN HTNOWHERE
RETURN HTNOWHERE
METHOD barLength() CLASS SCROLLBAR
RETURN ::nBarLength
METHOD Update() CLASS HBScrollBar
METHOD bitmaps( aBitmaps ) CLASS SCROLLBAR
LOCAL nCurRow, nCurCol
LOCAL lUpdated := .F.
LOCAL nThumbPos := ::ThumbPos
IF ISARRAY( aBitmaps ) .AND. ;
Len( aBitmaps ) == 3
IF !ThumbPos( Self )
ELSEIF nThumbPos != ::ThumbPos
lUpdated := .T.
nCurRow := Row()
nCurCol := Col()
DispBegin()
IF ::Orient == SB_VERT_SCROLL
DispOutAt( ::Start + nThumbPos, ::OffSet, ::aStyle[ 2 ], __guicolor( ::ColorSpec, 1 ) )
DispOutAt( ::Start + ::ThumbPos, ::OffSet, ::aStyle[ 3 ], __guicolor( ::ColorSpec, 2 ) )
ELSE
DispOutAt( ::OffSet, ::Start + nThumbPos, ::aStyle[ 2 ], __guicolor( ::ColorSpec, 1 ) )
DispOutAt( ::OffSet, ::Start + ::ThumbPos, ::aStyle[ 3 ], __guicolor( ::ColorSpec, 2 ) )
ENDIF
DispEnd()
SetPos( nCurRow, nCurCol )
::aBitmaps := aBitmaps
ENDIF
RETURN lUpdated
RETURN ::aBitmaps
METHOD colorSpec( cColorSpec ) CLASS SCROLLBAR
METHOD GetCurrent( nCurrent ) CLASS HBScrollBar
IF ISCHARACTER( cColorSpec ) .AND. ;
!Empty( __GUIColor( cColorSpec, 2 ) ) .AND. ;
Empty( __GUIColor( cColorSpec, 3 ) )
::cColorSpec := cColorSpec
ENDIF
RETURN ::cColorSpec
METHOD current( nCurrent ) CLASS SCROLLBAR
IF ISNUMBER( nCurrent ) .AND. ;
nCurrent <= ::nTotal .AND. ;
nCurrent != ::nCurrent
IF ! IsNumber( nCurrent )
ELSEIF nCurrent > ::nTotal
ELSEIF nCurrent != ::nCurrent
::nCurrent := nCurrent
ENDIF
RETURN ::nCurrent
RETURN ::nCurrent
METHOD end( nEnd ) CLASS SCROLLBAR
METHOD GetEnd( nEnd ) CLASS HBScrollBar
IF ISNUMBER( nEnd ) .AND. ;
nEnd >= ::nStart .AND. ;
nEnd != ::nEnd
IF !Isnumber( nEnd )
ELSEIF nEnd < ::nStart
ELSEIF nEnd != ::nEnd
::nEnd := nEnd
::BarLength := nEnd - ::nStart - 1
::nEnd := nEnd
::nBarLength := nEnd - ::nStart - 1
ENDIF
RETURN ::nEnd
RETURN ::nEnd
METHOD offset( nOffset ) CLASS SCROLLBAR
METHOD GetOffSet( nOffSet ) CLASS HBScrollBar
IF ISNUMBER( nOffset ) .AND. ;
nOffset != ::nOffset
IF ! IsNumber( nOffSet )
ELSEIF nOffSet != ::nOffSet
::nOffSet := nOffSet
::nOffset := nOffset
ENDIF
RETURN ::nOffSet
RETURN ::nOffset
METHOD orient( nOrient ) CLASS SCROLLBAR
METHOD GetOrient( nOrient ) CLASS HBScrollBar
IF ISNUMBER( nOrient ) .AND. ;
( nOrient == SCROLL_VERTICAL .OR. nOrient == SCROLL_HORIZONTAL )
IF ! IsNumber( nOrient )
ELSEIF nOrient == SB_VERT_SCROLL .OR. nOrient == SB_HORZ_SCROLL
::nOrient := nOrient
ENDIF
RETURN ::nOrient
RETURN ::nOrient
METHOD sBlock( bSBlock ) CLASS SCROLLBAR
METHOD GetStart( nStart ) CLASS HBScrollBar
IF ! IsNumber( nStart )
ELSEIF nStart > ::End
ELSEIF nStart != ::nStart
::nStart := nStart
::BarLength := ::nEnd - nStart - 1
IF ISBLOCK( bSBlock )
::bSBlock := bSBlock
ENDIF
RETURN ::nStart
RETURN ::bSBlock
METHOD start( nStart ) CLASS SCROLLBAR
METHOD GetThumbPos( nPos ) CLASS HBScrollBar
IF ISNUMBER( nStart ) .AND. ;
nStart <= ::nEnd .AND. ;
nStart != ::nStart
IF IsNumber( nPos )
IF nPos < 1
::nStart := nStart
::nBarLength := ::nEnd - nStart - 1
ENDIF
RETURN ::nStart
METHOD style( cStyle ) CLASS SCROLLBAR
IF ISCHARACTER( cStyle ) .AND. ;
Len( cStyle ) == 4
::cStyle := cStyle
ENDIF
RETURN ::cStyle
METHOD thumbPos( nThumbPos ) CLASS SCROLLBAR
IF ISNUMBER( nThumbPos )
IF nThumbPos < 1
::nThumbPos := 1
ELSEIF nPos >= ::BarLength
::nThumbPos := ::BarLength
ELSEIF nPos >= ::BarLength - 1
::nThumbPos := nPos
ELSEIF nThumbPos >= ::nBarLength
::nThumbPos := ::nBarLength
ELSEIF nThumbPos >= ::nBarLength - 1
::nThumbPos := nThumbPos
ELSE
::nThumbPos := nPos
ENDIF
IF nPos == 0
::hb_p_lShow := .F.
ELSE
::hb_p_lShow := .T.
::nThumbPos := nThumbPos
ENDIF
::lOverride := ( nThumbPos != 0 )
ENDIF
RETURN ::nThumbPos
RETURN ::nThumbPos
METHOD total( nTotal ) CLASS SCROLLBAR
METHOD GetTotal( nTotal ) CLASS HBScrollBar
IF ISNUMBER( nTotal ) .AND. ;
nTotal >= 2 .AND. ;
nTotal != ::nTotal
IF ! IsNumber( nTotal )
ELSEIF nTotal < 2
ELSEIF nTotal != ::nTotal
::nTotal := nTotal
ENDIF
RETURN ::nTotal
RETURN ::nTotal
METHOD CalcThumbPos() CLASS SCROLLBAR
STATIC FUNCTION ThumbPos( oScroll )
LOCAL nBarLength := ::nBarLength
LOCAL nTotal := ::nTotal
LOCAL nSize
LOCAL nCurrent
LOCAL nBarLength
LOCAL nTotal
IF oScroll:barLength < 2
IF nBarLength < 2 .OR. nTotal < 2
RETURN .F.
ENDIF
IF oScroll:total < 2
RETURN .F.
IF !::lOverride
::ThumbPos := Min( Max( Round( ( ( nBarLength - 1 ) * ::nCurrent + nTotal - 2 * nBarLength + 1 ) / ( nTotal - nBarLength ), 0 ), 1 ), nBarLength )
ENDIF
/*
IF oScroll:hb_p_lShow
RETURN .T.
ENDIF
*/
RETURN .T.
nCurrent := oScroll:Current
nBarLength := oScroll:BarLength
nTotal := oScroll:Total
/* New definitions for better coding. These are screen codepage dependent,
but can be changed with the setStyle method. */
#define SB_UPARROW Chr( 24 )
#define SB_DNARROW Chr( 25 )
#define SB_THUMB Chr( 176 )
#define SB_TRACK Chr( 178 )
#define SB_LEFTARROW Chr( 27 )
#define SB_RIGHTARROW Chr( 26 )
// percent relative to total
nSize := (100 * nCurrent / nTotal)
METHOD New( nStart, nEnd, nOffset, bSBlock, nOrient ) CLASS SCROLLBAR
// percent relative to nBarLength
nSize := (nBarLength * nSize / 100)
LOCAL cColor
// remove decimal point
nSize := IIF( nSize < (nBarLength / 2), ROUND( nSize, 0), INT( nSize) )
DEFAULT nOrient TO SCROLL_VERTICAL
IF nSize <= 1
if (nCurrent > 1)
nSize := 2
else
nSize := 1
endif
ENDIF
IF nSize >= nBarLength
if (nCurrent < nTotal)
nSize := nBarLength - 1
else
nSize := nBarLength
endif
ENDIF
if (nCurrent == 1)
nSize := 1
elseif (nCurrent == nTotal)
nSize := nBarLength
endif
oScroll:ThumbPos := nSize
RETURN .T.
FUNCTION SCROLLBAR( nStart, nEnd, nOffSet, bsBlock, nOrient )
IF !( IsNumber( nStart ) ) .OR. !( Isnumber( nEnd ) ) .OR.;
!( IsNumber( nOffSet )) .OR. !( IsNumber( nOrient ) )
IF !ISNUMBER( nStart ) .OR. ;
!ISNUMBER( nEnd ) .OR. ;
!ISNUMBER( nOffset ) .OR. ;
!ValType( bSBlock ) $ "BU" .OR. ;
!ISNUMBER( nOrient ) .OR. ;
( nOrient != SCROLL_VERTICAL .AND. nOrient != SCROLL_HORIZONTAL )
RETURN NIL
ENDIF
IF nOrient == NIL
nOrient := SB_VERT_SCROLL
::end := nEnd
::offSet := nOffset
::orient := nOrient
::sBlock := bSBlock
::start := nStart
::nBarLength := nEnd - nStart - 1
IF nOrient == SCROLL_VERTICAL
::cStyle := SB_UPARROW + SB_THUMB + SB_TRACK + SB_DNARROW
::aBitmaps := { "arrow_u.bmu", "arrow_d.bmu", "arrow_e.bmu" }
ELSEIF nOrient == SCROLL_HORIZONTAL
::cStyle := SB_LEFTARROW + SB_THUMB + SB_TRACK + SB_RIGHTARROW
::aBitmaps := { "arrow_l.bmu", "arrow_r.bmu", "arrow_e.bmu" }
ENDIF
RETURN HBScrollBar():New( nStart, nEnd, nOffSet, bsBlock, nOrient )
cColor := SetColor()
::cColorSpec := __GUIColor( cColor, CLR_UNSELECTED + 1 ) + "," + ;
__GUIColor( cColor, CLR_ENHANCED + 1 )
RETURN Self
FUNCTION Scrollbar( nStart, nEnd, nOffset, bSBlock, nOrient )
RETURN HBScrollBar():New( nStart, nEnd, nOffset, bSBlock, nOrient )
#endif

202
harbour/source/rtl/tbcolumn.prg
View File

@@ -54,102 +54,176 @@
#include "common.ch"
#include "tbrowse.ch"
CLASS TBColumn
/* NOTE: In CA-Cl*pper TBCOLUMN class does not inherit from any other classes
and there is no public class function like TBColumn(). There is
in XPP though. */
DATA Block // Code block to retrieve data for the column
DATA Cargo // User-definable variable
DATA ColorBlock // Code block that determines color of data items
DATA ColSep // Column separator character
DATA DefColor INIT { 1, 2, 1, 1 } // Array of numeric indexes into the color table
DATA Heading // Column heading
/* NOTE: ::Footing needs to be initialized to an empty string or TBrowse()::WriteMLineText() does not work
if there are columns which have a footing and others which don't. */
DATA Footing INIT "" // Column footing
DATA FootSep INIT "" // Footing separator character
DATA HeadSep // Heading separator character
DATA Picture // Column picture string
#ifdef HB_COMPAT_C53
DATA PreBlock // Code block determining editing
DATA PostBlock // Code block validating values
#endif
ACCESS Width INLINE ::nWidth // Column display width
ASSIGN Width( nWidth ) INLINE ::SetWidth( nWidth )
CREATE CLASS TBColumn
// NOTE: 17/08/01 - <maurilio.longo@libero.it>
// It is not correct in my opinion that this instance variable be exported
DATA ColPos INIT 1 // Temporary column position on screen needed by TBrowse class
METHOD New( cHeading, bBlock ) // Constructor
EXPORT:
#ifdef HB_COMPAT_C53
METHOD SetStyle( nMode, lSetting )
VAR cargo // User-definable variable
VAR picture // Column picture string
METHOD block( bBlock ) SETGET // Code block to retrieve data for the column
METHOD colorBlock( bColorBlock ) SETGET // Code block that determines color of data items
METHOD defColor( aDefColor ) SETGET // Array of numeric indexes into the color table
METHOD colSep( cColSep ) SETGET // Column separator character
METHOD heading( cHeading ) SETGET // Column heading
METHOD footing( cFooting ) SETGET // Column footing
METHOD headSep( cHeadSep ) SETGET // Heading separator character
METHOD footSep( cFootSep ) SETGET // Footing separator character
METHOD width( nWidth ) SETGET // Column display width
#ifdef HB_COMPAT_C53
METHOD preBlock( bPreBlock ) SETGET // Code block determining editing
METHOD postBlock( bPostBlock ) SETGET // Code block validating values
METHOD setStyle( nStyle, lSetting )
#endif
HIDDEN:
METHOD New( cHeading, bBlock ) /* NOTE: This method is a Harbour extension [vszakats] */
DATA nWidth
METHOD SetWidth( n )
PROTECTED:
VAR bBlock
VAR bColorBlock INIT {|| NIL }
VAR aDefColor INIT { 1, 2 } /* NOTE: Default value for both CA-Cl*pper 5.2 and 5.3. */
VAR cColSep
VAR cHeading INIT ""
VAR cFooting INIT ""
VAR cFootSep
VAR cHeadSep
VAR nWidth
#ifdef HB_COMPAT_C53
DATA aSetStyle
VAR bPreBlock
VAR bPostBlock
VAR aSetStyle INIT { .F., .F., .F. } /* TBC_READWRITE, TBC_MOVE, TBC_SIZE */
#endif
ENDCLASS
METHOD New( cHeading, bBlock ) CLASS TBColumn
METHOD block( bBlock ) CLASS TBColumn
DEFAULT cHeading TO ""
IF bBlock != NIL
::bBlock := _eInstVar( Self, "BLOCK", bBlock, "B", 1001 )
ENDIF
::Heading := cHeading
::block := bBlock
RETURN ::bBlock
#ifdef HB_COMPAT_C53
METHOD colorBlock( bColorBlock ) CLASS TBColumn
::aSetStyle := Array( TBC_CUSTOM - 1 )
IF bColorBlock != NIL
::bColorBlock := _eInstVar( Self, "COLORBLOCK", bColorBlock, "B", 1001 )
ENDIF
::aSetStyle[ TBC_READWRITE ] := .f.
::aSetStyle[ TBC_MOVE ] := .f.
::aSetStyle[ TBC_SIZE ] := .f.
RETURN ::bColorBlock
#endif
METHOD defColor( aDefColor ) CLASS TBColumn
return Self
IF aDefColor != NIL
::aDefColor := _eInstVar( Self, "DEFCOLOR", aDefColor, "A", 1001 )
ENDIF
RETURN ::aDefColor
METHOD SetWidth( nWidth ) CLASS TBColumn
METHOD colSep( cColSep ) CLASS TBColumn
/* NOTE: CA-Cl*pper won't allow the user to assign NIL to the :width variable. */
if nWidth != NIL
::nWidth := nWidth
endif
IF cColSep != NIL
::cColSep := _eInstVar( Self, "COLSEP", cColSep, "C", 1001 )
ENDIF
return nWidth
RETURN ::cColSep
METHOD heading( cHeading ) CLASS TBColumn
IF cHeading != NIL
::cHeading := _eInstVar( Self, "HEADING", cHeading, "C", 1001 )
ENDIF
RETURN ::cHeading
METHOD footing( cFooting ) CLASS TBColumn
IF cFooting != NIL
::cFooting := _eInstVar( Self, "FOOTING", cFooting, "C", 1001 )
ENDIF
RETURN ::cFooting
METHOD headSep( cHeadSep ) CLASS TBColumn
IF cHeadSep != NIL
::cHeadSep := _eInstVar( Self, "HEADSEP", cHeadSep, "C", 1001 )
ENDIF
RETURN ::cHeadSep
METHOD footSep( cFootSep ) CLASS TBColumn
IF cFootSep != NIL
::cFootSep := _eInstVar( Self, "FOOTSEP", cFootSep, "C", 1001 )
ENDIF
RETURN ::cFootSep
METHOD width( nWidth ) CLASS TBColumn
IF nWidth != NIL
::nWidth := _eInstVar( Self, "WIDTH", nWidth, "N", 1001 )
ENDIF
RETURN ::nWidth
#ifdef HB_COMPAT_C53
METHOD SetStyle( nMode, lSetting ) CLASS TBColumn
METHOD preBlock( bPreBlock ) CLASS TBColumn
local lRet := .F.
if nMode > Len( ::aSetStyle )
ASize( ::aSetStyle, nMode )
::aSetStyle[ nMode ] := .F.
endif
lRet := ::aSetStyle[ nMode ]
if ISLOGICAL( lSetting )
::aSetStyle[ nMode ] := lSetting
endif
IF bPreBlock != NIL
::bPreBlock := _eInstVar( Self, "PREBLOCK", bPreBlock, "B", 1001 )
ENDIF
return lRet
RETURN ::bPreBlock
METHOD postBlock( bPostBlock ) CLASS TBColumn
IF bPostBlock != NIL
::bPostBlock := _eInstVar( Self, "POSTBLOCK", bPostBlock, "B", 1001 )
ENDIF
RETURN ::bPostBlock
METHOD setStyle( nStyle, lNewValue ) CLASS TBColumn
/* NOTE: CA-Cl*pper 5.3 does no checks on the value of nStyle, so in case
it is zero or non-numeric, a regular RTE will happen. [vszakats] */
IF nStyle > Len( ::aSetStyle ) .AND. nStyle <= 4096 /* Some reasonable limit for maximum number of styles */
ASize( ::aSetStyle, nStyle )
ENDIF
IF ISLOGICAL( lNewValue )
::aSetStyle[ nStyle ] := lNewValue
ENDIF
RETURN ::aSetStyle[ nStyle ]
#endif
METHOD New( cHeading, bBlock ) CLASS TBColumn
function TBColumnNew(cHeading, bBlock)
/* NOTE: CA-Cl*pper will allow any types for the heading.
In Harbour this would cause various errors inside the object, so we're
not replicating this strange behaviour. [vszakats] */
return TBColumn():New(cHeading, bBlock)
#ifdef HB_C52_STRICT
::cHeading := cHeading
#else
IF ISCHARACTER( cHeading )
::cHeading := cHeading
ENDIF
#endif
::bBlock := bBlock /* NOTE: CA-Cl*pper allows any types here. [vszakats] */
RETURN Self
FUNCTION TBColumnNew( cHeading, bBlock )
RETURN TBColumn():New( cHeading, bBlock )

2274
harbour/source/rtl/tbrowse.prg
View File

File diff suppressed because it is too large Load Diff

1261
harbour/source/rtl/teditor.prg
View File

File diff suppressed because it is too large Load Diff

1742
harbour/source/rtl/tget.prg
View File

File diff suppressed because it is too large Load Diff

511
harbour/source/rtl/tgetlist.prg
View File

@@ -55,18 +55,19 @@
* www - http://www.harbour-project.org
*
* Copyright 2001 Luiz Rafael Culik
* Support for Ca-Clipper 5.3 Getsystem
* Support for CA-Cl*pper 5.3 Getsystem
*
* See doc/license.txt for licensing terms.
*
*/
#include "hbclass.ch"
#include "button.ch"
#include "common.ch"
#include "getexit.ch"
#include "inkey.ch"
#include "setcurs.ch"
#include "button.ch"
#include "tbrowse.ch"
#define SCORE_ROW 0
@@ -78,27 +79,12 @@
#define K_UNDO K_CTRL_U
CLASS HBGetList
CREATE CLASS HBGetList
DATA aGetList
DATA oGet
DATA nPos INIT 1
DATA bFormat
DATA lUpdated INIT .f.
DATA lKillRead INIT .f.
DATA lBumpTop INIT .f.
DATA lBumpBot INIT .f.
DATA nLastExitState INIT 0
DATA nLastPos INIT 0
DATA oActiveGet
DATA cReadProcName INIT ""
DATA nReadProcLine
DATA cVarName
DATA lHasFocus INIT .f.
DATA nHitCode INIT 0
DATA nNextGet
EXPORT:
VAR HasFocus AS LOGICAL INIT .F.
METHOD New( GetList )
METHOD Settle( nPos )
METHOD Reader()
METHOD GetApplyKey( nKey )
@@ -119,25 +105,38 @@ CLASS HBGetList
METHOD Updated()
#ifdef HB_COMPAT_C53
METHOD GUIReader( oGet, GetList, oMenu, aMsg )
METHOD GUIApplyKey( oGUI, nKey )
METHOD GUIPreValidate( oGUI )
METHOD GUIPostValidate( oGUI )
METHOD TBApplyKey( oGet, oTB, nKey )
METHOD TBReader( oGet)
METHOD Accelerator( nKey )
METHOD GUIReader( oGet, oMenu, aMsg )
METHOD GUIApplyKey( oGet, oGUI, nKey, oMenu, aMsg )
METHOD GUIPreValidate( oGUI, aMsg )
METHOD GUIPostValidate( oGUI, aMsg )
METHOD TBApplyKey( oGet, oTB, nKey, aMsg )
METHOD TBReader( oGet, oMenu, aMsg )
METHOD Accelerator( nKey, aMsg )
METHOD HitTest( nMouseRow, nMouseColumn, aMsg )
#endif
METHOD New( GetList )
VAR lUpdated AS LOGICAL INIT .F.
VAR bFormat
VAR lKillRead AS LOGICAL INIT .F.
VAR lBumpTop AS LOGICAL INIT .F.
VAR lBumpBot AS LOGICAL INIT .F.
VAR nLastExitState AS NUMERIC INIT 0
VAR nLastPos AS NUMERIC INIT 0
VAR oActiveGet
VAR cVarName
VAR cReadProcName AS CHARACTER INIT ""
VAR nReadProcLine
VAR nNextGet
VAR nHitCode AS NUMERIC INIT 0
VAR nPos AS NUMERIC INIT 1
VAR aGetList
VAR oGet
ENDCLASS
METHOD New( GetList ) CLASS HBGetList
::aGetList := GetList
::oGet := iif( ISARRAY( GetList ) .AND. Len( GetList ) >= 1, GetList[ 1 ], NIL )
return Self
METHOD ReadExit( lNew ) CLASS HBGetList
return iif( ISLOGICAL( lNew ), Set( _SET_EXIT, lNew ), Set( _SET_EXIT ) )
@@ -160,7 +159,7 @@ METHOD Reader() CLASS HBGetList
oGet:SetFocus()
while oGet:ExitState == GE_NOEXIT
do while oGet:ExitState == GE_NOEXIT
if oGet:typeOut
oGet:ExitState := GE_ENTER
endif
@@ -169,19 +168,19 @@ METHOD Reader() CLASS HBGetList
oGet:ExitState := GE_ENTER
endif
while oGet:exitState == GE_NOEXIT
do while oGet:exitState == GE_NOEXIT
::GetApplyKey( Inkey( 0 ) )
end
enddo
if ! ::GetPostValidate()
oGet:ExitState := GE_NOEXIT
endif
end
enddo
oGet:killFocus()
endif
return Self
return Self
METHOD GetApplyKey( nKey ) CLASS HBGetList
@@ -203,7 +202,7 @@ METHOD GetApplyKey( nKey ) CLASS HBGetList
oGet:ExitState := GE_SHORTCUT
::nNextGet := nHotItem
::nLastExitState := GE_SHORTCUT // Added.
::nLastExitState := GE_SHORTCUT
endif
@@ -251,14 +250,14 @@ METHOD GetApplyKey( nKey ) CLASS HBGetList
::ShowScoreboard()
case nKey == K_LBUTTONDOWN .OR. nKey == K_LDBLCLK
nMouseRow := mROW()
nMouseColumn := mCOL()
nMouseRow := MRow()
nMouseColumn := MCol()
nButton := 0
if ( nButton := oGet:HitTest( nMouseRow, nMouseColumn ) ) == HTCLIENT
do while oGet:Col+oGet:Pos-1 > nMouseColumn
do while oGet:Col + oGet:Pos - 1 > nMouseColumn
oGet:Left()
// Handle editing buffer if first character is non-editable:
@@ -284,9 +283,9 @@ METHOD GetApplyKey( nKey ) CLASS HBGetList
elseif nButton != HTNOWHERE
elseif ::aGetList != NIL .AND. ::HitTest( nMouseRow, nMouseColumn ) != 0 // Changed.
elseif ::aGetList != NIL .AND. ::HitTest( nMouseRow, nMouseColumn ) != 0
oGet:ExitState := GE_MOUSEHIT
::nLastExitState := GE_MOUSEHIT // Added.
::nLastExitState := GE_MOUSEHIT
else
oGet:ExitState := GE_NOEXIT
@@ -356,12 +355,12 @@ METHOD GetApplyKey( nKey ) CLASS HBGetList
endif
endcase
return Self
return Self
METHOD GetPreValidate() CLASS HBGetList
local oGet := ::oGet
local lUpdated, lWhen := .t.
local lUpdated, lWhen := .T.
local xValue
if oGet:PreBlock != NIL
@@ -391,37 +390,37 @@ METHOD GetPreValidate() CLASS HBGetList
endif
if ::lKillRead
lWhen := .f.
lWhen := .F.
oGet:ExitState := GE_ESCAPE
elseif ! lWhen
oGet:ExitState := GE_WHEN
else
oGet:ExitState := GE_NOEXIT
end
endif
return lWhen
return lWhen
METHOD GetPostValidate() CLASS HBGetList
local oGet := ::oGet
local lUpdated
local lValid := .t.
local lValid := .T.
local xValue
if oGet:ExitState == GE_ESCAPE
return .t.
return .T.
endif
if oGet:BadDate
oGet:home()
::DateMsg()
::ShowScoreboard()
return .f.
return .F.
endif
if oGet:Changed
oGet:Assign()
::lUpdated := .t.
::lUpdated := .T.
endif
oGet:Reset():Display()
@@ -454,11 +453,11 @@ METHOD GetPostValidate() CLASS HBGetList
if ::lKillRead
oGet:ExitState := GE_ESCAPE
lValid := .t.
lValid := .T.
endif
endif
return lValid
return lValid
METHOD GetDoSetKey( bKeyBlock ) CLASS HBGetList
@@ -466,7 +465,7 @@ METHOD GetDoSetKey( bKeyBlock ) CLASS HBGetList
if oGet:Changed
oGet:Assign()
::lUpdated := .t.
::lUpdated := .T.
endif
xValue := oGet:VarGet()
@@ -495,7 +494,7 @@ METHOD GetDoSetKey( bKeyBlock ) CLASS HBGetList
oGet:ExitState := GE_ESCAPE
endif
return Self
return Self
METHOD Settle( nPos ) CLASS HBGetList
@@ -517,8 +516,8 @@ METHOD Settle( nPos ) CLASS HBGetList
if nExitState != GE_WHEN
::nLastPos := nPos
::lBumpTop := .f.
::lBumpBot := .f.
::lBumpTop := .F.
::lBumpBot := .F.
else
if ::nLastExitState != 0
nExitState := ::nLastExitState
@@ -531,43 +530,43 @@ METHOD Settle( nPos ) CLASS HBGetList
endif
do case
case nExitState == GE_UP
nPos--
case nExitState == GE_UP
nPos--
case nExitState == GE_DOWN
nPos++
case nExitState == GE_DOWN
nPos++
case nExitState == GE_TOP
nPos := 1
::lBumpTop := .T.
nExitState := GE_DOWN
case nExitState == GE_TOP
nPos := 1
::lBumpTop := .T.
nExitState := GE_DOWN
case nExitState == GE_BOTTOM
nPos := Len( ::aGetList )
::lBumpBot := .t.
nExitState := GE_UP
case nExitState == GE_BOTTOM
nPos := Len( ::aGetList )
::lBumpBot := .T.
nExitState := GE_UP
case nExitState == GE_ENTER
nPos++
case nExitState == GE_ENTER
nPos++
case nExitState == GE_SHORTCUT
return ::nNextGet
case nExitState == GE_SHORTCUT
return ::nNextGet
case nExitState == GE_MOUSEHIT
return ::nNextGet
case nExitState == GE_MOUSEHIT
return ::nNextGet
endcase
if nPos == 0
if ! ::ReadExit() .and. ! ::lBumpBot
::lBumpTop := .t.
::lBumpTop := .T.
nPos := ::nLastPos
nExitState := GE_DOWN
endif
elseif nPos == Len( ::aGetList ) + 1
if ! ::ReadExit() .and. nExitState != GE_ENTER .and. ! ::lBumpTop
::lBumpBot := .t.
::lBumpBot := .T.
nPos := ::nLastPos
nExitState := GE_UP
else
@@ -581,7 +580,7 @@ METHOD Settle( nPos ) CLASS HBGetList
::aGetList[ nPos ]:ExitState := nExitState
endif
return nPos
return nPos
METHOD PostActiveGet() CLASS HBGetList
@@ -589,7 +588,7 @@ METHOD PostActiveGet() CLASS HBGetList
::ReadVar( ::GetReadVar() )
::ShowScoreBoard()
return Self
return Self
METHOD GetReadVar() CLASS HBGetList
@@ -601,9 +600,9 @@ METHOD GetReadVar() CLASS HBGetList
for n := 1 TO Len( oGet:Subscript )
cName += "[" + LTrim( Str( oGet:Subscript[ n ] ) ) + "]"
next
end
endif
return cName
return cName
METHOD SetFormat( bFormat ) CLASS HBGetList
@@ -611,7 +610,7 @@ METHOD SetFormat( bFormat ) CLASS HBGetList
::bFormat := bFormat
return bSavFormat
return bSavFormat
METHOD KillRead( lKill ) CLASS HBGetList
@@ -621,7 +620,7 @@ METHOD KillRead( lKill ) CLASS HBGetList
::lKillRead := lKill
endif
return lSavKill
return lSavKill
METHOD GetActive( oGet ) CLASS HBGetList
@@ -631,7 +630,7 @@ METHOD GetActive( oGet ) CLASS HBGetList
::oActiveGet := oGet
endif
return oOldGet
return oOldGet
METHOD ShowScoreboard() CLASS HBGetList
@@ -651,7 +650,7 @@ METHOD ShowScoreboard() CLASS HBGetList
endif
return Self
return Self
METHOD DateMsg() CLASS HBGetList
@@ -674,7 +673,7 @@ METHOD DateMsg() CLASS HBGetList
endif
return Self
return Self
METHOD ReadVar( cNewVarName ) CLASS HBGetList
@@ -684,7 +683,7 @@ METHOD ReadVar( cNewVarName ) CLASS HBGetList
::cVarName := cNewVarName
endif
return cOldName
return cOldName
METHOD ReadUpdated( lUpdated ) CLASS HBGetList
@@ -694,18 +693,17 @@ METHOD ReadUpdated( lUpdated ) CLASS HBGetList
::lUpdated := lUpdated
endif
return lSavUpdated
return lSavUpdated
#ifdef HB_COMPAT_C53
METHOD GuiReader( oGet, GetList, oMenu, aMsg ) CLASS HBGetList
Local oGUI
METHOD GUIReader( oGet, oMenu, aMsg ) CLASS HBGetList
LOCAL oGUI
HB_SYMBOL_UNUSED( GetList )
HB_SYMBOL_UNUSED( oMenu )
HB_SYMBOL_UNUSED( aMsg )
if ! ::GUIPreValidate( oGet:Control )
if ! ::GUIPreValidate( oGet:Control, aMsg )
elseif ISOBJECT( oGet:Control )
@@ -723,12 +721,12 @@ METHOD GuiReader( oGet, GetList, oMenu, aMsg ) CLASS HBGetList
// Apply keystrokes until exit
do while oGet:exitState == GE_NOEXIT .AND. !::lKillRead
::GUIApplyKey( oGUI, inkey(0) )
::GUIApplyKey( oGet, oGUI, Inkey( 0 ) )
enddo
// Disallow exit if the VALID condition is not satisfied
if !::GUIPostValidate( oGUI )
if !::GUIPostValidate( oGUI, aMsg )
oGet:exitState := GE_NOEXIT
endif
enddo
@@ -747,20 +745,21 @@ METHOD GuiReader( oGet, GetList, oMenu, aMsg ) CLASS HBGetList
return Self
METHOD GUIApplyKey( oGUI, nKey ) CLASS HBGetList
Local oGet := ::oGet
METHOD GUIApplyKey( oGet, oGUI, nKey, oMenu, aMsg ) CLASS HBGetList
Local bKeyBlock
Local oTheClass
Local nHotItem
Local lClose
Local nMouseRow, nMouseColumn, nButton
HB_SYMBOL_UNUSED( oMenu )
// Check for SET KEY first
if ( bKeyBlock := SetKey( nKey ) ) != NIL
::GetDoSetKey( bKeyBlock, oGet )
endif
if ( nHotItem := ::Accelerator( nKey ) ) != 0
if ( nHotItem := ::Accelerator( nKey, aMsg ) ) != 0
oGet:ExitState := GE_SHORTCUT
::nNextGet := nHotItem
endif
@@ -815,7 +814,7 @@ METHOD GUIApplyKey( oGUI, nKey ) CLASS HBGetList
nKey := 0
endif
elseif ( nButton := oGUI:FindText( chr(nKey), oGUI:Value+1, .f., .f. ) ) != 0
elseif ( nButton := oGUI:FindText( chr(nKey), oGUI:Value+1, .F., .F. ) ) != 0
oGUI:Select( nButton )
endif
@@ -882,7 +881,7 @@ METHOD GUIApplyKey( oGUI, nKey ) CLASS HBGetList
// Changed test:
if ::HitTest( nMouseRow, nMouseColumn ) != 0
oGet:ExitState := GE_MOUSEHIT
::nLastExitState := GE_MOUSEHIT // Added.
::nLastExitState := GE_MOUSEHIT
else
oGet:ExitState := GE_NOEXIT
endif
@@ -914,6 +913,126 @@ METHOD GUIApplyKey( oGUI, nKey ) CLASS HBGetList
return Self
METHOD GUIPostValidate( oGUI, aMsg ) CLASS HBGetList
Local oGet := ::oGet
Local lUpdated
Local lValid := .T.
Local xValue
if oGet:exitState == GE_ESCAPE
return .T. // NOTE
endif
if oGet:BadDate
oGet:home()
::DateMsg()
::ShowScoreboard()
return .F.
endif
if oGet:Changed
oGet:UpdateBuffer()
::lUpdated := .T.
endif
oGet:Reset():Display()
/*
// If editing occurred, assign the new value to the variable
if !( uOldData == uNewData )
oGet:VarPut( uNewData )
::lUpdated := .T.
endif
*/
// Check VALID condition if specified
if oGet:postBlock != NIL
xValue := oGet:VarGet()
lUpdated := ::lUpdated
lValid := Eval( oGet:postBlock, oGet, aMsg )
// Reset S'87 compatibility cursor position
SetPos( oGet:Row, oGet:Col )
if !( ValType( xValue ) == ValType( oGet:VarGet() ) ) .or.;
!( oGet:VarGet() == xValue )
oGet:VarPut( oGet:VarGet() )
endif
oGet:UpdateBuffer()
::ShowScoreBoard()
if ! ( oGUI:ClassName == "TBROWSE" )
oGUI:Select( oGet:VarGet() )
endif
::lUpdated := lUpdated
/*
if __GetListActive() != Self
__GetListSetActive( Self )
endif
*/
__GetListLast( Self )
if ::lKillRead
oGet:ExitState := GE_ESCAPE // Provokes ReadModal() exit
lValid := .T.
endif
endif
return lValid
METHOD GUIPreValidate( oGUI, aMsg ) CLASS HBGetList
Local oGet := ::oGet
Local lUpdated
Local lWhen := .T.
Local xValue
HB_SYMBOL_UNUSED( oGUI )
if oGet:preBlock != NIL
xValue := oGet:VarGet()
lUpdated := ::lUpdated
lWhen := Eval( oGet:preBlock, oGet, aMsg )
if !( ValType( xValue ) == ValType( oGet:VarGet() ) ) .or.;
!( oGet:VarGet() == xValue )
oGet:VarPut( oGet:VarGet() )
else
oGet:Display()
endif
::ShowScoreBoard()
::lUpdated := lUpdated
/*
if __GetListActive() != Self
__GetListSetActive( Self )
endif
*/
__GetListLast( Self )
endif
if ::lKillRead
lWhen := .F.
oGet:ExitState := GE_ESCAPE
elseif !lWhen
oGet:ExitState := GE_WHEN
else
oGet:ExitState := GE_NOEXIT
endif
return lWhen
METHOD TBApplyKey( oGet, oTB, nKey, aMsg ) CLASS HBGetList
Local bKeyBlock
@@ -929,7 +1048,7 @@ METHOD TBApplyKey( oGet, oTB, nKey, aMsg ) CLASS HBGetList
endif
endif
if ( nHotItem := ::Accelerator( nKey) ) != 0
if ( nHotItem := ::Accelerator( nKey, aMsg ) ) != 0
oGet:ExitState := GE_SHORTCUT
endif
@@ -970,8 +1089,8 @@ METHOD TBApplyKey( oGet, oTB, nKey, aMsg ) CLASS HBGetList
nMouseColumn := mCOL()
nButton := 0
if ( nButton := oTB:HitTest( nMouseRow, nMouseColumn ) ) == HTNOWHERE // Changed test:
if ::HitTest( nMouseRow, nMouseColumn, aMsg ) != 0
if ( nButton := oTB:HitTest( nMouseRow, nMouseColumn ) ) == HTNOWHERE
if ::HitTest( nMouseRow, nMouseColumn, aMsg ) != 0
oGet:ExitState := GE_MOUSEHIT
else
oGet:ExitState := GE_NOEXIT
@@ -982,141 +1101,20 @@ METHOD TBApplyKey( oGet, oTB, nKey, aMsg ) CLASS HBGetList
return self
METHOD GUIPostValidate( oGUI ) CLASS HBGetList
Local oGet := ::oGet
Local lUpdated
Local lValid := .T.
Local xValue
if oGet:exitState == GE_ESCAPE
return .t. // NOTE
endif
if oGet:BadDate
oGet:home()
::DateMsg()
::ShowScoreboard()
return .f.
endif
if oGet:Changed
oGet:UpdateBuffer()
::lUpdated := .t.
endif
oGet:Reset():Display()
/*
// If editing occurred, assign the new value to the variable
if !( uOldData == uNewData )
oGet:VarPut( uNewData )
::lUpdated := .T.
endif
*/
// Check VALID condition if specified
if oGet:postBlock != NIL
xValue := oGet:VarGet()
lUpdated := ::lUpdated
lValid := Eval( oGet:postBlock, oGet )
// Reset S'87 compatibility cursor position
setpos( oGet:Row, oGet:Col )
if !( ValType( xValue ) == ValType( oGet:VarGet() ) ) .or.;
!( oGet:VarGet() == xValue )
oGet:VarPut( oGet:VarGet() )
endif
oGet:UpdateBuffer()
::ShowScoreBoard()
if ! ( oGUI:ClassName == "TBROWSE" )
oGUI:Select( oGet:VarGet() )
endif
::lUpdated := lUpdated
/*
if __GetListActive() != Self
__GetListSetActive( Self )
endif
*/
__GetListLast( Self )
if ::lKillRead
oGet:ExitState := GE_ESCAPE // Provokes ReadModal() exit
lValid := .T.
endif
endif
return lValid
METHOD GUIPreValidate( oGUI ) CLASS HBGetList
Local oGet := ::oGet
Local lUpdated
Local lWhen := .T.
Local xValue
HB_SYMBOL_UNUSED( oGUI )
if oGet:preBlock != NIL
xValue := oGet:VarGet()
lUpdated := ::lUpdated
lWhen := eval( oGet:preBlock, oGet )
if !( ValType( xValue ) == ValType( oGet:VarGet() ) ) .or.;
!( oGet:VarGet() == xValue )
oGet:VarPut( oGet:VarGet() )
else
oGet:Display()
endif
::ShowScoreBoard()
::lUpdated := lUpdated
/*
if __GetListActive() != Self
__GetListSetActive( Self )
endif
*/
__GetListLast( Self )
endif
if ::lKillRead
lWhen := .F.
oGet:ExitState := GE_ESCAPE
elseif !lWhen
oGet:ExitState := GE_WHEN
else
oGet:ExitState := GE_NOEXIT
endif
return lWhen
METHOD TBReader( oGet, oGetsys, aMsg ) CLASS HBGetList
METHOD TBReader( oGet, oMenu, aMsg ) CLASS HBGetList
Local oTB, nKey, lAutoLite, nSaveCursor, nProcessed
// Local oGUI := oGet:control
HB_SYMBOL_UNUSED( oGetsys )
HB_SYMBOL_UNUSED( oMenu )
// Read the GET if the WHEN condition is satisfied
if ISOBJECT( oGet:control ) .AND. ; // Moved up 2 lines.
::nLastExitState == GE_SHORTCUT .OR. ; // Added.
::nLastExitState == GE_MOUSEHIT .OR. ; // Added.
if ISOBJECT( oGet:control ) .AND. ;
::nLastExitState == GE_SHORTCUT .OR. ;
::nLastExitState == GE_MOUSEHIT .OR. ;
::GetPreValidate( oGet, aMsg )
// ShowGetMsg( oGet, aMsg )
::nLastExitState := 0 // Added.
::nLastExitState := 0
nSaveCursor := SetCursor( SC_NONE )
@@ -1127,15 +1125,14 @@ METHOD TBReader( oGet, oGetsys, aMsg ) CLASS HBGetList
oTB:Autolite := .T.
oTB:Hilite()
if oGet:exitState == GE_NOEXIT // Added.
if oGet:exitState == GE_NOEXIT
if ::nHitcode == HTCELL
// tracelog('hitcode ',::nHitcode )
// Replaces call to TBMouse( oTB, mROW(), mCOL() ):
oTB:RowPos := oTb:mRowPos
oTB:ColPos := oTb:mColPos
oTB:Invalidate()
endif
endif // Added.
endif
::nHitcode := 0
@@ -1159,7 +1156,7 @@ METHOD TBReader( oGet, oGetsys, aMsg ) CLASS HBGetList
exit
elseif nProcessed == TBR_EXCEPTION
::TBApplyKey( oGet, oTB, nKey, aMsg )
::TBApplyKey( oGet, oTB, nKey, aMsg )
// nRow := ROW() // Commented out.
// nCol := COL() // Commented out.
@@ -1171,10 +1168,9 @@ METHOD TBReader( oGet, oGetsys, aMsg ) CLASS HBGetList
enddo
// Disallow exit if the VALID condition is not satisfied
if ::nLastExitState == GE_SHORTCUT // Added.
elseif ::nLastExitState == GE_MOUSEHIT // Added.
elseif !::GetPostValidate( oGet, aMsg ) // Changed.
// if !::GUIPostValidate( oGet, oGUI, aMsg ) // Old test.
if ::nLastExitState == GE_SHORTCUT
elseif ::nLastExitState == GE_MOUSEHIT
elseif !::GetPostValidate( oGet, aMsg )
oGet:ExitState := GE_NOEXIT
endif
@@ -1189,10 +1185,12 @@ METHOD TBReader( oGet, oGetsys, aMsg ) CLASS HBGetList
return Self
METHOD Accelerator( nKey ) CLASS HBGetList
METHOD Accelerator( nKey, aMsg ) CLASS HBGetList
Local nGet, oGet, nHotPos, cKey, cCaption, nStart, nEnd
Local nIteration, lGUI
local nGet, oGet, nHotPos, cKey, cCaption, nStart, nEnd
local nIteration, lGUI
HB_SYMBOL_UNUSED( aMsg )
if nKey >= K_ALT_Q .and. nKey <= K_ALT_P
cKey := substr( "qwertyuiop", nKey - K_ALT_Q + 1, 1 )
@@ -1236,10 +1234,10 @@ METHOD Accelerator( nKey ) CLASS HBGetList
// Test the current GUI-GET or Get PostValidation:
lGUI := ISOBJECT( ::aGetList[ ::nPos ]:Control )
if lGUI .and. !::GUIPostValidate( ::aGetList[ ::nPos ]:Control )
if lGUI .and. !::GUIPostValidate( ::aGetList[ ::nPos ]:Control, aMsg )
return 0
elseif !lGUI .and. !::GetPostValidate( ::aGetList[ ::nPos ] )
elseif !lGUI .and. !::GetPostValidate( ::aGetList[ ::nPos ], aMsg )
return 0
endif
@@ -1247,32 +1245,31 @@ METHOD Accelerator( nKey ) CLASS HBGetList
// Test the next GUI-GET or Get PreValidation:
lGUI := ISOBJECT( oGet:Control )
if lGUI .and. !::GUIPreValidate( oGet:Control )
if lGUI .and. !::GUIPreValidate( oGet:Control, aMsg )
// return 0 // Commented out.
return nGet // Changed.
elseif !lGUI .and. !::GetPreValidate( oGet )
elseif !lGUI .and. !::GetPreValidate( oGet, aMsg )
// return 0 // Commented out.
return nGet // Changed.
endif
return ( nGet )
return nGet
endif
next
nStart := 1
nEnd := ::nPos - 1
next
return 0
return 0
METHOD HitTest( nMouseRow, nMouseCol, aMsg ) CLASS HBGetList
Local nCount, nTotal, lGUI
::nNextGet := 0
nTotal := len( ::aGetList )
nTotal := len( ::aGetList )
for nCount := 1 to nTotal
if ( ::nHitCode := ::aGetList[ nCount ]:HitTest( nMouseRow, nMouseCol ) ) != HTNOWHERE
@@ -1329,3 +1326,13 @@ METHOD HitTest( nMouseRow, nMouseCol, aMsg ) CLASS HBGetList
return 0 // Changed.
#endif
METHOD New( GetList ) CLASS HBGetList
::aGetList := GetList
IF ISARRAY( GetList ) .AND. Len( GetList ) >= 1
::oGet := GetList[ 1 ]
ENDIF
return Self

57
harbour/source/rtl/tlabel.prg
View File

@@ -52,6 +52,7 @@
#include "hbclass.ch"
#include "common.ch"
#include "error.ch"
#include "fileio.ch"
#include "inkey.ch"
@@ -98,18 +99,20 @@
#define ACROSSOFFSET 72
#define ACROSSSIZE 2
CLASS HBLabelForm
CREATE CLASS HBLabelForm
VAR aLabelData AS ARRAY INIT {}
VAR aBandToPrint AS ARRAY
VAR cBlank AS STRING INIT ""
VAR lOneMoreBand AS LOGICAL INIT .T.
VAR nCurrentCol AS NUMERIC // The current column in the band
DATA aLabelData AS ARRAY init {}
DATA aBandToPrint AS ARRAY
DATA cBlank AS STRING init ""
DATA lOneMoreBand AS LOGICAL init .T.
DATA nCurrentCol AS NUMERIC // The current column in the band
METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
bWhile, nNext, nRecord, lRest, lSample )
METHOD ExecuteLabel()
METHOD SampleLabels()
METHOD LoadLabel(cLblFile)
METHOD LoadLabel( cLblFile )
ENDCLASS
@@ -123,7 +126,6 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
LOCAL err
LOCAL OldMargin
LOCAL cExt
// LOCAL nLen
::aBandToPrint := {} // ARRAY(5)
::nCurrentCol := 1
@@ -136,7 +138,8 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
err:subSystem := "FRMLBL"
Eval(ErrorBlock(), err)
ELSE
cLBLName := RTrim( cLBLName ) // ; TOFIX: Not very multiplatform.
/* NOTE: CA-Cl*pper does an RTrim() on the filename here,
but in Harbour we're using _SET_TRIMFILENAME. [vszakats] */
IF Set( _SET_DEFEXTENSIONS )
hb_FNameSplit( cLBLName, NIL, NIL, @cExt )
IF Empty( cExt )
@@ -145,13 +148,8 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
ENDIF
ENDIF
IF lPrinter == NIL
lPrinter := .F.
ENDIF
IF lSample == NIL
lSample := .F.
ENDIF
DEFAULT lPrinter TO .F.
DEFAULT lSample TO .F.
// Set output devices
IF lPrinter // To the printer
@@ -161,7 +159,7 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
lConsoleOn := SET( _SET_CONSOLE )
SET( _SET_CONSOLE, ! ( lNoConsole .OR. !lConsoleOn ) )
IF (!Empty(cAltFile)) // To file
IF !Empty(cAltFile) // To file
lExtraState := SET( _SET_EXTRA, .T. )
cExtraFile := SET( _SET_EXTRAFILE, cAltFile )
ENDIF
@@ -175,9 +173,6 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
// Add to the left margin if a SET MARGIN has been defined
::aLabelData[ LBL_LMARGIN ] := ::aLabelData[ LBL_LMARGIN ] + OldMargin
// Size the ::aBandToPrint array to the number of fields
// nLen := LEN( ::aLabelData[ LBL_FIELDS ] )
ASIZE( ::aBandToPrint, LEN( ::aLabelData[ LBL_FIELDS ]))
AFILL( ::aBandToPrint, SPACE( ::aLabelData[ LBL_LMARGIN ] ) )
@@ -215,7 +210,7 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
SET( _SET_PRINTER, lPrintOn ) // Set the printer back to prior state
SET( _SET_CONSOLE, lConsoleOn ) // Set the console back to prior state
IF (!Empty(cAltFile)) // Set extrafile back
IF !Empty(cAltFile) // Set extrafile back
SET( _SET_EXTRAFILE, cExtraFile )
SET( _SET_EXTRA, lExtraState )
ENDIF
@@ -235,7 +230,7 @@ METHOD ExecuteLabel() CLASS HBLabelForm
// Load the current record into aBuffer
FOR nField := 1 TO LEN( ::aLabelData[ LBL_FIELDS ] )
if ( ::aLabelData[ LBL_FIELDS, nField ] <> NIL )
if ::aLabelData[ LBL_FIELDS, nField ] != NIL
v := Eval( ::aLabelData[ LBL_FIELDS, nField, LF_EXP ] )
@@ -245,7 +240,7 @@ METHOD ExecuteLabel() CLASS HBLabelForm
if ( ::aLabelData[ LBL_FIELDS, nField, LF_BLANK ] )
if ( !Empty( cBuffer ) )
AADD( aBuffer, cBuffer )
end
endif
else
AADD( aBuffer, cBuffer )
endif
@@ -254,7 +249,7 @@ METHOD ExecuteLabel() CLASS HBLabelForm
AADD( aBuffer, NIL )
end
endif
NEXT
@@ -378,7 +373,7 @@ METHOD LoadLabel( cLblFile ) CLASS HBLabelForm
// Open the label file
nHandle := FOPEN( cLblFile )
IF ( ! EMPTY( nFileError := FERROR() ) ) .AND. !( "\" $ cLblFile .OR. ":" $ cLblFile )
IF ! EMPTY( nFileError := FERROR() ) .AND. !( "\" $ cLblFile .OR. ":" $ cLblFile )
// Search through default path; attempt to open label file
cDefPath := SET( _SET_DEFAULT )
@@ -474,9 +469,7 @@ FUNCTION __LabelForm( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
STATIC PROCEDURE PrintIt( cString )
IF cString == NIL
cString := ""
ENDIF
DEFAULT cString TO ""
QQOUT( cString )
QOUT()
@@ -489,11 +482,9 @@ STATIC FUNCTION ListAsArray( cList, cDelimiter )
LOCAL aList := {} // Define an empty array
LOCAL lDelimLast := .F.
IF cDelimiter == NIL
cDelimiter := ","
ENDIF
DEFAULT cDelimiter TO ","
DO WHILE LEN(cList) <> 0
DO WHILE LEN(cList) != 0
nPos := AT(cDelimiter, cList)
@@ -501,7 +492,7 @@ STATIC FUNCTION ListAsArray( cList, cDelimiter )
nPos := LEN(cList)
ENDIF
IF ( SUBSTR( cList, nPos, 1 ) == cDelimiter )
IF SUBSTR( cList, nPos, 1 ) == cDelimiter
lDelimLast := .T.
AADD(aList, SUBSTR(cList, 1, nPos - 1)) // Add a new element
ELSE

205
harbour/source/rtl/tmenuitm.prg
View File

@@ -51,66 +51,179 @@
*/
#include "hbclass.ch"
#include "common.ch"
#include "button.ch"
#include "common.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
//--------------------------------------------------------------------------//
FUNCTION MenuItem( cCaption, boData, nShortcut, cMsg, nID )
RETURN __MenuItem():New( cCaption, boData, nShortcut, cMsg, nID )
//--------------------------------------------------------------------------//
CLASS MenuItem STATIC FUNCTION __MenuItem
CREATE CLASS MENUITEM FUNCTION HBMenuItem
DATA caption init ""
DATA cargo
DATA checked init FALSE
DATA column init 0
DATA data
DATA enabled
DATA id
DATA message
DATA row init 0
DATA shortcut
DATA style init HB_TMENUITEM_STYLE
EXPORT:
VAR cargo
METHOD caption( cCaption ) SETGET
METHOD checked( lChecked ) SETGET
METHOD data( boData ) SETGET
METHOD enabled( lEnabled ) SETGET
METHOD id( nID ) SETGET
METHOD message( cMessage ) SETGET
METHOD shortcut( nShortcut ) SETGET
METHOD style( cStyle ) SETGET
VAR col INIT -1 AS NUMERIC /* NOTE: This is a Harbour extension. */
VAR row INIT -1 AS NUMERIC /* NOTE: This is a Harbour extension. */
METHOD New( cCaption, boData, nShortcut, cMsg, nID )
METHOD isPopUp()
METHOD New( cCaption, boData, nShortcut, cMsg, nID ) /* NOTE: This method is a Harbour extension [vszakats] */
PROTECTED:
VAR cCaption INIT ""
VAR lChecked INIT .F.
VAR boData
VAR lEnabled INIT .T.
VAR nID
VAR cMessage
VAR nShortcut
VAR cStyle INIT Chr( 251 ) + Chr( 16 )
ENDCLASS
//--------------------------------------------------------------------------//
METHOD New( cCaption, boData, nShortcut, cMsg, nID ) CLASS MenuItem
if ISBLOCK( boData ) .or. ISOBJECT( boData )
boData := iif( cCaption != MENU_SEPARATOR, boData, nil )
endif
METHOD caption( cCaption ) CLASS MENUITEM
DEFAULT cCaption TO ""
DEFAULT boData TO nil
DEFAULT nShortcut TO 0
DEFAULT cMsg TO ""
DEFAULT nID TO 0
IF cCaption != NIL
::caption := cCaption
::checked := FALSE
::column := 0
::data := boData
::enabled := iif( cCaption != MENU_SEPARATOR, TRUE, FALSE )
::id := nID
::message := cMsg
::row := 0
::shortcut := nShortcut
::style := HB_TMENUITEM_STYLE
::cCaption := _eInstVar( Self, "CAPTION", cCaption, "C", 1001 )
return Self
//--------------------------------------------------------------------------//
METHOD isPopUp() CLASS MenuItem
IF ::cCaption == MENU_SEPARATOR
::boData := NIL
::lChecked := .F.
::lEnabled := .F.
ENDIF
ENDIF
if ISOBJECT( ::data ) .and. ::data:ClassName() == "POPUPMENU"
return TRUE
endif
RETURN ::cCaption
return FALSE
//--------------------------------------------------------------------------//
METHOD checked( lChecked ) CLASS MENUITEM
IF lChecked != NIL .AND. !( ::cCaption == MENU_SEPARATOR )
::lChecked := _eInstVar( Self, "CHECKED", lChecked, "L", 1001 )
ENDIF
RETURN ::lChecked
METHOD data( boData ) CLASS MENUITEM
IF boData != NIL
IF ISBLOCK( boData )
::boData := boData
ELSE
::boData := _eInstVar( Self, "DATA", boData, "O", 1001, {|| boData:ClassName() == "POPUPMENU" } )
ENDIF
ENDIF
RETURN ::boData
METHOD enabled( lEnabled ) CLASS MENUITEM
IF lEnabled != NIL .AND. !( ::cCaption == MENU_SEPARATOR )
::lEnabled := _eInstVar( Self, "ENABLED", lEnabled, "L", 1001 )
ENDIF
RETURN ::lEnabled
METHOD id( nID ) CLASS MENUITEM
IF nID != NIL
::nID := _eInstVar( Self, "ID", nID, "N", 1001 )
ENDIF
RETURN ::nID
METHOD message( cMessage ) CLASS MENUITEM
IF cMessage != NIL
::cMessage := _eInstVar( Self, "MESSAGE", cMessage, "C", 1001 )
ENDIF
RETURN ::cMessage
METHOD shortcut( nShortcut ) CLASS MENUITEM
IF nShortcut != NIL
::nShortcut := _eInstVar( Self, "SHORTCUT", nShortcut, "N", 1001 )
ENDIF
RETURN ::nShortcut
METHOD style( cStyle ) CLASS MENUITEM
IF cStyle != NIL
::cStyle := _eInstVar( Self, "STYLE", cStyle, "C", 1001, {|| Len( cStyle ) == 2 } )
ENDIF
RETURN ::cStyle
METHOD isPopUp() CLASS MENUITEM
RETURN ISOBJECT( ::data ) .AND. ::data:ClassName() == "POPUPMENU"
METHOD New( cCaption, boData, nShortcut, cMessage, nID ) CLASS MENUITEM
IF !ISNUMBER( nShortcut )
nShortcut := 0
ENDIF
IF !ISCHARACTER( cMessage )
cMessage := ""
ENDIF
IF !ISNUMBER( nID )
nID := 0
ENDIF
::data := boData
::nID := nID
::cMessage := cMessage
::nShortcut := nShortcut
::caption := cCaption
RETURN Self
FUNCTION MenuItem( cCaption, boData, nShortcut, cMessage, nID )
RETURN HBMenuItem():New( cCaption, boData, nShortcut, cMessage, nID )
#ifdef HB_C52_UNDOC
FUNCTION __miColumn( o, nColumn )
IF ISOBJECT( o ) .AND. o:ClassName() == "MENUITEM"
IF ISNUMBER( nColumn )
o:col := nColumn
ENDIF
RETURN o:col
ENDIF
RETURN -1
FUNCTION __miRow( o, nRow )
IF ISOBJECT( o ) .AND. o:ClassName() == "MENUITEM"
IF ISNUMBER( nRow )
o:row := nRow
ENDIF
RETURN o:row
ENDIF
RETURN -1
#endif
#endif

660
harbour/source/rtl/tmenusys.prg Normal file
View File

@@ -0,0 +1,660 @@
/*
* $Id: mssgline.prg 7155 2007-04-14 10:41:54Z vszakats $
*/
/*
* Harbour Project source code:
* TMENUSYS class
*
* Copyright 2002 Larry Sevilla <lsevilla@nddc.edu.ph>
* 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
/* Class to simulate menusys.prg of CA-Cl*pper 5.3 */
CREATE CLASS HBMenuSys
EXPORT:
METHOD Modal( nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList )
METHOD New( oMenu )
PROTECTED:
METHOD PushMenu()
METHOD PopMenu()
METHOD PopChild( nNewLevel )
METHOD PopAll()
METHOD Execute()
METHOD MHitTest( oNewMenu, nNewLevel, nNewItem )
METHOD ShowMsg( lMode )
METHOD GetMsgArray()
VAR oMenu
VAR lOldMsgFlag
VAR cOldMessage
VAR aMenuList
VAR nMenuLevel
VAR nOldRow
VAR nOldCol
VAR nOldCursor
VAR lMsgFlag
VAR nMsgRow
VAR nMsgLeft
VAR nMsgRight
VAR cMsgColor
VAR cMsgSaveS
ENDCLASS
/***
*
* Standard Menu System Modal handling for Menu Items
*
***/
METHOD Modal( nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) CLASS HBMenuSys
LOCAL oTopMenu := ::oMenu
LOCAL nReturn := 0
LOCAL nKey
LOCAL nNewItem
LOCAL lLeftDown
LOCAL oNewMenu
LOCAL nNewLevel
LOCAL nEvent
LOCAL oMenuItem
LOCAL nMenuItem
LOCAL nTemp
LOCAL bKeyBlock
LOCAL lSubMenu
::nOldRow := Row()
::nOldCol := Col()
::nOldCursor := SetCursor( SC_NONE )
::nMsgRow := nMsgRow
::nMsgLeft := nMsgLeft
::nMsgRight := nMsgRight
::cMsgColor := cMsgColor
IF ( ::lMsgFlag := ISNUMBER( ::nMsgRow ) .AND. ;
ISNUMBER( ::nMsgLeft ) .AND. ;
ISNUMBER( ::nMsgRight ) )
IF !ISCHARACTER( ::cMsgColor )
::cMsgColor := GetClrPair( SetColor(), 1 )
ENDIF
Scroll( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight )
::cMsgSaveS := SaveScreen( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight )
ENDIF
oTopMenu:Select( nSelection )
IF !( oTopMenu:ClassName() == "TOPBARMENU" ) .AND. !oTopMenu:IsOpen
oTopMenu:Open()
ELSE
oTopMenu:Display()
ENDIF
IF nSelection <= 0
DO WHILE nSelection <= 0
nEvent := Set( _SET_EVENTMASK, INKEY_KEYBOARD + INKEY_LDOWN )
nKey := Inkey( 0 )
Set( _SET_EVENTMASK, nEvent )
IF nKey == K_LBUTTONDOWN .OR. nKey == K_LDBLCLK
nSelection := oTopMenu:hitTest( MRow(), MCol() )
ELSEIF ( nSelection := oTopMenu:getAccel( nKey ) ) != 0
ELSEIF IsShortCut( oTopMenu, nKey, @nReturn )
RETURN nReturn
ELSE
nSelection := 1
ENDIF
ENDDO
oTopMenu:Select( nSelection )
oTopMenu:Display()
ENDIF
IF !oTopMenu:GetItem( nSelection ):enabled
RETURN 0
ENDIF
::aMenuList := Array( 16 )
::nMenuLevel := 1
::aMenuList[ 1 ] := ::oMenu
lLeftDown := MLeftDown()
::ShowMsg( .T. )
DO WHILE .T.
nKey := Inkey( 0 )
IF ( bKeyBlock := SetKey( nKey ) ) != NIL
Eval( bKeyBlock, ProcName( 1 ), ProcLine( 1 ), "" )
LOOP
ENDIF
DO CASE
CASE nKey == K_MOUSEMOVE
IF lLeftDown
IF !::MHitTest( @oNewMenu, @nNewLevel, @nNewItem ) // ; hit nowhere.
ELSEIF nNewLevel != ::nMenuLevel // ; menu level change.
IF nNewItem != oNewMenu:current .AND. oNewMenu:GetItem( nNewItem ):enabled
::oMenu := oNewMenu
::PopChild( nNewLevel )
::oMenu:select( nNewItem )
::oMenu:display()
::PushMenu()
::ShowMsg( .T. )
ENDIF
ELSEIF nNewItem != oNewMenu:Current() // ; menu item change.
::PopChild( ::nMenuLevel )
IF ::oMenu:getItem( nNewItem ):enabled
::oMenu:select( nNewItem )
::oMenu:display()
::PushMenu()
::ShowMsg( .T. )
ENDIF
ENDIF
ENDIF
CASE nKey == K_DOWN
IF ::oMenu:ClassName() == "TOPBARMENU"
IF ::PushMenu()
::ShowMsg( .T. )
ENDIF
ELSE
nTemp := ::oMenu:getNext()
IF nTemp == 0
nTemp := ::oMenu:getFirst()
ENDIF
::oMenu:select( nTemp )
::oMenu:display()
::ShowMsg( .T. )
ENDIF
CASE nKey == K_UP
IF !( ::oMenu:ClassName() == "TOPBARMENU" )
nTemp := ::oMenu:getPrev()
IF nTemp == 0
nTemp := ::oMenu:getLast()
ENDIF
::oMenu:select( nTemp )
::oMenu:display()
::ShowMsg( .T. )
ENDIF
CASE nKey == K_LEFT
IF ( lSubMenu := ( ::nMenuLevel > 1 ) )
::PopMenu()
ENDIF
IF ::oMenu:ClassName() == "TOPBARMENU"
nTemp := ::oMenu:getPrev()
IF nTemp == 0
nTemp := ::oMenu:getLast()
ENDIF
::oMenu:select( nTemp )
::oMenu:display()
IF lSubMenu
::PushMenu()
ENDIF
ENDIF
::ShowMsg( .T. )
CASE nKey == K_RIGHT
IF ( lSubMenu := ( ::nMenuLevel > 1 ) )
::PopMenu()
ENDIF
IF ::oMenu:ClassName() == "TOPBARMENU"
nTemp := ::oMenu:getNext()
IF nTemp == 0
nTemp := ::oMenu:getFirst()
ENDIF
::oMenu:select( nTemp )
::oMenu:display()
IF lSubMenu
::PushMenu()
ENDIF
ENDIF
::ShowMsg( .T. )
CASE nKey == K_ENTER
IF ::PushMenu()
::ShowMsg( .T. )
ELSE
::ShowMsg( .F. )
nReturn := ::Execute()
IF nReturn != 0
EXIT
ENDIF
ENDIF
CASE nKey == K_ESC // go to previous menu
IF ::PopMenu()
::oMenu:display()
::ShowMsg( .T. )
ELSE
IF ::oMenu:ClassName() == "POPUPMENU"
::oMenu:close()
ENDIF
nReturn := -1 // Bail out if at the top menu item
EXIT
ENDIF
CASE nKey == K_LBUTTONDOWN
IF !::MHitTest( @oNewMenu, @nNewLevel, @nNewItem )
IF GetList != NIL .AND. HitTest( GetList, MRow(), MCol(), ::GetMsgArray() ) != 0
GetActive():ExitState := GE_MOUSEHIT
__GetListActive():nLastExitState := GE_MOUSEHIT // Reset Get System values
IF ::oMenu:ClassName() == "POPUPMENU"
::PopMenu()
ENDIF
nReturn := -1
EXIT
ENDIF
IF ::oMenu:ClassName() == "POPUPMENU"
::PopMenu()
ENDIF
ELSEIF nNewLevel == ::nMenuLevel
::oMenu:select( nNewItem )
::oMenu:display()
::PushMenu()
::ShowMsg( .T. )
ELSE
::nMenuLevel := nNewLevel
::oMenu := ::aMenuList[ ::nMenuLevel ]
nMenuItem := ::oMenu:current
oMenuItem := ::oMenu:getItem( nMenuItem )
IF ( oMenuItem := ::oMenu:getItem( ::oMenu:Current ) ):isPopUp()
oMenuItem:Data:Close()
ENDIF
IF nMenuItem != nNewItem
nMenuItem := nNewItem
::oMenu:select( nNewItem )
::oMenu:display()
::PushMenu()
ENDIF
::ShowMsg( .T. )
ENDIF
lLeftDown := .T.
CASE nKey == K_LBUTTONUP
lLeftDown := .F.
IF ::MHitTest( @oNewMenu, @nNewLevel, @nNewItem ) .AND. ;
nNewLevel == ::nMenuLevel
IF nNewItem == ::oMenu:current
::ShowMsg( .F. )
nReturn := ::Execute()
IF nReturn != 0
EXIT
ENDIF
ENDIF
ENDIF
CASE ( nNewItem := ::oMenu:getAccel( nKey ) ) != 0
IF ::oMenu:getItem( nNewItem ):enabled
::oMenu:select( nNewItem )
::oMenu:display()
IF !::PushMenu()
::ShowMsg( .F. )
nReturn := ::Execute()
IF nReturn != 0
EXIT
ENDIF
ENDIF
::ShowMsg( .T. )
ENDIF
CASE IsShortCut( oTopMenu, nKey, @nReturn )
IF nReturn != 0
EXIT
ENDIF
CASE GetList != NIL .AND. ( nNewItem := Accelerator( GetList, nKey, ::GetMsgArray() ) ) != 0
GetActive():ExitState := GE_SHORTCUT
__GetListActive():nNextGet := nNewItem // Reset Get System values
IF ::oMenu:ClassName() == "POPUPMENU"
::PopMenu()
ENDIF
nReturn := -1
EXIT
CASE ( nNewItem := oTopMenu:GetAccel( nKey ) ) != 0 // ; check for the top menu item accelerator key
IF oTopMenu:GetItem( nNewItem ):enabled
::PopAll()
::oMenu:select( nNewItem )
::oMenu:display()
IF oTopMenu:GetItem( nNewItem ):isPopUp()
::PushMenu()
ELSE
::ShowMsg( .F. )
nReturn := ::Execute()
IF nReturn != 0
EXIT
ENDIF
ENDIF
::ShowMsg( .T. )
ENDIF
ENDCASE
ENDDO
IF ::lMsgFlag
RestScreen( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight, ::cMsgSaveS )
ENDIF
::PopAll()
SetPos( ::nOldRow, ::nOldCol )
SetCursor( ::nOldCursor )
RETURN nReturn
/***
*
* Increment ::nMenuLevel and optionally select first item.
* If selected MenuItem IsPopUp, assign ::oMenu.
*
***/
METHOD PushMenu() CLASS HBMenuSys
LOCAL oNewMenu := ::oMenu:getItem( ::oMenu:current )
IF ISOBJECT( oNewMenu ) .AND. oNewMenu:IsPopUp
::oMenu := oNewMenu:Data
::aMenuList[ ++::nMenuLevel ] := ::oMenu
::oMenu:select( ::oMenu:getFirst() )
IF !::oMenu:isOpen
::oMenu:open()
ENDIF
RETURN .T.
ENDIF
RETURN .F.
/***
*
* Close SubMenuItem and Return to the upper MenuItem level.
*
***/
METHOD PopMenu() CLASS HBMenuSys
IF ::nMenuLevel > 1
::oMenu:select( 0 )
::oMenu:close( .T. )
::oMenu := ::aMenuList[ --::nMenuLevel ] // Decrement MenuItem level and assign
RETURN .T.
ENDIF
RETURN .F.
/***
*
* Close PopUp Child MenuItem and Return to the upper MenuItem level.
*
***/
METHOD PopChild( nNewLevel ) CLASS HBMenuSys
LOCAL oOldMenuItem
LOCAL nCurrent
IF ( nCurrent := ::oMenu:current ) != 0
oOldMenuItem := ::oMenu:getItem( nCurrent )
IF oOldMenuItem:IsPopUp
oOldMenuItem:Data:Close()
::nMenuLevel := nNewLevel
RETURN .T.
ENDIF
ENDIF
RETURN .F.
/***
*
* Close all Menus below Top Menu and Return to upper MenuItem level.
*
***/
METHOD PopAll() CLASS HBMenuSys
IF ::aMenuList[ 2 ] != NIL
::aMenuList[ 2 ]:Close()
ENDIF
// Set the menu level and position relative to the top menu item:
::nMenuLevel := 1
::oMenu := ::aMenuList[ 1 ]
RETURN .T.
/***
*
* Eval() the Data block if selected MenuItem is !IsPopUp.
*
***/
METHOD Execute() CLASS HBMenuSys
LOCAL oNewMenu := ::oMenu:getItem( ::oMenu:current )
LOCAL lPas := .T.
// Execute the Data block if selected MenuItem is !IsPopUp:
IF ISOBJECT( oNewMenu ) .AND. !oNewMenu:IsPopUp
IF ::oMenu:ClassName() $ "TOPBARMENU|POPUPMENU"
SetPos( ::nOldRow, ::nOldCol )
SetCursor( ::nOldCursor )
Eval( oNewMenu:Data, oNewMenu )
SetCursor( SC_NONE )
lPas := .F.
ENDIF
// Pop the Menu:
::oMenu:select( iif( ::PopMenu(), ::oMenu:current, 0 ) )
// Display newly selected current menu item:
IF ::oMenu:ClassName() == "POPUPMENU" .AND. ;
::nMenuLevel == 1 .AND. ;
!::oMenu:isOpen
::oMenu:open()
ENDIF
IF lPas
::oMenu:close()
SetPos( ::nOldRow, ::nOldCol )
SetCursor( ::nOldCursor )
Eval( oNewMenu:Data, oNewMenu )
SetCursor( SC_NONE )
ENDIF
RETURN oNewMenu:Id
ENDIF
RETURN 0
/***
*
* Test to find the Mouse location.
* Note: Formal parameters received here were passed by reference.
*
***/
METHOD MHitTest( oNewMenu, nNewLevel, nNewItem ) CLASS HBMenuSys
FOR nNewLevel := ::nMenuLevel TO 1 STEP -1
oNewMenu := ::aMenuList[ nNewLevel ]
nNewItem := oNewMenu:HitTest( MRow(), MCol() )
IF nNewItem < 0
// Test for the mouse on Menu separator or border
RETURN .F.
ELSEIF nNewItem > 0 .AND. oNewMenu:GetItem( nNewItem ):enabled
// Test for the mouse on an enabled item in the menu
RETURN .T.
ENDIF
NEXT
RETURN .F.
/***
*
* 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 ShowMsg( lMode ) CLASS HBMenuSys
LOCAL nCurrent
LOCAL cMsg
LOCAL lMOldState := MSetCursor( .F. )
IF ISLOGICAL( ::lOldMsgFlag ) .AND. ::lOldMsgFlag
RestScreen( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight, ::cMsgSaveS )
ENDIF
IF lMode
IF !ISCHARACTER( ::cMsgColor )
::cMsgColor := GetClrPair( SetColor(), 1 )
ENDIF
IF ::lMsgFlag .AND. ;
( nCurrent := ::oMenu:current ) != 0 .AND. ;
!Empty( cMsg := ::oMenu:getItem( nCurrent ):message )
DispOutAt( ::nMsgRow, ::nMsgLeft, PadC( cMsg, ::nMsgRight - ::nMsgLeft + 1 ), ::cMsgColor )
ENDIF
::cOldMessage := cMsg
::lOldMsgFlag := ::lMsgFlag
ENDIF
MSetCursor( lMOldState )
RETURN .T.
/* NOTE: Generates the somewhat internal, yet widely used message line format of CA-Cl*pper 5.3
This format contradicts the one in the official docs. */
METHOD GetMsgArray() CLASS HBMenuSys
RETURN { , ::nMsgRow, ::nMsgLeft, ::nMsgRight, ::cMsgColor, , , , , }
/* -------------------------------------------- */
METHOD New( oMenu ) CLASS HBMenuSys
::oMenu := oMenu
RETURN Self
#endif

1074
harbour/source/rtl/tpopup.prg
View File

File diff suppressed because it is too large Load Diff

154
harbour/source/rtl/treport.prg
View File

@@ -52,6 +52,7 @@
#include "hbclass.ch"
#include "common.ch"
#include "error.ch"
#include "fileio.ch"
#include "inkey.ch"
@@ -149,35 +150,46 @@
#define PE_OFFSET 23
#define OPTION_OFFSET 24
CLASS HBReportForm
CREATE CLASS HBReportForm
DATA aReportData AS ARRAY init {}
DATA aReportTotals AS ARRAY init {}
DATA aGroupTotals AS ARRAY init {}
DATA nPageNumber AS NUMERIC
DATA nLinesLeft AS NUMERIC
DATA lFirstPass AS LOGICAL
DATA lFormFeeds AS LOGICAL
DATA nMaxLinesAvail AS NUMERIC
DATA cExprBuff AS STRING
DATA cOffsetsBuff AS STRING
DATA cLengthsBuff AS STRING
VAR aReportData AS ARRAY INIT {}
VAR aReportTotals AS ARRAY INIT {}
VAR aGroupTotals AS ARRAY INIT {}
VAR nPageNumber AS NUMERIC
VAR nLinesLeft AS NUMERIC
VAR lFirstPass AS LOGICAL
VAR lFormFeeds AS LOGICAL
VAR nMaxLinesAvail AS NUMERIC
VAR cExprBuff AS STRING
VAR cOffsetsBuff AS STRING
VAR cLengthsBuff AS STRING
METHOD New( cFrmName AS STRING,;
lPrinter AS LOGICAL,;
cAltFile AS STRING,;
lNoConsole AS LOGICAL,;
bFor AS CODEBLOCK,;
bWhile AS CODEBLOCK,;
nNext AS NUMERIC,;
nRecord AS NUMERIC,;
lRest AS LOGICAL,;
lPlain AS LOGICAL, ;
cHeading AS STRING,;
lBEject AS LOGICAL,;
lSummary AS LOGICAL )
METHOD NEW( cFrmName AS STRING, lPrinter AS LOGICAL ,cAltFile AS STRING, lNoConsole AS LOGICAL ,bFor AS CODEBLOCK, ;
bWhile AS CODEBLOCK, nNext AS NUMERIC, nRecord AS NUMERIC, lRest AS LOGICAL ,lPlain AS LOGICAL, ;
cHeading AS STRING ,lBEject AS LOGICAL, lSummary AS LOGICAL )
METHOD ExecuteReport()
METHOD ReportHeader()
METHOD EjectPage()
METHOD PrintIt(cString AS STRING)
METHOD LoadReportFile(cFile AS STRING)
METHOD GetExpr( nPointer AS NUMERIC)
METHOD GetColumn( cFieldsBuffer AS STRING, nOffset AS NUMERIC)
METHOD PrintIt( cString AS STRING )
METHOD LoadReportFile( cFile AS STRING )
METHOD GetExpr( nPointer AS NUMERIC )
METHOD GetColumn( cFieldsBuffer AS STRING, nOffset AS NUMERIC )
ENDCLASS
METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,;
lRest,lPlain,cHeading,lBEject,lSummary) CLASS HBReportForm
METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nRecord,;
lRest, lPlain, cHeading, lBEject, lSummary ) CLASS HBReportForm
LOCAL lPrintOn, lConsoleOn // Status of PRINTER and CONSOLE
LOCAL cExtraFile, lExtraState // Status of EXTRA
@@ -197,7 +209,8 @@ METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,;
err:subSystem := "FRMLBL"
Eval(ErrorBlock(), err)
ELSE
cFRMName := RTrim( cFRMName ) // ; TOFIX: Not very multiplatform.
/* NOTE: CA-Cl*pper does an RTrim() on the filename here,
but in Harbour we're using _SET_TRIMFILENAME. [vszakats] */
IF Set( _SET_DEFEXTENSIONS )
hb_FNameSplit( cFRMName, NIL, NIL, @cExt )
IF Empty( cExt )
@@ -207,22 +220,15 @@ METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,;
ENDIF
#ifdef OLDCODE
IF lPrinter == NIL
lPrinter := .F.
ENDIF
DEFAULT lPrinter TO .F.
#endif
IF cHeading == NIL
cHeading := ""
ENDIF
DEFAULT cHeading TO ""
// Set output devices
lPrintOn := iif( lPrinter, SET( _SET_PRINTER, lPrinter ), ;
SET( _SET_PRINTER ) )
lPrintOn := iif( lPrinter, SET( _SET_PRINTER, lPrinter ), SET( _SET_PRINTER ) )
lConsoleOn := iif( lNoConsole, SET( _SET_CONSOLE, .F.), ;
SET( _SET_CONSOLE) )
lConsoleOn := iif( lNoConsole, SET( _SET_CONSOLE, .F.), SET( _SET_CONSOLE ) )
IF lPrinter // To the printer
::lFormFeeds := .T.
@@ -230,7 +236,7 @@ METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,;
::lFormFeeds := .F.
ENDIF
IF (!Empty(cAltFile)) // To file
IF !Empty(cAltFile) // To file
lExtraState := SET( _SET_EXTRA, .T. )
cExtraFile := SET( _SET_EXTRAFILE, cAltFile )
ENDIF
@@ -250,8 +256,8 @@ METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,;
ENDIF
IF lPlain // Set plain report flag
::aReportData[ RPT_PLAIN ] := .T.
cHeading := ""
::lFormFeeds := .F.
cHeading := ""
::lFormFeeds := .F.
ENDIF
::aReportData[ RPT_HEADING ] := cHeading
@@ -327,9 +333,9 @@ METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,;
ENDIF
// Print the first line
::PrintIt( SPACE(::aReportData[RPT_LMARGIN]) + ;
iif(nGroup==1,NationMsg(_RFRM_SUBTOTAL),;
NationMsg(_RFRM_SUBSUBTOTAL) ) )
::PrintIt( SPACE( ::aReportData[RPT_LMARGIN] ) + ;
iif( nGroup == 1, NationMsg( _RFRM_SUBTOTAL ),;
NationMsg( _RFRM_SUBSUBTOTAL ) ) )
// Print the second line
QQOUT( SPACE(::aReportData[RPT_LMARGIN]) )
@@ -421,7 +427,7 @@ METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,;
SET( _SET_PRINTER, lPrintOn ) // Set the printer back to prior state
SET( _SET_CONSOLE, lConsoleOn ) // Set the console back to prior state
IF (!Empty(cAltFile)) // Set extrafile back
IF !Empty(cAltFile) // Set extrafile back
SET( _SET_EXTRAFILE, cExtraFile )
SET( _SET_EXTRA, lExtraState )
ENDIF
@@ -429,17 +435,15 @@ METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,;
IF lBroke
// keep the break value going
BREAK xBreakVal
END
ENDIF
RETURN NIL
METHOD PrintIt(cString) CLASS HBReportForm
METHOD PrintIt( cString ) CLASS HBReportForm
IF cString == NIL
cString := ""
ENDIF
DEFAULT cString TO ""
QQOUT(cString)
QQOUT( cString )
QOUT()
RETURN Self
@@ -597,7 +601,7 @@ METHOD ExecuteReport() CLASS HBReportForm
NEXT
// retrieve group eject state from report form
IF ( nGroup == 1 )
IF nGroup == 1
lEjectGrp := ::aReportData[ RPT_GROUPS, nGroup, RGT_AEJECT ]
ENDIF
@@ -615,8 +619,8 @@ METHOD ExecuteReport() CLASS HBReportForm
IF lGroupChanged .OR. MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]),;
::aReportData[RPT_GROUPS,nGroup,RGT_TYPE]) != ::aGroupTotals[nGroup]
AADD( aRecordHeader, iif(nGroup==1,NationMsg(_RFRM_SUBTOTAL),;
NationMsg(_RFRM_SUBSUBTOTAL)) )
AADD( aRecordHeader, iif( nGroup == 1, NationMsg(_RFRM_SUBTOTAL),;
NationMsg(_RFRM_SUBSUBTOTAL) ) )
AADD( aRecordHeader, "" )
@@ -646,11 +650,11 @@ METHOD ExecuteReport() CLASS HBReportForm
ENDIF
IF ( LEN( aRecordHeader ) > 0 ) .AND. lEjectGrp .AND. lGroupChanged
IF LEN( aRecordHeader ) > 0 .AND. lEjectGrp .AND. lGroupChanged
IF LEN( aRecordHeader ) > ::nLinesLeft
::EjectPage()
IF ( ::aReportData[ RPT_PLAIN ] )
IF ::aReportData[ RPT_PLAIN ]
::nLinesLeft := 1000
ELSE
::ReportHeader()
@@ -659,13 +663,13 @@ METHOD ExecuteReport() CLASS HBReportForm
ENDIF
AEVAL( aRecordHeader, { | HeaderLine | ;
::PrintIt( SPACE( ::aReportData[ RPT_LMARGIN ] ) + HeaderLine ) } )
::PrintIt( SPACE( ::aReportData[ RPT_LMARGIN ] ) + HeaderLine ) } )
aRecordHeader := {}
::EjectPage()
IF ( ::aReportData[ RPT_PLAIN ] )
IF ::aReportData[ RPT_PLAIN ]
::nLinesLeft := 1000
ELSE
@@ -696,7 +700,7 @@ METHOD ExecuteReport() CLASS HBReportForm
ENDIF
AADD( aRecordHeader, iif(nGroup==1,"** ","* ") +;
AADD( aRecordHeader, iif( nGroup == 1, "** ", "* " ) +;
::aReportData[RPT_GROUPS,nGroup,RGT_HEADER] + " " +;
MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]), ;
::aReportData[RPT_GROUPS,nGroup,RGT_TYPE]) )
@@ -869,7 +873,7 @@ METHOD ExecuteReport() CLASS HBReportForm
RETURN NIL
METHOD LoadReportFile(cFrmFile) CLASS HBReportForm
METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
LOCAL cFieldsBuff
LOCAL cParamsBuff
LOCAL nFieldOffset := 0
@@ -917,7 +921,7 @@ METHOD LoadReportFile(cFrmFile) CLASS HBReportForm
// Open the report file
nFrmHandle := FOPEN( cFrmFile )
IF ( !EMPTY( nFileError := FERROR() ) ) .AND. !( "\" $ cFrmFile .OR. ":" $ cFrmFile )
IF !EMPTY( nFileError := FERROR() ) .AND. !( "\" $ cFrmFile .OR. ":" $ cFrmFile )
// Search through default path; attempt to open report file
cDefPath := SET( _SET_DEFAULT ) + ";" + SET( _SET_PATH )
@@ -1017,11 +1021,11 @@ METHOD LoadReportFile(cFrmFile) CLASS HBReportForm
// Line spacing
// Spacing is 1, 2, or 3
aReport[ RPT_SPACING ] := iif(SUBSTR(cParamsBuff, ;
aReport[ RPT_SPACING ] := iif( SUBSTR( cParamsBuff, ;
DBL_SPACE_OFFSET, 1) $ "YyTt", 2, 1)
// Summary report flag
aReport[ RPT_SUMMARY ] := iif(SUBSTR(cParamsBuff, ;
aReport[ RPT_SUMMARY ] := iif( SUBSTR( cParamsBuff, ;
SUMMARY_RPT_OFFSET, 1) $ "YyTt", .T., .F.)
// Process report eject and plain attributes option byte
@@ -1083,7 +1087,7 @@ METHOD LoadReportFile(cFrmFile) CLASS HBReportForm
aReport[ RPT_GROUPS ][1][ RGT_HEADER ] := ::GetExpr( nPointer )
// Page eject after group
aReport[ RPT_GROUPS ][1][ RGT_AEJECT ] := iif(SUBSTR(cParamsBuff, ;
aReport[ RPT_GROUPS ][1][ RGT_AEJECT ] := iif( SUBSTR( cParamsBuff, ;
PE_OFFSET, 1) $ "YyTt", .T., .F.)
ENDIF
@@ -1194,14 +1198,15 @@ STATIC FUNCTION Occurs( cSearch, cTarget )
RETURN nCount
STATIC FUNCTION XMLCOUNT( cString, nLineLength, nTabSize, lWrap )
// Set defaults if none specified
nLineLength := iif( nLineLength == NIL, 79, nLineLength )
nTabSize := iif( nTabSize == NIL, 4, nTabSize )
lWrap := iif( lWrap == NIL, .T., .F. )
DEFAULT nLineLength TO 79
DEFAULT nTabSize TO 4
DEFAULT lWrap TO .T.
IF nTabSize >= nLineLength
nTabSize := nLineLength - 1
ENDIF
RETURN MLCOUNT( TRIM(cString), nLineLength, nTabSize, lWrap )
/***
@@ -1212,17 +1217,16 @@ STATIC FUNCTION XMLCOUNT( cString, nLineLength, nTabSize, lWrap )
*/
STATIC FUNCTION XMEMOLINE( cString, nLineLength, nLineNumber, nTabSize, lWrap )
// Set defaults if none specified
nLineLength := iif( nLineLength == NIL, 79, nLineLength )
nLineNumber := iif( nLineNumber == NIL, 1, nLineNumber )
nTabSize := iif( nTabSize == NIL, 4, nTabSize )
lWrap := iif( lWrap == NIL, .T., lWrap )
DEFAULT nLineLength TO 79
DEFAULT nLineNumber TO 1
DEFAULT nTabSize TO 4
DEFAULT lWrap TO .T.
IF nTabSize >= nLineLength
nTabSize := nLineLength - 1
ENDIF
RETURN( MEMOLINE( cString, nLineLength, nLineNumber, nTabSize, lWrap ) )
RETURN MEMOLINE( cString, nLineLength, nLineNumber, nTabSize, lWrap )
STATIC FUNCTION ParseHeader( cHeaderString, nFields )
LOCAL cItem
@@ -1231,7 +1235,7 @@ STATIC FUNCTION ParseHeader( cHeaderString, nFields )
LOCAL nHeaderLen := 254
LOCAL nPos
DO WHILE ( ++nItemCount <= nFields )
DO WHILE ++nItemCount <= nFields
cItem := SUBSTR( cHeaderString, 1, nHeaderLen )
@@ -1342,11 +1346,9 @@ STATIC FUNCTION ListAsArray( cList, cDelimiter )
LOCAL aList := {} // Define an empty array
LOCAL lDelimLast := .F.
IF cDelimiter == NIL
cDelimiter := ","
ENDIF
DEFAULT cDelimiter TO ","
DO WHILE LEN(cList) <> 0
DO WHILE LEN(cList) != 0
nPos := AT(cDelimiter, cList)
@@ -1393,5 +1395,5 @@ STATIC FUNCTION MakeAStr( uVar, cType )
FUNCTION __ReportForm( cFRMName, lPrinter, cAltFile, lNoConsole, bFor, ;
bWhile, nNext, nRecord, lRest, lPlain, cHeading, ;
lBEject, lSummary )
RETURN HBReportForm():New(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,;
lRest,lPlain,cHeading,lBEject,lSummary)
RETURN HBReportForm():New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nRecord,;
lRest, lPlain, cHeading, lBEject, lSummary)

1271
harbour/source/rtl/ttopbar.prg
View File

File diff suppressed because it is too large Load Diff

1
harbour/tests/Makefile
View File

@@ -104,6 +104,7 @@ PRG_SOURCES=\
recursiv.prg \
returns.prg \
rto_get.prg \
rto_tb.prg \
round.prg \
say.prg \
scroll.prg \

47
harbour/tests/rto_get.prg
View File

@@ -109,6 +109,13 @@ FUNCTION Main( cArg01, cArg02, cArg03, cArg04 )
FWrite( s_fhnd, Set( _SET_DATEFORMAT ) + hb_OSNewLine() )
// ; Minus
SetPos( 14, 14 ) ; o := _GET_( nInt01, "nInt01", "9999.99",, )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:Minus := .T. )
TEST_LINE( o:Minus := .F. )
// ; Picture
SetPos( 14, 14 ) ; o := _GET_( cStr01, "cStr01", "9999999999",, )
@@ -276,7 +283,7 @@ FUNCTION Main( cArg01, cArg02, cArg03, cArg04 )
// ; Type change N -> C
SetPos( 14, 14 ) ; o := _GET_( nInt01, "nInt01" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:KillFocus() )
TEST_LINE( o:block := {| h | LogMe( h ), iif( h == NIL, cStr01, cStr01 := h ) } )
@@ -285,7 +292,7 @@ FUNCTION Main( cArg01, cArg02, cArg03, cArg04 )
// ; Reform
SetPos( 14, 14 ) ; o := _GET_( cStr01, "cStr01" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:picture := "!!!!!!!!" )
TEST_LINE( o:Reform() )
@@ -296,7 +303,7 @@ FUNCTION Main( cArg01, cArg02, cArg03, cArg04 )
// ; Minus
SetPos( 14, 14 ) ; o := _GET_( nInt01, "nInt01" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
bOldBlock := o:block
TEST_LINE( o:block := {| h | LogMe( h ), iif( h == NIL, Eval( bOldBlock ), Eval( bOldBlock, h ) ) } )
TEST_LINE( o:SetFocus() )
@@ -312,14 +319,14 @@ FUNCTION Main( cArg01, cArg02, cArg03, cArg04 )
SetPos( 14, 14 ) ; dDate01 := hb_SToD( "20070425" )
o := _GET_( dDate01, "dDate01" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:OverStrike("12345678") )
TEST_LINE( o:KillFocus() )
SetPos( 14, 14 ) ; dDate01 := hb_SToD( "20070425" )
o := _GET_( dDate01, "dDate01", "@E" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:OverStrike("12345678") )
TEST_LINE( o:KillFocus() )
@@ -328,42 +335,42 @@ FUNCTION Main( cArg01, cArg02, cArg03, cArg04 )
SetPos( 14, 14 ) ; dDate01 := hb_SToD( "20070425" )
o := _GET_( dDate01, "dDate01" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:OverStrike("12345678") )
TEST_LINE( o:KillFocus() )
SetPos( 14, 14 ) ; dDate01 := hb_SToD( "20070425" )
o := _GET_( dDate01, "dDate01", "@E" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:OverStrike("12345678") )
TEST_LINE( o:KillFocus() )
SetPos( 14, 14 ) ; cStr01 := "hello world"
o := _GET_( cStr01, "cStr01", "!!LY!!!!!!" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:OverStrike("12345678") )
TEST_LINE( o:KillFocus() )
SetPos( 14, 14 ) ; cStr01 := "hello world"
o := _GET_( cStr01, "cStr01", "!!!.!!!!!!" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:OverStrike("12345678") )
TEST_LINE( o:KillFocus() )
SetPos( 14, 14 ) ; cStr01 := "hello world"
o := _GET_( cStr01, "cStr01", "@R !!LY!!!!!!" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:OverStrike("12345678") )
TEST_LINE( o:KillFocus() )
SetPos( 14, 14 ) ; cStr01 := "hello world"
o := _GET_( cStr01, "cStr01", "@R !!!.!!!!!!" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:SetFocus() )
TEST_LINE( o:OverStrike("12345678") )
TEST_LINE( o:KillFocus() )
@@ -697,7 +704,7 @@ PROCEDURE TGetTest( xVar, cPic )
s_cTest := "Display Var: " + ValType( xVar ) + " Pic: " + iif( cPic == NIL, "(none)", cPic )
SetPos( 14, 14 ) ; o := _GET_( s_xVar, "s_xVar" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
TEST_LINE( o:Display() )
// ; In focus
@@ -705,7 +712,7 @@ PROCEDURE TGetTest( xVar, cPic )
s_cTest := "InFocus Var: " + ValType( xVar ) + " Pic: " + iif( cPic == NIL, "(none)", cPic )
SetPos( 14, 14 ) ; o := _GET_( s_xVar, "s_xVar" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
bOldBlock := o:block
TEST_LINE( o:block := {| h | LogMe( h ), iif( h == NIL, Eval( bOldBlock ), Eval( bOldBlock, h ) ) } )
TEST_LINE( o:SetFocus() )
@@ -725,7 +732,7 @@ PROCEDURE TGetTest( xVar, cPic )
s_cTest := "NotFocus Var: " + ValType( xVar ) + " Pic: " + iif( cPic == NIL, "(none)", cPic )
SetPos( 14, 14 ) ; o := _GET_( s_xVar, "s_xVar" )
TEST_LINE( GET_CREATE() )
TEST_LINE( OBJ_CREATE() )
bOldBlock := o:block
TEST_LINE( o:block := {| h | LogMe( h ), iif( h == NIL, Eval( bOldBlock ), Eval( bOldBlock, h ) ) } )
IF cPic != NIL
@@ -873,14 +880,14 @@ PROCEDURE LogGETVars( o, desc, xResult )
FWrite( s_fhnd, " TypeOut " + XToStr( o:TypeOut ) + hb_OSNewLine() )
#ifndef __HARBOUR__
IF s_lC5xDump
FWrite( s_fhnd, " _dump_ " + GetToList( o ) + hb_OSNewLine() )
FWrite( s_fhnd, " _dump_ " + ObjToList( o ) + hb_OSNewLine() )
ENDIF
#endif
FWrite( s_fhnd, "---------------------" + hb_OSNewLine() )
RETURN
STATIC FUNCTION GetToList( o )
STATIC FUNCTION ObjToList( o )
LOCAL cString := ""
LOCAL tmp
@@ -946,11 +953,13 @@ FUNCTION XToStrE( xValue )
RETURN ""
STATIC FUNCTION ErrorMessage( oError )
LOCAL cMessage := ""
LOCAL cMessage
LOCAL tmp
IF s_lRTEDetails
cMessage := ""
IF ValType( oError:severity ) == "N"
DO CASE
CASE oError:severity == ES_WHOCARES ; cMessage += "M "
@@ -1001,6 +1010,8 @@ STATIC FUNCTION ErrorMessage( oError )
cMessage += "S"
ENDIF
ENDIF
ELSE
cMessage := "(ERROR)"
ENDIF
RETURN cMessage
@@ -1036,7 +1047,7 @@ FUNCTION hb_SToD( cDate )
#endif
#endif
PROCEDURE GET_CREATE()
PROCEDURE OBJ_CREATE()
// ; Dummy

710
harbour/tests/rto_tb.prg Normal file
View File

@@ -0,0 +1,710 @@
/*
* $Id: rto_get.prg 7264 2007-04-24 08:38:50Z vszakats $
*/
/*
* Harbour Project source code:
* Regression tests for classes TBrowse/TBColumn
*
* Copyright 1999-2007 Viktor Szakats <viktor.szakats@syenar.hu>
* 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.
*
*/
/* NOTE: This source can be compiled with both Harbour and CA-Cl*pper. */
#include "common.ch"
#include "error.ch"
#include "fileio.ch"
#ifndef __HARBOUR__
#define hb_OSNewLine() ( Chr( 13 ) + Chr( 10 ) )
#endif
#translate TEST_L_TBR( <x> ) => TEST_C_TBR( o, #<x>, {|| <x> } )
#translate TEST_L_TBC( <x> ) => TEST_C_TBC( o, #<x>, {|| <x> } )
STATIC s_cTest := ""
STATIC s_xVar := NIL
STATIC s_fhnd
STATIC s_lCallBackStack
STATIC s_lRTEDetails
STATIC s_lIgnoreErrOp
STATIC s_lC5xDump
STATIC s_lCatchErr
STATIC s_lCheckResult
FUNCTION Main( cArg01, cArg02, cArg03, cArg04 )
LOCAL o
LOCAL cCommandLine
DEFAULT cArg01 TO ""
DEFAULT cArg02 TO ""
DEFAULT cArg03 TO ""
DEFAULT cArg04 TO ""
SET DATE ANSI
// ;
cCommandLine := cArg01 + " " + cArg02 + " " + cArg03 + " " + cArg04
s_lCallBackStack := "CALLBACKSTACK" $ Upper( cCommandLine )
s_lRTEDetails := "RTEDETAILS" $ Upper( cCommandLine )
s_lIgnoreErrOp := "IGNERROP" $ Upper( cCommandLine )
s_lC5xDump := "C5XDUMP" $ Upper( cCommandLine )
s_lCatchErr := .T.
s_lCheckResult := .F.
s_lRTEDetails := .T.
// s_lIgnoreErrOp := .T.
// ;
#ifdef __HARBOUR__
s_fhnd := FCreate( "tb_hb.txt", FC_NORMAL )
#else
s_fhnd := FCreate( "tb_cl5.txt", FC_NORMAL )
#endif
IF s_fhnd == F_ERROR
RETURN 1
ENDIF
// ;
o := TBColumnNew( "test00", {|| "test00" } )
TEST_L_TBC( OBJ_CREATE() )
TEST_L_TBC( o:defColor := {} )
TEST_L_TBC( o:defColor := { 1 } )
TEST_L_TBC( o:defColor := NIL )
TEST_L_TBC( o:defColor := { 1, 2 } )
TEST_L_TBC( o:defColor := { 1, 2, 3 } )
TEST_L_TBC( o:defColor := { 1, 2, 3, 4 } )
TEST_L_TBC( o:defColor := { 1, 2, 3, 4, 5 } )
TEST_L_TBC( o:defColor := { "1" } )
TEST_L_TBC( o:defColor := { "1", "2" } )
TEST_L_TBC( o:defColor := { "1", "2", "3" } )
TEST_L_TBC( o:defColor := { "1", "2", "3", "4" } )
TEST_L_TBC( o:defColor := { "1", "2", "3", "4", "5" } )
TEST_L_TBC( o:defColor := { "1", 2, "3" } )
// ;
s_lCheckResult := .T.
TEST_L_TBC( TBColumnNew( NIL , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( -1 , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( 0 , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( 1 , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( 3 , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( 25 , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( "" , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( "az" , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( hb_SToD( "20070425" ), {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( .F. , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( .T. , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( {|| NIL } , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( {} , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( { "" } , {|| "test00" } ) )
TEST_L_TBC( TBColumnNew( "test00", NIL ) )
TEST_L_TBC( TBColumnNew( "test00", -1 ) )
TEST_L_TBC( TBColumnNew( "test00", 0 ) )
TEST_L_TBC( TBColumnNew( "test00", 1 ) )
TEST_L_TBC( TBColumnNew( "test00", 3 ) )
TEST_L_TBC( TBColumnNew( "test00", 25 ) )
TEST_L_TBC( TBColumnNew( "test00", "" ) )
TEST_L_TBC( TBColumnNew( "test00", "az" ) )
TEST_L_TBC( TBColumnNew( "test00", hb_SToD( "20070425" ) ) )
TEST_L_TBC( TBColumnNew( "test00", .F. ) )
TEST_L_TBC( TBColumnNew( "test00", .T. ) )
TEST_L_TBC( TBColumnNew( "test00", {|| NIL } ) )
TEST_L_TBC( TBColumnNew( "test00", {} ) )
TEST_L_TBC( TBColumnNew( "test00", { "" } ) )
s_lCheckResult := .F.
// ;
TBRAssign( NIL )
TBRAssign( -1 )
TBRAssign( 0 )
TBRAssign( 1 )
TBRAssign( 3 )
TBRAssign( 25 )
TBRAssign( "" )
TBRAssign( "az" )
TBRAssign( hb_SToD( "20070425" ) )
TBRAssign( .F. )
TBRAssign( .T. )
TBRAssign( {|| NIL } )
TBRAssign( {} )
TBRAssign( { "" } )
// ;
TBCAssign( NIL )
TBCAssign( -1 )
TBCAssign( 0 )
TBCAssign( 1 )
TBCAssign( 3 )
TBCAssign( 25 )
TBCAssign( "" )
TBCAssign( "az" )
TBCAssign( hb_SToD( "20070425" ) )
TBCAssign( .F. )
TBCAssign( .T. )
TBCAssign( {|| NIL } )
TBCAssign( {} )
TBCAssign( { "" } )
// ;
s_cTest := ""
// ;
s_lCatchErr := .F.
o := TBrowseNew( 10, 10, 20, 50 )
TEST_L_TBR( OBJ_CREATE() )
TEST_L_TBR( o:AddColumn( TBColumnNew( "test01h", {|| "test01d" } ) ) )
TEST_L_TBR( o:DelColumn( 1 ) )
TEST_L_TBR( o:Left() )
TEST_L_TBR( o:Right() )
// ;
#ifdef HB_COMPAT_C53
o := TBColumnNew( "test01h", {|| "test01d" } )
TEST_L_TBC( OBJ_CREATE() )
TEST_L_TBC( o:SetStyle( 1 ) )
TEST_L_TBC( o:SetStyle( 2 ) )
TEST_L_TBC( o:SetStyle( 3 ) )
TEST_L_TBC( o:SetStyle( 4, .T. ) )
TEST_L_TBC( o:SetStyle( 4 ) )
TEST_L_TBC( o:SetStyle( 4, NIL ) )
TEST_L_TBC( o:SetStyle( 4 ) )
TEST_L_TBC( o:SetStyle( 5 ) )
TEST_L_TBC( o:SetStyle( 5, .T. ) )
TEST_L_TBC( o:SetStyle( 5, .F. ) )
o := TBrowseNew( 10, 10, 20, 50 )
TEST_L_TBR( OBJ_CREATE() )
TEST_L_TBR( o:SetStyle( 1 ) )
TEST_L_TBR( o:SetStyle( 2 ) )
TEST_L_TBR( o:SetStyle( 3 ) )
TEST_L_TBR( o:SetStyle( 4 ) )
TEST_L_TBR( o:SetStyle( 5 ) )
TEST_L_TBR( o:SetStyle( 4, .T. ) )
TEST_L_TBR( o:SetStyle( 4 ) )
TEST_L_TBR( o:SetStyle( 4, NIL ) )
TEST_L_TBR( o:SetStyle( 4 ) )
TEST_L_TBR( o:SetStyle( 6 ) )
TEST_L_TBR( o:SetStyle( 6, .T. ) )
TEST_L_TBR( o:SetStyle( 6, .F. ) )
#endif
// ;
FClose( s_fhnd )
RETURN 0
PROCEDURE TBRAssign( xVar )
LOCAL o
s_xVar := xVar
s_cTest := "TBrowse (empty) assigning: " + XToStr( xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:AutoLite := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:Cargo := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColCount := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColorSpec := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColPos := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColSep := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:FootSep := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:Freeze := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:GoBottomBlock := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:GoTopBlock := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:HeadSep := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:HitBottom := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:HitTop := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:LeftVisible := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nBottom := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nLeft := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nRight := xVar )
// ; This is needed for CA-Cl*pper 5.x otherwise an unmaskable (bug?) RTE would be thrown. [vszakats]
IF ISNUMBER( xVar ) .AND. xVar < o:nBottom
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nTop := xVar )
ENDIF
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:RightVisible := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:RowCount := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:RowPos := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:SkipBlock := xVar )
o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:Stable := xVar )
RETURN
PROCEDURE TBCAssign( xVar )
LOCAL o
s_xVar := xVar
s_cTest := "TBColumn assigning: " + XToStr( xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Block := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Cargo := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:ColorBlock := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:ColSep := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:DefColor := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Footing := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:FootSep := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Heading := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:HeadSep := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Picture := xVar )
o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Width := xVar )
RETURN
PROCEDURE TEST_C_TBR( o, cBlock, bBlock )
LOCAL xResult
LOCAL bOldError
LOCAL oError
SetPos( 0, 0 ) // ; To check where the cursor was moved after evaluating the block.
IF s_lCatchErr
bOldError := ErrorBlock( {|oError| Break( oError ) } )
ENDIF
BEGIN SEQUENCE
xResult := Eval( bBlock )
RECOVER USING oError
xResult := ErrorMessage( oError )
END SEQUENCE
IF s_lCatchErr
ErrorBlock( bOldError )
ENDIF
LogTBRVars( o, cBlock, xResult )
RETURN
PROCEDURE TEST_C_TBC( o, cBlock, bBlock )
LOCAL xResult
LOCAL bOldError
LOCAL oError
SetPos( 0, 0 ) // ; To check where the cursor was moved after evaluating the block.
IF s_lCatchErr
bOldError := ErrorBlock( {|oError| Break( oError ) } )
ENDIF
BEGIN SEQUENCE
xResult := Eval( bBlock )
RECOVER USING oError
xResult := ErrorMessage( oError )
END SEQUENCE
IF s_lCatchErr
ErrorBlock( bOldError )
ENDIF
IF s_lCheckResult
LogTBCVars( xResult, cBlock, xResult )
ELSE
LogTBCVars( o, cBlock, xResult )
ENDIF
RETURN
PROCEDURE LogMe( data, desc )
LOCAL nLevel
LOCAL cStack
cStack := ""
FOR nLevel := 2 TO 5
IF Empty( ProcName( nLevel ) )
EXIT
ENDIF
cStack += ProcName( nLevel ) + " (" + LTrim( Str( ProcLine( nLevel ) ) ) + ") "
NEXT
IF desc == NIL
desc := ""
ENDIF
desc := s_cTest + " " + desc
IF !s_lCallBackStack
cStack := ""
ENDIF
IF PCount() > 2
FWrite( s_fhnd, cStack + "BLOCK_SET " + iif( data == NIL, "NIL", data ) + " " + desc + hb_OSNewLine() )
ELSE
FWrite( s_fhnd, cStack + "BLOCK_GET " + desc + hb_OSNewLine() )
ENDIF
RETURN
PROCEDURE LogTBRVars( o, desc, xResult )
LOCAL nLevel
LOCAL cStack
LOCAL tmp
LOCAL col
cStack := ""
FOR nLevel := 2 TO 2
IF Empty( ProcName( nLevel ) )
EXIT
ENDIF
cStack += ProcName( nLevel ) + " (" + LTrim( Str( ProcLine( nLevel ) ) ) + ") "
NEXT
IF desc == NIL
desc := ""
ENDIF
desc := s_cTest + " " + XToStr( desc )
FWrite( s_fhnd, cStack + " " + desc + hb_OSNewLine() )
FWrite( s_fhnd, "---------------------" + hb_OSNewLine() )
FWrite( s_fhnd, " s_xVar " + XToStr( s_xVar ) + hb_OSNewLine() )
FWrite( s_fhnd, " xResult " + XToStr( xResult ) + hb_OSNewLine() )
FWrite( s_fhnd, " Row() " + XToStr( Row() ) + hb_OSNewLine() )
FWrite( s_fhnd, " Col() " + XToStr( Col() ) + hb_OSNewLine() )
FWrite( s_fhnd, " AutoLite " + XToStr( o:AutoLite ) + hb_OSNewLine() )
FWrite( s_fhnd, " Cargo " + XToStr( o:Cargo ) + hb_OSNewLine() )
FWrite( s_fhnd, " ColCount " + XToStr( o:ColCount ) + hb_OSNewLine() )
FWrite( s_fhnd, " ColorSpec " + XToStr( o:ColorSpec ) + hb_OSNewLine() )
FWrite( s_fhnd, " ColPos " + XToStr( o:ColPos ) + hb_OSNewLine() )
FWrite( s_fhnd, " ColSep " + XToStr( o:ColSep ) + hb_OSNewLine() )
FWrite( s_fhnd, " FootSep " + XToStr( o:FootSep ) + hb_OSNewLine() )
FWrite( s_fhnd, " Freeze " + XToStr( o:Freeze ) + hb_OSNewLine() )
FWrite( s_fhnd, " GoBottomBlock " + XToStr( o:GoBottomBlock ) + hb_OSNewLine() )
FWrite( s_fhnd, " GoTopBlock " + XToStr( o:GoTopBlock ) + hb_OSNewLine() )
FWrite( s_fhnd, " HeadSep " + XToStr( o:HeadSep ) + hb_OSNewLine() )
FWrite( s_fhnd, " HitBottom " + XToStr( o:HitBottom ) + hb_OSNewLine() )
FWrite( s_fhnd, " HitTop " + XToStr( o:HitTop ) + hb_OSNewLine() )
FWrite( s_fhnd, " LeftVisible " + XToStr( o:LeftVisible ) + hb_OSNewLine() )
FWrite( s_fhnd, " nBottom " + XToStr( o:nBottom ) + hb_OSNewLine() )
FWrite( s_fhnd, " nLeft " + XToStr( o:nLeft ) + hb_OSNewLine() )
FWrite( s_fhnd, " nRight " + XToStr( o:nRight ) + hb_OSNewLine() )
FWrite( s_fhnd, " nTop " + XToStr( o:nTop ) + hb_OSNewLine() )
FWrite( s_fhnd, " RightVisible " + XToStr( o:RightVisible ) + hb_OSNewLine() )
FWrite( s_fhnd, " RowCount " + XToStr( o:RowCount ) + hb_OSNewLine() )
FWrite( s_fhnd, " RowPos " + XToStr( o:RowPos ) + hb_OSNewLine() )
FWrite( s_fhnd, " SkipBlock " + XToStr( o:SkipBlock ) + hb_OSNewLine() )
FWrite( s_fhnd, " Stable " + XToStr( o:Stable ) + hb_OSNewLine() )
#ifndef __HARBOUR__
IF s_lC5xDump
FWrite( s_fhnd, " _dump_ " + ObjToList( o ) + hb_OSNewLine() )
ENDIF
#endif
FOR tmp := 1 TO o:colCount
FWrite( s_fhnd, " Column: " + StrZero( tmp, 3 ) + hb_OSNewLine() )
col := o:GetColumn( tmp )
IF ISOBJECT( col )
FWrite( s_fhnd, " Block " + XToStr( col:Block ) + hb_OSNewLine() )
FWrite( s_fhnd, " Cargo " + XToStr( col:Cargo ) + hb_OSNewLine() )
FWrite( s_fhnd, " ColorBlock " + XToStr( col:ColorBlock ) + hb_OSNewLine() )
FWrite( s_fhnd, " ColSep " + XToStr( col:ColSep ) + hb_OSNewLine() )
FWrite( s_fhnd, " DefColor " + XToStr( col:DefColor ) + hb_OSNewLine() )
FWrite( s_fhnd, " Footing " + XToStr( col:Footing ) + hb_OSNewLine() )
FWrite( s_fhnd, " FootSep " + XToStr( col:FootSep ) + hb_OSNewLine() )
FWrite( s_fhnd, " Heading " + XToStr( col:Heading ) + hb_OSNewLine() )
FWrite( s_fhnd, " HeadSep " + XToStr( col:HeadSep ) + hb_OSNewLine() )
FWrite( s_fhnd, " Picture " + XToStr( col:Picture ) + hb_OSNewLine() )
FWrite( s_fhnd, " Width " + XToStr( col:Width ) + hb_OSNewLine() )
ELSE
FWrite( s_fhnd, " Col: " + XToStr( col ) + hb_OSNewLine() )
ENDIF
NEXT
FWrite( s_fhnd, "---------------------" + hb_OSNewLine() )
RETURN
PROCEDURE LogTBCVars( o, desc, xResult )
LOCAL nLevel
LOCAL cStack
cStack := ""
FOR nLevel := 2 TO 2
IF Empty( ProcName( nLevel ) )
EXIT
ENDIF
cStack += ProcName( nLevel ) + " (" + LTrim( Str( ProcLine( nLevel ) ) ) + ") "
NEXT
IF desc == NIL
desc := ""
ENDIF
desc := s_cTest + " " + XToStr( desc )
FWrite( s_fhnd, cStack + " " + desc + hb_OSNewLine() )
FWrite( s_fhnd, "---------------------" + hb_OSNewLine() )
FWrite( s_fhnd, " s_xVar " + XToStr( s_xVar ) + hb_OSNewLine() )
FWrite( s_fhnd, " xResult " + XToStr( xResult ) + hb_OSNewLine() )
IF ISOBJECT( o )
FWrite( s_fhnd, " Block " + XToStr( o:Block ) + hb_OSNewLine() )
FWrite( s_fhnd, " Cargo " + XToStr( o:Cargo ) + hb_OSNewLine() )
FWrite( s_fhnd, " ColorBlock " + XToStr( o:ColorBlock ) + hb_OSNewLine() )
FWrite( s_fhnd, " ColSep " + XToStr( o:ColSep ) + hb_OSNewLine() )
FWrite( s_fhnd, " DefColor " + XToStr( o:DefColor ) + hb_OSNewLine() )
FWrite( s_fhnd, " Footing " + XToStr( o:Footing ) + hb_OSNewLine() )
FWrite( s_fhnd, " FootSep " + XToStr( o:FootSep ) + hb_OSNewLine() )
FWrite( s_fhnd, " Heading " + XToStr( o:Heading ) + hb_OSNewLine() )
FWrite( s_fhnd, " HeadSep " + XToStr( o:HeadSep ) + hb_OSNewLine() )
FWrite( s_fhnd, " Picture " + XToStr( o:Picture ) + hb_OSNewLine() )
FWrite( s_fhnd, " Width " + XToStr( o:Width ) + hb_OSNewLine() )
#ifndef __HARBOUR__
IF s_lC5xDump
FWrite( s_fhnd, " _dump_ " + ObjToList( o ) + hb_OSNewLine() )
ENDIF
#endif
ELSE
FWrite( s_fhnd, " o " + XToStr( o ) + hb_OSNewLine() )
ENDIF
FWrite( s_fhnd, "---------------------" + hb_OSNewLine() )
RETURN
STATIC FUNCTION ObjToList( o )
LOCAL cString := ""
LOCAL tmp
FOR tmp := 1 TO Len( o )
cString += XToStr( o[ tmp ] )
IF tmp < Len( o )
cString += ", "
ENDIF
NEXT
RETURN cString
FUNCTION XToStr( xValue )
LOCAL cType := ValType( xValue )
DO CASE
CASE cType == "C"
xValue := StrTran( xValue, Chr(0), '"+Chr(0)+"' )
xValue := StrTran( xValue, Chr(9), '"+Chr(9)+"' )
xValue := StrTran( xValue, Chr(10), '"+Chr(10)+"' )
xValue := StrTran( xValue, Chr(13), '"+Chr(13)+"' )
xValue := StrTran( xValue, Chr(26), '"+Chr(26)+"' )
RETURN '"' + xValue + '"'
CASE cType == "N" ; RETURN LTrim( Str( xValue ) )
CASE cType == "D" ; RETURN 'HB_SToD("' + DToS( xValue ) + '")'
CASE cType == "L" ; RETURN iif( xValue, ".T.", ".F." )
CASE cType == "O" ; RETURN xValue:className() + " Object"
CASE cType == "U" ; RETURN "NIL"
CASE cType == "B" ; RETURN '{||...} -> ' + XToStr( Eval( xValue ) )
CASE cType == "A" ; RETURN '{ ' + ArrayToList( xValue ) + ' }'
CASE cType == "M" ; RETURN 'M:"' + xValue + '"'
ENDCASE
RETURN ""
FUNCTION ArrayToList( a )
LOCAL tmp
LOCAL cString := ""
FOR tmp := 1 TO Len( a )
cString += XToStr( a[ tmp ] )
IF tmp < Len( a )
cString += ", "
ENDIF
NEXT
RETURN cString
FUNCTION XToStrE( xValue )
LOCAL cType := ValType( xValue )
DO CASE
CASE cType == "C"
xValue := StrTran( xValue, Chr(0), '"+Chr(0)+"' )
xValue := StrTran( xValue, Chr(9), '"+Chr(9)+"' )
xValue := StrTran( xValue, Chr(10), '"+Chr(10)+"' )
xValue := StrTran( xValue, Chr(13), '"+Chr(13)+"' )
xValue := StrTran( xValue, Chr(26), '"+Chr(26)+"' )
RETURN xValue
CASE cType == "N" ; RETURN LTrim( Str( xValue ) )
CASE cType == "D" ; RETURN DToS( xValue )
CASE cType == "L" ; RETURN iif( xValue, ".T.", ".F." )
CASE cType == "O" ; RETURN xValue:className() + " Object"
CASE cType == "U" ; RETURN "NIL"
CASE cType == "B" ; RETURN '{||...} -> ' + XToStrE( Eval( xValue ) )
CASE cType == "A" ; RETURN '{ ' + ArrayToEList( xValue ) + ' }'
CASE cType == "M" ; RETURN 'M:' + xValue
ENDCASE
RETURN ""
FUNCTION ArrayToEList( a )
LOCAL tmp
LOCAL cString := ""
FOR tmp := 1 TO Len( a )
cString += XToStrE( a[ tmp ] )
IF tmp < Len( a )
cString += ", "
ENDIF
NEXT
RETURN cString
STATIC FUNCTION ErrorMessage( oError )
LOCAL cMessage
LOCAL tmp
IF s_lRTEDetails
cMessage := ""
IF ValType( oError:severity ) == "N"
DO CASE
CASE oError:severity == ES_WHOCARES ; cMessage += "M "
CASE oError:severity == ES_WARNING ; cMessage += "W "
CASE oError:severity == ES_ERROR ; cMessage += "E "
CASE oError:severity == ES_CATASTROPHIC ; cMessage += "C "
ENDCASE
ENDIF
IF ValType( oError:subsystem ) == "C"
cMessage += oError:subsystem + " "
ENDIF
IF ValType( oError:subCode ) == "N"
cMessage += LTrim( Str( oError:subCode ) ) + " "
ENDIF
IF ValType( oError:description ) == "C"
cMessage += oError:description + " "
ENDIF
IF !Empty( oError:operation ) .AND. !s_lIgnoreErrOp
cMessage += oError:operation + " "
ENDIF
IF !Empty( oError:filename )
cMessage += oError:filename + " "
ENDIF
IF ValType( oError:Args ) == "A"
cMessage += "A:" + LTrim( Str( Len( oError:Args ) ) ) + ":"
FOR tmp := 1 TO Len( oError:Args )
cMessage += ValType( oError:Args[ tmp ] ) + ":" + XToStrE( oError:Args[ tmp ] )
IF tmp < Len( oError:Args )
cMessage += ";"
ENDIF
NEXT
cMessage += " "
ENDIF
IF oError:canDefault .OR. ;
oError:canRetry .OR. ;
oError:canSubstitute
cMessage += "F:"
IF oError:canDefault
cMessage += "D"
ENDIF
IF oError:canRetry
cMessage += "R"
ENDIF
IF oError:canSubstitute
cMessage += "S"
ENDIF
ENDIF
ELSE
cMessage := "(ERROR)"
ENDIF
RETURN cMessage
#ifdef __XPP__
FUNCTION hb_SToD( cDate )
RETURN SToD( cDate )
#endif
#ifndef HAVE_HBCLIP
#ifndef __HARBOUR__
#ifndef __XPP__
FUNCTION hb_SToD( cDate )
LOCAL cOldDateFormat
LOCAL dDate
IF ValType( cDate ) == "C" .AND. !Empty( cDate )
cOldDateFormat := Set( _SET_DATEFORMAT, "yyyy/mm/dd" )
dDate := CToD( SubStr( cDate, 1, 4 ) + "/" +;
SubStr( cDate, 5, 2 ) + "/" +;
SubStr( cDate, 7, 2 ) )
Set( _SET_DATEFORMAT, cOldDateFormat )
ELSE
dDate := CToD( "" )
ENDIF
RETURN dDate
#endif
#endif
#endif
PROCEDURE OBJ_CREATE()
// ; Dummy
RETURN