fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
0f9c19f41bbd93b2bc36e7331229b0fc2ee72983
harbour-core/harbour/tests/wvtext.prg
Przemyslaw Czerpak 93d3a46d84 2012-04-20 17:52 UTC+0200 Przemyslaw Czerpak (druzus/at/poczta.onet.pl) 
* harbour/include/hbdefs.h
    * moved HB_WCHAR definition from hbapicdp.h to hbdefs.h

  * harbour/include/hbapicdp.h
  * harbour/include/hbcdpreg.h
  * harbour/src/rtl/cdpapi.c
  * harbour/src/rtl/cdpapihb.c
    + added support for custom sorting redirected from HVM
    + added support for custom character indexes in strings
    + added support for custom character flags (upper, lower, alpha, digit)
    + added support for custom upper/lower conversions
    + added support for CPs using unicode character values instead of
      ASCII ones
    + added new CP functions which respects custom CP settings:
        hb_cdpUpperWC(), hb_cdpTextLen(), hb_cdpTextPos(),
        hb_cdpTextPosEx(), hb_cdpTextGetU16(), hb_cdpTextPutU16(),
        hb_cdpCharEq(), hb_cdpCharCaseEq()
    + added new conversion functions:
        hb_cdpGetUC(), hb_cdpGetWC(), hb_cdpGetU16Ctrl()
    + added macros to detect codepage parameters:
         HB_CDP_ISBINSORT() - codepage uses simple binary sorting
         HB_CDP_ISCUSTOM()  - codepage uses custom string decoding
         HB_CDP_ISCHARIDX() - codepage use character indexes instead
                              of bytes ones
         HB_CDP_ISCHARUNI() - CHR(), ASC() and similar functions operates
                              on Unicode values instead of bytes
         HB_CDP_ISUTF8()    - codepage uses UTF-8 encoding

  * harbour/include/inkey.ch
    - removed HB_INKEY_EXTENDED - it was not used in Harbour
    + added new flag HB_INKEY_EXT - it allows to used different
      event encoding system with automatic translation to
      standard Clipper values. It will be used in the future
      as base for low level GTs code. Now it's possible to
      selectively switch to the new system. New codes are
      unique and do not interacts with Clipper.
    + added HB_INKEY_ALL macro - it's similar to INKEY_ALL but
      enables also GTEVENT keys.

  * harbour/include/hbgtcore.h
  * harbour/src/rtl/hbgtcore.c
    * changed character values in internal screen buffer to unicode.
      Warning: this modification interacts with SAVESCREE()/RESTSCREEN()
               data. Now all GTs uses extended definition. If somene
               has code which needs VGA like screen buffers returned
               by SAVESCREE() then it can be forced by
                  hb_gtInfo( HB_GTI_COMPATBUFFER, .t. )
               Anyhow it will for to use only one CP in output.
    + added new GT methods which operated on HB_WCHAR values
    * modified existing methods using HB_WCHAR/HB_USHORT parameters
      to operate on HB_WCHAR values
    + added codepage conversion code directly to core code so it can
      be eliminated from low level GT drivers which do not need some
      special operations on it.
    + added support for extended inkey codes, they allow to encoded
      unicode values, mouse events with flags, keyboard events with
      modifier flags (shift,alt,ctrl,...), etc.
      Now in low level GT code only unicode key values are used but
      I plan to updated all GTs and switch to new code - it should
      resolve many small problems inheriting with Clipper inkey codes.

  * harbour/include/hbapifs.h
    * moved hb_fsNameConvU16() definition from hbapicdp.h to hbapifs.h

  * harbour/include/hbxvm.h
    - removed comment copied by mistake from GT header file

  * harbour/include/hbwinuni.h
    * changed HB_CHARDUP() and HB_CHARDUPN() macros - now they
      operate on functions which can be used without active HVM.
      In such case ANSI CP is used as source encoding.
    + added new macros: HB_OSSTRDUP() and HB_OSSTRDUP2().
      They make conversions from OS encoding to HVM one.
      They can be used without active HVM and in such case ANSI CP
      is used as destination encoding.

  * harbour/include/hbapi.h
  * harbour/src/vm/cmdarg.c
    + added new function hb_cmdargProgName()
      It returns application name with path or NULL if not set,
      caller must free returned value with hb_xfree() if not NULL.
      The string is in HVM encoding so it does not need any additional
      encodings.
    * modified hb_cmdargString() to return strings in HVM encoding.
    % some small code optimizations
    ; NOTE: parameters passed to MS-WINDOWS GUI programs which use
            WinMain() instead of main() as startup entry are translated
            to ANSICP before they can be accessed by application.
            This can be eliminated though not for console programs
            using where C compiler makes such translation to main()
            parameters.
            in all systems parameters are passed to application
            startup and init functions before programmer can set OS CP.
            This can be resolved by adding:
               INIT PROC CLIPINIT()
                  SET( _SET_CODEPAGE, <userCP> )
                  SET( _SET_OSCODEPAGE, <systemCP> )
               RETURN
            to linked code. INIT procedures called CLIPINIT() are
            executed before any other ones.

  * harbour/include/hbapi.h
  * harbour/src/vm/set.c
    + added new functions for CP converisons which can be used with
      and without active HVM:
         hb_osStrEncode(), hb_osStrEncodeN(),
         hb_osStrDecode(), hb_osStrDecode2(),
         hb_osStrU16Encode(), hb_osStrU16EncodeN(),
         hb_osStrU16Decode(), hb_osStrU16Decode2(),

  * harbour/include/hbvm.h
  * harbour/src/vm/hvm.c
    + added new function hb_vmIsReady() - it's similar to hb_vmActive()
      but it also checks if current thread has active HVM stack.
    * moved hb_cdpReleaseAll() to the end of HVM cleanup code so
      CP conversions are longer active.

  * harbour/include/hbcomp.h
  * harbour/src/compiler/cmdcheck.c
  * harbour/src/compiler/hbusage.c
  * harbour/src/common/expropt2.c
    + added new compiler switch:
         -ku  - strings in user encoding
      Now it informs compiler that strings use custom encoding so some
      optimizations which are byte oriented cannot be used.
      It's possible that in the future we will change above definition
      to sth like: "strings in UTF8 encoding" but now I would like to
      keep more general.

  * harbour/src/vm/macro.c
    * inform macrocompiler about custom CPs using own character indexes
      to disable byte oriented optimizations.

  * harbour/include/hbapigt.h
  * harbour/src/rtl/gtapi.c
  * harbour/src/rtl/inkeyapi.c
    + added HB_B_*_W macros with unicode box character definitions
    + added HB_MBUTTON_* macros
    + added new GT functions: hb_gtHostCP() and hb_gtBoxCP() which
      allows to extract CPs used in translations by GTs.
    + added new function hb_inkeyKeyString() - it converts inkey value
      to corresponding string
    + added new function hb_inkeyKeyStd() - it converts new extended
      key value to standard Clipper one.

  * harbour/include/hbapifs.h
  * harbour/src/common/hbffind.c
    * moved OS codepage translations fully to hb_fsFind*() functions.
      It fixes few problems which existed before, i.e. double CP
      conversions in MS-Windows builds and simplifies upper level code.

  * harbour/src/pp/hbpp.c
  * harbour/src/rtl/direct.c
  * harbour/src/rtl/fssize.c
  * harbour/src/rtl/file.c
  * harbour/contrib/hbct/files.c
    * eliminated not longer necessary CP conversions in code calling
      hb_fsFind*() functions.

  * harbour/src/common/hbgete.c
    * moved OS codepage translations to hb_getenv(), hb_getenv_buffer()
      and hb_setenv() functions. It fixes few problems which existed
      before, i.e. double CP conversions in MS-Windows builds and
      simplifies upper level code.

  * harbour/src/rtl/net.c
  * harbour/src/rtl/gete.c
    * eliminated not longer necessary CP conversions in code calling
      hb_getenv()/hb_setenv() functions.
    ; NOTE: additional parameters in HB_GETENV() and HB_SETENV() which
            disabled CP conversions are not longer supported.
            They were strictly platform dependent and ignored in chosen
            cases (i.e. in MS-Windows UNICODE builds we always have to
            convert strings transferred between HVM and OS. If someone
            needs old functionality for other platform then he should
            temporary disable _SET_OSCODEPAGE.

  * harbour/src/common/hbver.c
  * harbour/src/common/hbfsapi.c
  * harbour/src/rtl/fstemp.c
  * harbour/src/rtl/fslink.c
    * eliminated HB_TCHAR_*() macros

  * harbour/src/common/strwild.c
    + added supprot for custom CPs using own character indexes in:
         hb_strMatchWild(),
         hb_strMatchWildExact(),
         hb_strMatchCaseWildExact()

  * harbour/src/nortl/nortl.c
    + added new dummy function replacement for binaries which are not
      linked with HVM.

  * harbour/src/rtl/filesys.c
    ! fixed double CP conversions in MS-Windows builds of hb_fsCurDirBuff()
    * use hb_vmIsReady() instead of hb_stackId() in file name conversions.
    * use hb_cmdargProgName() in hb_fsBaseDirBuff()

  * harbour/src/rtl/philes.c
    * use hb_cmdargProgName() in HB_PROGNAME() function.

  * harbour/src/rtl/gtcgi/gtcgi.c
  * harbour/src/rtl/gtstd/gtstd.c
  * harbour/src/rtl/gtpca/gtpca.c
  * harbour/src/rtl/gtdos/gtdos.c
  * harbour/src/rtl/gtos2/gtos2.c
  * harbour/src/rtl/gtwin/gtwin.c
  * harbour/src/rtl/gtwvt/gtwvt.h
  * harbour/src/rtl/gtwvt/gtwvt.c
  * harbour/src/rtl/gttrm/gttrm.c
  * harbour/src/rtl/gtcrs/gtcrs.c
  * harbour/src/rtl/gtsln/gtsln.c
  * harbour/src/rtl/gtsln/kbsln.c
  * harbour/src/rtl/gtsln/gtsln.h
  * harbour/src/rtl/gtxwc/gtxwc.h
  * harbour/src/rtl/gtxwc/gtxwc.c
  * harbour/contrib/gtwvg/gtwvg.c
  * harbour/contrib/gtwvg/gtwvg.h
  * harbour/contrib/gtalleg/gtalleg.c
  * harbour/contrib/hbqt/gtqtc/gtqtc.cpp
  * harbour/contrib/hbqt/gtqtc/gtqtc.h
    * updated to work with new unicode GT API
      please make tests with different GTs - I'm not able to test
      all of them, i.e. I do not have any OS2 machine.

  * harbour/src/rtl/box.c
  * harbour/src/rtl/oldbox.c
  * harbour/src/rtl/scroll.c
  * harbour/src/rtl/console.c
    * updated to work with new unicode GT API and
      CPs using custom character indexes

  * harbour/src/rtl/at.c
  * harbour/src/rtl/ati.c
  * harbour/src/rtl/rat.c
  * harbour/src/rtl/len.c
  * harbour/src/rtl/transfrm.c
  * harbour/src/rtl/left.c
  * harbour/src/rtl/right.c
  * harbour/src/rtl/substr.c
  * harbour/src/rtl/stuff.c
  * harbour/src/rtl/padc.c
  * harbour/src/rtl/padl.c
  * harbour/src/rtl/padr.c
    * updated to work with CPs using custom character indexes

  * harbour/src/rtl/chrasc.c
    + added support for HB_CDP_ISCHARUNI() CPs.

  * harbour/src/rtl/mlcfunc.c
    * rewritten from scratch to work with CPs using custom character
      indexes

  * harbour/src/rtl/accept.c
    * updated to work with unicode inkey values and
      CPs using custom character indexes

  * harbour/src/rtl/strmatch.c
    % small optimization

  * harbour/src/rtl/Makefile
  + harbour/src/rtl/chruni.c
    + added new PRG functions which allows to make byte/binary and
      unicode/character operations on strings:
         HB_UCHAR( <nCode> ) -> <cText>
            return string with U+nCode character in HVM CP encoding
         HB_BCHAR( <nCode> ) -> <cText>
            return 1 byte string with <nCode> value
         HB_UCODE( <cText> ) -> <nCode>
            return unicode value of 1-st character (not byte) in given string
         HB_BCODE( <cText> ) -> <nCode>
            return value of 1-st byte in given string
         HB_ULEN( <cText> ) -> <nChars>
            return string length in characters
         HB_BLEN( <cText> ) -> <nBytes>
            return string length in bytes
         HB_UPEEK( <cText>, <n> ) -> <nCode>
            return unicode value of <n>-th character in given string
         HB_BPEEK( <cText>, <n> ) -> <nCode>
            return value of <n>-th byte in given string
         HB_UPOKE( [@]<cText>, <n>, <nVal> ) -> <cText>
            change <n>-th character in given string to unicode <nVal> one and
            return modified text
         HB_BPOKE( [@]<cText>, <n>, <nVal> ) -> <cText>
            change <n>-th byte in given string to <nVal> and return modified
            text

  * harbour/src/rtl/hbdoc.prg
  * harbour/src/rtl/memvarhb.prg
    * use HB_BCHAR() for binary string definitions

  * harbour/src/rtl/hbi18n2.prg
    * use hb_utf8CHR( 0xFEFF ) instead of hardcoded binary sting and
      HB_BLEN() instead of LEN()

  * harbour/src/rtl/inkey.c
    + added new functions:
         HB_KEYCHAR( <nKey> ) -> <cChar>
         HB_KEYSTD( <nExtKey> ) -> <nClipKey>
    ! use HB_INKEY_ALL instead of INKEY_ALL in LASTKEY()

  * harbour/src/rtl/achoice.prg
  * harbour/src/rtl/browse.prg
  * harbour/src/rtl/menuto.prg
  * harbour/src/rtl/tgetlist.prg
  * harbour/src/rtl/teditor.prg
  * harbour/src/rtl/tlabel.prg
  * harbour/src/rtl/tpopup.prg
  * harbour/src/rtl/radiobtn.prg
  * harbour/src/rtl/radiogrp.prg
  * harbour/src/rtl/wait.prg
    * updated to work with unicode inkey() values

  * harbour/src/rtl/listbox.prg
    * use box.ch macros instead of explicit CHR(...) definitions

  * harbour/src/rtl/ttopbar.prg
    * updated to work with different type of CPs

  * harbour/src/rtl/scrollbr.prg
    * formatting

  * harbour/src/rtl/mouse53.c
    * use HB_MBUTTON_* macros instead of local ones

  * harbour/src/codepage/cp_utf8.c
  + harbour/src/codepage/uc16def.c
  + harbour/src/codepage/utf8sort.c
    * replaced UTF8ASC with new CP: UTF8EX
      This CP uses character indexes instead of bytes one
      and operates on unicode characters flags.
      Tables for upper/lower conversions and upper/lower/alpha/digit
      flags were generated automatically from
         http://www.unicode.org/Public/UNIDATA/UnicodeData.txt
      It also uses custom collation rules. It's very simple one
      level sorting based on UTF8 C collation.
      If someone needs some advanced sorting rules, then it's enough
      to create copy of this cp with user custom version of UTF8_cmp()
      and UTF8_cmpi() functions, i.e. they can be redirected to some
      external library like ICU (icu-project.org).

  * harbour/contrib/hbct/ctwin.c
  * harbour/contrib/hbct/ctwin.h
  * harbour/contrib/hbct/ctwfunc.c
    * added support for new unicode GT API

  * harbour/contrib/xhb/xhbfunc.c
    * redirected HB_CMDARGARGV() to HB_PROGNAME()

  * harbour/contrib/hbnf/origin.c
    * redirected FT_ORIGIN() to HB_PROGNAME()

  * harbour/contrib/hbnf/getenvrn.c
    ! windows version of FT_GETE() fully rewritten - it should
      fix well known problems reported to the devel list. Please test.
    % small optimization for other systems

  * harbour/contrib/hbfship/exec.c
    * use hb_cmdargProgName() in EXECNAME()

  + harbour/tests/uc16_gen.prg
    + added code which generates tables with unicode character flags
      from http://www.unicode.org/Public/UNIDATA/UnicodeData.txt.
      harbour/src/codepage/uc16def.c was generated by this code.

  * harbour/tests/inkeytst.prg
  * harbour/tests/wvtext.prg
  * harbour/tests/gtkeys.prg
    * use HB_INKEY_ALL

  * harbour/include/harbour.hbx
  * harbour/include/hbcpage.hbx
  * harbour/include/hblang.hbx
    * regenerated

   ; It was quite big peace of modifications and for sure not everything
     is well tested so please make test and report problems you will find.
   ; This is basic version which introduce to HVM CPs with custom encodings.
     Some contrib code has to be updated to work correctly with it.
     I hope that developers interesting in will make necessary updates.
     I haven't touched GTWVW code at all - sorry but it needs very serious
     work to make it production ready and fix all existing problems.
   ; Special thanks to OTC - this firm sponsored adding basic UTF8 support
     to HVM.
2012-04-20 15:55:44 +00:00

617 lines
20 KiB
Plaintext
Raw Blame History

/*
* $Id$
*/
//----------------------------------------------------------------------//
//----------------------------------------------------------------------//
//----------------------------------------------------------------------//
//
// Harbour Extended Features Demo
// .
// Pritpal Bedi <pritpal@vouchcac.com>
//
//----------------------------------------------------------------------//
//----------------------------------------------------------------------//
//----------------------------------------------------------------------//
#include "hbgtinfo.ch"
#include "inkey.ch"
#include "setcurs.ch"
#define RGB( r, g, b ) ( r + ( g * 256 ) + ( b * 256 * 256 ) )
//----------------------------------------------------------------------//
STATIC s_nRows := 20
STATIC s_nCols := 60
STATIC s_nColorIndex := 1
//----------------------------------------------------------------------//
PROCEDURE Main()
LOCAL nKey, lMark, lResize, lClose, aKeys[ 50 ], nI, lAltEnter
LOCAL nHeight := 20
LOCAL nWidth := Int( nHeight / 2 )
LOCAL cFontName
LOCAL GetList := {}
LOCAL nModeCols, nModeRows, nWndHeight, nWndWidth, nMaxWHeight, nMaxWWidth, aWndSize := { 0, 0 }
LOCAL nMSec
AFill( aKeys, 0 )
hb_gtInfo( HB_GTI_FONTNAME , "Lucida Console" )
hb_gtInfo( HB_GTI_FONTWIDTH, nWidth )
hb_gtInfo( HB_GTI_FONTSIZE , nHeight )
hb_gtInfo( HB_GTI_WINTITLE , "GTWVT-Test (Resizable by Font)" )
hb_gtInfo( HB_GTI_ALTENTER, .T. ) // allow alt-enter for full screen
SetCursor( SC_NONE )
hb_gtInfo( HB_GTI_CLOSABLE, .F. )
DispScreen()
DO WHILE .T.
FOR nI := 1 TO Len( aKeys )
IF aKeys[ nI ] == 0 .OR. nI > MaxRow() - 1
EXIT
ENDIF
@ nI, MaxCol() - 5 SAY Str( aKeys[ nI ], 4, 0 )
NEXT
IF nMSec != NIL .AND. hb_milliSeconds() > nMSec + 2000
DispOutAt( MaxRow(), 0, Space( MaxCol() + 1 ), "N/G*" )
nMSec := NIL
ENDIF
nKey := Inkey( 0.1, 254 + HB_INKEY_GTEVENT )
IF nKey == 0
LOOP
ENDIF
AIns( aKeys, 1 )
aKeys[ 1 ] := nKey
FOR nI := 1 TO Len( aKeys )
IF aKeys[ nI ] == 0 .OR. nI > MaxRow() - 1
EXIT
ENDIF
@ nI, MaxCol() - 5 SAY Str( aKeys[ nI ], 4, 0 )
NEXT
IF nKey == K_ESC
EXIT
ENDIF
DO CASE
CASE nKey == K_ENTER
Alert( "<Enter> Pressed" )
CASE nKey == Asc( "0" ) // setmode
SetColor( "W+/B,GR+/N,W/B,B/B,G+/N" )
DO WHILE .T.
nModeCols := MaxCol() + 1
nModeRows := MaxRow() + 1
@ MaxRow() / 2 - 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 0 SAY Space( MaxCol() )
@ MaxRow() / 2 + 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 2 SAY "SetMode( 99 , 999 ) ESC-Cancels"
@ MaxRow() / 2, 11 GET nModeRows PICTURE "99" RANGE 10, 99
@ MaxRow() / 2, 16 GET nModeCols PICTURE "999" RANGE 20, 300
READ
IF LastKey() == K_ESC
EXIT
ENDIF
IF ! SetMode( nModeRows, nModeCols )
Alert( "SetMode() Failed!" )
ELSE
EXIT
ENDIF
ENDDO
DispScreen()
CASE nKey == Asc( "1" ) // "1" get/set Window-Height
nWndHeight := hb_gtInfo( HB_GTI_SCREENHEIGHT )
nMaxWHeight := hb_gtInfo( HB_GTI_DESKTOPHEIGHT )
SetColor( "W+/B,GR+/N,W/B,B/B,G+/N" )
@ MaxRow() / 2 - 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 0 SAY Space( MaxCol() )
@ MaxRow() / 2 + 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 2 SAY "Get/Set Window Height: 9999 (Max: " + hb_ntos( nMaxWHeight ) + ")"
@ MaxRow() / 2, 25 GET nWndHeight PICTURE "9999" RANGE 100, nMaxWHeight
READ
IF LastKey() != K_ESC
hb_gtInfo( HB_GTI_SCREENHEIGHT, nWndHeight )
ENDIF
DispScreen()
CASE nKey == Asc( "2" ) // get/set Window-WIDTH
nWndWIDTH := hb_gtInfo( HB_GTI_SCREENWIDTH )
nMaxWWIDTH := hb_gtInfo( HB_GTI_DESKTOPWIDTH )
SetColor( "W+/B,GR+/N,W/B,B/B,G+/N" )
@ MaxRow() / 2 - 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 0 SAY Space( MaxCol() )
@ MaxRow() / 2 + 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 2 SAY "Get/Set Window WIDTH: 9999 (Max: " + hb_ntos( nMaxWWIDTH ) + ")"
@ MaxRow() / 2, 24 GET nWndWIDTH PICTURE "9999" RANGE 100, nMaxWWIDTH
READ
IF LastKey() != K_ESC
hb_gtInfo( HB_GTI_SCREENWIDTH, nWndWIDTH )
ENDIF
DispScreen()
CASE nKey == Asc( "3" ) // get/set Window-Size
aWndSize := hb_gtInfo( HB_GTI_SCREENSIZE )
nMaxWWIDTH := hb_gtInfo( HB_GTI_DESKTOPWIDTH )
nMaxWHeight := hb_gtInfo( HB_GTI_DESKTOPHEIGHT )
SetColor( "W+/B,GR+/N,W/B,B/B,G+/N" )
@ MaxRow() / 2 - 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 0 SAY Space( MaxCol() )
@ MaxRow() / 2 + 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 2 SAY "Get/Set Window Size(WxH): 9999 x 9999 (Max: " + hb_ntos( nMaxWWIDTH ) + " x " + hb_ntos( nMaxWHeight ) + ")"
@ MaxRow() / 2, 28 GET aWndSize[ 1 ] PICTURE "9999" RANGE 100, nMaxWWIDTH
@ MaxRow() / 2, 35 GET aWndSize[ 2 ] PICTURE "9999" RANGE 100, nMaxWHeight
READ
IF LastKey() != K_ESC
hb_gtInfo( HB_GTI_SCREENSIZE, aWndSize )
ENDIF
DispScreen()
CASE nKey == Asc( "4" ) // set Window-Position by pixels
aWndSize := hb_gtInfo( HB_GTI_SETPOS_XY )
SetColor( "W+/B,GR+/N,W/B,B/B,G+/N" )
@ MaxRow() / 2 - 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 0 SAY Space( MaxCol() )
@ MaxRow() / 2 + 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 2 SAY "Get/Set Window Position in pixels(Left/Top): 9999 / 9999 "
@ MaxRow() / 2, 47 GET aWndSize[ 1 ] PICTURE "9999"
@ MaxRow() / 2, 54 GET aWndSize[ 2 ] PICTURE "9999"
READ
IF LastKey() != K_ESC
hb_gtInfo( HB_GTI_SETPOS_XY, aWndSize )
ENDIF
DispScreen()
CASE nKey == Asc( "5" ) // set Window-Position by row/col
aWndSize := hb_gtInfo( HB_GTI_SETPOS_ROWCOL )
SetColor( "W+/B,GR+/N,W/B,B/B,G+/N" )
@ MaxRow() / 2 - 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 0 SAY Space( MaxCol() )
@ MaxRow() / 2 + 1, 0 SAY Space( MaxCol() )
@ MaxRow() / 2, 2 SAY "Get/Set Window Position by Row/Col: 999 / 999 "
@ MaxRow() / 2, 38 GET aWndSize[ 1 ] PICTURE "999"
@ MaxRow() / 2, 44 GET aWndSize[ 2 ] PICTURE "999"
READ
IF LastKey() != K_ESC
hb_gtInfo( HB_GTI_SETPOS_ROWCOL, aWndSize[ 1 ], aWndSize[ 2 ] )
ENDIF
DispScreen()
CASE nKey == K_F1
Alert( "Additional Hot-Key Test Settings:;;" + ;
"0 - SetMode( nRows, nCols ) test ;" + ;
"1 - Get/Set HB_GTI_SCREENHEIGHT test ;" + ;
"2 - Get/Set HB_GTI_SCREENWIDTH test ;" + ;
"3 - Get/Set HB_GTI_SCREENSIZE test ;" + ;
"4 - Get/Set HB_GTI_SETPOS_XY test ;" + ;
"5 - Get/Set HB_GTI_SETPOS_ROWCOL test", , "W+/B" )
CASE nKey == K_F2
lMark := hb_gtInfo( HB_GTI_SELECTCOPY )
hb_gtInfo( HB_GTI_SELECTCOPY, ! lMark )
CASE nKey == K_F3
lResize := hb_gtInfo( HB_GTI_RESIZABLE )
hb_gtInfo( HB_GTI_RESIZABLE, ! lResize )
DispScreen()
CASE nKey == K_F4
lClose := hb_gtInfo( HB_GTI_CLOSABLE )
hb_gtInfo( HB_GTI_CLOSABLE, ! lClose )
DispScreen()
CASE nKey == K_F5
SetPalette( 1 )
CASE nKey == K_F6
SetPalette( 0 )
CASE nKey == K_F7
SetPaletteIndex()
CASE nKey == K_F8
Alert( "Menu text changed. Was: " + hb_gtInfo( HB_GTI_SELECTCOPY, Dtos(Date() ) + " " + Time() ) )
CASE nKey == K_F9
hb_gtInfo( HB_GTI_RESIZEMODE, iif( hb_gtInfo( HB_GTI_RESIZEMODE ) == HB_GTI_RESIZEMODE_ROWS, HB_GTI_RESIZEMODE_FONT, HB_GTI_RESIZEMODE_ROWS ) )
hb_gtInfo( HB_GTI_WINTITLE , "GTWVT-Test (Resizable by " + iif( hb_gtInfo( HB_GTI_RESIZEMODE ) == HB_GTI_RESIZEMODE_ROWS, "ROWS", "FONT" ) + ")" )
DispScreen()
CASE nKey == K_F10
IF hb_MTVM()
hb_threadStart( @thFunc() )
ELSE
Alert( "MT mode not available. Rebuild this program with -mt switch and try again." )
ENDIF
CASE nKey == K_F11
lAltEnter := hb_gtInfo( HB_GTI_ALTENTER )
hb_gtInfo( HB_GTI_ALTENTER, ! lAltEnter )
DispScreen()
CASE nKey == K_F12
cFontName := hb_gtInfo( HB_GTI_FONTNAME )
IF cFontName == "Lucida Console"
hb_gtInfo( HB_GTI_FONTNAME , "Courier New" )
ELSEIF cFontName == "Courier New"
hb_gtInfo( HB_GTI_FONTNAME , "Terminal" )
ELSEIF cFontName == "Terminal"
hb_gtInfo( HB_GTI_FONTNAME , "DejaVu Sans Mono" )
ELSE
hb_gtInfo( HB_GTI_FONTNAME , "Lucida Console" )
ENDIF
IF hb_gtInfo( HB_GTI_RESIZEMODE ) == HB_GTI_RESIZEMODE_ROWS
hb_gtInfo( HB_GTI_RESIZEMODE, HB_GTI_RESIZEMODE_FONT )
SetMode( MaxRow(), MaxCol() )
SetMode( MaxRow() + 2, MaxCol() + 2 )
hb_gtInfo( HB_GTI_RESIZEMODE, HB_GTI_RESIZEMODE_ROWS )
ELSE
SetMode( MaxRow(), MaxCol() )
SetMode( MaxRow() + 2, MaxCol() + 2 )
ENDIF
DispScreen()
DispOutAt( MaxRow(), 2, "< Font changed to " + hb_gtInfo( HB_GTI_FONTNAME ) + " >", "B/G*" )
nMSec := hb_milliSeconds()
CASE nKey == HB_K_RESIZE
DispScreen()
DispOutAt( MaxRow(), 33, "Resized ", "B/G*" )
nMSec := hb_milliSeconds()
CASE nKey == HB_K_GOTFOCUS
ChgPalette( .T. )
DispOutAt( MaxRow(), 33, "We got focus ", "B/G*" )
nMSec := hb_milliSeconds()
CASE nKey == HB_K_LOSTFOCUS
ChgPalette( .F. )
DispOutAt( MaxRow(), 33, "We lost focus", "B/G*" )
nMSec := hb_milliSeconds()
CASE nKey == HB_K_CLOSE
IF Alert( "Close Application", { "Yes", "No" } ) == 1
QUIT
ENDIF
ENDCASE
ENDDO
RETURN
//-------------------------------------------------------------------//
STATIC PROCEDURE DispScreen()
LOCAL nRow := 9
LOCAL cColor := "N/W"
LOCAL nMaxCol := MaxCol() + 1
DispBegin()
SetColor( "N/W" )
CLS
DispOutAt( 0, 0, PadC( "Harbour GT - New Features", nMaxCol ), "N/GR*" )
// Contributed by Massimo Belgrano
DispOutAt( 2, 0, PadC( "______ __ ______________________ ", nMaxCol ), "W+/W" )
DispOutAt( 3, 0, PadC( "___ / / /_____ ___________ /___________ _________ __ ____/____/", nMaxCol ), "W+/W" )
DispOutAt( 4, 0, PadC( "__ /_/ /_ __ `/_ ___/_ __ \ __ \ / / /_ ___/ _ / __ __/ ", nMaxCol ), "W+/W" )
DispOutAt( 5, 0, PadC( "_ __ / / /_/ /_ / _ /_/ / /_/ / /_/ /_ / / /_/ / _ / ", nMaxCol ), "W+/W" )
DispOutAt( 6, 0, PadC( "/_/ /_/ \__,_/ /_/ /_.___/\____/\__,_/ /_/ \____/ /_/ ", nMaxCol ), "W+/W" )
DispOutAt( 8, 0, PadC( "MODE: " + hb_ntos( MaxRow() + 1 ) + " Rows and " + hb_ntos( nMaxCol ) + " Columns", nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F2 MarkCopy Toggle > ", nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F3 Resizable Toggle > " + iif( hb_gtInfo( HB_GTI_RESIZABLE ), "ON ", "Off" ), nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F4 Closable Toggle > " + iif( hb_gtInfo( HB_GTI_CLOSABLE ), "ON ", "Off" ), nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F5 Palette L Repeat > ", nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F6 Palette D Repeat > ", nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F7 Palette By Index R > ", nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F8 MarkCopy menu text > ", nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< Click Other Window > ", nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< Click X Button > ", nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F9 Resize Mode Toggle > " + iif( hb_gtInfo( HB_GTI_RESIZEMODE ) == HB_GTI_RESIZEMODE_ROWS, "ROWS", "FONT" ), nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F10 Open New Window > ", nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F11 Alt-Enter Toggle > " + iif( hb_gtInfo( HB_GTI_ALTENTER ), "ON ", "Off" ), nMaxCol ), cColor )
DispOutAt( ++nRow, 0, PadC( "< F12 Change Font Test > " + hb_gtInfo( HB_GTI_FONTNAME ) + " " + hb_ntos( hb_gtInfo( HB_GTI_FONTWIDTH ) ) + "x" + hb_ntos( hb_gtInfo( HB_GTI_FONTSIZE ) ), nMaxCol ), cColor )
DispOutAt( MaxRow(), 0, Space( MaxCol() + 1 ), "N/G*" )
DispOutAt( 0, 0 , "TL", "N/GR*" )
DispOutAt( 0, MaxCol() - 1 , "TR", "N/GR*" )
DispOutAt( MaxRow(), 0 , "BL", "N/G*" )
DispOutAt( MaxRow(), MaxCol() - 1, "BR", "N/G*" )
DispEnd()
RETURN
//-------------------------------------------------------------------//
PROCEDURE HB_GTSYS()
REQUEST HB_GT_WVT_DEFAULT
REQUEST HB_GT_WIN
RETURN
//-------------------------------------------------------------------//
FUNCTION SetPalette( nMode )
LOCAL aPalette := hb_gtInfo( HB_GTI_PALETTE )
THREAD STATIC t_nR := 198
THREAD STATIC t_nG := 198
THREAD STATIC t_nB := 198
t_nR += iif( nMode == 0, - 5, 5 )
t_nG += iif( nMode == 0, - 5, 5 )
t_nB += iif( nMode == 0, - 5, 5 )
// Change "W" to slightly gray everytime you press F5
//
aPalette[ 8 ] := RGB( t_nR, t_nG, t_nB )
hb_gtInfo( HB_GTI_PALETTE, aPalette )
DispScreen()
RETURN NIL
//-------------------------------------------------------------------//
FUNCTION SetPaletteIndex()
hb_gtInfo( HB_GTI_PALETTE, 8, RGB( 120, 200, 240 ) )
DispScreen()
RETURN NIL
//-------------------------------------------------------------------//
PROCEDURE thFunc()
STATIC nBrowser := 0
STATIC nZx := 0
STATIC nZy := 0
LOCAL cTitle, oBrowse, lEnd, nKey, i, aStruct
LOCAL aColor := { "W+/N", "W+/B", "W+/G", "W+/BG", "W+/N*", "W+/RB", "N/W*", "N/GR*" }
nBrowser++
nZx += 20
nZy += 20
/* allocate own GT driver */
hb_gtReload( "WVT" )
hb_gtInfo( HB_GTI_PALETTE, 8, RGB( 120, 200, 240 ) )
IF ( nBrowser % 2 ) != 0
hb_gtInfo( HB_GTI_RESIZEMODE, HB_GTI_RESIZEMODE_ROWS )
ENDIF
hb_gtInfo( HB_GTI_FONTNAME , "Lucida Console" )
hb_gtInfo( HB_GTI_WINTITLE, "test.dbf [" + iif( ( nBrowser % 2 ) != 0, "RESIZABLE_BY_ROWS", "RESIZABLE_BY_FONT" ) + "]" )
hb_gtInfo( HB_GTI_ALTENTER, .T. ) //allow alt-enter for full screen
SetCursor( SC_NONE )
s_nColorIndex++
IF s_nColorIndex > Len( aColor )
s_nColorIndex := 1
ENDIF
s_nRows++
s_nCols += 2
SetMode( s_nRows, s_nCols )
SetColor( aColor[ s_nColorIndex ] )
cTitle := "New Window with " + hb_ntos( MaxRow() ) + ;
" Rows and " + hb_ntos( MaxCol() ) + " Columns"
dispOutAt( 0, 0, PadC( cTitle, MaxCol() + 1 ), "N/GR*" )
hb_gtInfo( HB_GTI_SETPOS_XY, nZx, nZy ) //this does not work until something is displayed
USE test NEW SHARED
aStruct := dbStruct()
oBrowse := TBrowse():New( 1, 0, MaxRow(), MaxCol() )
oBrowse:ColSep := " | "
oBrowse:HeadSep := "-+-"
oBrowse:GoTopBlock := { || dbGoTop() }
oBrowse:GoBottomBlock := { || dbGoBottom() }
oBrowse:SkipBlock := { | nSkip | dbSkipBlock( nSkip, oBrowse ) }
FOR i := 1 TO Len( aStruct )
oBrowse:AddColumn( TBColumnNew( aStruct[ i, 1 ], BlockField( i ) ) )
NEXT
oBrowse:configure()
lEnd := .F.
DO WHILE ! lEnd
oBrowse:ForceStable()
nKey := Inkey( 0, HB_INKEY_ALL )
IF ! BrwHandleKey( oBrowse, nKey, @lEnd )
DO CASE
CASE nKey == HB_K_GOTFOCUS
ChgPalette( .T. )
CASE nKey == HB_K_LOSTFOCUS
ChgPalette( .F. )
CASE nKey == HB_K_RESIZE
cTitle := "New Window with " + hb_ntos( MaxRow() ) + ;
" Rows and " + hb_ntos( MaxCol() ) + " Columns"
dispOutAt( 0, 0, PadC( cTitle, MaxCol() + 1 ), "N/GR*" )
oBrowse:nBottom := MaxRow()
oBrowse:nRight := MaxCol()
oBrowse:Configure()
oBrowse:RefreshAll()
ENDCASE
ENDIF
ENDDO
dbCloseArea()
RETURN
//-------------------------------------------------------------------//
STATIC FUNCTION DbSkipBlock( n, oTbr )
LOCAL nSkipped := 0
IF n == 0
dbSkip( 0 )
ELSEIF n > 0
DO WHILE nSkipped != n .AND. TBNext( oTbr )
nSkipped++
ENDDO
ELSE
DO WHILE nSkipped != n .AND. TBPrev( oTbr )
nSkipped--
ENDDO
ENDIF
RETURN nSkipped
//-------------------------------------------------------------------//
STATIC FUNCTION TBNext( oTbr )
LOCAL nSaveRecNum := RecNo()
LOCAL lMoved := .T.
HB_SYMBOL_UNUSED( oTbr )
IF Eof()
lMoved := .F.
ELSE
dbSkip( 1 )
IF Eof()
lMoved := .F.
dbGoto( nSaveRecNum )
ENDIF
ENDIF
RETURN lMoved
//-------------------------------------------------------------------//
STATIC FUNCTION TBPrev( oTbr )
LOCAL nSaveRecNum := RecNo()
LOCAL lMoved := .T.
HB_SYMBOL_UNUSED( oTbr )
dbSkip( - 1 )
IF Bof()
dbGoto( nSaveRecNum )
lMoved := .F.
ENDIF
RETURN lMoved
//-------------------------------------------------------------------//
STATIC FUNCTION BlockField( i )
RETURN { || FieldGet( i ) }
//-------------------------------------------------------------------//
STATIC FUNCTION BrwHandleKey( oBrowse, nKey, lEnd )
LOCAL lRet := .T.
DO CASE
CASE nKey == K_ESC ; lEnd := .T.
// CASE nKey == K_ENTER ; lEnd := .T.
CASE nKey == K_DOWN ; oBrowse:Down()
CASE nKey == K_UP ; oBrowse:Up()
CASE nKey == K_LEFT ; oBrowse:Left()
CASE nKey == K_RIGHT ; oBrowse:Right()
CASE nKey == K_PGDN ; oBrowse:pageDown()
CASE nKey == K_PGUP ; oBrowse:pageUp()
CASE nKey == K_CTRL_PGUP ; oBrowse:goTop()
CASE nKey == K_CTRL_PGDN ; oBrowse:goBottom()
CASE nKey == K_HOME ; oBrowse:home()
CASE nKey == K_END ; oBrowse:end()
CASE nKey == K_CTRL_LEFT ; oBrowse:panLeft()
CASE nKey == K_CTRL_RIGHT ; oBrowse:panRight()
CASE nKey == K_CTRL_HOME ; oBrowse:panHome()
CASE nKey == K_CTRL_END ; oBrowse:panEnd()
CASE nKey == K_MWBACKWARD ; oBrowse:down()
CASE nKey == K_MWFORWARD ; oBrowse:up()
OTHERWISE ; lRet := .F.
ENDCASE
RETURN lRet
//-------------------------------------------------------------------//
FUNCTION ChgPalette( lFocus )
LOCAL aPalette := hb_gtInfo( HB_GTI_PALETTE )
LOCAL cSaveScreen := SaveScreen( 0, 0, MaxRow(), MaxCol() )
LOCAL nR, nG, nB, nColor, nI, nDimFactor := 1.5
THREAD STATIC t_aSavePalette
IF t_aSavePalette == NIL
t_aSavePalette := AClone( aPalette )
ENDIF
IF lFocus
aPalette := t_aSavePalette
ELSE
FOR nI := 2 TO Len( aPalette )
nColor := aPalette[ nI ]
IF nColor >= 65536
nB := Int( nColor / 65536 )
nColor -= nB * 65536
nB := Int( nB / nDimFactor )
ELSE
nB := 0
ENDIF
IF nColor >= 256
nG := Int( nColor / 256 )
nColor -= nG * 256
nG := Int( nG / nDimFactor )
ELSE
nG := 0
ENDIF
IF nColor > 0
nR := Int( nColor / nDimFactor )
ELSE
nR := 0
ENDIF
aPalette[ nI ] := RGB( nR, nG, nB )
NEXT
ENDIF
hb_gtInfo( HB_GTI_PALETTE, aPalette )
RestScreen( 0, 0, MaxRow(), MaxCol(), cSaveScreen )
RETURN NIL
Reference in New Issue View Git Blame Copy Permalink