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

2012-10-18 11:31 UTC+0200 Viktor Szakats (harbour syenar.net)

Browse Source 
* contrib/hbnf/*.prg
    * cleanups, minor opts
This commit is contained in:
Viktor Szakats
2012-10-18 09:33:53 +00:00
parent 357d768615
commit 7fdcfe1ff8
23 changed files with 258 additions and 720 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
harbour/ChangeLog
View File

@@ -16,6 +16,10 @@
The license applies to all entries newer than 2009-04-28.
*/
2012-10-18 11:31 UTC+0200 Viktor Szakats (harbour syenar.net)
* contrib/hbnf/*.prg
* cleanups, minor opts
2012-10-18 02:19 UTC+0200 Viktor Szakats (harbour syenar.net)
* src/rtl/gtdos/gtdos.c
* TOFIX added about duplicate macros with same functionality

2
harbour/contrib/hbnf/acctadj.prg
View File

@@ -42,7 +42,7 @@ FUNCTION FT_ACCTADJ( dGivenDate, lIsEnd )
nTemp := FT_DAYTOBOW( dGivenDate )
IF nTemp > ( 2 + iif( lIsEnd, 0, 1 ) )
dGivenDate += ( 7 - nTemp ) // Next Week Start (This Week End + 1)
dGivenDate += 7 - nTemp // Next Week Start (This Week End + 1)
ELSE
dGivenDate -= nTemp // This Week Start (Prior Week End + 1)
ENDIF

2
harbour/contrib/hbnf/amedian.prg
View File

@@ -47,7 +47,7 @@ FUNCTION FT_AMEDIAN( aArray, nStart, nEnd )
// Determine middle value(s)
IF ( nTemplen % 2 ) == 0
nMiddle1 := aTemparray[ ( nTemplen / 2 ) ]
nMiddle1 := aTemparray[ nTemplen / 2 ]
nMiddle2 := aTemparray[ Int( nTemplen / 2 ) + 1 ]
nMedian := Int( ( nMIddle1 + nMiddle2 ) / 2 )
ELSE

47
harbour/contrib/hbnf/clrsel.prg
View File

@@ -47,12 +47,8 @@
* Thanks to Brian Loesgen for offering ideas and helping to tweak
* the code.
*
*
*/
//------------------------------------------------
// Pre-processor stuff
#include "setcurs.ch"
#include "inkey.ch"
@@ -70,25 +66,6 @@
#translate BkGrnd( <t>, <l>, <b>, <r>, <c> ) =>;
hb_DispBox( <t>, <l>, <b>, <r>, Replicate( <c>, 9 ) )
//------------------------------------------------
// Demo of FT_ClrSel()
/*
* To run the sample program:
*
* Compile : Clipper ClrSel /n /m /w /dFT_TEST
* Link : Rtlink FILE ClrSel LIB NanFor [/PLL:Fullbase]
* .OR. [/PLL:Base50]
*
* ClrSel MONO To force monochrome mode
* ClrSel NOSNOW To prevent CGA snowstorms
* ClrSel EGA 43 line mode
* ClrSel VGA 50 line mode
*
*/
//------------------------------------------------
FUNCTION FT_ClrSel( aClrs, lColour, cChr )
// Colour selection routine
@@ -115,7 +92,7 @@ FUNCTION FT_ClrSel( aClrs, lColour, cChr )
SetCursor( SC_NONE )
SetColor( iif( lColour, "GR+/N,,N/N", "W+/N,,N/N" ) )
CLS
hb_Scroll()
//.... initialize the colour palette
aClrPal := _ftInitPal( iif( lColour, aClrTab, aClrBW ) )
@@ -167,7 +144,7 @@ FUNCTION FT_ClrSel( aClrs, lColour, cChr )
RETURN iif( nChoice == 1, aClrs, aClrOld )
//------------------------------------------------
//
// Highlight the current selected aChoice element
// Return -> NIL
@@ -180,7 +157,7 @@ STATIC FUNCTION _ftHiLite( nRow, nCol, cStr, nLen )
RETURN NIL
//------------------------------------------------
//
// Colour selection for specific type of colour setting
// Return -> aOpt with modified colour strings
@@ -292,7 +269,7 @@ STATIC FUNCTION _ftColours( aOpt, aClrPal, lColour )
RETURN aOpt
//------------------------------------------------
//
// Show an example of the colour setting
// Return -> NIL
@@ -404,7 +381,7 @@ STATIC FUNCTION _ftShowIt( aOpt )
RETURN NIL
//------------------------------------------------
//
// select the colour combination from aClrPal and place in cClr
// cClr is the current colour being modified
@@ -482,7 +459,7 @@ STATIC FUNCTION _ftClrSel( aClrPal, cClr, nElem, aOpt )
RETURN cClr
//------------------------------------------------
//
// Place a colour setting in the colour string
// Return -> modified colour string
@@ -495,7 +472,7 @@ STATIC FUNCTION _ftClrPut( cClrStr, nElem, cClr )
RETURN _ftArr2Chr( aClr )
//------------------------------------------------
//
// Select the character to be used for the desktop background
// Return -> same array with new character
@@ -550,7 +527,7 @@ STATIC FUNCTION _ftDeskChar( aOpt )
RETURN aOpt
//------------------------------------------------
//
// Convert a chr string to an array
// Return -> array
@@ -575,7 +552,7 @@ STATIC FUNCTION _ftChr2Arr( cString, cDelim )
RETURN aArray
//------------------------------------------------
//
// convert an array to a chr string
// Return -> string
@@ -591,7 +568,7 @@ STATIC FUNCTION _ftArr2Chr( aArray, cDelim )
RETURN cString
//------------------------------------------------
//
// Paint the palette on the screen
// Return -> NIL
@@ -617,7 +594,7 @@ STATIC FUNCTION _ftShowPal( aClrPal, cChr )
RETURN NIL
//------------------------------------------------
//
// Initialise the colour palette based on the passed colour table aClrTab
// Load the palette with colours
@@ -639,7 +616,7 @@ STATIC FUNCTION _ftInitPal( aClrTab )
RETURN aClrPal
//------------------------------------------------
//
// Compares the contents of 2 arrays
// Return -> logical

6
harbour/contrib/hbnf/dectobin.prg
View File

@@ -25,7 +25,8 @@
FUNCTION FT_DEC2BIN( x )
LOCAL i, buffer := { "0", "0", "0", "0", "0", "0", "0", "0" }
LOCAL buffer := { "0", "0", "0", "0", "0", "0", "0", "0" }
LOCAL i
FOR i := 8 TO 1 STEP -1
IF x >= 2 ^ ( i - 1 )
@@ -34,5 +35,6 @@ FUNCTION FT_DEC2BIN( x )
ENDIF
NEXT
RETURN buffer[ 1 ] + buffer[ 2 ] + buffer[ 3 ] + buffer[ 4 ] + ;
RETURN ;
buffer[ 1 ] + buffer[ 2 ] + buffer[ 3 ] + buffer[ 4 ] + ;
buffer[ 5 ] + buffer[ 6 ] + buffer[ 7 ] + buffer[ 8 ]

2
harbour/contrib/hbnf/diskfunc.prg
View File

@@ -28,7 +28,9 @@
#include "fileio.ch"
FUNCTION FT_DSKSIZE( cDrive )
RETURN hb_DiskSpace( cDrive + hb_osDriveSeparator(), HB_DISK_TOTAL )
FUNCTION FT_DSKFREE( cDrive )
RETURN hb_DiskSpace( cDrive + hb_osDriveSeparator(), HB_DISK_FREE )

9
harbour/contrib/hbnf/e2d.prg
View File

@@ -25,13 +25,10 @@
FUNCTION ft_e2d( sNumE )
LOCAL nMant, nExp
nMant := Val( Left( sNumE, At( "E", sNumE ) - 1 ) )
nExp := Val( SubStr( sNumE, ;
LOCAL nMant := Val( Left( sNumE, At( "E", sNumE ) - 1 ) )
LOCAL nExp := Val( SubStr( sNumE, ;
At( "E", sNumE ) + 1, ;
Len( sNumE ) - At( "E", sNumE ) ;
) ;
)
) )
RETURN nMant * 10 ^ nExp

4
harbour/contrib/hbnf/eltime.prg
View File

@@ -28,9 +28,9 @@ FUNCTION FT_ELTIME( cTIME1, cTIME2 )
LOCAL nDELSECS, nHRS, nMINS, nSECS, nSECS1, nSECS2
nSECS1 := ( Val( SubStr( cTIME1, 1, 2 ) ) * 3600 ) + ;
( Val( SubStr( cTIME1, 4, 2 ) ) * 60 ) + ( Val( SubStr( cTIME1, 7 ) ) )
( Val( SubStr( cTIME1, 4, 2 ) ) * 60 ) + Val( SubStr( cTIME1, 7 ) )
nSECS2 := ( Val( SubStr( cTIME2, 1, 2 ) ) * 3600 ) + ;
( Val( SubStr( cTIME2, 4, 2 ) ) * 60 ) + ( Val( SubStr( cTIME2, 7 ) ) )
( Val( SubStr( cTIME2, 4, 2 ) ) * 60 ) + Val( SubStr( cTIME2, 7 ) )
nDELSECS := Abs( nSECS2 - nSECS1 )
nHRS := Int( nDELSECS / 3600 )
nMINS := Int( ( nDELSECS - nHRS * 3600 ) / 60 )

10
harbour/contrib/hbnf/menuto.prg
View File

@@ -78,7 +78,6 @@ FUNCTION FT_Prompt( nRow, nCol, cPrompt, cColor, ;
nUp, nDown, nLeft, nRight, bExecute )
// If the prompt color setting is not specified, use default
IF cColor == NIL
cColor := SetColor()
ENDIF
@@ -92,13 +91,11 @@ FUNCTION FT_Prompt( nRow, nCol, cPrompt, cColor, ;
ELSE
// If message row not supplied, use the default
IF nMsgRow == NIL
nMsgRow := Set( _SET_MESSAGE )
ENDIF
// If message column not supplied, use the default
IF nMsgCol == NIL
IF Set( _SET_MCENTER )
nMsgCol := Int( ( MaxCol() + 1 - Len( cPrompt ) ) / 2 )
@@ -108,14 +105,12 @@ FUNCTION FT_Prompt( nRow, nCol, cPrompt, cColor, ;
ENDIF
// If message color not specified, use the default
IF cMsgColor == NIL
cMsgColor := cColor
ENDIF
ENDIF
// If trigger values not specifed, set the defaults
IF nTrigger == NIL
nTrigger := 1
ENDIF
@@ -125,7 +120,6 @@ FUNCTION FT_Prompt( nRow, nCol, cPrompt, cColor, ;
// Now add elements to the static arrays -- t_nLevel indicates the recursion
// level, which allows for nested menus.
AAdd( t_aRow[ t_nLevel ], nRow )
AAdd( t_aCol[ t_nLevel ], nCol )
AAdd( t_aPrompt[ t_nLevel ], cPrompt )
@@ -146,7 +140,6 @@ FUNCTION FT_Prompt( nRow, nCol, cPrompt, cColor, ;
AAdd( t_aExecute[ t_nLevel ], bExecute )
// Now display the prompt for the sake of compatibility
DispBegin()
hb_DispOutAt( nRow, nCol, cPrompt, cColor )
hb_DispOutAt( nRow, nCol - 1 + nTrigger, cTrigger, cTriggerColor )
@@ -252,17 +245,14 @@ FUNCTION FT_MenuTo( bGetSet, cReadVar, lCold )
DispEnd()
// Wait for a keystroke
nKey := Inkey( 0 )
// If the key was an alphabetic char, convert to uppercase
IF isBetween( nKey, 97, 122 )
nKey -= 32
ENDIF
// Set nPrev to the currently active menu item
nPrev := nActive
DO CASE

160
harbour/contrib/hbnf/metaph.prg
View File

@@ -91,11 +91,7 @@
*
*/
//------------------------------------------------
FUNCTION FT_METAPH( cName, nSize )
// Calculates the metaphone of a character string
FUNCTION FT_METAPH( cName, nSize ) // Calculates the metaphone of a character string
LOCAL cMeta
@@ -109,23 +105,23 @@ FUNCTION FT_METAPH( cName, nSize )
cMeta := " " + _ftMakeAlpha( Upper( AllTrim( cName ) ) ) + " "
// prefixes which need special consideration
IF " KN" $ cMeta ; cMeta := StrTran( cMeta, " KN" , " N" ) ; ENDIF
IF " GN" $ cMeta ; cMeta := StrTran( cMeta, " GN" , " N" ) ; ENDIF
IF " PN" $ cMeta ; cMeta := StrTran( cMeta, " PN" , " N" ) ; ENDIF
IF " AE" $ cMeta ; cMeta := StrTran( cMeta, " AE" , " E" ) ; ENDIF
IF " X" $ cMeta ; cMeta := StrTran( cMeta, " X" , " S" ) ; ENDIF
IF " WR" $ cMeta ; cMeta := StrTran( cMeta, " WR" , " R" ) ; ENDIF
IF " WHO" $ cMeta ; cMeta := StrTran( cMeta, " WHO", " H" ) ; ENDIF
IF " WH" $ cMeta ; cMeta := StrTran( cMeta, " WH" , " W" ) ; ENDIF
IF " MCG" $ cMeta ; cMeta := StrTran( cMeta, " MCG", " MK" ) ; ENDIF
IF " MC" $ cMeta ; cMeta := StrTran( cMeta, " MC" , " MK" ) ; ENDIF
IF " MACG" $ cMeta ; cMeta := StrTran( cMeta, " MACG", " MK" ) ; ENDIF
IF " MAC" $ cMeta ; cMeta := StrTran( cMeta, " MAC", " MK" ) ; ENDIF
IF " GI" $ cMeta ; cMeta := StrTran( cMeta, " GI", " K" ) ; ENDIF
IF " KN" $ cMeta ; cMeta := StrTran( cMeta, " KN" , " N" ) ; ENDIF
IF " GN" $ cMeta ; cMeta := StrTran( cMeta, " GN" , " N" ) ; ENDIF
IF " PN" $ cMeta ; cMeta := StrTran( cMeta, " PN" , " N" ) ; ENDIF
IF " AE" $ cMeta ; cMeta := StrTran( cMeta, " AE" , " E" ) ; ENDIF
IF " X" $ cMeta ; cMeta := StrTran( cMeta, " X" , " S" ) ; ENDIF
IF " WR" $ cMeta ; cMeta := StrTran( cMeta, " WR" , " R" ) ; ENDIF
IF " WHO" $ cMeta ; cMeta := StrTran( cMeta, " WHO", " H" ) ; ENDIF
IF " WH" $ cMeta ; cMeta := StrTran( cMeta, " WH" , " W" ) ; ENDIF
IF " MCG" $ cMeta ; cMeta := StrTran( cMeta, " MCG", " MK" ) ; ENDIF
IF " MC" $ cMeta ; cMeta := StrTran( cMeta, " MC" , " MK" ) ; ENDIF
IF " MACG" $ cMeta ; cMeta := StrTran( cMeta, " MACG", " MK" ) ; ENDIF
IF " MAC" $ cMeta ; cMeta := StrTran( cMeta, " MAC", " MK" ) ; ENDIF
IF " GI" $ cMeta ; cMeta := StrTran( cMeta, " GI", " K" ) ; ENDIF
// Suffixes which need special consideration
IF "MB " $ cMeta ; cMeta := StrTran( cMeta, "MB " , "M " ) ; ENDIF
IF "NG " $ cMeta ; cMeta := StrTran( cMeta, "NG " , "N " ) ; ENDIF
IF "MB " $ cMeta ; cMeta := StrTran( cMeta, "MB " , "M " ) ; ENDIF
IF "NG " $ cMeta ; cMeta := StrTran( cMeta, "NG " , "N " ) ; ENDIF
// Remove inner spaces (1st and last byte are spaces)
IF " " $ SubStr( cMeta, 2, Len( cMeta ) - 2 )
@@ -133,58 +129,58 @@ FUNCTION FT_METAPH( cName, nSize )
ENDIF
// Double consonants sound much the same as singles
IF "BB" $ cMeta ; cMeta := StrTran( cMeta, "BB" , "B" ) ; ENDIF
IF "CC" $ cMeta ; cMeta := StrTran( cMeta, "CC" , "CH" ) ; ENDIF
IF "DD" $ cMeta ; cMeta := StrTran( cMeta, "DD" , "T" ) ; ENDIF
IF "FF" $ cMeta ; cMeta := StrTran( cMeta, "FF" , "F" ) ; ENDIF
IF "GG" $ cMeta ; cMeta := StrTran( cMeta, "GG" , "K" ) ; ENDIF
IF "KK" $ cMeta ; cMeta := StrTran( cMeta, "KK" , "K" ) ; ENDIF
IF "LL" $ cMeta ; cMeta := StrTran( cMeta, "LL" , "L" ) ; ENDIF
IF "MM" $ cMeta ; cMeta := StrTran( cMeta, "MM" , "M" ) ; ENDIF
IF "NN" $ cMeta ; cMeta := StrTran( cMeta, "NN" , "N" ) ; ENDIF
IF "PP" $ cMeta ; cMeta := StrTran( cMeta, "PP" , "P" ) ; ENDIF
IF "RR" $ cMeta ; cMeta := StrTran( cMeta, "RR" , "R" ) ; ENDIF
IF "SS" $ cMeta ; cMeta := StrTran( cMeta, "SS" , "S" ) ; ENDIF
IF "TT" $ cMeta ; cMeta := StrTran( cMeta, "TT" , "T" ) ; ENDIF
IF "XX" $ cMeta ; cMeta := StrTran( cMeta, "XX" , "KS" ) ; ENDIF
IF "ZZ" $ cMeta ; cMeta := StrTran( cMeta, "ZZ" , "S" ) ; ENDIF
IF "BB" $ cMeta ; cMeta := StrTran( cMeta, "BB" , "B" ) ; ENDIF
IF "CC" $ cMeta ; cMeta := StrTran( cMeta, "CC" , "CH" ) ; ENDIF
IF "DD" $ cMeta ; cMeta := StrTran( cMeta, "DD" , "T" ) ; ENDIF
IF "FF" $ cMeta ; cMeta := StrTran( cMeta, "FF" , "F" ) ; ENDIF
IF "GG" $ cMeta ; cMeta := StrTran( cMeta, "GG" , "K" ) ; ENDIF
IF "KK" $ cMeta ; cMeta := StrTran( cMeta, "KK" , "K" ) ; ENDIF
IF "LL" $ cMeta ; cMeta := StrTran( cMeta, "LL" , "L" ) ; ENDIF
IF "MM" $ cMeta ; cMeta := StrTran( cMeta, "MM" , "M" ) ; ENDIF
IF "NN" $ cMeta ; cMeta := StrTran( cMeta, "NN" , "N" ) ; ENDIF
IF "PP" $ cMeta ; cMeta := StrTran( cMeta, "PP" , "P" ) ; ENDIF
IF "RR" $ cMeta ; cMeta := StrTran( cMeta, "RR" , "R" ) ; ENDIF
IF "SS" $ cMeta ; cMeta := StrTran( cMeta, "SS" , "S" ) ; ENDIF
IF "TT" $ cMeta ; cMeta := StrTran( cMeta, "TT" , "T" ) ; ENDIF
IF "XX" $ cMeta ; cMeta := StrTran( cMeta, "XX" , "KS" ) ; ENDIF
IF "ZZ" $ cMeta ; cMeta := StrTran( cMeta, "ZZ" , "S" ) ; ENDIF
// J sounds
IF "DGE" $ cMeta ; cMeta := StrTran( cMeta, "DGE" , "J" ) ; ENDIF
IF "DGY" $ cMeta ; cMeta := StrTran( cMeta, "DGY" , "J" ) ; ENDIF
IF "DGI" $ cMeta ; cMeta := StrTran( cMeta, "DGI" , "J" ) ; ENDIF
IF "GI" $ cMeta ; cMeta := StrTran( cMeta, "GI" , "J" ) ; ENDIF
IF "GE" $ cMeta ; cMeta := StrTran( cMeta, "GE" , "J" ) ; ENDIF
IF "GY" $ cMeta ; cMeta := StrTran( cMeta, "GY" , "J" ) ; ENDIF
IF "DGE" $ cMeta ; cMeta := StrTran( cMeta, "DGE" , "J" ) ; ENDIF
IF "DGY" $ cMeta ; cMeta := StrTran( cMeta, "DGY" , "J" ) ; ENDIF
IF "DGI" $ cMeta ; cMeta := StrTran( cMeta, "DGI" , "J" ) ; ENDIF
IF "GI" $ cMeta ; cMeta := StrTran( cMeta, "GI" , "J" ) ; ENDIF
IF "GE" $ cMeta ; cMeta := StrTran( cMeta, "GE" , "J" ) ; ENDIF
IF "GY" $ cMeta ; cMeta := StrTran( cMeta, "GY" , "J" ) ; ENDIF
// X sounds (KS)
IF "X" $ cMeta ; cMeta := StrTran( cMeta, "X" , "KS" ) ; ENDIF
IF "X" $ cMeta ; cMeta := StrTran( cMeta, "X" , "KS" ) ; ENDIF
// special consideration for SCH
IF "ISCH" $ cMeta; cMeta := StrTran( cMeta, "ISCH", "IX" ) ; ENDIF
IF "SCH" $ cMeta ; cMeta := StrTran( cMeta, "SCH" , "SK" ) ; ENDIF
IF "ISCH" $ cMeta; cMeta := StrTran( cMeta, "ISCH", "IX" ) ; ENDIF
IF "SCH" $ cMeta ; cMeta := StrTran( cMeta, "SCH" , "SK" ) ; ENDIF
// sh sounds (X)
IF "CIA" $ cMeta ; cMeta := StrTran( cMeta, "CIA" , "X" ) ; ENDIF
IF "SIO" $ cMeta ; cMeta := StrTran( cMeta, "SIO" , "X" ) ; ENDIF
IF "C" $ cMeta ; cMeta := StrTran( cMeta, "SIA" , "X" ) ; ENDIF
IF "SH" $ cMeta ; cMeta := StrTran( cMeta, "SH" , "X" ) ; ENDIF
IF "TIA" $ cMeta ; cMeta := StrTran( cMeta, "TIA" , "X" ) ; ENDIF
IF "TIO" $ cMeta ; cMeta := StrTran( cMeta, "TIO" , "X" ) ; ENDIF
IF "TCH" $ cMeta ; cMeta := StrTran( cMeta, "TCH" , "X" ) ; ENDIF
IF "CH" $ cMeta ; cMeta := StrTran( cMeta, "CH" , "X" ) ; ENDIF
IF "CIA" $ cMeta ; cMeta := StrTran( cMeta, "CIA" , "X" ) ; ENDIF
IF "SIO" $ cMeta ; cMeta := StrTran( cMeta, "SIO" , "X" ) ; ENDIF
IF "C" $ cMeta ; cMeta := StrTran( cMeta, "SIA" , "X" ) ; ENDIF
IF "SH" $ cMeta ; cMeta := StrTran( cMeta, "SH" , "X" ) ; ENDIF
IF "TIA" $ cMeta ; cMeta := StrTran( cMeta, "TIA" , "X" ) ; ENDIF
IF "TIO" $ cMeta ; cMeta := StrTran( cMeta, "TIO" , "X" ) ; ENDIF
IF "TCH" $ cMeta ; cMeta := StrTran( cMeta, "TCH" , "X" ) ; ENDIF
IF "CH" $ cMeta ; cMeta := StrTran( cMeta, "CH" , "X" ) ; ENDIF
// hissing sounds (S)
IF "SCI" $ cMeta ; cMeta := StrTran( cMeta, "SCI" , "S" ) ; ENDIF
IF "SCE" $ cMeta ; cMeta := StrTran( cMeta, "SCE" , "S" ) ; ENDIF
IF "SCY" $ cMeta ; cMeta := StrTran( cMeta, "SCY" , "S" ) ; ENDIF
IF "CI" $ cMeta ; cMeta := StrTran( cMeta, "CI" , "S" ) ; ENDIF
IF "CE" $ cMeta ; cMeta := StrTran( cMeta, "CE" , "S" ) ; ENDIF
IF "CY" $ cMeta ; cMeta := StrTran( cMeta, "CY" , "S" ) ; ENDIF
IF "Z" $ cMeta ; cMeta := StrTran( cMeta, "Z" , "S" ) ; ENDIF
IF "SCI" $ cMeta ; cMeta := StrTran( cMeta, "SCI" , "S" ) ; ENDIF
IF "SCE" $ cMeta ; cMeta := StrTran( cMeta, "SCE" , "S" ) ; ENDIF
IF "SCY" $ cMeta ; cMeta := StrTran( cMeta, "SCY" , "S" ) ; ENDIF
IF "CI" $ cMeta ; cMeta := StrTran( cMeta, "CI" , "S" ) ; ENDIF
IF "CE" $ cMeta ; cMeta := StrTran( cMeta, "CE" , "S" ) ; ENDIF
IF "CY" $ cMeta ; cMeta := StrTran( cMeta, "CY" , "S" ) ; ENDIF
IF "Z" $ cMeta ; cMeta := StrTran( cMeta, "Z" , "S" ) ; ENDIF
// th sound (0)
IF "TH" $ cMeta ; cMeta := StrTran( cMeta, "TH" , "0" ) ; ENDIF
IF "TH" $ cMeta ; cMeta := StrTran( cMeta, "TH" , "0" ) ; ENDIF
// Convert all vowels to 'v' from 3rd byte on
cMeta := Left( cMeta, 2 ) + _ftConvVowel( SubStr( cMeta, 3 ) )
@@ -197,62 +193,58 @@ FUNCTION FT_METAPH( cName, nSize )
ENDIF
// More G sounds, looking at surrounding vowels
IF "GHv" $ cMeta ; cMeta := StrTran( cMeta, "GHv" , "G" ) ; ENDIF
IF "vGHT" $ cMeta; cMeta := StrTran( cMeta, "vGHT", "T" ) ; ENDIF
IF "vGH" $ cMeta ; cMeta := StrTran( cMeta, "vGH" , "W" ) ; ENDIF
IF "GN" $ cMeta ; cMeta := StrTran( cMeta, "GN" , "N" ) ; ENDIF
IF "G" $ cMeta ; cMeta := StrTran( cMeta, "G" , "K" ) ; ENDIF
IF "GHv" $ cMeta ; cMeta := StrTran( cMeta, "GHv" , "G" ) ; ENDIF
IF "vGHT" $ cMeta; cMeta := StrTran( cMeta, "vGHT", "T" ) ; ENDIF
IF "vGH" $ cMeta ; cMeta := StrTran( cMeta, "vGH" , "W" ) ; ENDIF
IF "GN" $ cMeta ; cMeta := StrTran( cMeta, "GN" , "N" ) ; ENDIF
IF "G" $ cMeta ; cMeta := StrTran( cMeta, "G" , "K" ) ; ENDIF
// H sounds, looking at surrounding vowels
IF "vHv" $ cMeta ; cMeta := StrTran( cMeta, "vHv" , "H" ) ; ENDIF
IF "vH" $ cMeta ; cMeta := StrTran( cMeta, "vH" , "" ) ; ENDIF
IF "vHv" $ cMeta ; cMeta := StrTran( cMeta, "vHv" , "H" ) ; ENDIF
IF "vH" $ cMeta ; cMeta := StrTran( cMeta, "vH" , "" ) ; ENDIF
// F sounds
IF "PH" $ cMeta ; cMeta := StrTran( cMeta, "PH" , "F" ) ; ENDIF
IF "V" $ cMeta ; cMeta := StrTran( cMeta, "V" , "F" ) ; ENDIF
IF "PH" $ cMeta ; cMeta := StrTran( cMeta, "PH" , "F" ) ; ENDIF
IF "V" $ cMeta ; cMeta := StrTran( cMeta, "V" , "F" ) ; ENDIF
// D sounds a bit like T
IF "D" $ cMeta ; cMeta := StrTran( cMeta, "D" , "T" ) ; ENDIF
IF "D" $ cMeta ; cMeta := StrTran( cMeta, "D" , "T" ) ; ENDIF
// K sounds
IF "CK" $ cMeta ; cMeta := StrTran( cMeta, "CK" , "K" ) ; ENDIF
IF "Q" $ cMeta ; cMeta := StrTran( cMeta, "Q" , "K" ) ; ENDIF
IF "C" $ cMeta ; cMeta := StrTran( cMeta, "C" , "K" ) ; ENDIF
IF "CK" $ cMeta ; cMeta := StrTran( cMeta, "CK" , "K" ) ; ENDIF
IF "Q" $ cMeta ; cMeta := StrTran( cMeta, "Q" , "K" ) ; ENDIF
IF "C" $ cMeta ; cMeta := StrTran( cMeta, "C" , "K" ) ; ENDIF
// Remove vowels
cMeta := StrTran( cMeta, "v" )
RETURN PadR( AllTrim( cMeta ), nSize )
//------------------------------------------------
//
STATIC FUNCTION _ftMakeAlpha( cStr )
// Strips non-alpha characters from a string, leaving spaces
STATIC FUNCTION _ftMakeAlpha( cStr ) // Strips non-alpha characters from a string, leaving spaces
LOCAL x, cAlpha := ""
FOR x := 1 TO Len( cStr )
IF SubStr( cStr, x, 1 ) == " " .OR. IsAlpha( SubStr( cStr, x, 1 ) )
cAlpha := cAlpha + SubStr( cStr, x, 1 )
cAlpha += SubStr( cStr, x, 1 )
ENDIF
NEXT
RETURN cAlpha
//------------------------------------------------
//
STATIC FUNCTION _ftConvVowel( cStr )
// Converts all vowels to letter 'v'
STATIC FUNCTION _ftConvVowel( cStr ) // Converts all vowels to letter 'v'
LOCAL x, cConverted := ""
FOR x := 1 TO Len( cStr )
IF SubStr( cStr, x, 1 ) $ "AEIOU"
cConverted := cConverted + "v"
cConverted += "v"
ELSE
cConverted := cConverted + SubStr( cStr, x, 1 )
cConverted += SubStr( cStr, x, 1 )
ENDIF
NEXT

16
harbour/contrib/hbnf/mouse1.prg
View File

@@ -85,8 +85,7 @@ FUNCTION FT_MDBLCLK( nClick, nButton, nInterval, nRow, nCol, nStart )
ENDDO
// make sure we haven't moved
lDouble := lDouble .AND. ( nVert == nRow .AND. nHorz == nCol )
lDouble := lDouble .AND. nVert == nRow .AND. nHorz == nCol
ENDIF
@@ -129,7 +128,6 @@ FUNCTION FT_MINIT()
t_lMinit := ( FT_MRESET() != 0 )
ELSE
// Reset maximum x and y limits
FT_MYLIMIT( 0, 8 * 24 )
FT_MXLIMIT( 0, 8 * 80 )
ENDIF
@@ -140,14 +138,14 @@ FUNCTION FT_MRESET()
LOCAL lStatus
t_lCrsState := .F. // Cursor is off after reset
t_lCrsState := .F. // Cursor is off after reset
lStatus := _m_reset()
// Reset maximum x and y limits
// Reset maximum x and y limits
FT_MYLIMIT( 0, 8 * MaxRow() )
FT_MXLIMIT( 0, 8 * MaxCol() )
RETURN lStatus // return status code
RETURN lStatus // return status code
FUNCTION FT_MCURSOR( lState )
@@ -169,12 +167,12 @@ FUNCTION FT_MSHOWCRS()
t_lCrsState := .T.
RETURN NIL // no output from function
RETURN NIL // no output from function
FUNCTION FT_MHIDECRS() // decrement internal cursor flag and hide cursor
FUNCTION FT_MHIDECRS() // decrement internal cursor flag and hide cursor
_mse_mhidecrs()
t_lCrsState := .F.
RETURN NIL // no output from function
RETURN NIL // no output from function

2
harbour/contrib/hbnf/nooccur.prg
View File

@@ -25,7 +25,7 @@
FUNCTION FT_NOOCCUR( cCheckFor, cCheckIn, lIgnoreCase )
// Is Case Important??
// Is Case Important?
IF ! HB_ISLOGICAL( lIgnoreCase ) .OR. lIgnoreCase
cCheckFor := Upper( cCheckFor )
cCheckIn := Upper( cCheckIn )

9
harbour/contrib/hbnf/ntow.prg
View File

@@ -20,17 +20,20 @@
*
*/
STATIC sc_ones := { "", " One", " Two", " Three", " Four", " Five", ;
STATIC sc_ones := { ;
"", " One", " Two", " Three", " Four", " Five", ;
" Six", " Seven", " Eight", " Nine" ;
}
STATIC sc_teens := { " Ten", " Eleven", " Twelve", ;
STATIC sc_teens := { ;
" Ten", " Eleven", " Twelve", ;
" Thirteen", " Fourteen", " Fifteen", ;
" Sixteen", " Seventeen", " Eighteen", ;
" Nineteen" ;
}
STATIC sc_tens := { "", "", " Twenty", " Thirty", " Forty", " Fifty", ;
STATIC sc_tens := { ;
"", "", " Twenty", " Thirty", " Forty", " Fifty", ;
" Sixty", " Seventy", " Eighty", " Ninety" }
STATIC sc_qualifiers := { "", " Thousand", " Million", " Billion", " Trillion" }

8
harbour/contrib/hbnf/nwsem.prg
View File

@@ -32,9 +32,8 @@
*
*/
// --------------------------------------------------------------
// Semaphore Package for Novell NetWare
// --------------------------------------------------------------
// Semaphore Package for Novell NetWare
// ------------------------------------
#include "ftint86.ch"
@@ -102,9 +101,8 @@ FUNCTION ft_nwSemClose( nHandle )
RETURN _ftnwsem( CLOSE_SEMAPHORE, nHandle )
// ---------------------------------------------------------
// -----------------------------------------------
// _ftnwsem() - internal for the semaphore package
// ---------------------------------------------------------
/* TODO: rewrite in C */
STATIC FUNCTION _ftnwsem( nOp, nHandle, nTimeout )

1
harbour/contrib/hbnf/nwuid.prg
View File

@@ -33,6 +33,7 @@
#include "ftint86.ch"
/* TODO: rewrite in C */
FUNCTION FT_NWUID( nConn )
LOCAL aRegs[ INT86_MAX_REGS ]

8
harbour/contrib/hbnf/pegs.prg
View File

@@ -90,7 +90,7 @@ FUNCTION FT_PEGS()
*/
scanblock := {| a | a[ 2 ] == move2 }
CLS
hb_Scroll()
SetColor( "w/r" )
hb_DispBox( 22, 31, 24, 48, hb_UTF8ToStrBox( "┌─┐│┘─└│ " ) )
hb_DispOutAt( 23, 33, "Your move:" )
@@ -163,7 +163,7 @@ FUNCTION FT_PEGS()
RETURN NIL
//--------------------------------------------------------------------*
//
STATIC FUNCTION DrawBox( board_, nelement )
@@ -179,7 +179,7 @@ STATIC FUNCTION DrawBox( board_, nelement )
RETURN NIL
//--------------------------------------------------------------------*
//
STATIC FUNCTION err_msg( msg )
@@ -194,7 +194,7 @@ STATIC FUNCTION err_msg( msg )
RETURN NIL
//--------------------------------------------------------------------*
//
STATIC FUNCTION moremoves( board_ )

649
harbour/contrib/hbnf/popadder.prg
View File

@@ -3,7 +3,7 @@
*/
/*
* Author....: Keith A. Wire
* Author....: Keith A. Wire (docs included)
* CIS ID....: 73760,2427
*
* This is an original work by Keith A. Wire and is placed in the
@@ -112,22 +112,12 @@ THREAD STATIC t_nWinColor
THREAD STATIC t_aWinColor
THREAD STATIC t_aStdColor
/*+- Function ---------------------------------------------------------------+
| Name: FT_Adder() Docs: Keith A. Wire |
| Description: Pop Up Adder / Calculator with Tape Display |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 11:18:40am Time updated: 11:18:40am |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: None |
| Return Value: NIL |
| Notes: To make FT_Adder() pop up from any wait state in your |
| : application just insert the line: |
| : SET KEY K_ALT_A TO FT_Adder |
| : at the top of your application |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Pop Up Adder / Calculator with Tape Display
// NOTE: To make FT_Adder() pop up from any wait state in your
// application just insert the line:
// SET KEY K_ALT_A TO FT_Adder
// at the top of your application
FUNCTION FT_Adder()
@@ -303,18 +293,8 @@ FUNCTION FT_Adder()
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftAddScreen() Docs: Keith A. Wire |
| Description: Display the Adder |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 11:24:29am Time updated: 11:24:29am |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Display the Adder
STATIC FUNCTION _ftAddScreen( aAdder )
@@ -365,19 +345,8 @@ STATIC FUNCTION _ftAddScreen( aAdder )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftChangeDec() Docs: Keith A. Wire |
| Description: Change the decimal position in the display |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 11:25:17am Time updated: 11:25:17am |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| : nNumDec |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Change the decimal position in the display
STATIC FUNCTION _ftChangeDec( aAdder, nNumDec )
@@ -406,18 +375,8 @@ STATIC FUNCTION _ftChangeDec( aAdder, nNumDec )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftDispTotal() Docs: Keith A. Wire |
| Description: Display total number to Adder Window |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 11:25:58am Time updated: 11:25:58am |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Display total number to Adder Window
STATIC FUNCTION _ftDispTotal( aAdder )
@@ -440,18 +399,8 @@ STATIC FUNCTION _ftDispTotal( aAdder )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftDispSubTot() Docs: Keith A. Wire |
| Description: Display subtotal number |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 11:26:31am Time updated: 11:26:31am |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Display subtotal number
STATIC FUNCTION _ftDispSubTot( aAdder )
@@ -474,19 +423,8 @@ STATIC FUNCTION _ftDispSubTot( aAdder )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftProcessNumb() Docs: Keith A. Wire |
| Description: Act on NUMBER key pressed |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 11:38:34am Time updated: 11:38:34am |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| : nKey |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Act on NUMBER key pressed
STATIC FUNCTION _ftProcessNumb( aAdder, nKey )
@@ -520,18 +458,8 @@ STATIC FUNCTION _ftProcessNumb( aAdder, nKey )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftAddTotal() Docs: Keith A. Wire |
| Description: Enter key - SUBTOTAL\TOTAL |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:05:29pm Time updated: 12:05:29pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Enter key - SUBTOTAL\TOTAL
STATIC FUNCTION _ftAddTotal( aAdder )
@@ -605,19 +533,8 @@ STATIC FUNCTION _ftAddTotal( aAdder )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftAddSub() Docs: Keith A. Wire |
| Description: Process + or - keypress |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:06:13pm Time updated: 12:06:13pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| : nKey |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Process + or - keypress
STATIC FUNCTION _ftAddSub( aAdder, nKey )
@@ -659,19 +576,8 @@ STATIC FUNCTION _ftAddSub( aAdder, nKey )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftMultDiv() Docs: Keith A. Wire |
| Description: Process * or / keypress |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:06:43pm Time updated: 12:06:43pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| : nKey |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Process * or / keypress
STATIC FUNCTION _ftMultDiv( aAdder, nKey )
@@ -718,18 +624,8 @@ STATIC FUNCTION _ftMultDiv( aAdder, nKey )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftAddHelp Docs: Keith A. Wire |
| Description: Help window |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:07:07pm Time updated: 12:07:07pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: None |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Help window
STATIC FUNCTION _ftAddHelp
@@ -756,18 +652,8 @@ STATIC FUNCTION _ftAddHelp
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftClearAdder() Docs: Keith A. Wire |
| Description: Clear entry / Clear Adder |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:07:33pm Time updated: 12:07:33pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Clear entry / Clear Adder
STATIC FUNCTION _ftClearAdder( aAdder )
@@ -788,20 +674,8 @@ STATIC FUNCTION _ftClearAdder( aAdder )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftUpdateTrans() Docs: Keith A. Wire |
| Description: Update transactions array |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:07:55pm Time updated: 12:07:55pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| : lTypeTotal |
| : nAmount |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Update transactions array
STATIC FUNCTION _ftUpdateTrans( aAdder, lTypeTotal, nAmount )
@@ -836,18 +710,8 @@ STATIC FUNCTION _ftUpdateTrans( aAdder, lTypeTotal, nAmount )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftEraseTotSubTot() Docs: Keith A. Wire |
| Description: Clear the <TOTAL> & <SUBTOTAL> from Adder |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:08:14pm Time updated: 12:08:14pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Clear the <TOTAL> & <SUBTOTAL> from Adder
STATIC FUNCTION _ftEraseTotSubTot( aAdder )
@@ -857,18 +721,8 @@ STATIC FUNCTION _ftEraseTotSubTot( aAdder )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftRoundIt() Docs: Keith A. Wire |
| Description: Adder Rounding function |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:09:00pm Time updated: 12:09:00pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: nNumber |
| : nPlaces |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Adder Rounding function
STATIC FUNCTION _ftRoundIt( nNumber, nPlaces )
@@ -877,19 +731,8 @@ STATIC FUNCTION _ftRoundIt( nNumber, nPlaces )
RETURN iif( nNumber < 0.0, -1.0, 1.0 ) * ;
Int( Abs( nNumber ) * 10 ^ nPlaces + 0.50 + 10 ^ -12 ) / 10 ^ nPlaces
/*+- Function ---------------------------------------------------------------+
| Name: _ftDivide() Docs: Keith A. Wire |
| Description: Check divide by zero not allowed |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:10:41pm Time updated: 12:10:41pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| : nNumerator |
| : nDenominator |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Check divide by zero not allowed
STATIC FUNCTION _ftDivide( aAdder, nNumerator, nDenominator )
@@ -902,17 +745,8 @@ STATIC FUNCTION _ftDivide( aAdder, nNumerator, nDenominator )
RETURN nNumerator / nDenominator
/*+- Function ---------------------------------------------------------------+
| Name: _ftValDeci() Docs: Keith A. Wire |
| Description: Validate the number of decimals |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:10:56pm Time updated: 12:10:56pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: oGet |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Validate the number of decimals
STATIC FUNCTION _ftValDeci( oGet )
@@ -925,19 +759,8 @@ STATIC FUNCTION _ftValDeci( oGet )
RETURN lRtnValue
/*+- Function ---------------------------------------------------------------+
| Name: _ftDisplayTape() Docs: Keith A. Wire |
| Description: Display the Tape |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:11:28pm Time updated: 12:11:28pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: aAdder |
| : nKey |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Display the Tape
STATIC FUNCTION _ftDisplayTape( aAdder, nKey )
@@ -975,20 +798,10 @@ STATIC FUNCTION _ftDisplayTape( aAdder, nKey )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftSetLastKey() Docs: Keith A. Wire |
| Description: Sets the LASTKEY() value to value of nLastKey |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:12:00pm Time updated: 12:12:00pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: nLastKey |
| Return Value: NIL |
| Notes: I use this in most of my Pop-Up routines to reset the |
| : original value of LASTKEY() when quitting. |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Sets the LASTKEY() value to value of nLastKey
// NOTE: I use this in most of my Pop-Up routines to reset the
// original value of LASTKEY() when quitting.
STATIC FUNCTION _ftSetLastKey( nLastKey )
@@ -999,21 +812,11 @@ STATIC FUNCTION _ftSetLastKey( nLastKey )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftPushKeys Docs: Keith A. Wire |
| Description: Push any keys in the Keyboard buffer on the array t_aKeys[]|
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:16:09pm Time updated: 12:16:09pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: None |
| Return Value: NIL |
| Notes: Save any keys in the buffer... for FAST typists <g>. |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Push any keys in the Keyboard buffer on the array t_aKeys[]
// NOTE: Save any keys in the buffer... for FAST typists <g>.
STATIC FUNCTION _ftPushKeys
STATIC FUNCTION _ftPushKeys()
DO WHILE NextKey() != 0
AAdd( t_aKeys, Inkey() )
@@ -1021,19 +824,8 @@ STATIC FUNCTION _ftPushKeys
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftPopKeys Docs: Keith A. Wire |
| Description: Restore the keyboard with any keystrokes that were saved |
| : with _ftPushKeys |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:17:58pm Time updated: 12:17:58pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: None |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Restore the keyboard with any keystrokes that were saved with _ftPushKeys
STATIC FUNCTION _ftPopKeys
@@ -1044,24 +836,9 @@ STATIC FUNCTION _ftPopKeys
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftPushMessage() Docs: Keith A. Wire |
| Description: Display a message on the screen in a window |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:18:53pm Time updated: 12:18:53pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: cMessage |
| : lWait |
| : cTitle |
| : cBotTitle |
| : xQuiet |
| : nTop |
| Return Value: NIL |
| See Also: _ftPopMessage |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Display a message on the screen in a window
// See Also: _ftPopMessage
STATIC FUNCTION _ftPushMessage( cMessage, lWait, cTitle, cBotTitle, xQuiet, nTop )
@@ -1108,19 +885,9 @@ STATIC FUNCTION _ftPushMessage( cMessage, lWait, cTitle, cBotTitle, xQuiet, nTop
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftPopMessage Docs: Keith A. Wire |
| Description: Pop off the Message Box |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:24:22pm Time updated: 12:24:22pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: None |
| Return Value: NIL |
| See Also: _ftPushMessage() |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Pop off the Message Box
// See Also: _ftPushMessage()
STATIC FUNCTION _ftPopMessage
@@ -1128,25 +895,9 @@ STATIC FUNCTION _ftPopMessage
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftQuest() Docs: Keith A. Wire |
| Description: Push a Question Box on the Screen |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:25:32pm Time updated: 12:25:32pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: cMessage |
| : xVarVal |
| : cPict |
| : bValid |
| : lNoESC |
| : nWinColor |
| : nTop |
| Return Value: xVarVal |
| Notes: This function will work for all Data Types |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Push a Question Box on the Screen
// NOTE: This function will work for all Data Types
STATIC FUNCTION _ftQuest( cMessage, xVarVal, cPict, bValid, lNoESC, nWinColor, nTop )
@@ -1236,20 +987,8 @@ STATIC FUNCTION _ftQuest( cMessage, xVarVal, cPict, bValid, lNoESC, nWinColor, n
RETURN xVarVal
/*+- Function ---------------------------------------------------------------+
| Name: _ftAdderTapeUDF() Docs: Keith A. Wire |
| Description: User function for ACHOICE() when scrolling tape |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:26:44pm Time updated: 12:26:44pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: mode |
| : cur_elem |
| : rel_pos |
| Return Value: nRtnVal |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// User function for ACHOICE() when scrolling tape
STATIC FUNCTION _ftAdderTapeUDF( mode, cur_elem, rel_pos, /* @ */ lAC_exit_ok )
@@ -1280,19 +1019,8 @@ STATIC FUNCTION _ftAdderTapeUDF( mode, cur_elem, rel_pos, /* @ */ lAC_exit_ok )
RETURN nRtnVal
/*+- Function ---------------------------------------------------------------+
| Name: _ftError() Docs: Keith A. Wire |
| Description: Display an ERROR message in a window |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:27:43pm Time updated: 12:27:43pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: cMessage |
| : xDontReset |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Display an ERROR message in a window
STATIC FUNCTION _ftError( cMessage, xDontReset )
@@ -1339,19 +1067,8 @@ STATIC FUNCTION _ftError( cMessage, xDontReset )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftStuffComma() Docs: Keith A. Wire |
| Description: Stuff a Comma in a string |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:28:19pm Time updated: 12:28:19pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: cStrToStuff |
| : lTrimStuffedStr |
| Return Value: cStrToStuff |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Stuff a Comma in a string
STATIC FUNCTION _ftStuffComma( cStrToStuff, lTrimStuffedStr )
@@ -1387,22 +1104,9 @@ STATIC FUNCTION _ftStuffComma( cStrToStuff, lTrimStuffedStr )
RETURN cStrToStuff
/*+- Function ---------------------------------------------------------------+
| Name: _ftSetSCRColor() Docs: Keith A. Wire |
| Description: Set the standard screen colors to the color requested. |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:28:48pm Time updated: 12:28:48pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: nStd |
| : nEnh |
| : nBord |
| : nBack |
| : nUnsel |
| See Also: _ftSetWinColor() |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Set the standard screen colors to the color requested.
// See Also: _ftSetWinColor()
STATIC FUNCTION _ftSetSCRColor( nStd, nEnh, nBord, nBack, nUnsel )
@@ -1423,39 +1127,20 @@ STATIC FUNCTION _ftSetSCRColor( nStd, nEnh, nBord, nBack, nUnsel )
t_aStdColor[ nBack ] + "," + ;
t_aStdColor[ nUnsel ] )
/*+- Function ---------------------------------------------------------------+
| Name: _ftPushWin() Docs: Keith A. Wire |
| Description: Push a new window on the screen |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:34:38pm Time updated: 12:34:38pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: t |
| : l |
| : b |
| : r |
| : cTitle |
| : cBotTitle |
| : nWinColor |
| Return Value: NIL |
| See Also: |
| Notes: Push a new window on the screen in the position t,l,b,r |
| : and if cTitle is not NIL print the title for the window |
| : in centered in the top line of the box. Similarly do |
| : the same for cBotTitle. If nWinColor==NIL get the next |
| : window color and use it for all the colors. If |
| : cTypeBord==NIL use the single line border, else use the |
| : one they requested. Push the window coordinates, the |
| : color number, the SAVESCREEN() value, and whether they |
| : picked the window color they wanted to use. If |
| : lAutoWindow=.F. then the window color was incremented |
| : and we will will restore the color number when we pop |
| : the window off. |
| : |
| : nWinColor DEFAULT == _ftNextWinColor() |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// NOTE: Push a new window on the screen in the position t,l,b,r
// and if cTitle is not NIL print the title for the window
// in centered in the top line of the box. Similarly do
// the same for cBotTitle. If nWinColor==NIL get the next
// window color and use it for all the colors. If
// cTypeBord==NIL use the single line border, else use the
// one they requested. Push the window coordinates, the
// color number, the SAVESCREEN() value, and whether they
// picked the window color they wanted to use. If
// lAutoWindow=.F. then the window color was incremented
// and we will will restore the color number when we pop
// the window off.
// nWinColor DEFAULT == _ftNextWinColor()
STATIC FUNCTION _ftPushWin( t, l, b, r, cTitle, cBotTitle, nWinColor )
@@ -1482,25 +1167,15 @@ STATIC FUNCTION _ftPushWin( t, l, b, r, cTitle, cBotTitle, nWinColor )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftPopWin Docs: Keith A. Wire |
| Description: Pop a Window off the screen |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 12:52:34pm Time updated: 12:52:34pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: None |
| Return Value: NIL |
| Notes: Pop the currently active window off the screen by restoring|
| : it from the t_aWindow Array and if they pushed a new window|
| : automatically selecting the color we will roll back the |
| : current window setting using _ftLastWinColor() and reset |
| : the color to the color setting when window was pushed. |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Pop a Window off the screen
// NOTE: Pop the currently active window off the screen by restoring
// it from the t_aWindow Array and if they pushed a new window
// automatically selecting the color we will roll back the
// current window setting using _ftLastWinColor() and reset
// the color to the color setting when window was pushed.
STATIC FUNCTION _ftPopWin
STATIC FUNCTION _ftPopWin()
LOCAL nNumWindow := Len( t_aWindow )
@@ -1522,25 +1197,11 @@ STATIC FUNCTION _ftPopWin
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftSetWinColor() Docs: Keith A. Wire |
| Description: Set the Color to the Window Colors requested |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 01:37:32pm Time updated: 01:37:32pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: nWin |
| : nStd |
| : nEnh |
| : nBord |
| : nBack |
| : nUnsel |
| See Also: _ftSetSCRColor() |
| Notes: If the window number is not passed use the currently active|
| : window number nWinColor. |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Set the Color to the Window Colors requested
// See Also: _ftSetSCRColor()
// NOTE: If the window number is not passed use the currently
// active window number nWinColor.
STATIC FUNCTION _ftSetWinColor( nWin, nStd, nEnh, nBord, nBack, nUnsel )
@@ -1558,37 +1219,17 @@ STATIC FUNCTION _ftSetWinColor( nWin, nStd, nEnh, nBord, nBack, nUnsel )
t_aWinColor[ nBack, nWin ] + "," + ;
t_aWinColor[ nUnsel, nWin ] )
/*+- Function ---------------------------------------------------------------+
| Name: _ftLastWinColor Docs: Keith A. Wire |
| Description: Decrement the active window color number and return the |
| : current value |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 01:49:19pm Time updated: 01:49:19pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: None |
| Notes: If we are already on window #1 restart count by using # 4. |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Decrement the active window color number and return the current value
// NOTE: If we are already on window #1 restart count by using # 4.
STATIC FUNCTION _ftLastWinColor()
RETURN t_nWinColor := iif( t_nWinColor == 1, 4, t_nWinColor - 1 )
/*+- Function ---------------------------------------------------------------+
| Name: _ftNextWinColor Docs: Keith A. Wire |
| Description: Increment the active window color number and return the |
| : current value |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 01:51:12pm Time updated: 01:51:12pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: None |
| Notes: If we are already on window #4 restart count by using # 1. |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Increment the active window color number and return the current value
// NOTE: If we are already on window #4 restart count by using # 1.
STATIC FUNCTION _ftNextWinColor()
@@ -1598,20 +1239,9 @@ STATIC FUNCTION _ftNextWinColor()
RETURN t_nWinColor := ( iif( t_nWinColor < 4, t_nWinColor + 1, 1 ) )
/*+- Function ---------------------------------------------------------------+
| Name: _ftWinTitle() Docs: Keith A. Wire |
| Description: Print the top or bottom titles on the border of the |
| : currently active window. |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 01:52:29pm Time updated: 01:52:29pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: cTheTitle |
| : cTopOrBot |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Print the top or bottom titles on the border of the currently
// active window.
STATIC FUNCTION _ftWinTitle( cTheTitle, cTopOrBot )
@@ -1623,20 +1253,10 @@ STATIC FUNCTION _ftWinTitle( cTheTitle, cTopOrBot )
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftInitColors Docs: Keith A. Wire |
| Description: Initilize the colors for the Adder |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 02:59:58pm Time updated: 02:59:58pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: None |
| Return Value: NIL |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Initilize the colors for the Adder
STATIC FUNCTION _ftInitColors
STATIC FUNCTION _ftInitColors()
t_aWinColor := { ;
{ "GR+/BG","GR+/G", "B+/RB", "G+/R" } ,;
@@ -1660,70 +1280,29 @@ STATIC FUNCTION _ftInitColors
RETURN NIL
/*+- Function ---------------------------------------------------------------+
| Name: _ftPosRepl() Docs: Keith A. Wire |
| Description: Replace the Character at nPosit in cString with cChar |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 01:44:21pm Time updated: 01:44:21pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: cString |
| : cChar |
| : nPosit |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Replace the Character at nPosit in cString with cChar
STATIC FUNCTION _ftPosRepl( cString, cChar, nPosit )
RETURN StrTran( cString, "9", cChar, nPosit, 1 ) + ""
/*+- Function ---------------------------------------------------------------+
| Name: _ftCharRem() Docs: Keith A. Wire |
| Description: Removes all occurances of cChar from cString. |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 01:45:41pm Time updated: 01:45:41pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: cChar |
| : cString |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Removes all occurances of cChar from cString.
STATIC FUNCTION _ftCharRem( cChar, cString )
RETURN StrTran( cString, cChar )
/*+- Function ---------------------------------------------------------------+
| Name: _ftCountLeft() Docs: Keith A. Wire |
| Description: Returns the number of spaces on the Left side of the String|
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 01:47:00pm Time updated: 01:47:00pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: cString |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Returns the number of spaces on the Left side of the String
STATIC FUNCTION _ftCountLeft( cString )
RETURN Len( cString ) - Len( LTrim( cString ) )
/*+- Function ---------------------------------------------------------------+
| Name: _ftPosIns() Docs: Keith A. Wire |
| Description: Insert the Character cChar in cString at position nPosit |
| Author: Keith A. Wire |
| Date created: 10-03-93 Date updated: 10-03-93 |
| Time created: 01:48:30pm Time updated: 01:48:30pm |
| Copyright: None - Public Domain |
+--------------------------------------------------------------------------+
| Arguments: cString |
| : cChar |
| : nPosit |
+--------------------------------------------------------------------------+
*/
//----------------------------------------------------------
// Insert the Character cChar in cString at position nPosit
STATIC FUNCTION _ftPosIns( cString, cChar, nPosit )

2
harbour/contrib/hbnf/rand1.prg
View File

@@ -29,6 +29,6 @@ FUNCTION ft_rand1( nMax )
LOCAL m := 100000000, b := 31415621
t_nSeed := iif( t_nSeed == NIL, Seconds(), t_nSeed ) // init_seed()
t_nSeed := iif( t_nSeed == NIL, Seconds(), t_nSeed )
RETURN nMax * ( ( t_nSeed := Mod( t_nSeed * b + 1, m ) ) / m )

2
harbour/contrib/hbnf/round.prg
View File

@@ -89,7 +89,7 @@ FUNCTION FT_ROUND( nNumber, nRoundToAmount, cRoundType, cRoundDirection, ;
nResult := Int( nResult / nRoundToAmount ) * nRoundToAmount
OTHERWISE // Round Normally
OTHERWISE // Round Normally
nResult := Int( ( nResult + nRoundToAmount / 2 ) / nRoundToAmount ) * ;
nRoundToAmount

6
harbour/contrib/hbnf/sqzn.prg
View File

@@ -47,10 +47,10 @@ FUNCTION ft_unsqzn( cCompressed, nSize, nDecimals )
cCompressed := iif( multi == -1, hb_BSubStr( cCompressed, 2 ), cCompressed )
nSize := iif( nSize / 2 != Int( nSize / 2 ), nSize + 1, nSize )
IF hb_BCode( cCompressed ) > 127
tmp := Str( hb_BCode( cCompressed ) - 128, 2 )
multi := -1
tmp := Str( hb_BCode( cCompressed ) - 128, 2 )
multi := -1
ELSE
tmp := Str( hb_BCode( cCompressed ), 2 )
tmp := Str( hb_BCode( cCompressed ), 2 )
ENDIF
FOR k := 2 TO hb_BLen( cCompressed )

24
harbour/contrib/hbnf/tbwhile.prg
View File

@@ -58,7 +58,7 @@
#include "set.ch"
#include "setcurs.ch"
/* ------------------------------------------------------------------- */
//
FUNCTION FT_BRWSWHL( aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
cColorList, cColorShad, nTop, nLeft, nBottom, nRight )
@@ -79,7 +79,7 @@ FUNCTION FT_BRWSWHL( aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
lKeepScrn := PCount() > 6
SEEK cKey
dbSeek( cKey )
IF ! Found() .OR. LastRec() == 0
RETURN 0
ENDIF
@@ -144,7 +144,7 @@ FUNCTION FT_BRWSWHL( aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
IF ! lKeepScrn
SetColor( cColorBack )
CLS
hb_Scroll()
ENDIF
/* make a window shadow */
@@ -156,6 +156,7 @@ FUNCTION FT_BRWSWHL( aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
lMore := .T.
DO WHILE lMore
/* stabilize the display */
nKey := 0
DispBegin()
@@ -175,8 +176,7 @@ FUNCTION FT_BRWSWHL( aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
// up-to-date data in case we are on a network.
DispBegin()
b:refreshCurrent()
DO WHILE ! b:stabilize()
ENDDO
b:forceStable()
DispEnd()
/* everything's done. just wait for a key */
@@ -263,7 +263,7 @@ FUNCTION FT_BRWSWHL( aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
RETURN nPassRec
/* -------------------------------------------------------------------- */
//
STATIC FUNCTION TbSkipWhil( n, bWhileCond )
@@ -297,15 +297,15 @@ STATIC FUNCTION TbSkipWhil( n, bWhileCond )
RETURN i
/* -------------------------------------------------------------------- */
//
STATIC FUNCTION TbWhileTop( cKey )
SEEK cKey
dbSeek( cKey )
RETURN NIL
/* -------------------------------------------------------------------- */
//
STATIC FUNCTION TbWhileBot( cKey )
@@ -316,9 +316,7 @@ STATIC FUNCTION TbWhileBot( cKey )
// string cKey by one ascii character. After SEEKing the new string,
// back up one record to get to the last record which matches cKey.
LOCAL cSoftSave := Set( _SET_SOFTSEEK, .T. )
SEEK Left( cKey, Len( cKey ) - 1 ) + Chr( Asc( Right( cKey, 1 ) ) + 1 )
Set( _SET_SOFTSEEK, cSoftSave )
SKIP -1
dbSeek( Left( cKey, Len( cKey ) - 1 ) + Chr( Asc( Right( cKey, 1 ) ) + 1 ), .T. )
dbSkip( -1 )
RETURN NIL

2
harbour/contrib/hbnf/week.prg
View File

@@ -49,7 +49,7 @@ FUNCTION FT_WEEK( dGivenDate, nWeekNum )
dGivenDate := aRetVal[ 2 ] + ( nWeekNum - 1 ) * 7
ENDIF
dGivenDate += ( 6 - FT_DAYTOBOW( dGivenDate ) ) // end of week
dGivenDate += 6 - FT_DAYTOBOW( dGivenDate ) // end of week
aRetVal[ 1 ] += StrZero( Int( ( dGivenDate - aRetVal[ 2 ] ) / 7 ) + 1, 2 )
aRetVal[ 2 ] := Max( dGivenDate - 6, dTemp )

3
harbour/contrib/hbnf/woy.prg
View File

@@ -33,17 +33,14 @@ FUNCTION FT_WOY( dInDate )
cCentury := Left( DToS( dInDate ), 4 )
// find number of days in first week of year
nFirstDays := 8 - DOW( SToD( cCentury + "0101" ) )
nWkNumber := 1
// find how many days after first week till dInDate
nDayOffset := ( dInDate - SToD( cCentury + "0101" ) ) - nFirstDays + 1
// count weeks in offset period
DO WHILE nDayOffset > 0
++nWkNumber
nDayOffset -= 7