Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : SNDVIS.ZIP
Filename : DEMO.PRG

 
Output of file : DEMO.PRG contained in archive : SNDVIS.ZIP
/*
* PROGRAMM ... : Demo.prg
* AUTHOR ..... : Tom Groeger
* TRANSLATION : Max Bressel
* DATE ....... : 09/26/93
* PURPOSE .... : Sound & Vision demonstration
*
* compile CLIPPER DEMO /m /n
* link BLINKER FI Demo, Errorsys, Getsys LIB SoundVis
* or RTLINK FI Demo, Errorsys, Getsys LIB SoundVis
*
* ATTENTION!
* SetPref() only available in registered version !
*
*/


// INCLUDES
// --------
#include 'INKEY.CH'
#include 'SET.CH'
#include "SOUNDVIS.CH"

// color definition
// ----------------
#define F_NHB 48 // black on light blue
#define F_NW 112 // black on white
#define F_RW 116 // black on red
#define F_WBROWN 191 // light white on brown (transfered)
#define F_NBEIGE 208 // black on beige (transfered)

// menu definitions
// -----------------
#define M_POINTSTAT 12
#define M_POINTLIST 13
#define M_MEMORY 40
#define M_VGASET 41
#define M_SIGN 42
#define M_SOUND 44
#define M_FM 45
#define M_SBINIT 46
#define M_RECVOC 47
#define M_CDROM 48
#define M_SETMODE 49
#define M_HBUTTON 50
#define M_VBUTTON 51
#define M_LISTE 52
#define M_CRC 53
#define M_OUTLINE 54
#define M_QUEST 55
#define M_ALERT 56
#define M_FILE 75
#define M_HELP 200

#define STD_INFO 'N/*RB,N/W,,,R/*RB'



PROCEDURE Main

// save DOS screen
LOCAL TestScr := ScrSave(0,0,24,79)

// break flag
LOCAL lExit := .f.

// codeblock for end or programm
LOCAL bExit := {||lExit := .t.}

// MouseArray, Pos 1,2 to 1,3 will end the program
LOCAL aMaus := {{1, 2, 3, bExit}}

// WorkVars..
LOCAL nKey, cCrc32, nX
LOCAL c2Screen, cChr, nZeile, nSpalte

LOCAL cMessage, aButton := {'~OK','watch ~again ??'}

LOCAL xDummy1, xDummy2, xDummy3, xDummy4, aText, oScroll

// presetting CheckPrompt
LOCAL lSound := .t.

// block for CheckPrompt, lSound PER REFERENCE!!
LOCAL bSetSound := {|lModus|SetSound(@lSound, lModus)}


//building the menu arrays
// --------------------------

LOCAL aDatei := { ;
{'~Horizont. Buttons' , M_HBUTTON, .T. ,'Window with ButtonChoice'},;
{'~Vertical Buttons' , M_VBUTTON, .T. ,'Window with ButtonBar'},;
{A_SEP},;
{'~Listings-Demo' , M_LISTE, .T. ,'Browse with 3D effects and buttons.'},;
{'~OutLine-Demo' , M_OUTLINE, .T. ,'GETs with frames...'},;
{'~CRC calculation' , M_CRC, .T. ,'CRC32-Checksum of a file'},;
{A_SEP},;
{'~Question-Box' , M_QUEST, .T. ,'any questions ?'},;
{'~AlertBox' , M_ALERT, .T. ,"alarm.. hey what's going on..."},;
{'~FileBox' , M_FILE, .T. ,'filebox, use your mouse '},;
{A_SEP},;
{'~End of Demo' , B_QUIT, .T. ,"...outta here ?!", 'ALT-F4' } }


LOCAL aSubSubPt :={ ;
{'~shoot him', 111, .T. , 'oh no, too loud'},;
{'~hang him', 112, .T. , 'not loud enough'},;
{'~drown him', 113, .T. , 'hmmm...too ~good for him'},;
{'~slain him', 114, .T. , "yeah... ~that's it!"} }


LOCAL aSubPoint :={ ;
{'~add new Points', 101 , .T. ,'gee, another one ?'},;
{'~change Points', 102 , .T. ,"are you sure ? :-)"},;
{'~delete Point', 103 , .T. ,'hum...why did he leave ?'},;
{A_SEP},;
{'~get rid of Point ', aSubSubpt, .T.,'ultima ratio..',''} }


LOCAL aPoint :={ ;
{'~Fees', M_POINTSTAT,.T.,'payments, ~contributions'},;
{'~Pointlist', M_POINTLIST,.F.,'list of all my points'},;
{A_SEP},;
{'~Database of points',aSubPoint, .T.,'what will we do with them ?','' } }


LOCAL aSystem :={ ;
{'~Memory information' , M_MEMORY, .T. ,'what fits ?'},;
{'C~olor change' , M_VGASET, .T. ,'feel like Picasso'},;
{'~ASCII-characters' , M_SIGN, .T. ,'wow...'},;
{A_SEP},;
{'Soundblaster ~Init', M_SBINIT, .T., 'Change Portadress and IRQ'},;
{'Sound~blaster VOC' , M_SOUND, .T., 'do you have one ?'},;
{'S~oundblaster FM' , M_FM, .T., 'do you have one ?'},;
{'turn on the Soun~d' , bSetSound, .T., 'toggle Sound '},;
{A_SEP},;
{'~CD-Player', M_CDROM, .T., 'May the Sound be with you'},;
{'~burn in serial numbers',M_SETMODE,.F., 'yes, will be part of the next release !'}}



LOCAL aMain :={ ;
{'~Window' , aDatei, .T., 'Window and Button demo'},;
{'~PopUps' , aPoint, .T., 'nested PopUp Menu'},;
{'Sys & ~Sound' , aSystem, .T., "let's boot your computer "},;
{'~Help' , M_HELP, .T., 'I think I can help', 36 } }


// Settings
// --------
SET(_SET_CURSOR,0)
SET(_SET_DECIMALS,2)
SET(_SET_WRAP,.t.)
SET(_SET_SCOREBOARD,.f.)
SET(_SET_DELIMITERS,.f.)
SET DATE german
SETBLINK(.f.)

// mask- and Menu color
// ----------------------
SetDAC (C_RB,25,17,23) // magenta will be brown/red
SetDAC (C_RG, 41, 31, 24) // brown will be somewhat darker
SetDAC (C_HW,55,55,55) // light white will be somewhat lighter
SetDac (C_HBG, 34, 18, 26) // light blue will be red-brown
SetDac (C_HRB, 42, 41, 36) // light magenta will be pus-yellow
SetDac (C_HRG, 63, 54, 21) // Yellow a little darker


// here we go ...
// --------------
PlayVoc ( 'hal.voc')


SETCOLOR('RG+/RG') // background
CLS

SetPref ( C_POPCOL, 240 ) // windows/text black on white
SetPref ( C_POPKEY, 244 ) // Hotkeys red on light blue
SetPref ( C_POPPASSIV, 248 ) // non chooseable point, grey on white
SetPref ( C_POPSHORT, 244 ) // ShortCut blue on light white

SetPref ( C_BOXHEADER, 31 ) // heading of the Alertboxes

SetPref ( C_DESCROW, 22 ) // row for description
SetPref ( C_DESCCOL, 5 ) // column for descripton
SetPref ( C_DESCEND, 75 ) // endcolumn
SetPref ( C_GRAFBUTTON, 1 ) // graphic button


// set mouse on position 13,39 and show
//---------------------------------------
Mse_Set ( 13,39, .f.)



// does the nice window
// ---------------------
OPENWIN FROM 1,2 TO 23,77 ;
TITLE 'SOUND & VISION demonstration' ;
TYP WIN_FULL


// color for inside window
// ------------------------
ColorMe ( 4, 4, 20, 73, 94)

SETKEY(K_ALT_F4, bExit) // ALT-F4 ends the demo


// PROGRAM
// -------

DO WHILE nKey # B_QUIT

// call menu
nKey := BarMen (2,4,1,,aMain, aMaus)




DO CASE

// ========================
// horizontal ButtonDemo
// ========================
CASE nKey == M_HBUTTON


DO WHILE .t.
nKey := AlertBox(2,'DEMO.EXE Vers. 1.4 å 1993 Tom Groeger;'+;
'choose via cursor, mouse;'+;
'or character', aButton)

IF nKey = M_CLOSE
Describe('CloseIcon')

ELSEIF nKey = M_MOVE
Describe('MoveIcon')

ELSEIF nKey = M_CHOICE
Describe('ChoiceIcon')

ENDIF

IF nKey == 1 .OR. nKey == K_ESC
Exit
ENDIF

ENDDO


// ======================
// Vertical ButtonDemo
// ======================
CASE nKey == M_VBUTTON

OPENWIN FROM 6,25 TO 18,55 ;
TITLE 'vertical button ' ;
TOPCOLOR F_WBROWN ;
WINCOLOR F_NBEIGE ;
TYP WIN_MESSAGE ;
SAVE TO c2Screen

ShowStr ( 11, 27, 'which drive')
ShowStr ( 12, 27, 'should be')
ShowStr ( 13, 27, 'formatted?')

xDummy1 := 3
@ 8,46 GET xDummy1 AS PUSHBUTTON ;
{' ~A: ',' ~B: ',' ~C: ',' ~D: ','~Exit'} ;
COLOR F_NW HOTKEY F_RW ;
VERTIKAL

READ
ScrRest ( c2Screen )


// ==================
// list-browsing demo
// ==================
CASE nKey == M_LISTE


// make TestArray
aText := {'Al Bundy 452324 1022.50',;
'Mr.Fabulous 2 -55721 561.80',;
'Billy Wilder 23/4530 51022.00',;
'El Diabolo i-448 45.60',;
'Luciano Pavarotti 275679 532.10',;
'Margret Thatcher 75424 32423.67',;
'Toni Curtis 2435654 34.50',;
'Stan Laurel 345 4522.20',;
'Mark Lussier 32527 911.20',;
'Bruce Wayne 1-3/93 1723.20' }



// Window
// --------------
OPENWIN FROM 2,10 TO 22,68 ;
TITLE 'Hall of Fame';
TOPCOLOR F_WBROWN ;
WINCOLOR F_NBEIGE ;
TYP WIN_LIST ;
SAVE TO c2Screen

// create ScrollBar
oScroll := ScrollNew ( 3, 67, 21, .f., 1 )
oHScroll := ScrollNew ( 22, 10, 65, .t., 12 )


// Frame ListArea
OutFrame ( 6, 12, 15, 64, 2)


// with SetPref ( C_BUTTLOWER, 208 ) the outline-boarder
// would be drawn as a double line (asc208)

xDummy1 := SetPref( C_BUTTLOWER, 208 )

OutLine ( 4, 15, 'GOODS', 1, F_NW , .t.)
OutLine ( 4, 34, 'INVOICE No.', 1, F_NW )
OutLine ( 4, 52, 'AMOUNT', 1, F_NW )

SetPref ( C_BUTTLOWER, xDummy1 )

ShowStr( 21, 14, 'Sum of Invoices')

// redirect ScrollKeys
SETKEY(K_DOWN, {||ScrollIt ( K_DOWN, aText, @oScroll)})
SETKEY(K_UP, {||ScrollIt ( K_UP, aText, @oScroll)})
SETKEY(K_HOME, {||ScrollIt ( K_HOME, aText, @oScroll)})
SETKEY(K_END, {||ScrollIt ( K_END, aText, @oScroll )})


// Draw Buttons and choose
// -----------------------
nChoice := K_HOME
nPos := 1


DO WHILE nChoice # 0 .AND. nChoice # 4 .AND. nChoice # K_ESC

oScroll := ScrollIt ( nChoice, aText, oScroll )
nChoice := 1

@ 18, 13 GET nChoice ;
AS PUSHBUTTON ;
{ '~book','~print','~delete','~abort' } ;
COLOR F_NW ;
HOTKEY F_RW

READ

DO CASE

// test horizontal ScrollBar
CASE nChoice == M_LEFT
oHScroll := ScrollPos ( oHScroll,;
GetScrollPos ( oHScroll )-1)

CASE nChoice == M_RIGHT
oHScroll := ScrollPos ( oHScroll,;
GetScrollPos ( oHScroll )+1)

// test ListBox
CASE nChoice == 1
ChoseBox ( 4, 25, 10,, aText )

ENDCASE

ENDDO


// release KeyTraps
// -----------------------
SETKEY(K_DOWN, NIL )
SETKEY(K_UP, NIL )
SETKEY(K_HOME, NIL )
SETKEY(K_END, NIL )


// restaore Screen
ScrRest ( c2Screen )



// ==============
// OutLine - Demo
// ==============
CASE nKey == M_OUTLINE

// some dummys
xDummy1 := 'Focke Wulff'
xDummy2 := '190-D9 '
xDummy3 := CTOD('12.10.44')
xDummy4 := 1250

OPENWIN from 8,22 to 18,55 title 'Airplane' ;
topcolor F_WBROWN wincolor F_NBEIGE ;
typ WIN_MESSAGE ;
save to c2Screen

SETCOLOR ( STD_INFO )
SETCURSOR ( 1 )

@ 10, 26 SAY 'Manufacturer'
@ 12, 26 SAY 'Type'
@ 14, 26 SAY 'First flight'
@ 16, 26 SAY 'Produced'

// READ as a 'boardered' get
// -------------------------
@ 10, 40 GET xDummy1 AS FRAME IN F_NW,F_NBEIGE ;
LISTBOX { 'Focke Wulff', ;
'Messerschm.', ;
'Arado', ;
'Heinkel', ;
'Junkers '}
@ 12, 43 GET xDummy2 AS FRAME IN F_NW,F_NBEIGE
@ 14, 43 GET xDummy3 AS FRAME IN F_NW,F_NBEIGE
@ 16, 42 GET xDummy4 AS FRAME IN F_NW,F_NBEIGE PICT '999999.99'
READ

SETCURSOR ( 0 )
ScrRest ( c2Screen )

// ===========
// Crc-Demo
// ===========
CASE nKey == M_CRC
xDummy1 := DirManager ('','*.*')

IF LEN(xDummy1) > 0

c2Screen := OpenMask ( 8, 10, 16, 70,;
'CRC-Check', 51, F_WBROWN, F_NBEIGE)

SETCOLOR( 'N/*RB,N/W,,,R/*RB' )

// switch mouse cursor to a sandglass
Mse_Wait ( .t. )
Mse_Set ( 14, 45, .t.)

// calculate Crc-Sum
xDummy2 := GetCrc32 ( xDummy1 )

// Reset Mouse
Mse_Wait (.f.)
Mse_Show(.f.)

// Show CRC
ShowStr ( 12, 17, SPACE( 52) )
ShowStr ( 11, 17, 'CRC-Sum of '+ xDummy1 +' is', F_NBEIGE)
ShowStr ( 12, 35, xDummy2 , 222 )

// Ok ?
xDummy := 1
@ 14, 34 GET xDummy AS PUSHBUTTON {' ~OK '} ;
COLOR F_NW HOTKEY F_RW ;
TIMEOUT 5

READ

ScrRest ( c2Screen )

ENDIF


// =============
// QuestionBox
// =============
CASE nKey == M_QUEST
xDummy1 := SetPref( C_BOXHEADER, F_NW )

AlertBox(0,'Are you going to registrate for;'+;
' SOUND & VISION ?',;
{'~Sure,', "~I'll do it", '~tomorrow...'})

SetPref( C_BOXHEADER, xDummy1 )


// ==========
// Alert Box
// ==========
CASE nKey == M_ALERT
xDummy1 := SetPref( C_BOXHEADER, F_NW )

AlertBox(1,'do you really want to format ;'+;
'drive C: ?',;
{'~Yeah, sure', 'oh no, better ~not'})

SetPref( C_BOXHEADER, xDummy1 )



// ======
// FEES
// ======
CASE nKey == M_POINTSTAT

OPENWIN FROM 06, 20 TO 21, 60 ;
TITLE "Cheaper than you'd think....." ;
TOPCOLOR F_WBROWN ;
WINCOLOR F_NBEIGE ;
TYP WIN_MESSAGE ;
SAVE TO c2Screen

ShowStr ( 08, 26, 'Copyright å Tom Groeger 1993', 212 )
ShowStr ( 10, 32, 'Distributed by:')
ShowStr ( 11, 33, 'SOFTSOL GmbH', 212 )
ShowStr ( 12, 31, 'Neue Strasse 35a')
ShowStr ( 13, 29, '21073 HAMBURG/Germany')
ShowStr ( 14, 30, 'Tel:+49-40-7661290')
ShowStr ( 15, 30, 'Fax:+49-40-7665664')
ShowStr ( 16, 30, 'BBS:+49-40-7665527')
ShowStr ( 17, 30, 'CIS: 100112,3401')

xDummy := 1
@ 19, 34 GET xDummy AS PUSHBUTTON {' ~OK '} ;
COLOR F_NW HOTKEY F_RW ;
TIMEOUT 20
READ

ScrRest ( c2Screen )

// =============
// SOUNDBLASTER
// =============
CASE nKey == M_FM

aPiano := { 1, 17, 77, 0, 241, 210, 96, 123, 00, 00, 08 }
aString := { 113, 161, 139, 64, 113, 66, 17, 21, 00, 00, 06 }


FM_Instr (1, aPiano)
FM_Instr (2, aPiano )
FM_Instr (3, aString )
FM_Instr (4, aString )

nx = 1
do while nx < 13

FM_KeyOn ( 1, nx , 2)
FM_KeyOn ( 2, nx , 4)
FM_KeyOn ( 3, 13-nx , 2 )
FM_KeyOn ( 4, 13-nx++, 4 )

FM_Delay (9)

enddo
FM_KeyOff ( 1 )
FM_KeyOff ( 2 )
FM_KeyOff ( 3 )
FM_KeyOff ( 4 )


CASE nKey == M_SOUND
xTemp1 := DirManager ('','*.voc')

IF LEN(xTemp1) > 0
PlayVoc ( xTemp1 )
ENDIF



CASE nKey == M_SBINIT
// Soundblaster Init

xDummy1 := 7
xDummy2 := 220

PlayStop()

OPENWIN from 9,22 to 17,55 title 'Soundblaster' ;
topcolor F_WBROWN wincolor F_NBEIGE ;
typ WIN_MESSAGE ;
save to c2Screen

SETCOLOR ( STD_INFO )
SETCURSOR ( 1 )

@ 12, 26 SAY 'IRQ-Number'
@ 14, 26 SAY 'Portadress'

DO WHILE .t.

// a 'framed' Get
// --------------
@ 12, 41 GET xDummy1 AS FRAME IN F_NW,F_NBEIGE PICT '99'
@ 14, 40 GET xDummy2 AS FRAME IN F_NW,F_NBEIGE PICT '999'
READ

IF ! SbInit ( xDummy1, xDummy2 )
IF AlertBox (1,;
'Something seems to be wrong ... Valid Inputs are ;'+;
'IRQ 2/5/7/10 and Port 220/240/260',;
{ '~Retry', '~Cancel' } ) == 2
EXIT
ENDIF

ELSE
EXIT

ENDIF

ENDDO
SETCURSOR ( 0 )
ScrRest ( c2Screen )

// =============
// File-Manager
// =============
CASE nKey == M_FILE
Dirmanager('','*.*')


// ============
// CD-ROM
// ============
CASE nKey == M_CDROM
CdPlayer()

// ================
// character table
// ================
CASE nKey == M_SIGN
nX := 1
xDummy1 := ScrSave(4,4,20,73)

FOR nRow := 1 TO 15
FOR nColumn := 1 TO 51 STEP 3
IF nX >= 213 .AND. nX <= 217
nX++
ELSE
ShowStr (nRow+4, nColumn+14, CHR( nX++))
ENDIF
NEXT
NEXT

MSE_Show (.t.)
INKEY(0)
MSE_Show (.f.)

ScrRest ( xDummy1 )


// ============
// SystemInfo
// ============
CASE nKey == M_MEMORY
ShowMem()


// ==============
// Change colors
// ==============
CASE nKey == M_VGASET
VgaMenu()

CASE nKey == M_HELP

ShowStr(12,35,'RTFM !')
INKEY(1)
ShowStr(12,35,' ')


// ===============
// Finito l'amore
// ===============
CASE nKey == K_ESC .OR. lExit

// Now we want show our impressions on SOUND & VISION
PlayVoc("Cheer.voc")


nKey := 'Y'
SETCURSOR(1)
Describe ('Programm ~abort ? ')

SETCOLOR(',N/*W')
@ 22,27 Get nKey PICT '!'
READ

IF 'Y' $ nKey
nKey := B_QUIT
ELSE
nKey := 0
lExit := .f.

ENDIF

SETCURSOR(0)


ENDCASE

ENDDO


// brutal method
// ---------------
PlayStop()

// turn mouse off
// ---------------
Mse_Show(.f.)
Mse_Exit()

// restoring
// -----------
SETCOLOR('W/N')
ScrRest(TestScr)
@ 23,0 SAY 'Thanks for trying SOUND & VISION'

// byebye
// -------
QUIT




/**************************************************
*
* INIT PROCEDURE ClipInit ()
*
* !! CAUTION !! ClipInit replaces the Clipper-function ClipInit,
* which sets the default Errorhandler and initializes the public
* GetList-Array.
* But we don't want no PUBLIC Getlist{} ( or do you ? ),
* we want it LOCAL where we need it, and therefore we replace this
* function with our own. If this is to Internal for you, please feel
* free to give this INIT PROC another name ( and then don't call
* ERRORSYS()
*
* We need this INIT PROCEDURE to initialize our Sound& Vision BEFORE
* any other Code will be executed !
*/

INIT PROCEDURE ClipInit()
LOCAL nMouse, nFont, lSound
LOCAL cMessage, aButton := {'~OK','~QUIT'}

// initialize Errorsys
ErrorSys()

// install MausEventDriver
nMouse := Mse_Init()

// load Font
lFont := SET_FONT('SVFont.016')

// Soundblaster INIT
lSound := SbInit( 7, 220)


// OK ?
IF nMouse # 0
cMessage := 'Error during Mouse Installation !'

DO CASE
CASE nMouse == 1
cMessage := cMessage - ';StoneAge Cpu < 80286'
QUIT

CASE nMouse == 2
cMessage := cMessage - ';No Vga/Ega-Adapter'

CASE nMouse == 3
cMessage := cMessage - ';Hey, no MouseDriver !'

ENDCASE


IF AlertBox(1,cMessage,aButton) == 2
QUIT
ENDIF


ENDIF

IF ! lFont
IF AlertBox(1,'Font could not be installed !',aButton) == 2
QUIT
ENDIF

ENDIF

IF ! lSound
IF AlertBox(1,'Soundcard could not be initialized !'+;
'please set IRQ/Port',aButton) == 2
QUIT
ENDIF

ENDIF

RETURN



/**************************************************
*
* FUNCTION ScrollIt( nKey, aText, oScroll ) -> oScroll
*
* Demo of a function called via SetKey.
* This function is passed via CodeBlock and scrolls the data
* in a BrowseWindow up and down.
* Function is called via SETKEY or by the GET AS A PUSHBUTTON
* PARAMETER : nGrab : key pressed
* aText : Array containing test-data
* oScroll: ScrollBarObject
*/
FUNCTION ScrollIt ( nKey, aText, oScroll )

LOCAL nX, nIndex
LOCAL nMaxLen := LEN ( aText )
LOCAL nTop := GetScrollTop(oScroll)
LOCAL nBot := GetScrollEnd(oScroll)
LOCAL nPos := GetScrollPos(oScroll)



DO CASE
CASE nKey == K_UP .OR. nKey == M_UP
oScroll := ScrollPos ( oScroll, --nPos )

CASE nKey == K_DOWN .OR. nKey == M_DOWN
oScroll := ScrollPos ( oScroll, ++nPos )

CASE nKey == K_HOME
oScroll := ScrollTop(oScroll)

CASE nKey == K_END
oScroll := ScrollBottom(oScroll)


ENDCASE


// Show Array
// --------------
FOR nX := 1 TO nMaxLen

// Change row-colors White/Lightblue
ColorMe ( nX+5, 12, nX+5, 64, IIF (nX % 2 == 0, F_NHB, F_NW ))

// show ArrayPosition
ShowStr ( nX+5, 17, aText [nX])


NEXT

nPos := GetScrollPos ( oScroll )+2
c_ColMen( MIN( MAX(nPos, nTop+3),nTop+12), 12, 64, 2)


RETURN ( oScroll )



**************************************************
*
* FUNCTION SetSound( lSound , lMode ) -> lSound
*
* Demonstrates a function called via CheckPrompt.
* This function is passed via CodeBlock, it inverts
* VAR lSound, which is also passed via the CodeBlock
* (PER REFERENCE). Returns the new value.
*
* PARAMETER : lSound is a logVar for Sound on/off
* lMode .F.= read only lSound and return it
* .T.= invert lSound and return it
*

FUNCTION SetSound( lSound , lMode )

IF lMode
lSound := ! lSound

// check if you're already playing a VOC-File and turn it off
IF ! lSound
PlayStop ()
ENDIF

ENDIF

RETURN (lSound)





/**********************************************************
*
* Function ShowMem () -> NIL
* Demofunction how to use IsCpu() and IsVideo(),
* shows you all memory() return values, some of them
* are undocumented by Clipper
*/

FUNCTION ShowMem()

LOCAL nCur := Setcursor(0)
LOCAL cCol := SETCOLOR( '+GR/*RB')
LOCAL xDummy
LOCAL cScreen

OPENWIN FROM 3,15 TO 21,65 ;
TITLE 'System-Info' ;
TYP WIN_MESSAGE ;
TOPCOLOR F_WBROWN ;
WINCOLOR F_NBEIGE ;
SAVE TO cScreen



// Scavenge
// --------
MEMORY(-1)

// descriptions
// -------------
ShowStr ( 06, 20, 'CPU')
ShowStr ( 07, 20, 'Video Adapter')
ShowStr ( 09, 20, 'Conventional Memory KByte' ) //Memory(0)
ShowStr ( 10, 20, 'Free Swap-Memory KByte' ) //Mem(0)+MEM(103)
ShowStr ( 11, 20, 'Largest StringObject KByte' ) //Memory(1)
ShowStr ( 12, 20, 'Free Run-Memory KByte' ) //Memory(2)
ShowStr ( 13, 20, 'String/Array Memory KByte' ) //Mem(3)
ShowStr ( 14, 20, 'Available EMS-Memory KByte' ) //Mem(4)+(105)
ShowStr ( 15, 20, 'Locked Heap-Segments KByte' ) //Mem(101)
ShowStr ( 16, 20, 'Segments in Heap' ) //102
ShowStr ( 17, 20, 'Unused Conv. Memory KByte' ) //Mem(104)

// show memory() returns
// ----------------------
@ 06,53 SAY IsCpu ( .t.)
@ 07,49 SAY IsVideo(.t.)

@ 09,53 SAY MEMORY(0) PICT '99999'
@ 10,53 SAY MEMORY(0)+MEMORY(103) PICT '99999'
@ 11,53 SAY MEMORY(1) PICT '99999'
@ 12,53 SAY MEMORY(2) PICT '99999'
@ 13,53 SAY MEMORY(3) PICT '99999'

@ 14,53 SAY MEMORY(4)+MEMORY(105) PICT '99999'
@ 15,53 SAY MEMORY(101) PICT '99999'
@ 16,53 SAY MEMORY(102) PICT '99999'
@ 17,53 SAY MEMORY(104) PICT '99999'

// draw button
// -------------
xDummy := 1
@ 19, 34 GET xDummy AS PUSHBUTTON {' ~OK '} ;
COLOR F_NW HOTKEY F_RW
READ

SETCOLOR(cCol)
SETCURSOR(nCur)
ScrRest(cScreen)

RETURN( NIL )


/**********************************************************
*
* Function VgaMenu () -> NIL
* Demo using WrapWert(), SetDac() and a_Red(), a_Blue(), a_Green(),
* with the help of these functions you can read the Vga-Palette and
* change it. It's also a good example on 'how to add a mouse'.
*/

FUNCTION VgaMenu()

// Coordinates
LOCAL nTRow := 7, nLCol := 1

// Array for the 3 main colors
LOCAL aColorCon := { a_Red(0), a_Green(0), a_Blue(0) }

// Control and UpdateFlags
LOCAL lNewCon := .f., lNewColorCon := .f., lNewDAC := .f.

// WorkVars
LOCAL nPalette := 0, nControl := 1
LOCAL xTemp, nX, nKey, cScreen

// MousePosition and first ControlRow
LOCAL nMouseRow, nMouseCol, nConRow

// declare ColorSave-Array
LOCAL aOrgColor [ 16, 3], nOrgButt

// turn of Cursor and Mouse
LOCAL nCursor := SETCURSOR(0), lMouse := Mse_Show (.F.)

// save original values
FOR nX := 0 TO 15
aOrgColor [nX+1] := { a_Red(nX), a_Green(nX), a_Blue(nX) }
NEXT

// Here comes the surrounding 'move-loop'
// --------------------------------------
DO WHILE nKey # K_ESC


// build screen
// --------------
OPENWIN FROM nTRow, nLCol TO nTRow+11, nLCol+75 ;
TITLE 'ColorSet' ;
TYP WIN_MESSAGE ;
TOPCOLOR F_WBROWN ;
WINCOLOR F_NBEIGE ;
SAVE TO cScreen


// Calculate first ControlRow
nConRow := nTRow+4


// draw ColorFields
// -----------------
FOR nX := 0 TO 15
OutLine ( nTRow+2, nLCol+7+( nX*4 ), ' ', 1, (nX+1)*15 )

NEXT


// 1.Controller is activ (pushed)
// --------------------------------------------
OutLine ( nTRow+4, nLCol+2, 'R', 2)
OutLine ( nTRow+6, nLCol+2, 'G', 1)
OutLine ( nTRow+8, nLCol+2, 'B', 1)


// draw field
// ------------
ShowStr ( 10, 3, 'Color:',, .t. )
ShowStr ( 10, 44, 'F3',, .t. )
ShowStr ( 10, 56, 'F4',, .t. )

nOrgButt := SetPref (C_BUTTLOWER, 208 )
OutLine ( nTRow+10, nLCol+47, 'Reset', 1, F_NW )
OutLine ( nTRow+10, nLCol+59, 'Reset all', 1, F_NW )

OutLine ( nTRow+10, nLCol+11, STR( nPalette, 3), 1, F_NW )
OutLine ( nTRow+10, nLCol+18, SPACE(22), 1, 15 )

SetPref (C_BUTTLOWER, nOrgButt )


// ============
// Input-Loop
// ------------
DO WHILE .t.



// Draw Control-line and Values
// -----------------------------
FOR nX := 1 TO 3
// Calculate Row
xTemp := nTRow+2+( nX * 2)

// Draw Control-line ( akctive Control-line light white)
HLinie ( xTemp, nLCol+6, nLCol+70,;
IIF ( nControl == nX, 240, F_NW), A_HORIZONT )

ShowStr ( xTemp, nLCol+6+ aColorCon [nX], '')
ShowStr ( xTemp, nLCol+71, STR( aColorCon [nX], 2) )

NEXT

// draw description
// -----------------
ShowStr ( 10, 12, STR( nPalette, 3),, .t.)
ShowStr ( 10, 18, SPACE(24), nPalette * 16, .t. )

// Wait for the user to do something
// ----------------------------------
Mse_Show (.t.)
nKey := INKEY(0)
Mse_Show (.f.)

// =====================
// get key
// mousebutton pushed ?
// ---------------------
IF nKey == K_MOUSE

// get Position
nMouseRow := Mse_Row()
nMouseCol := Mse_Col()


DO CASE

// Mouse on Icon ?
// ---------------
CASE ( nX := oMouseWin ()) # 0
IF nX == M_CLOSE
nKey := K_ESC

ELSEIF nX == M_MOVE
nTRow := IIF ( nTRow == 0, 7, 0)
nLCol := IIF ( nLCol == 0, 1, 0)
EXIT

ENDIF


// Mouse on ColorField ?
// ----------------------
CASE Mse_Check ( 2, 7,, 70, .t. )

// on which one, please ?
FOR nX := 1 TO 16

// I see.. get ColorValues
IF nMouseCol < nLCol+7+( nX * 4 )
nPalette := --nX
aColorCon := { a_red ( nPalette ),;
a_green( nPalette ),;
a_blue (nPalette ) }
EXIT
ENDIF
NEXT


// Maus on RED ?
// --------------
CASE Mse_Check ( 4, 5,, 70, .t. )
nControl := 1
lNewCon := lNewDAC := .t.
aColorCon[ nControl ] := nMouseCol - (nLCol+6)


// hum, maybe on GREEN ?
// ---------------------
CASE Mse_Check ( 6, 5,, 70, .t. )
nControl := 2
lNewCon := lNewDAC := .t.
aColorCon[ nControl ] := nMouseCol - (nLCol+6)


// or BLUE
// --------
CASE Mse_Check ( 8, 5,, 70, .t. )
nControl := 3
lNewCon := lNewDAC := .t.
aColorCon[ nControl ] := nMouseCol - (nLCol+6)


// Reset Color ?
// -------------
CASE Mse_Check ( 10, 47,, 51, .t. )
nKey := K_F3


// Reset all Colors ?
// ------------------
CASE Mse_Check ( 10, 59,, 66, .t. )
nKey := K_F4

ENDCASE
ENDIF


// Now for 'normal' KeyCodes
// --------------------------
DO CASE


// Increase or Decrease ColorIntensity ?
// --------------------------------------
CASE nKey == K_LEFT .OR. nKey == K_RIGHT
aColorCon[nControl] := ;
WrapWert ( nKey == K_RIGHT, aColorCon[nControl], 0, 63 )
lNewDAC := .t.


// Beginning or End of Control-line ?
// -----------------------------------
CASE nKey == K_HOME .OR. nKey == K_END
aColorCon[nControl] := IIF( nKey == K_HOME, 0, 63 )
lNewDAC := .t.


// Up or Down, change MainColor
// -----------------------------
CASE nKey == K_UP .OR. nKey == K_DOWN
// get new ColorNo
nControl := WrapWert( nKey == K_DOWN, nControl, 1, 3)
lNewCon := .t.


// Next Palette
// -------------
CASE nKey == K_PGDN .OR. nKey == K_PGUP
nPalette := WrapWert( nKey == K_PGUP, nPalette, 0, 15)
aColorCon := { a_red (nPalette),;
a_green(nPalette),;
a_blue (nPalette)}


// Restore all DAC-Registers
// --------------------------
CASE nKey == K_F4
FOR nX := 1 TO 16
SetDac ( nX-1, aOrgColor [ nX, 1],;
aOrgColor [ nX, 2],;
aOrgColor [ nX, 3] )
NEXT

lNewColorCon := .t.


// Restore active DAC-Register
// ----------------------------
CASE nKey == K_F3
lNewDAC := .t.
aColorCon := { aOrgColor [ nPalette+1, 1],;
aOrgColor [ nPalette+1, 2],;
aOrgColor [ nPalette+1, 3] }

// Done ?
// -------
CASE nKey == K_ESC
EXIT


ENDCASE



// Set new ColorControl ?
// =======================
IF lNewCon

// Flag reset
lNewCon := .f.

// deactivate old ColorControl
OutFrame ( nConRow, nLCol+2, nConRow, nLCol+4, 1)

// calculate new row
nConRow := nTRow+2+( 2*nControl )

// 'push' the right ColorButton
OutFrame( nConRow, nLCol+2, nConRow, nLCol+4, 2)

ENDIF


// Read new ColorRegister ?
// =========================
IF lNewColorCon

// Flag reset
lNewColorCon := .f.

// Read ColorRegister and save to array
aColorCon := { a_red (nPalette),;
a_green(nPalette),;
a_blue (nPalette)}
ENDIF

// DAC new ?
// ==========
IF lNewDAC
lNewDAC := .f.
SetDAC ( nPalette, aColorCon[1], aColorCon[2], aColorCon[3] )

ENDIF


ENDDO
ScrRest (cScreen)

ENDDO
Mse_Show(lmouse)


RETURN ( nil )



// ========================================================================
FUNCTION MemBrowse ( nTRow, nLCol, nBRow, nRCol, aArray , aMse, nStart )
// ========================================================================

LOCAL nY, nX , nChoice := 0

LOCAL nMaxLen := LEN( aArray )

LOCAL nKey, nScan, cScanKey := '', cOldKey := ' '

LOCAL nMseRow, nMseCol

LOCAL oBrowse := TBrowseNew ( nTRow, nLCol, nBRow, nRCol-1 )

LOCAL oScroll := ScrollNew ( nTRow, nRCol, nBRow, 0 )

DEFAULT nStart TO 1


// Install Skipper for Arraybrowser
// --------------------------------
oBrowse:Cargo := nStart
oBrowse:goTopBlock := { || oBrowse:Cargo := 1 }
oBrowse:goBottomBlock := { || oBrowse:Cargo := nMaxLen }
oBrowse:SkipBlock := { | nSoll, nIst |;
nIst := MIN( MAX( nSoll, -oBrowse:Cargo+1 ),;
nMaxLen-oBrowse:Cargo ),;
oBrowse:Cargo += nIst, nIst }


// Add Column
// ----------
oBrowse:AddColumn( TbColumnNew( , { || ' '+aArray [ oBrowse:Cargo ]+' '}))
oBrowse:GetColumn(1):width := nRCol+1-nLCol


DO WHILE .t.

// Stabilize
DO WHILE ! oBrowse:stabilize() .AND. (nKey := INKEY()) == 0 ; ENDDO

// Everythings stable ?
IF oBrowse:stable

// position ScrollPointer
oScroll := ScrollPos ( oScroll, nTRow+1+ROUND((oBrowse:Cargo-1) / ;
(nMaxLen-1) * (oBrowse:RowCount-3), 0 ))

Mse_Show(.t.)
nKey := INKEY(0)
Mse_Show(.f.)

ENDIF


// Mouseladies first
// -----------------
DO CASE
CASE nKey == K_MOUSE
nMseRow := MSE_Row()
nMseCol := MSE_Col()



// Valid Row ?
DO CASE
CASE Mse_Check ( nTRow, nLCol, nBRow, nRCol-1 )

// New CursorRow
nMseCol := ( nMseRow-nTRow)+1
oBrowse:RowPos := nMseCol
oBrowse:RefreshAll()

// stabilze obj ( update RowPos )
DO WHILE ! oBrowse:stabilize() ; ENDDO

// Exit, if MouseRow is valid
IF oBrowse:RowPos == nMseCol
nChoice := oBrowse:Cargo
EXIT
ENDIF

// Scrollbar ?
CASE ( nX := ScrollMse ( oScroll )) # 0

DO CASE
CASE nX == M_UP
oBrowse:up()

CASE nX == M_DOWN
oBrowse:down()

// First Scrollfield
CASE nX == 1
oBRowse:goTop()

// Last Scrollfield
CASE nX == ( nBRow - nTRow-1)
oBrowse:goBottom()

OTHERWISE
oBrowse:Cargo := ;
INT ((nMaxLen / (nBRow-nTrow - 1)) * nX )

oBrowse:RefreshAll()


ENDCASE

// CloseIcon ?
CASE oMouseWin() = M_CLOSE
nChoice := B_ESC
EXIT

// scan MouseArray
CASE VALTYPE( aMse ) = 'A'

nChoice := 0

FOR nX := 1 TO LEN ( aMse )

IF Mse_Check ( aMse[nX, MSE_TROW], ;
aMse[nX, MSE_LCOL], ;
aMse[nX, MSE_BROW], ;
aMse[nX, MSE_RCOL] )
nChoice := aMse[nX, MSE_RET]
EXIT

ENDIF

NEXT

IF nChoice # 0
EXIT

ENDIF

ENDCASE


CASE nKey == K_UP
oBrowse:up()

CASE nKey == K_DOWN
oBrowse:down()

CASE nKey == K_HOME
oBrowse:goTop()

CASE nKey == K_END
oBrowse:goBottom()

CASE nKey == K_PGUP
oBrowse:pageUp()

CASE nKey == K_PGDN
oBrowse:pageDown()

CASE nKey == K_ENTER
nChoice := oBrowse:Cargo
EXIT

CASE nKey == K_LEFT .OR. nKey == K_SH_TAB
nChoice := B_LEFT
EXIT

CASE nKey == K_RIGHT .OR. nKey == K_TAB
nChoice := B_RIGHT
EXIT

CASE nKey == K_ESC
nChoice := B_ESC
EXIT

CASE ISALPHA (CHR (nKey))

// new Try ?
IF (cScanKey := UPPER( CHR( nKey))) # cOldKey
cOldKey := cScanKey
nX := 1

ELSE
nX := oBrowse:Cargo + 1

ENDIF

// lets look it up ...
IF (nScan := ASCAN ( aArray,{|a|UPPER(a) = cScanKey }, nX )) > 0
oBrowse:Cargo := nScan
oBrowse:refreshAll()

ENDIF

ENDCASE

ENDDO

// delete PromptBar
oBrowse:deHiLite()

// delete ScrollPtr
ScrollPos ( oScroll, 0 )

RETURN ( nChoice )





// =========================================================
FUNCTION ChoseBox ( nTop, nLeft, nBottom, nRight, aArray, nStart )
// =========================================================
LOCAL nX := 1
LOCAL cColor := SETCOLOR ( 'N/W, +W/N')
LOCAL cScreen


// Default Parameters
DEFAULT nTop TO 10
DEFAULT nLeft TO 30
DEFAULT nBottom TO nTop+10


IF nRight == nil

// get the longest string
// ----------------------
AEVAL ( aArray, { | a | nX := MAX( nX, LEN(a)) } )
nRight := nLeft+nX+3

ENDIF

OPENWIN FROM nTop-1, nLeft-2 TO nBottom+1, nRight+1 ;
TOPCOLOR 112 ;
WINCOLOR 112 ;
TYP WIN_GSINGLE ;
SAVE TO cScreen


// Start browsing
nX := MemBrowse ( nTop, nLeft-1, nBottom, nRight , aArray,, nStart )


// CleanUp
ScrRest ( cScreen )
SetColor ( cColor )


RETURN ( nX )



// Youn should better link them with the other obj's, but for now it is
// easier to do it this way :

#include 'DIRBROWS.PRG'
#include 'CDPLAY.prg'


*********** EOF Demo.prg **********




  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : SNDVIS.ZIP
Filename : DEMO.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/