GFA 16 Code Snippets

Cut and Paste

These are cut and paste code examples. 
1.Just paste into the GFA 16 Editor and Run
The Back Button Will Return you to the Menu Area

A B C D E F G H I J K L M N O P Q R S T U V W X Y Z

GFA Basic 16 Cut And Paste Code Snippets

( A) Cut And Paste Code Snippets

Array Fill Array fill With A Value

Available Drives Available Drives On System

Arrow Keys Monitoring The Arrow Keys

( B) Cut And Paste Code Snippets

Bezier Curve Drawing A Bezier Curve

Bitmap Inflo All Bitmap Information

Bitmap Load Bitmap Loading And Displaying

Bitmap Load With User.dll Bitmap Loading And Displaying Using USER.DLL

Bitmap Rotate This Will Load and Rotate a Bitmap of Certain Sizes

Bload Bloading A Data File

Bmove Bmove a Block of Data

Browse Bowsing For a Folder

( C) Cut And Paste Code Snippets

Calling *.Hlp Calling A Programs Wnhelp .HLP File

CallBack Using A CallBack Routine

Call NotePad Calling NotePad Exe

CD Drive Finding The Lettter Of Your CD Drive

Change To Caps Capitalizing The The First Letter Of Each Word In A Strings

Change Cursor Changing A Programs Cursor To A Different Shape (GFA 16)

Change Dialog Changing a Dialogs Color

Chart Menu Charting A Menu

CHAR{} Using CHAR{}

Child Window Creating A Child Window -Hi Mommy

Choose Font Chooseing a New Font For Your Program

ClipBoard API Using The ClipBoard API

ClipBoard API2 Another Example Of Using The ClipBoard API

ClipBoard Copying To The ClipBoard

Copy Files Fast Copy BIG Files :Very Fast

Create BItmap Create A Compatible Bitmap (GFA)

Create Polygon Create A Polygon Region (GFA)

Create Pop Menu Create A PopUp Menu (GFA)

( D) Cut And Paste Code Snippets

Delete Element Deleting A Elemenet From A Array (GFA 16)

Dialog CallBack Usin A CallBack For A Dialog (GFA 16)

Dialog Font Changing Fonts In A Dialog Box (GFA 16)

Drive Type Displaying The Type Of Drives On A System

DRAWTEXT Using DRAWTEXT In (GFA 16)

Drive Ready Checking If A Drive Is Ready

Dupe Disk Duplicating A Floppy From GFA

( E) Cut And Paste Code Snippets

EditBox Fonts Changing Edit Box Fonts (GFA 16)

Edit Array Editing A String Array (GFA 16)

Enum Fonts Enumerate System Fonts (GFA 16)

Evaluate Key Evaluate Key (F1-F12) (GFA 16)

( F) Cut And Paste Code Snippets

FilesLast4 Inserting The Last Four FIles Accessed Into Your Menu

Fonts Using GetStockObject For System Fonts (GFA 16)

Fonts- Diagonal Displaying Diagonal Fonts (GFA 16)

Fonts- Mixed Displaying Diagonal Fonts (GFA 16)

Fonts- Shadowed Displaying Shadowed and Outlined Fonts(GFA 16)

Fonts- Sizes Displaying Font Information

Fonts- Selecting Selecting And Displaying Any Font (GFA 16)

Fonts- Setting Selecting A New Windows Font

Format Format A Floppy Disk-Full or Quick

Function Keys Reading The Function Keys

( G) Cut And Paste Code Snippets

G Data No G Data At Present (GFA 16)

( H) Cut And Paste Code Snippets

Huge Using _Huge To Copy Large Files (GFA 16) John Findlay

( I) Cut And Paste Code Snippets

Icon Dialog Putting Icons In A Dialog Box (GFA 16) by Eberhard Funck

INSTR Using The Instr Command (GFA 16)

( J) Cut And Paste Code Snippets

J Data No J Data At Present (GFA 16)

( K) Cut And Paste Code Snippets

Key Codes Displaying The Key Codes (GFA 16)

( L) Cut And Paste Code Snippets

L Data No L Data At Present (GFA 16)

( M) Cut And Paste Code Snippets

Free Memory Shows amount Of Free Memory

Menu Charting Check Marking Menu Items (GFA 16)

( N) Cut And Paste Code Snippets

N Data No Data

( O) Cut And Paste Code Snippets

O Data No O Data

( P) Cut And Paste Code Snippets

Play Meta Playing A Meta File From Disk

Progress Bar Making A Progress Bar (Roland Walter)

( Q) Cut And Paste Code Snippets

Qsort Using The Built In Qsort Command

( R) Cut And Paste Code Snippets

Random Access Random Access File Handling

Rectangle Drawing A Rectangle

RoundRect Drawing A Round RecTangle

Rectangle Text Using Textout To Put Text In A Rectangle

( S) Cut And Paste Code Snippets

Searching A Fast Binary Search Routine

Searching Multiple Searching For All Occurrences Of A Record With A Binary Search

Select Switch Using SELECT or SWITCH

Set Cursor Setting The Cursors Position

Set Font Setting The Height Of A Font

Set Text Setting The Alignment Of Text

Sound The SOUND Command

Sub Menu Adding A SubMenu To A Menu

( T) Cut And Paste Code Snippets

TextOut Using TextOut Instead Of PRINT To Display Text

TextOut2 Using TextOut With A Different Font

TrackPopUpMenu Using TrackPopUpMenu For A PopUp Menu

TRIM$ Using TRIM To Remove Spaces From Both Ends Of a String

Type Array Using a TYPE Array For Strings

( U) Cut And Paste Code Snippets

U Data No U Data At Present

( V) Cut And Paste Code Snippets

Variable Types Gfa Basic 16 Variable Types

( W) Cut And Paste Code Snippets

WINDGET Using WINDGET to Find A Windows Attributes

WINDGET2 Using WINDGET to Find A Windows Attributes by Alan Shura

Window Help Displaying A Windows .HLP File

Window Fonts Windows Fonts

( X) Cut And Paste Code Snippets

X Data No X Data At Present

( Y) Cut And Paste Code Snippets

Y Data No Y Data At Present

( Z) Cut And Paste Code Snippets

Zeropad Padding A String WIrh Zeros

ZTRIM$ Trimming Chr$(0) From A String With ZTRIM$

Array Fill
'Array Fill DIM A(20) OPENW #1 FULLW #1 ARRAYFILL A(),1 FOR I = 0 TO 20 PRINT A(I),"ENTRY ";I NEXT I KEYGET K% CLOSEW #1 EDIT

Available Drives
'Available Drives ' contributed by Tom Record '''' drives03.lst - testbed.lst - expanded from some Joe Hurst code TITLEW #1, " drives03.lst" OPENW #1, 150,50,308,390,48 ' ' // detect installed drives PRINT PRINT " I'll attempt to identify your drives." PRINT PRINT " Any <key> closes me." PRINT drivemap$ = "" driveplot$ = "" FOR t% = 1 TO 16 erg% = GetDriveType(t% - 1) IF erg% <> 0 AND erg% <> 1 THEN c% = c% + 1 drivemap$ = drivemap$ + CHR$(t% + 64) + ", " driveplot$ = " " + CHR$(t% + 64) + ": " @words() PRINT driveplot$ + t$ ENDIF NEXT t% drivemap$ = LEFT$(drivemap$, LEN(drivemap$) - 2) + " (" + STR$(c%) + " drives)" cdrom$ = "" ~INTR($2F,_AX = $1500,_BX = $0) IF _CL => 3 THEN cdrom$ = CHR$(_CL + 65) cdrom$ = RIGHT$(cdrom$,2) PRINT PRINT " " + drivemap$ PRINT " CD is: " + cdrom$ PRINT PRINT " Did I get'em right?" PRINT PRINT " Tiger.Genealogical.Rescue@worldnet.att.net" KEYGET k% CLOSEW #1 END PROCEDURE words() IF erg% = 2 THEN t$ = "floppy/removeable" IF erg% = 3 THEN t$ = "HD/fixed" IF erg% = 4 THEN t$ = "remote/network/CD" RETURN

Copy Large file
'=>>Copying Files Using Kernel.dll by Roland Walter '[ed] I copied a 1mb file with this in the blink of an eye. '�Roland Walter, Berlin Feb. 1999 'Just since Windows 3.1 there are some API functions for easy handling files ' bigger then 64KB, 'You simply have to use them. This example program copys a file wich can be 'so big if You have memory. ' 'If You want to make changes in a part of the memory block it is important not to forget 'we have to work with Segment+Offset addresses. The GFA Basic functions _HUGE can help 'to handle this problem relatively simple. FULLW #1 InFile$ = "c:\zips\gfawhelp.zip" 'source file wich is to copy (with each 'size if You have enough free memory) OutFile$ = "C:\zips\test\gfawhelp.zip" 'destination filename + path DLL #1,"kernel" 'declare functions not just declared in GFA Basic 4.38 DECL LONG hread(W,L,L) 'load files bigger then 64KB into memory (exists since Windows 3.1) DECL LONG hwrite(W,L,L) 'write files bigger then 64KB from memory (exists since Windows 3.1) /* neither of the 2 above wants an underscore ~_hread... or ~_hwrite... DECL BYTE hmemcpy(L,L,L) 'copy memory blocks bigger then 64KB (exists since Windows 3.1) /* works without the above... should it be in for some reason? ENDDLL hFile& = _lopen(InFile$,OF_READ) 'The file can be so big as You have free memory lenFile% = @LOF(hFile&) 'because we use Windows file handles we cannot use the GFA LOF command hMem& = GlobalAlloc(GMEM_FIXED,lenFile%) 'get a memory block lpMem% = GlobalLock(hMem&) ' fix the memory block and get back the address ~@@hread(hFile&,lpMem%,lenFile%) 'read the complete file into the memory block /* above does NOT want an underscore ~@@_hread... ~_lclose(hFile&) 'after closing the file handle is invalid IF EXIST(OutFile$) /* *I* found this moved by wordwrap... gotta be here! hFile& = _lopen(OutFile$,OF_WRITE) 'open the destination file and set length to zero ELSE hFile& = _lcreat(OutFile$,0) 'create and open the destination file ENDIF ~@@hwrite(hFile&,lpMem%,lenFile%) 'write the file from memory to hard disk /* again, above does NOT want an underscore ~@@_hwrite... ~_lclose(hFile&) ' close the destination file ~GlobalUnlock(hMem&) 'don't forget to unlock the memory block before free it ~GlobalFree(hMem&) 'free the memory block FREEDLL 1 PRINT "File Copied" PRINT "File size ";size% PRINT "Any Key" KEYGET k% CLOSEW #1 END FUNCTION LOF(hFile&) 'replacement for GFA's LOF using "real" file handles $FUNC% LOCAL CurrentPos%=_llseek(hFile&,0,0) 'return the current position in file LOCAL LOF%=_llseek(hFile&,0,2) 'set file pointer to end of file and get position ~_llseek(hFile&,CurrentPos%,0) 'reset to the current position size% = LOF% RETURN LOF% 'return length of file or -1 if error ENDFUNC

Bitmap Info
'Bitmap Information ' The following routine retrieves some information from a BMP file. ' Routine by Sjaak Aarnoutse ' Change file$ to appropiate path FULLW #1 file$ = "c:\bmps\backup.bmp" OPEN "i",#1,file$ ERASE buf&() DIM buf&(24) BGET #1,V:buf&(1),32 bmw& = buf&(10) // width bmh& = buf&(12) // height bmh& = 2 ^ buf&(15) // number of colours PRINT file$ PRINT "Width ";bmw& PRINT "Height ";bmh& PRINT "Number of Colors ";bmh& KEYGET k% ERASE buf&() CLOSE #1 CLOSEW #1 'It reads the BITMAPINFOHEADER structure: //BITMAPINFOHEADER (3.0) '=>>typedef struct tagBITMAPINFOHEADER { /* bmih */ '=>>DWORD biSize; '=>>LONG biWidth; '=>>LONG biHeight; '=>>WORD biPlanes; '=>>WORD biBitCount; '=>>DWORD biCompression; '=>>DWORD biSizeImage; '=>>LONG biXPelsPerMeter; '=>>LONG biYPelsPerMeter; '=>>DWORD biClrUsed; '=>>DWORD biClrImportant; } BITMAPINFOHEADER;

Load and Display a Bitmap
' Loading & Displaying a Bitmap ' OPENW #1 _WIN$(WIN(1)) = "Right Mouse Exits" path$ = CHR$(_DRIVE) + ":" + DIR$(0) ' 'make the palette the screen palette dc& = GetDC(1) SETDC dc& ~ReleaseDC(1,dc&) ' CLS ' ' bitmap filename goes here Picture$ = path$ + "\13.bmp" picture& = LOADBMP(Picture$ ) PUT 0,50,picture& PRINT Picture$ DO EXIT IF MOUSEK = 2 LOOP FREEBMP (picture&) CLS ' CLOSEW #1 EDIT

Load Bmp with User.dll
'=>>Loading a bitmap with USER.DLL // Russell Hayword // load and display a bitmap with USER.DLL FULLW #1 DLL #1,"USER" DECL WORD LoadImage(W,L,W,W,W,W) ENDDLL OPENW #1 file$ = "gfalogo.BMP" + CHR$(0) bmp = @@LoadImage(0,V:file$,0,0,0,128 | 16) '128=Loadrealsize 16 Loadfromfile REPEAT PEEKEVENT PUT 0,0,bmp UNTIL MOUSEK FREEBMP bmp FREEDLL 1 CLOSEW #1

Rotate Bitmap
'Rotating A Bitmap 'bmprtate.lst ' if bmp width >220 program ends FULLW #1 gAppPath$ = CHR$(_DRIVE) + ":" + DIR$(0) 'path to folder containing picture FILESELECT "*.bmp","*.bmp",Picture$ picture& = LOADBMP(Picture$) PUT 0, 0,picture& rotPict& = FN bmp_rotate(picture&,2 * PI) //rotate 360 PAUSE 15 FOR p& = 1 TO 4 rotPict& = FN bmp_rotate(picture&,p& * PI) //rotate 360 PAUSE 5 NEXT p& PAUSE 30 FREEBMP (picture&) CLOSEW #1 FUNCTION bmp_rotate(hbmp1&,theta) LOCAL c1x& 'center of hbmp1& LOCAL c1y& ' " LOCAL c2x& 'center of hbmp2& LOCAL c2y& ' " LOCAL a 'angle of c2 to p2 LOCAL r& 'radius from c2 to p2 LOCAL p1x& 'position of hbmp1& LOCAL p1y& ' " LOCAL p2x& 'position of hbmp2& LOCAL p2y& ' " LOCAL n& 'max width or height of hbmp2& LOCAL bmp1Width LOCAL bmp1Height LOCAL bmp2Width LOCAL bmp2Height 'compute the cnters GetBmpSize(hbmp1&,bmp1Width,bmp1Height) m$ = "To large to rotate" IF bmp1Width > 220 MESSAGE m$,"",MB_ICONSTOP,IDABORT END ENDIF c1x& = bmp1Width / 2 c1y& = bmp1Height / 2 bmp2Width = bmp1Height bmp2Height = bmp1Width c2x& = bmp2Width / 2 c2y& = bmp2Height / 2 'compute the image size n& = bmp2Width IF n& < bmp2Height THEN n& = bmp2Height n& = n& / 2 - 1 offsetx = bmp1Width offsety = bmp1Height 'for each pixel position on bmp2 FOR p2x& = 0 TO n& FOR p2y& = 0 TO n& 'compute polar coordinate of p2 IF p2x& = 0 THEN a = PI / 2. ELSE a = ATN(p2y& / p2x&) ENDIF r& = SQR(p2x& * p2x& + p2y& * p2y&) 'computer rotated position of bmp1 p1x& = r& * COS(a + theta) p1y& = r& * SIN(a + theta) 'copy pixels, 4 quadrants at once c0% = POINT(c1x& + p1x&,c1y& + p1y&) c1% = POINT(c1x& - p1x&,c1y& - p1y&) c2% = POINT(c1x& + p1y&,c1y& - p1x&) c3% = POINT(c1x& - p1y&,c1y& + p1x&) PSET c2x& + p2x& + offsetx,c2y& + p2y& + offsety,c0% PSET c2x& - p2x& + offsetx,c2y& - p2y& + offsety,c1% PSET c2x& + p2y& + offsetx,c2y& - p2x& + offsety,c2% PSET c2x& - p2y& + offsetx,c2y& + p2x& + offsety,c3% NEXT p2y& NEXT p2x& RETURN hbmp2& ENDFUNC ' PROCEDURE GetBmpSize(hbitmap,VAR width,height) 'courtesy of S. Hamstra LOCAL bmp$ = STRING$(14,0) //bitmap structure ~GetObject(hbitmap,14,V:bmp$) width = WORD{V:bmp$ + 2} height = WORD{V:bmp$ + 4} RETURN

Using TYPE for String Array
// Create a Global TYPE that has an only element as a string. TYPE MyString: - CHAR*20 Buffer$ ENDTYPE MyString: Str. PRINT a$ = "Qwerty" BMOVE V:a$, V:Str., LEN(a$) PRINT TRIM$(Str.Buffer$), LEN(Str.) PRINT a$ = "Qwerty" + CHR$(0) BMOVE V:a$, V:Str., LEN(a$) PRINT ZTRIM$(Str.Buffer$), LEN(Str.) DELAY 3 CLOSEW #1

Bload Data
'Bsave & Bload OPENW #1 FULLW #1 DIM a%(20),b%(20) WHILE _DATA READ a%(r%) r% ++ WEND adr% = V:a%(0) arl% = (V:a%(1) - V:a%(0)) * r% // NOTE : Change drive to preference BSAVE "d:test.dat",adr%,arl% adr2% = V:b%(0) BLOAD "d:test.dat",adr2% ? "Data Bloaded" FOR i& = 0 TO r% PRINT b%(i&) NEXT i& KEYGET k% CLOSEW #1 DATA 1,2,3,4,5,6,7,8,9,10

Bmove Data
'Bmove An Array // bmove - use swap a$(),b$() instead - demo only DIM a$(10),b$(10) OPENW #1 FULLW #1 WHILE _DATA READ a$(r%) r% ++ WEND FOR i& = 0 TO 10 b$(i&) = SPACE$(LEN(a$(i&))) BMOVE V:a$(i&),V:b$(i&),LEN(a$(i&)) PRINT b$(i&) NEXT i& KEYGET k% CLOSEW #1 DATA This was a$(0) DATA This was a$(1) DATA This was a$(2) DATA This was a$(3) DATA This was a$(4) DATA This was a$(5) DATA This was a$(6) DATA This was a$(7) DATA This was a$(8) DATA This was a$(9) DATA This was a$(10)

Browse For Folder
//Browse For Folder '"Browse For Folder" ' Include for GFA-BASIC 16 ' From the Book "Microsoft Windows 95 / Programmierleitfaden" ' The technical reference ' Free 02/1999 Eberhard Func (funck@hildesheim.sgh-net.de) ' -DLL #1,"kernel" DECL DWORD LoadLibraryEx32W(L,L,L) DECL BOOL FreeLibrary32W(L) DECL DWORD GetProcAddress32W(L,L) ENDDLL ' lpf32% = GetProcAddress (GetModuleHandle ("kernel"), "CallProc32W") hshell32% = ^LoadLibraryEx32W ("shell32.dll", 0, 0) hole32% = ^LoadLibraryEx32W ("Ole32.dll", 0, 0) hwow32% = ^LoadLibraryEx32W ("wow32.dll", 0, 0) ' OPENW #1, 100, 0, 400, 400, -1 hwnd& = WIN(1) ' Init_FolderHandler BrowseForFolder (hwnd&, BIF_RETURNONLYFSDIRS%, "Choose a folder") ' DO GETEVENT IF MENU(1) = 21 && pidl% PRINT "Folder: ";ZTRIM$(folder$) PRINT "Displayname: ";ZTRIM$(DisplayName$) ENDIF UNTIL MENU(1) = 4 ' CLOSEW #1 ~@CoTaskMemFree32 (pidl%) /* from Joe Hurst, thanks ' ~^FreeLibrary32W (hshell32%) ~^FreeLibrary32W (hole32%) ~^FreeLibrary32W (hwow32%) FREEDLL 1 END ' PROCEDURE Init_FolderHandler BIF_RETURNONLYFSDIRS% = $1 BIF_DONTGOBELOWDOMAIN% = $2 BIF_STATUSTEXT% = $4 BIF_RETURNFSANCESTORS% = $8 BIF_BROWSEFORCOMPUTER% = $1000 BIF_BROWSEFORPRINTER% = $2000 ' TYPE BROWSEINFO: - DWORD hwnd - DWORD pidlRoot - DWORD pszDisplayName - DWORD lpszTitle - DWORD ulFlags - DWORD lpfn - DWORD lParam - DWORD iImage ENDTYPE RETURN ' PROCEDURE BrowseForFolder (hwnd&, Flags%, title$) ' a% = 0 ~@SHGetSpecialFolderLocation (hwnd&, 0, V:a%) ' DIM BROWSEINFO: lpbi. lpbi.hwnd = hwnd& lpbi.pidlRoot = a% DisplayName$ = STRING$ (260, 0) lpbi.pszDisplayName = @SelectorOffsetToLinear (V:DisplayName$, lstrlen (V:DisplayName$), 1) lpbi.lpszTitle = @SelectorOffsetToLinear (V:title$, LEN (title$), 1) lpbi.ulFlags = Flags% lpbi.lpfn = NULL lpbi.lParam = 0 lpbi.iImage = 0 ' pidl% = @SHBrowseForFolder (*lpbi.) IF pidl% folder$ = STRING$ (128, 0) ~@SHGetPathFromIDList (pidl%, V:folder$) ENDIF ' RETURN ' FUNCTION SHGetSpecialFolderLocation (lp1%, lp2%, lp3%) adr% = ^GetProcAddress32W (hshell32%, "SHGetSpecialFolderLocation") RETURN P:(lpf32%) (L:lp1%, L:lp2%, L:lp3%, L:adr%, L:%001, L:3) ENDFUNC ' FUNCTION SHGetPathFromIDList (lp1%, lp2%) adr% = ^GetProcAddress32W (hshell32%, "SHGetPathFromIDListA") RETURN P:(lpf32%) (L:lp1%, L:lp2%, L:adr%, L:%01, L:2) ENDFUNC ' FUNCTION SHBrowseForFolder (lp1%) adr% = ^GetProcAddress32W (hshell32%, "SHBrowseForFolderA") RETURN P:(lpf32%) (L:lp1%, L:adr%, L:%1, L:1) ENDFUNC ' FUNCTION CoTaskMemFree32 (lpPidl%) adr% = ^GetProcAddress32W (hole32%, "CoTaskMemFree") RETURN P:(lpf32%) (L:lpPidl%, L:adr%, L:%0, L:1) ENDFUNC ' FUNCTION SelectorOffsetToLinear (vp%, dwBytes%, fProtectedMode%) adr% = ^GetProcAddress32W (hwow32%, "WOWGetVDMPointer") RETURN P:(lpf32%) (L:vp%, L:dwBytes%, L:fProtectedMode%, L:adr%, L:%000, L:3) ENDFUNC

Button Push Button
'BUTTON 'button.lst 'Creates a BUTTON With Text 'PUSH' FULLW #1 BUTTON "PUSH",31,100,100,80,50,WS_TABSTOP DO GET_EVENT SELECT MENU(11) CASE WM_COMMAND /* message from button btn_ccode| = HIWORD(MENU(13)) /* notification code '************************************************************************ ' get the id number if button has been clicked '************************************************************************ button_id& = MENU(12) /* id of button sending message SELECT button_id& CASE 31 /* Button ID PRINT button_id& ;" Is the Button ID" /************************************************************************ /* see if action (notification code) indicates button has been clicked /************************************************************************ IF btn_ccode| = BN_CLICKED /* Ok button has been clicked aborted! = TRUE PRINT "BUTTON SELECTED" DELAY 2 ENDIF ENDSELECT ENDSELECT EXIT IF aborted! LOOP CLOSEW #1

A Simple Callback Proc
'A Simple CallBack /* using callback // note that the CallBack procedure returns // a message when the mouse is clicked where // the PeekEvent loop returns a message when // the mouse is released FULLW #1 /* /* create a horizontal scroll bar /*********************************** // combine into 1 line SBAR& = CreateWindow("SCROLLBAR","",WS_VISIBLE | WS_CHILD | SBS_HORZ,250,100,100,20,WIN(1),9,_INSTANCE,0) CB -1,O TO -1,CALLBACK() /* handle all messages DO PEEKEVENT SELECT MENU(1) /*********************************** /* check for scroll bar message /*********************************** CASE 9 /* scroll bar left arrow button pressed PRINT "Left scroll bar arrow from PEEKEVNT" CASE 10 /* scroll bar right arrow pressed PRINT "Right scroll bar arrow from PEEKEVENT" ENDSELECT LOOP UNTIL MENU(1) = 4 CLOSEW #1 /************************* /* callback procedure /************************* PROCEDURE CALLBACK(Hwnd&,msg&,wparam&,lparam%) SELECT msg& CASE WM_HSCROLL /* horizontal scroll bar message /************************************** /* get type of scroll bar message /************************************** SELECT wparam& CASE SB_LINEUP /* left arrow button pressed PRINT "Left SCROLL Bar Arrow from CallBack" BEEP CASE SB_LINEDOWN /* right arrow button pressed PRINT "Right SCROLL Bar Arrow from CallBack" BEEP ENDSELECT ENDSELECT RETURN

Calling a .HLP Help File
'Calling .hlp Help DIM m$(20) // how to call a window .hlp format file // your menu should be defined and created m$(0) = "TEMP" m$(1) = "DISPLAY" m$(2) = "---------" m$(3) = "_Exit" m$(4) = "" OPENW #1 FULLW #1 MENU m$() DO //check for menu GETEVENT //selections IF MENU(1) = 20 THEN eval_menu IF MENU(11) = WM_KEYDOWN THEN eval_key() EXIT IF MENU(1) = 4 || aborted! LOOP CLOSEW #1 EDIT PROCEDURE eval_menu SWITCH MENU(0) CASE 1 PRINT "Test Only" DELAY 4 CASE 3 aborted! = TRUE OTHERWISE ENDSWITCH RETURN PROCEDURE eval_key m& = MENU(12) SELECT m& CASE VK_F1 //F1 KEY ~WinHelp(WIN(0),"gfawhelp.hlp",HELP_INDEX,0) ENDSELECT RETURN PROCEDURE wen_help() // file name must be a null terminated string //calls this .hlp file // HLP$="gfawhelp.hlp"+CHR$(0) // F!=WinHelp(hlp&,V:HLP$,HELP_INDEX,d%) // ************* POSSIBLES ************** // HELP_INDEX ($0003) Display Index // HELP_CONTEXT ($0001) Display Topic in Topic // HELP_QUIT ($0002) Terminate Help // HELP_HELPONHELP ($0004) Display Help On Using Help // HELP_SETINDEX ($0005) Set The Current Index For Multi Index Help // HELP_KEY ($0101) Display Topic For Keyword in offabData // HELP_MULTIKEY ($0201) Display Topic For Keyword in Alternare Keyword Table RETURN 'second method 'Friedrich Rhode TITLEW #1,"Right Mouse To End" FULLW #1 help_file$ = "bcopy.hlp" + CHR$(0) help& = WinHelp(DLG(1),help_file$ , HELP_INDEX,NULL) DO GETEVENT EXIT IF MENU(11) = WM_RBUTTONDOWN LOOP ~WinHelp(DLG(1),help_file$ , HELP_QUIT, NULL) CLOSEW #1 EDIT

Call NOTEPAD.EXE
'Calling NOTEPAD.EXE ' callnote.lst ' calling the Windows NOTEPAD ' and loading a .TXT FILE ' Modified from code by Michael K. Kroeger ' Declare Windows API calls. DLL #1, "kernel" DECL WORD WinExec( l, w ) ENDDLL FULLW #1 TITLEW #1,"Close This Window" ' Close NOTEPAD and Window ' Note : call NOTEPAD.EXE and load editor.txt ' Note : Leave out path and .txt filename to just call notepad ' Note : Can use SW_MAXIMIZE in place of SW_SHOW if desired ExecError& = ^WinExec( "notepad.exe c:\gfw\editor.txt", SW_SHOW ) // Check for an execution error. IF ExecError& < 32 THEN // combine into 1 line ALERT 3, "Could not start notepad.exe|WinExec Error = " + STR$(ExecError& ), 1, " OK ", i% ENDIF DO PEEKEVENT SELECT MENU(1) CASE 4 aborted! = TRUE ENDSELECT LOOP UNTIL aborted! CLOSEW #1 END

CD Rom Drive
'CDROM Installed? OPENW #1 PRINT PRINT "CD-ROM (c) 1994 by Steffen Janke, Turbo-Pascal Programmierer" PRINT "Checking For CD-ROM Installation" PRINT ~INTR($2f,_AX = $1100) IF _AL = $FF THEN PRINT PRINT _AX = $1500 _BX = 0 ~INTR($2f) PRINT "Found : ";_BX;" CD-ROM's" PRINT PRINT "The CD-ROM-Drive is : ";CHR$(_CX + 65);":" PRINT ELSE PRINT "No CDROM Drive :-(" ENDIF KEYGET a% CLOSEW #1

Change Dialog Color
'Changing Background Colors In A Dialog ' colordlg.lst - Roland Walters OPENW #1 @dlg CLOSEW #1 END PROCEDURE dlg DLG BASE UNIT DIALOG #1,100,50,85,65,"Demo-Dialog",WS_CAPTION | WS_MINIMIZEBOX CONTROL "Demo",-1,"button",BS_GROUPBOX | WS_CHILD | WS_VISIBLE | WS_GROUP,5,2,38,47 CONTROL "&gray",101,"button",BS_AUTORADIOBUTTON | WS_CHILD | WS_VISIBLE,10,12,28,12 CONTROL "&blue",102,"button",BS_AUTORADIOBUTTON | WS_CHILD | WS_VISIBLE,10,24,28,12 CONTROL "&red",103,"button",BS_AUTORADIOBUTTON | WS_CHILD | WS_VISIBLE,10,36,28,12 CONTROL "#1",-1,"static",SS_ICON | WS_CHILD | WS_VISIBLE,63,11,16,16 CONTROL "&Exit",104, "button",BS_PUSHBUTTON | WS_CHILD | WS_VISIBLE,51,35,40,14 ENDDIALOG DLG FILL 1,RGB(192,192,192) SHOWDIALOG #1 SETCHECK 1,101,1 DO GETEVENT IF MENU(11) = WM_COMMAND SELECT MENU(12) CASE 101 //gray DLG FILL 1,RGB(192,192,192) CASE 102 //blue DLG FILL 1,RGB(0,120,255) CASE 103 //red DLG FILL 1,RGB(255,0,0) CASE 104 //End finit! = TRUE ENDSELECT ENDIF UNTIL finit! CLOSEDIALOG #1 RETURN

CHDIR
'CHDIR OPENW #1 CURDRV = _DRIVE CURPATH$ = DIR$(0) PATH$ = CHR$(CURDRV) + ":" + CURPATH$ CHDIR PATH$ PRINT PATH$ KEYGET K% CLOSEW #1

Change Windows Background
'Change Window Background REM How do I change the background colour of a window? REM OPENW #1,0,0,640,400,-1 // Create a windows CLS 4 //set to a colour CB WIN(1), WM_ERASEBKGND TO WM_ERASEBKGND,ClearProc DO GETEVENT //wait till user closes window LOOP UNTIL MENU(1) = 4 PROCEDURE ClearProc(w&,m&,wp&,lp%) CLS 4 RETVAL 1 // return 1=basic will not fill in white RETURN REM With CB a procedure is defined that will clear the windows in the particular colour. REM By returning something the Basic is told not to react on the message and therefore REM you supress the default clearing of the window in wehite colour.

Change Windows Font
'Changing A Windows Font FULLW #1 dkgray& = GETNEAREST(128,128,128) ltyelo& = GETNEAREST(255,255,225) ltgray& = GETNEAREST(192,192,192) CLS ltgray& PRINT "Before SendMessage" SETFONT ANSI_FIXED_FONT FONT TO fntaff& SENDMESSAGE WIN(1),WM_SETFONT,fntaff&,0 a$ = "Testing Ansi Fixed Font" + CHR$(0) ~TextOut(_DC(1),0,40,V:a$,LEN(a$) - 1) a$ = "Press Any Key" + CHR$(0) COLOR dkgray&,ltyelo& ~TextOut(_DC(1),0,72,V:a$,LEN(a$) - 1) KEYGET k| CLOSEW #1 EDIT

Char()
'CHAR{} 'CHAR{} FULLW #1 st$ = "Here " a$ = "it is" st$ = st$ + CHAR{V:a$} ~TextOut(_DC(1),0,3 * 16,st$,LEN(st$) - 1) b$ = SPACE$(LEN(st$) - 1) CHAR{V:b$} = st$ PRINT b$ KEYGET k% CLOSEW #1

Chart Menu
'Chart Menu DIM m$(20) m$(0) = "FILE" m$(1) = "Chart Demo" m$(2) = "---------" m$(3) = "Sort" m$(4) = "Search" m$(5) = "Save" m$(6) = "--------" m$(7) = "E_xit" m$(8) = "" OPENW #1 FULLW #1 MENU m$() chart_menu() DO GET_EVENT IF (MENU(1) = 20) && (MENU(0)) eval_menu() ENDIF EXIT IF aborted! LOOP CLOSEW #1 EDIT PROCEDURE eval_menu() ee_% = MENU(0) SELECT ee_% CASE 7 aborted! = TRUE OTHERWISE ENDSELECT RETURN PROCEDURE chart_menu() // possible menu actions listed below // MENU ITEM,ACTION TO TAKE,MENU STRING(ITEM) // ------------------------------------------- MENU 3,MF_CHECKED,m$(3) // put a check mark by item 3 [sort] MENU 4,MF_GRAYED,m$(4) // disabled but grey MENU 5,MF_GRAYED,m$(5) // possibles // MENU 2,MF_ENABLED,m$(2) // enables - removes gray if needed // MENU 2,MF_DISABLED.M$(2) // disabled but black // MENU 2,MF_GRAYED,M$(2) // disabled but grey // MENU 2,MF_SEPARATOR,M$(2) // dashed line, text$ is ignored // MENU 2,MF_MENUBREAK,M$(2) // two column menu, text$ is the next item // MENU 2,MF_MENUBARBREAK,M$(2) // as above but w/vertical separtor bar RETURN

Is Disk Drive Ready
'=>>Is Drive Ready? 'Eberhard Funck 'Another way to test an empty drive: ' ~SetErrorMode(1) /* switch out the system message ' Drive$ = "A" ' e% = FGATTR (Drive$ + ":\") /* e% always < 0, if you can't read from a drive IF (e% < 0 ) m$ = "I can not read from drive: " + Drive$ + CHR$(13) //m$ = m$ + "Give security, that a disk is in this drive." m$ = m$ + "Drive not ready, please insert disk." ~MessageBox (hwnd&,m$, "Error", MB_OK | MB_ICONEXCLAMATION) ENDIF ' ~SetErrorMode(0) /* switch on the system message

Child Window
''Child Window - Static // STATIC2.GFW B. Deck 2/99 // Program to demonstrate using static child window as an auto redraw text display. // See CreateWindow() in GFA help for more info. // setup1 crlf$ = CHR$(13) + CHR$(10) edit_text$ = "This is an static control child of a simple window." edit_text$ = edit_text$ + crlf$ + " Click right mouse to change data " + CHR$(0) // must be 0 terminated ~SendMessage(id_static&,WM_SETTEXT,0,V:edit_text$) WIN #1 DO PEEKEVENT m1% = MENU(1) IF m1% = 6 || m1% = 18 ~MoveWindow(id_static&,0,0,_X ,_Y ,1) ENDIF IF MENU(4) = 2 THEN dostuff LOOP UNTIL m1% = 4 CLOSEW #1 END PROCEDURE setup1 OPENW #1,0,0,200,400,1008 e1% = WS_VISIBLE | WS_CHILDWINDOW | WS_BORDER e2% = ES_LEFT style% = e1% + e2% // CreateWindow("STATIC","",style%,0,0,_X,_Y,WIN(1),1,_INSTANCE,0) id_static& = CreateWindow("STATIC","",style%,0,0,_X,_Y,WIN(1),1,_INSTANCE,0) RETURN PROCEDURE dostuff bfr$ = "" FOR i% = 1 TO 30 s% = WM_SETTEXT // from win SDK v% = RAND(100) bfr$ = bfr$ + RIGHT$(STR$(i%),3) + " random number " + RIGHT$(STR$(v%),3) + crlf$ NEXT i% bfr$ = bfr$ + CHR$(0) ~SendMessage(id_static&,s%,0,V:bfr$) ~FRE(0) // garbage collection RETURN

Choose A Font
'Choose Font // chosefnt.lst // Written 2-9-93 by Craig Randall // chooses printer //DLG PRINT 1,0,dc& ' User determines all font values. This font is set up in memory, ' but is not actually accessed until the FONT TO command points to it. OPENW #1 FULLW #1 PRINT "Choose a font. The font will then display" PRINT "on the screen with characteristics chosen." //chooses font to use DLG FONT 1,dc&,CF_BOTH | CF_EFFECTS,0,0,0,"" // * Output is sent to the screen first. // Set screenfont& as the handle of the font. FONT TO screenfont& ' Return to p% the handle of the name of the font (see Ref. pg 512). RFONT NAME p% ' Build output string to show "FONT - STYLE." _EBX may return ' Bold and/or Italic as a string. n$ = CHAR{p%} + " - " + CHAR{_EBX} ' Change the current font to x& SETFONT screenfont& ' Output the text to the screen. do_mess() FREEFONT screenfont& FREEFONT printfont& ' Free up Device Context (Recommended for efficiency). FREEDC dc& MESSAGE "Press to end program.","Font Demo",MB_OK,a CLOSEW #1 PROCEDURE do_mess() CLS PRINT "Chosen Font is ";n$ WINDGET 14,ch% TEXT 0,ch%,"This is line #1" TEXT 0,2 * ch%,"This is line #2" RETURN

Clipboard Copy and Paste
'CLRCLIP - CLIPPASTE - CLIPFORMAT 'clipbord.lst OPENW #1,0,0,200,200,48 ' path to bitmap CLRCLIP ' clear the ClipBoard aa& = LOADBMP("c:\gfw\diskcopy.bmp") ' load bitmap PUT 0,0,aa& ' display bmp GET 0,0,_X,_Y,aa& ' get it CLIPFORMAT CF_BITMAP ' format is CF_BITMAP CLIPCOPY aa&,0 ' copy it to ClipBoard KEYGET a% CLS 15 KEYGET a% CLIPPASTE aa&,b% ' paste from ClipBoard PUT 0,0,aa& KEYGET a% CLOSEW #1

Clipboard API
'CLIP Board,Using,Windows,API ' ClipBoardCopy By Eberhard Funck ' using the Windows API ' Checked by pasting in MS WORD FULLW #1 ' API function: wert$ = "ClipBoard Copy By Eberhard Funck using the Windows API" IF OpenClipboard (WIN(1)) ~EmptyClipboard() hGlobal& = GlobalAlloc (GMEM_SHARE, 512) lpMem% = GlobalLock (hGlobal&) ~lstrcpy (lpMem%, wert$) ~SetClipboardData (CF_TEXT, hGlobal&) ~GlobalUnlock (hGlobal&) ~CloseClipboard () ENDIF ' '=>>finish your apps or not ' IF OpenClipboard (WIN(1)) hGlobal& = GetClipboardData (CF_TEXT) lpMem% = GlobalLock (hGlobal&) wert$ = CHAR{lpMem%} ~CloseClipboard () ENDIF CLOSEW #1 EDIT

Clipboard API2
//ClipBoard Example ' ClipBoardAPI2 ' Roland Walter ' Shows test from Clipboard ' Shows length of memory block ' Shows length of the text on clipboard OPENW #1 IF OpenClipboard(WIN(1)) <> 0 'only if not just opened hMem& = GetClipboardData(CF_TEXT) IF hMem& 'only if available lenMem% = GlobalSize(hMem&) 'get size (may be > 32KB!!!) ptrMem% = GlobalLock(hMem&) 'lock and get address TheText$ = PEEK$(ptrMem%,lenMem%) 'copy into string by length TheText$ = CHAR{ptrMem%} 'copy into string by NULL termination ~GlobalUnlock(hMem&) 'Unlock (do NOT free it!) ~CloseClipboard() 'do NOT forget! PRINT TheText$ PRINT "The memory block is " + STR$(lenMem%) + " bytes long" PRINT "The text block is " + STR$(LEN(TheText$)) + " bytes long" ENDIF ENDIF KEYGET Dummy% CLOSEW #1

Capitalize Each Word
'Convert To Caps // Converts first letter of each word to capitals OPENW #1,200,100,200,100,-1 c$ = "gfa basic is unsurpassed!" r$ = @caps$(c$) PRINT r$ KEYGET k% CLOSEW #1 END FUNCTION caps$(cap$) MID$(cap$,1,1) = UPPER$(MID$(cap$,1,1)) FOR i = 1 TO LEN(cap$) IF MID$(cap$,i,1) = " " MID$(cap$,i + 1,1) = UPPER$(MID$(cap$,i + 1)) ENDIF NEXT i RETURN cap$ ENDFUNC

Duplicate Floppy Disk
'Copy Disk (duplicate) 'dupedisk.lst FULLW #1 PRINT "close window when finished" @init @dupe DO GET_EVENT EXIT IF MENU(1) = 4 //close window to exit LOOP CLOSEW #1 END PROCEDURE dupe //Checks whether diskcopy.dll exists IF EXIST (windir$ + "\system\diskcopy.dll") THEN found| = 1 //Checks whether rundll32.exe exists IF EXIST(windir$ + "\rundll32.exe") AND found| = 1 // if found, starts DiskCopyDialog EXEC windir$ + "\rundll32.exe Diskcopy.dll,DiskCopyRunDll" , "" found| = 0 ELSE // if not found // starts message found| = 0 MESSAGE sysfile$(0),"Warning",MB_ICONEXCLAMATION | MB_OK,n& ENDIF RETURN PROCEDURE init DIM sysfile$(14) sysfile$(0) = " Can not find SysFile " // Messagetext sysfile$(1) = "FormatDisk" // Format Disk sysfile$(2) = "DiskCopy" // Diskcopy buffer$ = SPACE$(255) // creates Buffer for 255 characters tchars& = GetWindowsDirectory(V:buffer$,255) // read the name of the WinDir windir$ = LEFT$(buffer$,tchars&) RETURN

Create Compatible Bitmap
'CreateCompatibleBitmap() //looks like hook rug OPENW #1,0,0,0,0,0 mdc& = MEMDC(_DC(1)) hbm& = CreateCompatibleBitmap(_DC(1),481,470) hbo& = SelectObject(mdc&,hbm&) ~BitBlt(mdc&,0,0,481,471,0,0,0,WHITENESS) SETDC mdc& FOR i& = 0 TO 255 STEP 3 COLOR i& & 15 CIRCLE 240,240, i& NEXT i& ~SelectObject(mdc&,hbo&) FREEDC mdc& CLOSEW #1 FULLW #2 SETDC _DC(1) DO PEEKEVENT IF _Mess = WM_PAINT PUT 0,0,hbm& ENDIF LOOP UNTIL _Mess = WM_CHAR FREEBMP hbm& CLOSEW #2

CreatePolygonRgn
'CreatePolygonRgn() ' James Schumacher & Sjouke Hamstra ' CreatePolygonRgn ' PaintRgn OPENW #1 @init brushHandle& = GetStockObject(BLACK_BRUSH) oldbrushHandle& = SelectObject(_DC(),brushHandle&) //create regions rgnHndl2& = CreatePolygonRgn(V:shape%(0),4,ALTERNATE) DO GETEVENT ~PaintRgn(_DC(),rgnHndl2&) UNTIL MENU(1) = 4 ~DeleteObject(oldbrushHandle&) ~DeleteObject(rgnHndl2&) CLOSEW #1 PROCEDURE init //create a TYPE array with 4 points in it per Sjouke TYPE POINT: - WORD h - WORD v ENDTYPE DIM shape%(4) {V:shape%(0)}.h = 30 {V:shape%(0)}.v = 30 {V:shape%(1)}.h = 60 {V:shape%(1)}.v = 30 {V:shape%(2)}.h = 30 {V:shape%(2)}.v = 60 {V:shape%(3)}.h = 60 {V:shape%(3)}.v = 60 RETURN

Create PopUp Menu
'CreateMenu ' activate by pressing right mouse button OPENW #1 ? "Right Mouse for POPUP Menu" pu& = CreatePopupMenu() FOR i& = 0 TO 4 ~AppendMenu(pu&,MF_STRING,i&,"Entry " + STR$(i&)) NEXT i& ~AppendMenu(pu&,MF_STRING,i&,"Exit " + STR$(i&)) DO GETEVENT IF _Mess = WM_RBUTTONDOWN ~TrackPopupMenu(pu&,0,MOUSESX,MOUSESY,0,WIN(1),0) ENDIF IF _Mess = WM_COMMAND ? MENU(12) Exit! = (MENU(12) = 5) ENDIF LOOP UNTIL Exit! || MENU(1) = 4 CLOSEW #1

Change Cursors
'New cursor shape From a .CUR file // Cursor.gfw - load cursor and display it // R. Geiger // Cursor created with Borland Resource Workhop. TITLEW #1,"Cursor" OPENW #1 a% = MALLOC(326) b% = MALLOC(260) OPEN "i",#1,"c:\gb32\aall.cur" BGET #1,a%,326 CLOSE #1 BMOVE a% + 70 ,b% + 4,256 XHotSpot& = WORD{a% + 10} YHotSpot& = WORD{a% + 12} FOR i% = 0 TO 63 b| = BYTE{b% + 4 + i%} c| = BYTE{b% + 4 + 127 - i%} BYTE{b% + 4 + i%} = c| BYTE{b% + 4 + 127 - i%} = b| NEXT i% FOR i% = 128 TO 191 b| = BYTE{b% + 4 + i%} c| = BYTE{b% + 4 + 128 + 255 - i%} BYTE{b% + 4 + i%} = c| BYTE{b% + 4 + 128 + 255 - i%} = b| NEXT i% FOR i% = 0 TO 127 b| = BYTE{b% + 4 + i%} c| = BYTE{b% + 4 + 128 + i%} BYTE{b% + 4 + i%} = c| BYTE{b% + 4 + 128 + i%} = b| NEXT i% WORD{b%} = XHotSpot& WORD{b% + 2} = YHotSpot& DEFMOUSE b% DIM m$(10) m$(0) = "CURSOR" m$(1) = "-" m$(2) = "-" m$(3) = "E&xit" m$(4) = "" MENU m$() DO GET_EVENT EXIT IF MENU(1) = 20 && MENU(0) = 3 LOOP CLOSEW #1 ~MFREE(a%) ~MFREE(b%) END

Dialog Box CallBack
'Dialog Box CallBack ' about dialog ' Controlling a dialog box with a callback FULLW #1 Aboutdlg() CLOSEW #1 EDIT PROCEDURE Aboutdlg @messbarfont DLGBASE PIXEL DLG 3D ON DIALOG #0,200,120,260,120,"",WS_POPUP | WS_DLGFRAME CB DLG(0),0 TO -1,ppxd() DLG FILL 0,RGB(192,192,192) CTEXT "R E M O V E R",100,50,12,160,16 ICON "#1" ,101,8,8,0,0 CTEXT "REM Line Remover",102,50,36,160,32 CTEXT "Copyright 1996" ,103,40,58,180,32 CTEXT "by Dale Bryant",104,40,78,180,32 // DEFPUSHBUTTON "OK" ,109,100,95,62,24,WS_GROUP CONTROL "OK",109,"button",$10000001,100,95,62,24 ENDDIALOG ~SendMessage(DLGITEM(0,102),WM_SETFONT,BarFont&,0) ~SendMessage(DLGITEM(0,103),WM_SETFONT,BarFont&,0) ~SendMessage(DLGITEM(0,104),WM_SETFONT,BarFont&,0) ~SendMessage(DLGITEM(0,109),WM_SETFONT,BarFont&,0) SHOWDIALOG #0 DLG 3D OFF DO GETEVENT LOOP UNTIL finit! CLOSEDIALOG #1 RETURN PROCEDURE ppxd(hw&,m&,w&,l%) SWITCH m& CASE WM_COMMAND SWITCH w& CASE 109 //IDOK LET finit! = 1 POSTMESSAGE WIN(1),WM_CLOSE,0,0 // One of the commands forbidden in callbacks is END // just remember: there's some program waiting for the // callback to return, not abort (most often windows itself) // an end does very often kill BASIC or WINDOWS or any other // program. that's why Ctrl-Break does not work inside // callbacks. on break gosub does work. ENDSWITCH ENDSWITCH RETURN PROCEDURE messbarfont ' 100,0 is standard ' 100,1 is italic BarFont& = CreateFont(12,5,0,0,100,1,0,0,ANSI_CHARSET,OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY,VARIABLE_PITCH | FF_ROMAN, "Helv") SETFONT BarFont& RETURN

DRAWTEXT Example
'Drawtext // DRAWTEXT OPENW #1 FULLW #1 ip_mask() KEYGET k% CLOSEW #1 PROCEDURE ip_mask() nc% = 320 DRAWTEXT 0,5 * 16,110,nc%,"Invoice :",DT_RIGHT DRAWTEXT 0,7 * 16,110,nc%,"Cust Act :",DT_RIGHT DRAWTEXT 0,9 * 16,110,nc%,"Cash Total :",DT_RIGHT DRAWTEXT 0,11 * 16,110,nc%,"TaxbleMerch :",DT_RIGHT DRAWTEXT 0,13 * 16,110,nc%,"Sale Type :",DT_RIGHT DRAWTEXT 0,15 * 16,110,nc%,"TxblLab :",DT_RIGHT DRAWTEXT 0,17 * 16,110,nc%,"ChrgTotal :",DT_RIGHT DRAWTEXT 0,19 * 16,110,nc%,"Sales Tax :",DT_RIGHT RETURN

DLG Fonts For an EditBox
'Choosing A Font For an Edit Box /******************************** /* Edboxfnt.lst /******************************** DLG FONT 1,0,CF_SCREENFONTS, _ECX,0,0,"Style" FONT TO eboxfont& /******************** /* open a window /******************** OPENW #1,50,50,400,150,&X0000110000 /************************ /* create the edit box /************************ ' text for edit box ebtext$ = "This is a long line of text to the edit box. The text should wrap around in the box." ebtext$ = ebtext$ + " Choose Appropiate Font Size. F4 or Closer To Exit." ' style for edit box style% = WS_VISIBLE | WS_CHILD | WS_BORDER | ES_MULTILINE | ES_LEFT /* edit box style // combine into 1 line editbox_id& = CreateWindow("EDIT","",style%,10,10,350,150, WIN(1),1,_INSTANCE,0) ' set font chosen with DLG FONT ~SendMessage(editbox_id&,WM_SETFONT,eboxfont&,0) ' put the text in the edit box _WIN$(editbox_id&) = ebtext$ ' set the focus ~SetFocus(editbox_id&) /* Exit loop if ALT F4 or Window closed /****************************************** DO PEEKEVENT LOOP UNTIL MENU(1) = 4 FREEFONT ebfont& CLOSEW #1

Edit Box Fonts
'Choosing A Font For an Edit Box /******************************** /* Edboxfnt.lst /******************************** DLG FONT 1,0,CF_SCREENFONTS, _ECX,0,0,"Style" FONT TO eboxfont& /******************** /* open a window /******************** OPENW #1,50,50,400,150,&X0000110000 /************************ /* create the edit box /************************ ' text for edit box ebtext$ = "This is a long line of text to the edit box. The text should wrap around in the box." ebtext$ = ebtext$ + " Choose Appropiate Font Size. F4 or Closer To Exit." ' style for edit box style% = WS_VISIBLE | WS_CHILD | WS_BORDER | ES_MULTILINE | ES_LEFT /* edit box style // combine into 1 line editbox_id& = CreateWindow("EDIT","",style%,10,10,350,150, WIN(1),1,_INSTANCE,0) ' set font chosen with DLG FONT ~SendMessage(editbox_id&,WM_SETFONT,eboxfont&,0) ' put the text in the edit box _WIN$(editbox_id&) = ebtext$ ' set the focus ~SetFocus(editbox_id&) /* Exit loop if ALT F4 or Window closed /****************************************** DO PEEKEVENT LOOP UNTIL MENU(1) = 4 FREEFONT ebfont& CLOSEW #1

Edit String Array
'Edit String Array // note:for large arrays a binary search should be used DIM a$(20) OPENW #1 FULLW #1 WHILE _DATA READ c$ a$(r%) = UPPER$(c$) r% ++ WEND SSORT a$(),r% FOR i& = o TO r% PRINT a$(i&) NEXT i& PRINT "Note that JONH should be JOHN" PRINT "Edit Which Record [Name]" LINE INPUT b$ b$ = UPPER$(b$) WHILE i% <= r% c% = INSTR(a$(i%),b$) IF c% <> 0 f% = i% PRINT a$(f%) ENDIF i% ++ WEND PRINT "Change the name ";a$(f%) LINE INPUT "New Name ";nm$ nm$ = UPPER$(nm$) a$(f%) = nm$ CLS FOR i& = 0 TO r% PRINT a$(i&) NEXT i& PRINT "Edited Records" PRINT "Press Any Key" KEYGET k% CLOSEW #1 EDIT DATA eberhard DATA joe DATA pat DATA david DATA jonh DATA dale DATA tom DATA peter DATA patrik DATA michael

Enumerate Fonts
'EnumFonts() //by Ophir Daniels TYPE RECT: - USHORT left - USHORT top - USHORT right - USHORT bottom ENDTYPE RECT:RC. TYPE DRAWITEMSTRUCT: - USHORT CtlType - USHORT CtlID - USHORT itemID - USHORT itemAction - USHORT itemState - USHORT hwndItem - USHORT hDC - DOUBLE rcItem# - DWORD itemData ENDTYPE DRAWITEMSTRUCT:DRAWITEM. TYPE LOGFONT:/*************************************************** - SHORT lfHeight - SHORT lfWidth - SHORT lfEscapement - SHORT lfOrientation - SHORT lfWeight - BYTE lfItalic - BYTE lfUnderline - BYTE lfStrikeOut - BYTE lfCharSet - BYTE lfOutprecision - BYTE lfClipPrecision - BYTE lfQuality - BYTE lfPitchAndFamily - CHAR *32 lfFaceName$ ENDTYPE /****************************************************** _CB (1) = EnumFontsProc(l,l,w,l) DIALOG #0,(SYSMETRIC(0) / 2) - 300,(SYSMETRIC(1) / 2) - 200,600,400,"Enum fonts",DS_MODALFRAME CB DLG(0),WM_DRAWITEM,denu() DLG FILL 0,RGB(192,192,192) LISTBOX "",10,20,20,560,320,LBS_OWNERDRAWFIXED | LBS_HASSTRINGS | WS_VSCROLL | LBS_SORT | WS_BORDER BUTTON "E&xit",1,250,348,100,20 ENDDIALOG ~SendMessage(DLG(0,10),WM_USER + 33,-1,32) ~EnumFonts(_DC(),NULL,_CB(1),0)//for screen ~SendMessage(DLG(0,10),LB_SETCURSEL,0,0) SHOWDIALOG #0 DO PEEKEVENT UNTIL MENU(1) = 4 OR MENU(0) = 2 OR MENU(0) = 1 CLOSEDIALOG #0 PROCEDURE EnumFontsProc(plf%,ptm%,ftyp&,ldat%) ~SendMessage(DLG(0,10),LB_ADDSTRING,0,{plf%}.lfFaceName$) RETVAL TRUE RETURN PROCEDURE denu(h&,m&,w&,l%) BMOVE l%,*DRAWITEM.,LEN(DRAWITEM.) BMOVE *DRAWITEM. + 14,*RC.,LEN(RC.) outtxt$ = SPACE$(200) dummy& = SendMessage(DRAWITEM.hwndItem,LB_GETTEXT,DRAWITEM.itemID,V:outtxt$) outtxt$ = LEFT$(outtxt$,dummy&) + CHR$(0) list_font& = CreateFont(16,8,0,0,FW_DONTCARE,0,0,0,1,0,0,DEFAULT_PITCH | FF_DONTCARE,fontfam|,V:outtxt$) ~SetBkMode(DRAWITEM.hDC,TRANSPARENT) IF DRAWITEM.itemState & ODS_SELECTED blue_brush& = CreateSolidBrush(RGB(0,0,255)) ~FillRect(DRAWITEM.hDC,*RC.,blue_brush&) ~SetTextColor(DRAWITEM.hDC,RGB(255,255,0)) ~DeleteObject(blue_brush&) ELSE ~FillRect(DRAWITEM.hDC,*RC.,GetStockObject(WHITE_BRUSH)) ~SetTextColor(DRAWITEM.hDC,RGB(0,0,0)) ENDIF old_font& = SelectObject(DRAWITEM.hDC,list_font&) ~DrawText(DRAWITEM.hDC,outtxt$,LEN(outtxt$) - 1,*RC.,DT_SINGLELINE | DT_LEFT | DT_VCENTER) ~SelectObject(DRAWITEM.hDC,old_font&) ~DeleteObject(list_font&) ~ReleaseDC(DRAWITEM.hwndItem,DRAWITEM.hDC) RETURN

Evaluate Key [F1]
'Getevent : Evaluate Key // GETEVENT // EVALUATE KEY VK-F1 // DIM m$(20) build_menu() do_Wenon(1) DO GETEVENT IF MENU(1) = 20 THEN eval_menu() IF MENU(11) = WM_KEYDOWN THEN eval_key() EXIT IF MENU(1) = 4 || aborted! LOOP PROCEDURE eval_menu() me_% = MENU(0) SELECT me_% CASE 1 PRINT "Loading File" PAUSE 20 CLS CASE 3 // If exit selected aborted! = TRUE OTHERWISE ENDSELECT RETURN PROCEDURE eval_key m& = MENU(12) SELECT m& CASE VK_F1 wen_help() OTHERWISE ENDSELECT RETURN PROCEDURE build_menu() m$(0) = "Options" m$(1) = "_Load File" m$(2) = "----------" m$(3) = "e_Xit" m$(4) = "" RETURN PROCEDURE do_Wenon(w&) IF w& = 1 OPENW #w& FULLW #w& MENU m$() ELSE OPENW #w& FULLW #w& ENDIF RETURN PROCEDURE wen_help() //call GFAW .hlp file - set path if not in same DIR HLP$ = "c:\gfw\bcopy41.HLP" + CHR$(0) F! = WinHelp(hlp&,V:HLP$,HELP_INDEX,d%) // ************* POSSIBLES ************** // HELP_INDEX ($0003) Display Index // HELP_CONTEXT ($0001) Display Topic in Topic // HELP_QUIT ($0002) Terminate Help // HELP_HELPONHELP ($0004) Display Help On Using Help // HELP_SETINDEX ($0005) Set The Current Index For Multi Index Help // HELP_KEY ($0101) Display Topic For Keyword in offabData // HELP_MULTIKEY ($0201) Display Topic For Keyword in Alternare Keyword Table RETURN

The EXEC Command
'The EXEC Command 'Executing A Dos .EXE From Windows DIM m$(10) m$(0) = "EXEC" m$(1) = "EXEC PROG" m$(2) = "--------" m$(3) = "e_Xit" m$(4) = "" OPENW #1 FULLW #1 MENU m$() DO GET_EVENT IF MENU(1) = 20 THEN eval_menu EXIT IF aborted! LOOP PROCEDURE eval_menu m& = MENU(0) SWITCH m& CASE 1 FILESELECT "*.exe","*.exe",f$ IF LEN(f$) A% = EXEC(f$,"") ENDIF CASE 3 aborted! = TRUE OTHERWISE ENDSWITCH RETURN

Fonts Using GetStockObject
'Using GetStockObjects For System Fonts // getting stockobhject fonts FULLW #1 to$ = "This is font - SYSTEM FIXED FONT" hwnd& = WIN(1) hdc& = GetDC(hwnd&) ~SelectObject(hdc&,GetStockObject(SYSTEM_FIXED_FONT)) ~TextOut(hdc&,10,10,V:to$,LEN(to$)) ~ReleaseDC(hwnd&,hdc&) to$ = "This is font - ANSI FIXED FONT" hdc& = GetDC(hwnd&) ~SelectObject(hdc&,GetStockObject(ANSI_FIXED_FONT)) ~TextOut(hdc&,10,26,V:to$,LEN(to$)) ~ReleaseDC(hwnd&,hdc&) to$ = "This is font - OEM FIXED FONT" hdc& = GetDC(hwnd&) ~SelectObject(hdc&,GetStockObject(OEM_FIXED_FONT)) ~TextOut(hdc&,10,42,V:to$,LEN(to$)) ~ReleaseDC(hwnd&,hdc&) to$ = "This is font - ANSI VAR FONTT" hdc& = GetDC(hwnd&) ~SelectObject(hdc&,GetStockObject(ANSI_VAR_FONT)) ~TextOut(hdc&,10,58,V:to$,LEN(to$)) ~ReleaseDC(hwnd&,hdc&) KEYGET k% CLOSEW #1 EDIT

Font Selection
'Font Sizes ' by Thomas Engel ' User determines all font values. This font is set up in memory, ' but is not actually accessed until the FONT TO command points to it. ' This program demonstrates the difference between character point size and character cell size ' I release this program to the public domain. Thomas G. Engel 10/18/96 OPENW #1 FULLW #1 PRINT "Choose any font" nm$ = "arial" FONT nm$ TO screenfont& SETFONT screenfont& DLG FONT 1,0,CF_BOTH | CF_EFFECTS | CF_INITTOLOGFONTSTRUCT,0,0,0,""// | CF_INITTOLOGFONTSTRUCT //choose font FONT TO screenfont& SETFONT screenfont& RFONT NAME p% RFONT HEIGHT lfHeight& n$ = CHAR{p%} + " - " + CHAR{_EBX} CLS PRINT "Chosen Font is ";n$ PRINT "Chosen Font point size is ";ROUND(ABS((72 * lfHeight&) / GETDEVCAPS(LOGPIXELSY))) WINDGET 14,ch% PRINT "Chosen Font cell size is ";ch% PRINT "Press any key to continue" KEYGET a% CLS TEXT 0,ch%,"The next FONT selection box will" TEXT 0,2 * ch%,"have the chosen font style highlighted." TEXT 0,3 * ch%,"Press any key to continue." KEYGET a% CLS PRINT "Cancel to End" DLG FONT 1,0,CF_BOTH | CF_EFFECTS | CF_INITTOLOGFONTSTRUCT FREEFONT screenfont& MESSAGE "Press to end program.","Font Demo",MB_OK,a CLOSEW #1

Format a Floppy Disk
'Format Floppy 'format.lst FULLW #1 PRINT "close window when finished" @init @format DO GET_EVENT EXIT IF MENU(1) = 4 //close window to exit LOOP CLOSEW #1 END PROCEDURE format //Checks whether diskcopy.dll exists //Checks whether Shell32.dll exists IF EXIST(windir$ + "\system\shell32.dll") THEN found| = 1 //Checks whether rundll32.exe exists IF EXIST(windir$ + "\rundll32.exe") AND found| = 1 // if found, starts FormatDialog EXEC windir$ + "\rundll32.exe shell32.dll,SHFormatDrive","" found| = 0 ELSE // if not found // starts message found| = 0 MESSAGE sysfile$(0),"Warning",MB_ICONEXCLAMATION | MB_OK,n& ENDIF RETURN PROCEDURE init DIM sysfile$(14) sysfile$(0) = " Can not find SysFile " // Messagetext sysfile$(1) = "FormatDisk" // Format Disk sysfile$(2) = "DiskCopy" // Diskcopy buffer$ = SPACE$(255) // creates Buffer for 255 characters tchars& = GetWindowsDirectory(V:buffer$,255) // read the name of the WinDir windir$ = LEFT$(buffer$,tchars&) RETURN

Huge file Copy
'=>>Using _Huge by John Findlay '==================================================================== ' ' HugeRead & HugeWrite routines using API's _lread() & _lwrite(). ' ' John Findlay ' '==================================================================== DEFINT "l" ' 32 bit/long DEFWRD "h,n" ' 16 bit/word DEFBYT "i" ' 8 bit/byte OPENW #1, 2, 0, _X - 20, _Y - 20, ~15 ladr = MALLOC(178000) ' Fill memory with a-z i = 97 FOR l = 0 TO 177999 IF i > 122 THEN i = 97 BYTE{_Huge(ladr, l)} = i i ++ NEXT l ' Write out Huge Block OPEN "O", #1, "d:\myfile.txt" PRINT "The Bytes Sent", @HugeWrite(_FILE(1), ladr, 178000) CLOSE #1 ' Read in Huge Block OPEN "I", #1, "d:\myfile.txt" PRINT "Read File Size", LOF(#1) PRINT "Bytes Read Back", @HugeRead(_FILE(1), ladr, LOF(#1)) CLOSE #1 ~MFREE(ladr) KEYGET l CLOSEW #1 EDIT FUNCTION HugeWrite(hFile, lpBuf, lBytes) LOCAL lBytesTmp = lBytes '------------------------------------------- ' Write out the data in 32767 byte chunks. '------------------------------------------- WHILE lBytes > 32767 IF _lwrite(hFile, lpBuf, 32767) != 32767 RETURN -1 ' Error ENDIF lBytes -= 32767 lpBuf = _Huge(lpBuf, 32767) WEND '------------------------------------------- ' If there's some still to write send the ' last chunk which is < 32767 bytes '------------------------------------------- IF lBytes IF _lwrite(hFile, lpBuf, lBytes) != lBytes RETURN -1 ' Error ENDIF ENDIF '------------------------------------------- ' Return number of bytes written '------------------------------------------- RETURN lBytesTmp ' Success ENDFUNC FUNCTION HugeRead(hFile, lpBuf, lBytes) LOCAL lCount = 0, nMaxLen '------------------------------------------- ' Is lBytes greater than 32767, set nMaxLen '------------------------------------------- nMaxLen = IMIN(32767, lBytes) WHILE lCount < lBytes IF _lread(hFile, _Huge(lpBuf, lCount), nMaxLen) != nMaxLen RETURN -1 ' Error ENDIF lCount += nMaxLen nMaxLen = IMIN(32767, lBytes - lCount) WEND '------------------------------------------- ' Return number of bytes read '------------------------------------------- RETURN lCount ' Success ENDFUNC

Icons -System
'=>>Icon Dialog by Eberhard Funck ' Example to insert Windows system icons in a dialogbox ' You don't destroy this system icons with ~DestroyIcon (hicon&) ' If you load an icon from your own resource file with ' LoadIcon (_INSTANCE, "name" or 1234) /* resource name or number of resource ' you must destroy this handle with ~DestroyIcon (hicon&) after ending the application. ' STYLE% = DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU DIALOG #1, 168, 140, 280, 200, "Icons in DialogBox", STYLE%, 8, "MS Sans Serif" ' CONTROL "Next Icon", IDOK, "BUTTON", BS_DEFPUSHBUTTON | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 26, 122, 100, 28 CONTROL "Exit", IDCANCEL, "BUTTON", BS_PUSHBUTTON | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 146, 122, 100, 28 CONTROL "", 100, "STATIC", SS_ICON | WS_CHILD | WS_VISIBLE, 12, 40, 36, 36 CONTROL "Text", 200, "STATIC", SS_LEFT | WS_CHILD | WS_VISIBLE | WS_GROUP, 50, 50, 220, 16 ' ENDDIALOG DLG FILL 1, GetSysColor (COLOR_BTNFACE) ' text$ = "<-- System Icon: IDI_APPLICATION" ~SendDlgItemMessage (DLG(1), 200, WM_SETTEXT, 0, text$) STM_SETICON& = WM_USER + 0 hicon& = LoadIcon (NULL, IDI_APPLICATION) ~SendDlgItemMessage (DLG(1), 100, STM_SETICON&, hicon&, 0) bInc| = 1 ' SHOWDIALOG #1 ' DO GETEVENT IF MENU(1) = 30 SELECT MENU(6) CASE IDOK ' SELECT bInc| CASE 0 hicon& = LoadIcon (NULL, IDI_APPLICATION) text$ = "<-- System Icon: IDI_APPLICATION" ~SendDlgItemMessage (DLG(1), 200, WM_SETTEXT, 0, text$) bInc| ++ CASE 1 hicon& = LoadIcon (NULL, IDI_ASTERISK) text$ = "<-- System Icon: IDI_ASTERISK" ~SendDlgItemMessage (DLG(1), 200, WM_SETTEXT, 0, text$) bInc| ++ CASE 2 hicon& = LoadIcon (NULL, IDI_EXCLAMATION) text$ = "<-- System Icon: IDI_EXCLAMATION" ~SendDlgItemMessage (DLG(1), 200, WM_SETTEXT, 0, text$) bInc| ++ CASE 3 hicon& = LoadIcon (NULL, IDI_HAND) text$ = "<-- System Icon: IDI_HAND" ~SendDlgItemMessage (DLG(1), 200, WM_SETTEXT, 0, text$) bInc| ++ CASE 4 hicon& = LoadIcon (NULL, IDI_QUESTION) text$ = "<-- System Icon: IDI_QUESTION" ~SendDlgItemMessage (DLG(1), 200, WM_SETTEXT, 0, text$) bInc| = 0 ENDSELECT ~SendDlgItemMessage (DLG(1), 100, STM_SETICON&, hicon&, 0) ' CASE IDCANCEL ende! = TRUE ENDSELECT ENDIF UNTIL MENU(1) = 4 || ende! = TRUE ' CLOSEDIALOG #1 END

Delete Array Element
'Insert & Delete Array Elements OPENW #1 FULLW #1 DIM a$(20) WHILE _DATA READ a$(r%) r% ++ WEND DEC r% SSORT a$(),r% PRINT "Orig. array" shoit() b$ = "TEST inserted" // Insert b$ WHILE i% < r% IF a$(i%) > b$ INSERT a$(i%) = b$ ENDIF i% ++ WEND PRINT "B$ inserted into a$ array" shoit() WHILE i% < r% IF a$(i%) > b$ INSERT a$(i%) = b$ ENDIF i% ++ WEND i% = 0 WHILE i% < r% IF a$(i%) = b$ DELETE a$(i%) ENDIF i% ++ WEND ? "B$ deleted from a$ array" shoit() CLOSEW #1 EDIT PROCEDURE shoit FOR i& = 0 TO r% + 1 PRINT a$(i&) NEXT i& KEYGET k% RETURN KEYGET k% EDIT DATA JOHN DATA EBERHARD DATA PATRIK DATA MICHAEL DATA JOACHIM DATA TOM DATA PETER DATA PAT DATA SVEN DATA FRANK

Instr Command
'Instr - Rinstr - Txtlen //INSTR Find string within a string //RINSTR Find string within a string //TEXTLEN Center a text string on the screen OPENW #1 FULLW #1 a$ = "This text should be centered on the screen." x& = _X / 2 - TXTLEN(a$) / 2 TEXT x&,100,a$ // INSTR Find a string residing in another string // search for b$ b$ = "centered" c% = INSTR(a$,b$) c$ = MID$(a$,c%,LEN(b$)) PRINT "Using INSTR ";b$;" ";"found at position ";c% x& = _X / 2 - TXTLEN(c$) / 2 TEXT x&,116,c$ // RINSTR - Returns position from start of string // search for b$ b$ = "screen" c% = RINSTR(a$,b$) PRINT "Using RINSTR ";b$;" ";"found at position ";c% KEYGET k% CLOSEW #1

Key Codes
'=>>Codes : Scan & Key /* Scan & ASCII Codes /* by Bev Brown /* Apr.10/93 ' OPENW #1 SETFONT OEM_FIXED_FONT ? AT(30,0);"Press any key!" DO SLEEP IF MENU(11) = WM_KEYDOWN a| = LOBYTE(HIWORD(MENU(13))) b| = MENU(12) ? AT(1,2);"Menu(11)" ? AT(1,3);" Menu(13): " + STR$(a|,3) + SPACE$(10) ? AT(1,4);" Menu(12): " + STR$(b|,3) + SPACE$(10) ENDIF IF MENU(1) = 1 a| = HIBYTE(MENU(5)) b| = LOBYTE(MENU(5)) ? AT(1,6);"Menu(1)" ? AT(1,7);" Menu(5)-hibyte: " + STR$(a|,3) + SPACE$(10) ? AT(1,8);" Menu(5)-lobyte: " + STR$(b|,3) + SPACE$(10) ? AT(1,10);"CHR$ " + CHR$(b|) ENDIF UNTIL MENU(1) = 4 CLOSEW #1

Menu Charting
'Chart Menu DIM m$(20) m$(0)="FILE" m$(1)="Chart Demo" m$(2)="---------" m$(3)="Sort" m$(4)="Search" m$(5)="Save" m$(6)="--------" m$(7)="E_xit" m$(8)="" OPENW #1 FULLW #1 MENU m$() chart_menu() DO GET_EVENT IF (MENU(1)=20) && (MENU(0)) eval_menu() ENDIF EXIT IF aborted! LOOP CLOSEW #1 EDIT PROCEDURE eval_menu() ee_%=MENU(0) SELECT ee_% CASE 7 aborted!=TRUE OTHERWISE ENDSELECT RETURN PROCEDURE chart_menu() // possible menu actions listed below // MENU ITEM,ACTION TO TAKE,MENU STRING(ITEM) // ------------------------------------------- MENU 3,MF_CHECKED,m$(3) // put a check mark by item 3 [sort] MENU 4,MF_GRAYED,m$(4) // disabled but grey MENU 5,MF_GRAYED,m$(5) // possibles // MENU 2,MF_ENABLED,m$(2) // enables - removes gray if needed // MENU 2,MF_DISABLED.M$(2) // disabled but black // MENU 2,MF_GRAYED,M$(2) // disabled but grey // MENU 2,MF_SEPARATOR,M$(2) // dashed line, text$ is ignored // MENU 2,MF_MENUBREAK,M$(2) // two column menu, text$ is the next item // MENU 2,MF_MENUBARBREAK,M$(2) // as above but w/vertical separtor bar RETURN

Play Meta File
'Play Meta File do_meta(4) PROCEDURE do_meta(w&) // click cancel at file selector to end // Procedures Called [play_meta] [holdit3] OPENW #w& FULLW #w& TITLEW #w&,"CHOOSE .WMF FILE" // select a window META file DO FILESELECT "*.wmf","*.wmf",wmf$ EXIT IF wmf$ = "" IF LEN(wmf$) play_meta(w&) ENDIF LOOP CLOSEW #w& RETURN PROCEDURE play_meta(w&) OPENW #w& FULLW #w& DEFMOUSE 2 PLAYMETA wmf$ holdit3() DEFMOUSE 0 CLOSEW #w& RETURN PROCEDURE holdit3() mess$ = "Press Mouse Or Key" cntr& = _X / 2 - TXTLEN(mess$) / 2 TEXT cntr&,_Y - 40,mess$ DO k$ = INKEY$ UNTIL k$ <> "" || MOUSEK <> 0 RETURN

Progress Bar
'Progress Bar 'Neue CONTROLs unter Windows 95 / NT 4.0: Die Progressbar (Fortschrittsbalken) ' � September 1996, Roland Walter, Sch�nhauser Allee 64, D-10437 Berlin ' Progress-Bar-Botschaften: PBM_SETRANGE& = WM_USER + 1 //setzt Bereich (Voreinstellung: 0 bis 100) PBM_SETPOS& = WM_USER + 2 //setzt die Position PBM_DELTAPOS& = WM_USER + 3 //ver�ndert die Position um den angegebenen Wert PBM_SETSTEP& = WM_USER + 4 //setzt die Schrittweite (Voreinstellung: 10) PBM_STEPIT& = WM_USER + 5 //ver�ndert die Position um die eingestellte Schrittweite DLGBASE UNIT DIALOG #1, 50,50,140,105,"Progress Bar",DS_MODALFRAME | WS_POPUP | WS_CAPTION | WS_SYSMENU CONTROL "", 100, "msctls_progress", WS_CHILD | WS_VISIBLE | WS_BORDER, 10, 10, 130, 12 CONTROL "Auf Position 10 setzen", 201, "BUTTON", BS_PUSHBUTTON | WS_CHILD | WS_VISIBLE | WS_BORDER, 10, 30, 130, 12 CONTROL "Um 2 erh�hen", 202, "BUTTON", BS_PUSHBUTTON | WS_CHILD | WS_VISIBLE | WS_BORDER, 10, 45, 130, 12 CONTROL "Um 2 erniedrigen", 203, "BUTTON", BS_PUSHBUTTON | WS_CHILD | WS_VISIBLE | WS_BORDER, 10, 60, 130, 12 CONTROL "Per Timer steppen", 204, "BUTTON", BS_AUTOCHECKBOX | WS_CHILD | WS_VISIBLE, 10, 75, 130, 12 ENDDIALOG DLG FILL 1,RGB(192,192,192) SHOWDIALOG #1 ~SendMessage(DLGITEM(1,100), PBM_SETRANGE&, 0, MAKELONG(20,0)) //Bereich von 0 bis 20 festlegen ~SendMessage(DLGITEM(1,100), PBM_SETSTEP&, 1, 0) //Schrittweite von 1 festlegen DO GETEVENT IF MENU(11) = WM_COMMAND SELECT MENU(12) CASE 201 ~SendMessage(DLGITEM(1,100), PBM_SETPOS&, 10, 0) //Auf Position 10 setzen CASE 202 ~SendMessage(DLGITEM(1,100), PBM_DELTAPOS&, 2, 0) //Um 2 erh�hen CASE 203 ~SendMessage(DLGITEM(1,100), PBM_DELTAPOS&, -2, 0) //Um 2 erniedrigen CASE 204 IF CHECK?(1,204) = 1 SETTIMER DLG(1), 1,1000 //jede Sekunde eine WM_TIMER-Botschaft ELSE KILLTIMER DLG(1),1 ENDIF ENDSELECT ELSE IF MENU(11) = WM_TIMER ~SendMessage(DLGITEM(1,100), PBM_STEPIT&, 0, 0) //Einen Schritt h�her ENDIF UNTIL MENU(1) = 4 IF CHECK?(1,204) = 1 THEN KILLTIMER DLG(1),1 CLOSEDIALOG #1 END

Put and Get
'Get & Put // GET & PUT W& = 1 OPENW #W& FULLW #W& // MAKE WINDOW GRAY CLS 7 a% = GETSIZE(0,0,125,125) //CUT OUT A SQUARE GET 0,0,125,125,s$ //CLEAR SCREEN CLS 2 // DISPLAY CUTOUT SQUARE FOR i% = 10 TO 500 STEP 140 PUT i%,10,s$ PUT i%,160,s$ NEXT i% TEXT 10,290,"Using GET and PUT" KEYGET K% CLOSEW #W&

Random Access
'Random Access Files // RANDOM ACCESS FILE EXAMPLE OPENW #1,0,0,_X,_Y,~15 CLS //GOTO rede OPEN "R",#1,"test.dat",36 FIELD #1,24 AS name$,12 AS phone$ cnt% = 0 DO PRINT "Name :"; FORM INPUT 24,n$ EXIT IF n$ = "" PRINT "Phone :"; FORM INPUT 12,p$ LSET name$ = n$ LSET phone$ = p$ PUT #1,cnt% cnt% ++ CLS LOOP CLOSE #1 CLS rede: //read file OPEN "R",#1,"test.dat",36 FIELD #1,24 AS name$,12 AS phone$ cnt% = 0 WHILE NOT EOF(#1) GET #1,cnt% PRINT "Name :";name$ PRINT "Phone :";phone$ cnt% ++ WEND CLOSE #1 KEYGET k% CLOSEW #1 END

Rectangle
'Rectangle() FULLW #1 hdc& = _DC(1) hBrush& = GetStockObject(GRAY_BRUSH) ~SelectObject(hdc&,hBrush&) ~Rectangle(hdc&,40,40,400,300) KEYGET k% ~DeleteObject(hBrush&) CLOSEW #1 EDIT

Round Rectangle
'RoundRect() FULLW #1 HDC& = _DC(1) hBrush& = GetStockObject(GRAY_BRUSH) ~SelectObject(HDC&,hBrush&) ~Ellipse(HDC&,40,40,400,300) KEYGET k% ~Rectangle(HDC&,40,40,400,300) KEYGET k% CLS xleft = 40,ytop = 40,xright = 400,ybottom = 300 xcorner = (xright - xleft) / 4 ycorner = (ybottom - ytop) / 4 ~RoundRect(HDC&,xleft,ytop,xright,ybottom,xcorner,ycorner) KEYGET k% CLOSEW #1 EDIT

Select / Switch
'SELECT //SELECT & SWITCH OPENW #1 FULLW #1 PRINT "Choose Y or N" PRINT "Escape Aborts" DO K$ = UPPER$(INKEY$) // get key press SELECT K$ // select it CASE "Y" // if 'Y' pressed PRINT "Y CHOSEN" CASE "N" // if 'N' pressed PRINT "N CHOSEN" CASE 27 // if escape pressed ask if abort desired MESSAGE m$,"Abort Routine",MB_YESNO,r& SWITCH r& // Yes=6 No=7 CASE 6 // if 'YES' ABORTED! = TRUE // set abort flag OTHERWISE // if 'NO' forget it ENDSWITCH // end it OTHERWISE ENDSELECT // end it LOOP UNTIL ABORTED! CLOSEW #1 EDIT

Binary Search Routine
'Binary Search /* BINSRCH.LST windows /* Note: search array must be in sorted order OPENW #1 FULLW #1 _WIN$(WIN(1)) = "Binary Search" DIM a$(100) do_data() // create small amount of data binsrch_recs(a$,r%) // call binary search routine EDIT //*** S E A R C H F O R 1 R E C O R D *** //*********************************************** PROCEDURE binsrch_recs(a$,r%) //********************************************* searchagain: //LABEL-USE FOR ANOTHER SEARCH FOR i& = 0 TO r% PRINT a$(i&) NEXT i& LINE INPUT "Search Phrase: "; search$ //GET NAME TO SEARCH FOR AND search$ = UCASE$(search$) //MAKE SURE IT'S UPPER CASE @binsearch(a$, search$, r%) hdr2$ = LEFT$(hdr$,38) IF located% THEN 'If search phrase found then LOCATE 1,15 ? hdr2$ PRINT a$(f%);" found at array location ";f% ELSE LOCATE 1,10 ? hdr2$ COLOR 0,15 PRINT search$;" Not Found" //Tell user NOT found COLOR 15,1 ? SPACE$(LEN(hdr2$)) LOCATE 1,13 ? " Ex.:Smith, Robert[May Include Comma] ";CHR$(7) ENDIF LOCATE 1,18 PRINT "Search Again [Y\N]" DO k$ = UCASE$(INPUT$(1)) //Wait for users choice-change to upper case LOOP UNTIL k$ <> "" SELECT k$ //take action based on user selection CASE "Y" //If "Y" then CLS GOTO searchagain //do another search DEFAULT ENDSELECT CLOSEW #1 RETURN //*** B I N A R Y S E A R C H *** '************************************************ PROCEDURE binsearch (a$, search$,last%) //********************************************* begin% = 0 //Our array begins at the zero element located% = 0 //Set located variables to zero f% = 0 //Then do the search WHILE begin% <= last% AND NOT located% middle% = (begin% + last%) / 2 IF search$ = LEFT$(a$(middle%),LEN(search$)) located% = TRUE //if located%=-1(TRUE) we found it f% = middle% //at middle% so shared f% with main ELSE IF search$ > LEFT$(a$(middle%),LEN(search$)) begin% = middle% + 1 //Keep searching ELSE last% = middle% - 1 ENDIF WEND RETURN PROCEDURE do_data() WHILE _DATA READ a$(r%) r% ++ WEND DATA RASCOM DATA GBUG DATA INTEL DATA WINDOWS DATA MICROSOFT DATA BORLAND DATA APPLE DATA ATARI DATA COMPUSERVE DATA GENIE DATA PRODIGY DATA ZNET DATA GFA NET QSORT a$(),r% CLS RETURN

Search Mutiple Occurrencess
'Multi Binary Search // BSRCHALL.GFA // binary search for finding all occurences of the // searched-for phrase and their location in a // sorted array. // searches from 1st array character to len of search phrase // demo only DIM a$(100) rede_records() srch_recs(a$,r%) CLOSEW #1 EDIT // //*** S E A R C H F O R 1 R E C O R D *** //*********************************************** PROCEDURE srch_recs(a$,r%) //********************************************* OPENW #1 FULLW #1 LOCAL found!,begin%,search$ searchagain: //LABEL-USE FOR ANOTHER SEARCH CLS FOR i& = 0 TO r% PRINT a$(i&) NEXT i& fi% = 0 found! = FALSE // set found flag for anoher search LINE INPUT "Search Phrase: "; search$ //GET NAME TO SEARCH FOR AND search$ = UCASE$(search$) //MAKE SURE IT'S UPPER CASE begin% = 0 @binsearch(a$, search$,begin%,r%) IF found% THEN //If search phrase found then CLS PRINT a$(f%) found! = TRUE // set found flag fi% ++ s1% = f% - 1 // check array above f% s2% = f% + 1 // check array below f% IF f% > 0 WHILE LEFT$(a$(s1%),LEN(search$)) = LEFT$(a$(f%),LEN(search$)) PRINT a$(s1%) // show match if found fi% ++ s1% -- // decrement counter EXIT IF s1% < 0 // NOT -1 PLEASE WEND ENDIF WHILE LEFT$(a$(s2%),LEN(search$)) = LEFT$(a$(f%),LEN(search$)) PRINT a$(s2%) // show match if found fi% ++ s2% ++ //increment counter WEND ENDIF IF NOT found! CLS LOCATE 1,10 PRINT search$;" Not Found" //Tell user NOT found ? " Ex.:Smith, Robert[May Include Comma] ";CHR$(7) ENDIF LOCATE 1,12 PRINT fi%;" occurences of ";search$;" Found" LOCATE 1,13 PRINT "Search Again [Y\N]" DO k$ = UCASE$(INPUT$(1)) //Wait for users choice-change to upper case LOOP UNTIL k$ <> "" SELECT k$ //take action based on user selection CASE "Y" //If "Y" then GOTO searchagain //do another search DEFAULT ENDSELECT RETURN //*** B I N A R Y S E A R C H *** '************************************************ PROCEDURE binsearch (a$, search$,begin%,last%) //********************************************* begin% = 0 //Our array begins at the zero element found% = FALSE //Set located variables to zero f% = 0 //Then do the search WHILE begin% <= last% AND NOT found% middle% = (begin% + last%) / 2 IF search$ = LEFT$(a$(middle%),LEN(search$)) found% = TRUE //if found%=-1(TRUE) we found it f% = middle% //at middle% so shared f% with main ELSE IF search$ > LEFT$(a$(middle%),LEN(search$)) begin% = middle% + 1 //Keep searching ELSE last% = middle% - 1 ENDIF WEND RETURN PROCEDURE rede_records() WHILE _DATA READ b$ a$(r%) = UPPER$(b$) r% ++ WEND DATA gfa DATA gfa DATA gfa DATA gbug DATA gbug DATA rascom DATA rascom DATA gfa DATA gbug DATA rascom DATA genie DATA genie DATA genie DATA gbug DATA rascom QSORT a$(),r% // sort records before search PRINT "Any Key To Search" KEYGET k% RETURN

Set Cursor Position
'SetCursorPos() FULLW #1 DIM struct&(1) Print$ = "Press Left mouse for cursor position, right mouse to quit" + CHR$(0) Print2$ = "Notice that the mouse cursor position stays at 200,100" + CHR$(0) ~TextOut(_DC(1), 10, 10, V:Print$, LEN(Print$) - 1 ) ~TextOut(_DC(1), 10, 26, V:Print2$, LEN(Print2$) - 1 ) DO PEEKEVENT SWITCH MENU(11) CASE WM_LBUTTONDOWN @mpos CASE WM_RBUTTONDOWN aborted! = TRUE ENDSWITCH LOOP UNTIL aborted! CLOSEW #1 END PROCEDURE mpos ' set the cursor at 200, 100 when left mouse buuton pressed ~SetCursorPos(200,100) ~GetCursorPos(V:struct&(0)) mx& = struct&(0) my& = struct&(1) PRINT mx&, my& RETURN

Set Font Height
'Setting A Fonts Height FULLW #1 n& = 10 FOR i& = 8 TO 30 STEP 2 pointsz& = i& charh& = pointsz& * GETDEVCAPS(LOGPIXELSY) / 72 FONT HEIGHT -charh& TO hFnt& SETFONT hFnt& WINDGET (14),w& to$ = "Font Height " + STR$(w&) ~TextOut (_DC(1),10,n&,to$,LEN(to$)) ADD n&,w& NEXT i& SETFONT SYSTEM_FONT FREEFONT hFnt& ~TextOut(_DC(1),10,n& + 48,"Any Key",7) KEYGET k% CLOSEW #1 END

SetTextAlign
' ~SetTextAlign() FULLW #1 To$ = "Test for text alignment" + CHR$(0) ak$ = "any key to end" + CHR$(0) hwnd& = WIN(1) hdc& = GetDC(hwnd&) ~SetTextAlign(hdc&,TA_RIGHT | TA_BOTTOM) ~TextOut(hdc&,240,40,V:To$,LEN(To$) - 1) ~TextOut(hdc&,240,56,V:ak$,LEN(ak$) - 1) KEYGET k% ~ ReleaseDC(hwnd&,hdc&) CLOSEW #1 ' possibles //TA_NOUPDATECP (0) //TA_UPDATECP (1) //TA_LEFT (0) //TA_RIGHT (2) //TA_CENTER (6) //TA_TOP (0) //TA_BOTTOM (8) //TA_BASELINE (24)

Sound Command
' Sound Command // Bev Brown OPENW #1 whistle() CLOSEW #1 END PROCEDURE whistle LOCAL i% FOR i% = 0 TO 2 SOUND 3000,0.5 PAUSE 1 NEXT i% RETURN

Sorting With QSort
'Qsort OPENW #1,0,0,SUB(_X,10),SUB(_Y,10),~15 DIM a$(20) DO UNTIL b$ = "END" READ b$ a$(r%) = UPPER$(b$) r% ++ LOOP DATA dale,dolores,andy,peri,ken,fran,russel,tim,mike,steve DATA END DEC r% DEC r% PRINT "UNSORTED" FOR i% = 0 TO r% PRINT a$(i%) NEXT i% COLOR 4 PRINT "PRESS ANY KEY" KEYGET K% PRINT "SORTED" QSORT a$(),r% FOR i% = 0 TO r% PRINT a$(i%) NEXT i% PRINT "Press Right Mouse Button" REPEAT GETEVENT UNTIL MOUSEK = 2 CLOSEW #1

SubMenu Addittion
//Appending A Submenu To a Menu Item ' adding a submenu to a menu item FULLW #1 WINDGET 14,cx% DIM menu$(50) FOR i& = 0 TO 50 READ menu$(i&) EXIT IF menu$(i&) = "**" NEXT i& MENU menu$() ' Create a POPUP menu for Open hPop& = CreatePopupMenu() ' add second submenu FOR i& = 0 TO 20 READ a$,Id& EXIT IF a$ = "**" flag& = MF_STRING IF a$ = "~" THEN flag& = MF_SEPARATOR ~AppendMenu(hPop&,flag&,Id&,a$) NEXT i& ' Add popup to submenu #1 'Edit' (counting starts at 0) hSub& = GetSubMenu(GetMenu(WIN(WIN())),0) ~ModifyMenu(hSub&,2,MF_STRING | MF_BYCOMMAND | MF_POPUP,hPop&,menu$(2)) DO GET_EVENT ch% = MENU(0) IF MENU(1) = 20 THEN @eval_menu(ch%) EXIT IF abort! LOOP CLOSEW #1 END PROCEDURE eval_menu(ch%) SELECT ch% CASE 5 abort! = TRUE CASE 111 'bmp @bmap CASE 112 @icon CASE 113 @cursor ENDSELECT RETURN ' Menu data DATA &File, &New, &Open, &Save,-, E&xit, DATA &Info, &About..., DATA ,,** ' Popup data for open DATA &Bitmap,111 DATA &Icon,112 DATA Cursor,113 DATA **,0 PROCEDURE bmap ~TextOut(_DC(1),10,cx% * 2,"Bitmap",6) PAUSE 20 CLEARW #1 RETURN PROCEDURE icon ~TextOut(_DC(1),10,cx% * 2,"Icon ",6) PAUSE 20 CLEARW #1 RETURN PROCEDURE cursor ~TextOut(_DC(1),10,cx% * 2,"Cursor",6) PAUSE 20 CLEARW #1 RETURN

TextOut
'TextOut() OPENW #1 Print$ = "From The GFAW Help File." + CHR$(0) Print2$ = "Mouse Exits!" + CHR$(0) ~TextOut(_DC(1), 10, 10, V:Print$, LEN(Print$) - 1 ) ~TextOut(_DC(1), 10, 26, V:Print2$, LEN(Print2$) - 1 ) DO LOOP UNTIL MOUSEK CLOSEW #1

TrackPopUpMenu
'CreateMenu ' activate by pressing right mouse button OPENW #1 ? "Right Mouse" pu& = CreatePopupMenu() FOR i& = 0 TO 4 ~AppendMenu(pu&,MF_STRING,i&,"Entry " + STR$(i&)) NEXT i& ~AppendMenu(pu&,MF_STRING,i&,"Exit " + STR$(i&)) DO GETEVENT IF _Mess = WM_RBUTTONDOWN ~TrackPopupMenu(pu&,0,MOUSESX,MOUSESY,0,WIN(1),0) ENDIF IF _Mess = WM_COMMAND ? MENU(12) Exit! = (MENU(12) = 5) ENDIF LOOP UNTIL Exit! || MENU(1) = 4 CLOSEW #1

Variable Types
//VARIABLES SIGN TYPE //--------------------------- // DOUBLE # 8 BYTES FLOATING POINT (ASSUMED) // LONG % 4 BYTES INTEGER (SIGNED) -2147483658/+2147483647 // WORD & 2 BYTES INTEGER (SIGNED) -32768/+32767 // BYTE | 1 BYTE INTEGER (UNSIGNED) 0-255 // BOOLEAN ! 1 BIT INTEGER (SIGNED) 0-FALSE/-1 TRUE // STRING $ 32767 MAX LEN

Window Font -Changeing
'Changing A Windows Font FULLW #1 dkgray& = GETNEAREST(128,128,128) ltyelo& = GETNEAREST(255,255,225) ltgray& = GETNEAREST(192,192,192) CLS ltgray& PRINT "Before SendMessage" SETFONT ANSI_FIXED_FONT FONT TO fntaff& SENDMESSAGE WIN(1),WM_SETFONT,fntaff&,0 a$ = "Testing Ansi Fixed Font" + CHR$(0) ~TextOut(_DC(1),0,40,V:a$,LEN(a$) - 1) a$ = "Press Any Key" + CHR$(0) COLOR dkgray&,ltyelo& ~TextOut(_DC(1),0,72,V:a$,LEN(a$) - 1) KEYGET k| CLOSEW #1 EDIT

WinHelp - Calling
'Window Help Format WEN_HELP() PROCEDURE WEN_HELP() OPENW #1 FULLW #1 //HLP$="C:\WINDOWS\GFAWIN\GFAWIN.HLP"+CHR$(0) hlp$ = "gfawhelp.hlp" + CHR$(0) F! = WinHelp(h&,V:hlp$,HELP_INDEX,d%) // ************* POSSIBLES ************** // HELP_INDEX ($0003) Display Index // HELP_CONTEXT ($0001) Display Topic in Topic // HELP_QUIT ($0002) Terminate Help // HELP_HELPONHELP ($0004) Display Help On Using Help // HELP_SETINDEX ($0005) Set The Current Index For Multi Index Help // HELP_KEY ($0101) Display Topic For Keyword in offabData // HELP_MULTIKEY ($0201) Display Topic For Keyword in Alternare Keyword Table CLOSEW #1 RETURN

Diagonal Fonts - Calling
'Diagonal Fonts //DIAGFONT.GFW //FULLW #1 MAIN() CLEAN_UP() KEYGET k% CLOSEW #1 EDIT PROCEDURE MAIN() OPENW #1,0,0,_X,_Y,1008 TITLEW #1,"FONTS" // CREATEMETA "diagfont.wmf" f$ = "GFA Basic Help Files" do_fonts1() do_fonts2() f$ = "Download it Today!" do_fonts3() f$ = "You'll Be Glad You Did!" DELAY 3 do_fonts4() BEEP //CLOSEMETA RETURN PROCEDURE do_fonts1() org& = system_font RFONT HEIGHT h&,WIDTH w& FONT "roman",ITALIC O,WEIGHT 1000,WIDTH w& * 2,HEIGHT h& * 10 FONT FAMILY FF_ROMAN,CHARSET OEM_CHARSET,PITCH FIXED_PITCH FONT ORIENTATION 0,STRIKEOUT 0,UNDERLINE 0,ESCAPEMENT 450 FONT ORIENTATION 0,ESCAPEMENT 450 FONT TO fnt& SETFONT fnt& COLOR 1 + 8 TEXT 5,220,f$ SETFONT system_font FREEFONT fnt& RETURN PROCEDURE do_fonts2() FONT "roman",ITALIC 0,WEIGHT 0,WIDTH w& * 2,HEIGHT h& * 10 FONT FAMILY FF_ROMAN,CHARSET OEM_CHARSET,PITCH FIXED_PITCH FONT ORIENTATION 0,STRIKEOUT 0,UNDERLINE 0,ESCAPEMENT -380 FONT TO fnt& SETFONT fnt& COLOR 2 + 8 TEXT 350,20,f$ SETFONT system_font FREEFONT fnt& RETURN PROCEDURE do_fonts3() FONT "roman",ITALIC 0,WEIGHT 0,WIDTH 8,HEIGHT 12 FONT FAMILY FF_ROMAN,CHARSET OEM_CHARSET,PITCH FIXED_PITCH FONT ORIENTATION 0,STRIKEOUT 0,UNDERLINE 1,ESCAPEMENT 0 FONT TO fnt& SETFONT fnt& COLOR 4 + 8 TEXT 210,210,f$ SETFONT system_font FREEFONT fnt& RETURN PROCEDURE do_fonts4() FONT "roman",ITALIC 0,WEIGHT 0,WIDTH 8,HEIGHT 12 FONT FAMILY FF_ROMAN,CHARSET OEM_CHARSET,PITCH FIXED_PITCH FONT ORIENTATION 0,STRIKEOUT 0,UNDERLINE 1,ESCAPEMENT 0 FONT TO fnt& SETFONT fnt& COLOR 5 + 8 TEXT 210,180,f$ SETFONT system_font FREEFONT fnt& RETURN PROCEDURE CLEAN_UP() SETFONT system_font FREEFONT fnt& RETURN

Mixed Fonts
'mixedfnt 'Fonts - Italic, Underline // Fonts OPENW #1 FULLW #1 change_fnt() do_fnt_uline() do_fnt_ital() do_fnt_ital2() SETFONT SYSTEM_FONT //back to normal CLOSEW #1 END PROCEDURE change_fnt() // read system character set org& = OEM_FIXED_FONT //use for different font look // org&=SYSTEM_FONT SETFONT org& GETFONT org& RFONT NAME p% //read font names //p$=CHAR{p%} // italic, otherwise as org& FONT ITALIC 1 TO fnt_i& // underlined, not italic FONT UNDERLINE 1,ITALIC 0 TO fnt_u& FONT UNDERLINE 0 ORG2& = FF_SCRIPT SETFONT ORG2& RFONT NAME P2% FONT ITALIC 2 TO Fnt2& FONT UNDERLINE 1,ITALIC 1 TO Fnt2& RETURN PROCEDURE do_fnt_uline() SETFONT fnt_u& PRINT "Testing Underline Font" FREEFONT fnt_u& RETURN PROCEDURE do_fnt_ital() SETFONT fnt_i& PRINT PRINT "Testing Italic Font" FREEFONT fnt_i& RETURN PROCEDURE do_fnt_ital2() SETFONT Fnt2& PRINT PRINT "Testing another font" FREEFONT Fnt2& KEYGET k% RETURN

Shadowed Fonts
'Shadowed & Outlined Fonts 'outline and shadowed fonts ' By Friedreich Rode TITLEW #1,"Outline und Shadowtext Demo" OPENW #1,0,0,_X,_Y,16 hdc& = GetDC(WIN(1)) @initmenu DO GETEVENT SELECT _Mess CASE WM_PAINT //Hat im urspr�nglichen Beispiel gefehlt.... IF Modus| = 1 @shadow ELSE IF Modus| = 2 @outline ENDIF CASE WM_COMMAND SWITCH _wParam CASE 100 ende| = 1 CASE 200 Modus| = 2 //wg. WM_PAINT erg�nzt CLS @neuerfont @outline CASE 300 Modus| = 1 //wg. WM_PAINT erg�nzt CLS @neuerfont @shadow ENDSWITCH ENDSELECT UNTIL ende| = 1 FREEFONT font& CLOSEW #1 PROCEDURE neuerfont DLG FONT 1,hdc&,CF_BOTH | CF_EFFECTS,0,0,0,"" ' // Gleich danach die Auswahl eines Fonts FONT TO font& // Den eben ausgew�hlten Font erzeugen RFONT NAME neuerfont% // Seinen Namen bestimmen und die ' // Auszeichnung CHAR{_EBX} (DLG FONT .....,"") n$ = CHAR{neuerfont%} + " - " + CHAR{_EBX} SETFONT font& // Font aktivieren RETURN ' PROCEDURE outline text$ = n$ + " Outline - Font" x% = _X / 2 - (TXTLEN(text$) / 2) //mittige Darstellung y% = _Y / 2 GRAPHMODE R2_COPYPEN,TRANSPARENT textspace% = 2 // Buchstabenabstand ~SetTextCharacterExtra(hdc&,textspace%) COLOR 0 // Outlinefarbe TEXT x% + 1,y%,text$ TEXT x%,y% + 1,text$ TEXT x%,y% - 1,text$ TEXT x% - 1,y%,text$ TEXT x% - 1,y% - 1,text$ TEXT x% + 1,y% + 1,text$ TEXT x% - 1,y% + 1,text$ TEXT x% + 1,y% - 1,text$ IF _ECX = 0 // wenn Textcolor=schwarz COLOR 255 // unschalten auf wei� sonst keine ELSE // Outline-darstellung RGBCOLOR _ECX ENDIF TEXT x%,y%,text$ FREEFONT font& // Font freigeben RETURN ' PROCEDURE shadow text$ = n$ + " Shadow - Font" x% = _X / 2 - (TXTLEN(text$) / 2) // mittige Darstellung y% = _Y / 2 tiefe% = 2 // Schattentiefe RGBCOLOR RGB(192,192,192) // Schattenfarbe TEXT x%,y%,text$ GRAPHMODE R2_COPYPEN,TRANSPARENT RGBCOLOR _ECX // Schriftfarbe TEXT x% - tiefe%,y% - tiefe%,text$ FREEFONT font& RETURN ' PROCEDURE initmenu bar& = CreateMenu() // Menuleiste ~AppendMenu(bar&,MF_STRING,100,"Ende") ~AppendMenu(bar&,MF_STRING,200,"Outline-Font") ~AppendMenu(bar&,MF_STRING,300,"Shadow-Font") ~SetMenu(WIN(1),bar&) RETURN

Font Sizes
'Font Sizes ' by Thomas Engel ' User determines all font values. This font is set up in memory, ' but is not actually accessed until the FONT TO command points to it. ' This program demonstrates the difference between character point size and character cell size ' I release this program to the public domain. Thomas G. Engel 10/18/96 OPENW #1 FULLW #1 PRINT "Choose any font" nm$ = "arial" FONT nm$ TO screenfont& SETFONT screenfont& DLG FONT 1,0,CF_BOTH | CF_EFFECTS | CF_INITTOLOGFONTSTRUCT,0,0,0,""// | CF_INITTOLOGFONTSTRUCT //choose font FONT TO screenfont& SETFONT screenfont& RFONT NAME p% RFONT HEIGHT lfHeight& n$ = CHAR{p%} + " - " + CHAR{_EBX} CLS PRINT "Chosen Font is ";n$ PRINT "Chosen Font point size is ";ROUND(ABS((72 * lfHeight&) / GETDEVCAPS(LOGPIXELSY))) WINDGET 14,ch% PRINT "Chosen Font cell size is ";ch% PRINT "Press any key to continue" KEYGET a% CLS TEXT 0,ch%,"The next FONT selection box will" TEXT 0,2 * ch%,"have the chosen font style highlighted." TEXT 0,3 * ch%,"Press any key to continue." KEYGET a% CLS PRINT "Cancel to End" DLG FONT 1,0,CF_BOTH | CF_EFFECTS | CF_INITTOLOGFONTSTRUCT FREEFONT screenfont& MESSAGE "Press to end program.","Font Demo",MB_OK,a CLOSEW #1

Setting A WIndows Font
'Setting a Window Font FULLW #1 dkgray& = GETNEAREST(128,128,128) ltyelo& = GETNEAREST(255,255,225) ltgray& = GETNEAREST(192,192,192) CLS ltgray& PRINT "Before SendMessage" SETFONT ANSI_FIXED_FONT FONT TO fntaff& SENDMESSAGE WIN(1),WM_SETFONT,fntaff&,0 a$ = "Testing Ansi Fixed Font" + CHR$(0) ~TextOut(_DC(1),0,40,V:a$,LEN(a$) - 1) a$ = "Press Any Key" + CHR$(0) COLOR dkgray&,ltyelo& ~TextOut(_DC(1),0,72,V:a$,LEN(a$) - 1) KEYGET k| SETFONT SYSTEM_FONT FREEFONT fntaff& CLOSEW #1 EDIT

Format Floppy
'Format Floppy 'format.lst FULLW #1 PRINT "close window when finished" @init @format DO GET_EVENT EXIT IF MENU(1) = 4 //close window to exit LOOP CLOSEW #1 END PROCEDURE format //Checks whether diskcopy.dll exists //Checks whether Shell32.dll exists IF EXIST(windir$ + "\system\shell32.dll") THEN found| = 1 //Checks whether rundll32.exe exists IF EXIST(windir$ + "\rundll32.exe") AND found| = 1 // if found, starts FormatDialog EXEC windir$ + "\rundll32.exe shell32.dll,SHFormatDrive","" found| = 0 ELSE // if not found // starts message found| = 0 MESSAGE sysfile$(0),"Warning",MB_ICONEXCLAMATION | MB_OK,n& ENDIF RETURN PROCEDURE init DIM sysfile$(14) sysfile$(0) = " Can not find SysFile " // Messagetext sysfile$(1) = "FormatDisk" // Format Disk sysfile$(2) = "DiskCopy" // Diskcopy buffer$ = SPACE$(255) // creates Buffer for 255 characters tchars& = GetWindowsDirectory(V:buffer$,255) // read the name of the WinDir windir$ = LEFT$(buffer$,tchars&) RETURN

Reading The Function Keys
'Reading The Function Keys //FUNCKEYS OPENW #1 FULLW #1 PRINT "TESTING FUNCTION KEY VALUES ESC. KEY EXITS" DO GET_EVENT IF MENU(11) = WM_KEYDOWN THEN EVALKEY EXIT IF MENU(12) = 27 LOOP CLOSEW #1 PROCEDURE EVALKEY M12& = MENU(12) SELECT M12& CASE VK_F1 PRINT "F1 PRESSED" CASE VK_F2 PRINT "F2 PRESSED" CASE VK_F3 PRINT "F3 PRESSED" CASE VK_F4 PRINT "F4 PRESSED" CASE VK_F5 PRINT "F5 PRESSED" CASE VK_F6 PRINT "F6 PRESSED" CASE VK_F7 PRINT "F7 PRESSED" CASE VK_F8 PRINT "F8 PRESSED" CASE VK_F9 PRINT "F9 PRESSED" // CASE VK_F10 ACTVATES GFA MENU // PRINT "F10 PRESSED" CASE VK_F11 PRINT "F11 PRESSED" CASE VK_F12 PRINT "F12 PRESSED" OTHERWISE PRINT "NOT A FUNCTION KEY" ENDSELECT RETURN

Show A Window Attributes
'WINDGET //WINDGET.LST OPENW #1,10,10,_X - 20,_Y - 20,-1 TITLEW #1,"WINDGET" WINDGET 0,ox% WINDGET 1,oy% PRINT "SOME WINDOW COORDINATES" PRINT "outer X coordinate is"'ox% PRINT "outer Y coordinate is"'oy% WINDGET 2,ow% WINDGET 3,oh% PRINT "the outer width of this window is "'ow% PRINT "the outer height of this window is "'oh% WINDGET 4,ix% WINDGET 5,iy% PRINT "the inner X coordinate is"'ix% PRINT "the inner Y coordinate is "'iy% WINDGET 6,ww% PRINT "the inner width of this window is "'ww% WINDGET 7,wh% PRINT "the inner height of this window is "'wh% WINDGET 14,ch% PRINT "font character height is ";ch% FOR i& = 12 TO 14 TEXT 1,i& * ch%,"text 1,i&*ch% prints here " NEXT i& KEYGET k% CLOSEW #1 OPENW #2 TITLEW #2,"USING WINDGET 6 TO CENTER" FULLW #2 WINDGET 6,ix% WINDGET 14,ch% a$ = "This should center text in any window" b$ = "Using WINDGET 6 For Centering Text In A Window" c% = ix% / 2 - TXTLEN(a$) / 2 TEXT c%,1 * ch%,a$ c% = ix% / 2 - TXTLEN(b$) / 2 TEXT c%,2 * ch%,b$ KEYGET k% CLOSEW #2 EDIT

WINDGET Examle #2
'POLLWING.LST ' WINDGET Example 'By Allan Shura 'Email: A_Shura@telus.net Neotrek Software Ltd. 2001 'may use freely with modification as needed 'If you are programming a project with multiple 'GFA windows #(handle 0-31) this should be helpful 'once the parameters are polled decisions can be 'made about the window. 'WINDGET reads GFA 16 window parameters. DIM WPara$(19) WPara$(0) = " 0 outer X-coordinate" WPara$(1) = " 1 outer Y-coordinate" WPara$(2) = " 2 outer width" WPara$(3) = " 3 outer height" WPara$(4) = " 4 inner X-coordinate" WPara$(5) = " 5 inner Y-coordinate" WPara$(6) = " 6 inner width" WPara$(7) = " 7 inner height" WPara$(8) = " 8 *WSET position of vertical slider (0..1000)" WPara$(9) = " 9 *WSET size of slider area" WPara$(10) = "10 *WSET position of horizontal slider (0..1000)" WPara$(11) = "11 *WSET size of slider area" WPara$(12) = "12 window attributes set with OPENW" WPara$(13) = "13 *WSET attributes of pressed window button" WPara$(14) = "14 character height (for example 8, 14, 16)" WPara$(15) = "15 character set address" WPara$(16) = "16 number of top window" WPara$(17) = "17 number of second to top window" WPara$(18) = "18 number of second to bottom window" WPara$(19) = "19 number of bottom window" //The asterisk indicates which parameters can be changed //with WINDSET. OPENW #1,20,20,400,400,-1 DIM wget_par&(19) TITLEW #1,"PARAMETERS for this GFA-BASIC WINDOW" FOR parm& = 1 TO 19 WINDGET parm&,wget_par&(parm&) //TEXT could be faster PRINT AT(1,parm&);wget_par&(parm&);AT(8,parm&);WPara$(parm&) NEXT parm& KEYGET a% CLOSEW #1

Using TRIM$
' TRIM$ OPENW #1 a$ = " Their are spaces in this string on both ends " a = LEN(a$) ? a$;"Len= ";a ? "After TRIM$" a$ = TRIM$(a$) MID$(a$,7,3) = "was" a = LEN(a$) ? a$;" Len now= ";a KEYGET k% CLOSEW #1

Using ZTRIM$
OPENW #1 ' ztrim$ strips chr$(0) from the end of a string a$ = " Hello GFA " + CHR$(0) PRINT a$ //prints ` Hello GFA ' PRINT TRIM$(ZTRIM$(a$)) //prints `Hello GFA' ? ZTRIM$(a$) KEYGET a% CLOSEW #1

Textout With A Different Font
OPENW #1 FULLW #1 hdc& = _DC(1) @screen_fonts f$ = "Testing Fonts" mess(f$,10,10) f$ = "Testing Textout" + CHR$(0) @mess(f$,10,26) KEYGET k% CLOSEW #1 SETFONT SYSTEM_FONT FREEFONT fnt_b& END PROCEDURE screen_fonts() org& = OEM_FIXED_FONT GETFONT org& SETFONT org& RFONT HEIGHT fh&,WIDTH fw& //read height and width FONT HEIGHT fh&,WEIGHT 200,WIDTH fw& TO fnt_b& SETFONT fnt_b& RETURN PROCEDURE mess(mess$,x&,y&) ~TextOut(hdc&, x&, y&, V:mess$, LEN(mess$) - 1 ) RETURN

Checking The Arrow Keys
OPENW #1,0,0,200,200,0 DO c$ = INKEY$ c = ASC(RIGHT$(c$)) SELECT c CASE &H48 PRINT "Up arrow was pressed" CASE &H50 PRINT "Down arrow was pressed" CASE &H4B PRINT "Left arrow was pressed" CASE &H4D PRINT "Right arrow was pressed" ENDSELECT LOOP UNTIL c = 27 PRINT "Finish !!!" PAUSE 10 CLOSEW #1

Paddin With Zeros
/************************************** /* When sorting a list of numbers they /* all need to be the same length /* This routine pads all numbers to /* 6 digits so all are the same length /************************************** OPENW #1 DIM a$(20) WHILE _DATA READ b$ a$(i) = b$ a$(i) = STRING$(6 - LEN(a$(i)), "0") + a$(i) i ++ WEND //DEC i QSORT a$(),i ? i;" Numbers zero Padded" FOR j = 0 TO i ? a$(j) NEXT j KEYGET k CLOSEW #1 DATA 7456,2250,221,822456,7406 DATA 2,8,24451,802020,24

Inserting Last 4 Files Into Your Menu
'=>>Inserting Last 4 Files Selected Into A Menu ' lastfile.lst ' shows last four files selected in menu and ' stores them in lastfile.ini when program exited ' by Dale Bryant & Bev Brown ' demo ttab$ = CHR$(9) prog$ = "Lastfile" FULLW #1 hWndMain& = WIN(1) @get_drive @Ini_Load @Init_Menu @Ini_Set WINDGET (14), x& DO GET_EVENT ch% = MENU(0) SELECT _Mess CASE WM_PAINT ~TextOut(_DC(1),10,x& * 5,V:sf$,LEN(sf$) - 1) ~TextOut(_DC(1),10,x& * 6,V:sf2$,LEN(sf2$) - 1) ~TextOut(_DC(1),10,x& * 7,V:sf3$,LEN(sf3$) - 1) ~TextOut(_DC(1),10,200,V:to$,LEN(to$) - 1) ~TextOut(_DC(1),10,x& * 10,V:ego$,LEN(ego$) - 1) ENDSELECT IF MENU(1) = 20 THEN eval_menu(ch%) EXIT IF MENU(1) = 4 || aborted! LOOP CLOSEW #1 END PROCEDURE get_drive LOCAL i% drv% = _DRIVE path$ = CHR$(drv%) + ":" + DIR$(0) IF RIGHT$(path$) <> "\" THEN path$ = path$ + "\" RETURN /* PROCEDURE eval_menu(sel%) ' buffer for last 4 files selected filebuf$ = SPACE$(150) SELECT sel% CASE MID_OPEN& @Load_file CASE MID_QUIT& @Ini_Save aborted! = TRUE CASE MID_LAST1& TO MID_LAST4& testfile$ = lastfiles$(sel% - MID_LAST1& + 1) DELETE lastfiles$(sel% - MID_LAST1& + 1) INSERT lastfiles$(1) = testfile$ pos& = (sel% - 101 ) @show_selection @Ini_Set ENDSELECT RETURN /* PROCEDURE show_selection /* ~GetMenuString(file_menu&,pos&,V:filebuf$,150,mf_pos%) ~TextOut(_DC(hWndMain&),10,216,"File Selected:",14) wipe$ = SPACE$(LEN(filebuf$)) filebuf$ = ZTRIM$(TRIM$(MID$(filebuf$,3))) to2$ = filebuf$ + CHR$(0) ~TextOut(_DC(hWndMain&),10,232,V:wipe$,LEN(wipe$) - 1) ~TextOut(_DC(hWndMain&),10,232,V:to2$,LEN(to2$) - 1) RETURN /* PROCEDURE Init_Menu LOCAL s& s& = GetSystemMenu(hWndMain&,FALSE) IF s& <> 0 ~ModifyMenu(s&,SC_CLOSE,MF_STRING,SC_CLOSE,prog$ + " Goodbye..." + ttab$ + "Alt+F4") ENDIF main_menu& = CreateMenu() file_menu& = CreatePopupMenu() MID_NEW& = 101, MID_OPEN& = 102 MID_LAST1& = 104, MID_LAST2& = 105, MID_LAST3& = 106, MID_LAST4& = 107 MID_QUIT& = 109 ~AppendMenu(file_menu&,MF_STRING,MID_NEW& , "&New") ~AppendMenu(file_menu&,MF_STRING,MID_OPEN&, "&Select File" + ttab$ ) //+ "F3") FOR i% = 1 TO 4 IF LEN(lastfiles$(i%)) > 0 IF i% = 1 THEN ~InsertMenu(file_menu&,4,MF_SEPARATOR | MF_BYPOSITION,NULL,NULL) a$ = "&" + STR$(i%) + " " + lastfiles$(i%) + CHR$(0) ~InsertMenu(file_menu&,4 + i%,MF_STRING,103 + i%,V:a$) flag! = TRUE ENDIF NEXT i% ~AppendMenu(file_menu&,MF_SEPARATOR,-1,"") ' put Exit on last in menu ~AppendMenu(file_menu&,MF_STRING,MID_QUIT&, "E&xit...") ~AppendMenu(main_menu&,MF_POPUP,file_menu&,"&Files") mf_pos% = MF_BYPOSITION sf$ = "If Menu Slots 1-4 are Empty Then Use Select File From Menu To Fill Slots." + CHR$(0) sf2$ = "LASTFILE.INI Will Be Created In Current Directory." + CHR$(0) sf3$ = "LASTFILE.INI will be updated on program exit." + CHR$(0) to$ = "Select Items 1 thru 4 From Menu To Display." + CHR$(0) ego$ = "Code by Bev Brown & Dale Bryant" + CHR$(0) ~SetMenu(hWndMain&,main_menu&) RETURN /* PROCEDURE Load_file FILESELECT #prog$,"*.*","*.*",fsel$ IF LEN(fsel$) testfile$ = fsel$ @File_AdjustFilter(testfile$) ENDIF RETURN /* PROCEDURE Ini_Set @Menu_ChangeText(file_menu&,MID_LAST1&,"&1 " + lastfiles$(1)) @Menu_ChangeText(file_menu&,MID_LAST2&,"&2 " + lastfiles$(2)) @Menu_ChangeText(file_menu&,MID_LAST3&,"&3 " + lastfiles$(3)) @Menu_ChangeText(file_menu&,MID_LAST4&,"&4 " + lastfiles$(4)) RETURN /* PROCEDURE Menu_ChangeText(menuindex&,itemindex&,newtext$) ~ModifyMenu(menuindex&,itemindex&,MF_STRING,itemindex&,newtext$) RETURN /* PROCEDURE Ini_Save // USER-DEF ' save or create lastfile.ini TRY OPEN "O",#2,path$ + prog$ + ".Ini" // PRINT #2 l��t files selected // could also do with WritePrivateProfileString ? #2;"" ? #2;"; -------------------------------------------------------------" ? #2;"; Ini-File for " + prog$ ? #2;"; Updated on " + DATE$ + " at " + MID$(TIME$,1,5) + " Hour" ? #2;"; By Dale Bryant & Bev Brown" ? #2;"; -------------------------------------------------------------" ? #2;"" ? #2;"[LastFiles]" ? #2;"File1=" + lastfiles$(1) ? #2;"File2=" + lastfiles$(2) ? #2;"File3=" + lastfiles$(3) ? #2;"File4=" + lastfiles$(4) ? #2;"" CLOSE #2 CATCH BEEP RETURN /* PROCEDURE Ini_Load // USER-DEF 'if lastfile.ini exist then load it DIM lastfiles$(4) FOR t% = 1 TO 4 lastfiles$(t%) = "" NEXT t% ini_success! = FALSE IF !EXIST(path$ + prog$ + ".Ini") THEN EXPROC TRY OPEN "I",#2,path$ + prog$ + ".Ini" WHILE !EOF(#2) INPUT #2,a$ a$ = TRIM$(a$) IF LEN(a$) > 0 AND LEFT$(a$,1) <> ";" AND LEFT$(a$,1) <> "[" i% = INSTR(a$,"=") IF i% > 0 THEN // FOUND IT a1$ = LOWER$(MID$(a$,i% - 1,1)) a2$ = MID$(a$,i% + 1) lastfiles$(VAL(a1$)) = a2$ ENDIF ENDIF WEND CLOSE #2 ini_success! = TRUE CATCH RETURN /* PROCEDURE File_AdjustFilter(testfile$) LOCAL t%,i%,ext$,a1$ i% = 0 FOR t% = 4 DOWNTO 1 IF lastfiles$(t%) = "" THEN i% = t% NEXT t% IF i% = 0 INSERT lastfiles$(1) = testfile$ ELSE IF i% = 1 THEN ~InsertMenu(file_menu&,4,MF_SEPARATOR | MF_BYPOSITION,NULL,NULL) lastfiles$(i%) = testfile$ a$ = "&" + STR$(i%) + " " + lastfiles$(i%) + CHR$(0) ~InsertMenu(file_menu&,4 + i%,MF_STRING,103 + i%,V:a$) ENDIF @Ini_Set RETURN

Free Memory
'GetFreeMemory() ' getmemry.lst 'Source code is from // sysinfo.gfw // Michael K. Kroeger 26 May 93 // Declare Windows API calls. DIM msg$(30) DLL #1, "kernel" DECL DWORD GetFreeSpace( w ) DECL DWORD GetWinFlags( ) DECL DWORD GlobalCompact( l ) DECL DWORD LocalCompact( l ) ENDDLL DLL #2, "user" DECL WORD GetFreeSystemResources( w ) ENDDLL FULLW #1 Memory() FOR i&=0 TO lastline& TEXT 0,i&*20,msg$(i&) NEXT i& DO PEEKEVENT SELECT MENU(1) CASE 4 aborted!=TRUE ENDSELECT LOOP UNTIL aborted! CLOSEW #1 END PROCEDURE Memory MemFree% = INT( ^GetFreeSpace( 0 ) / 1024 ) InitGbl% = INT( ^GlobalCompact( 0 ) / 1024 ) InitLcl% = INT( ^LocalCompact ( 0 ) / 1024 ) VOID ^LocalCompact( 10000000 ) VOID ^LocalCompact( 10000000 ) VOID ^GlobalCompact( MemFree% * 1024 ) VOID ^GlobalCompact( MemFree% * 1024 ) FinlGbl% = INT( ^GlobalCompact( MemFree% * 1024 ) / 1024 ) Flags% = ^GetWinFlags( ) Title$ = "RAM and CPU" // combine into 1 line msg$( 0 ) = "Free Resources: System = " + STR$( ^GetFreeSystemResources( 0 ) ) + " %, " // combine into 1 line msg$( 0 ) = msg$( 0 ) + "GDI = " + STR$( ^GetFreeSystemResources( 1 ) ) + " %, " // combine into 1 line msg$( 0 ) = msg$( 0 ) + "User = " + STR$( ^GetFreeSystemResources( 2 ) ) + " %" // combine into 1 line msg$( 1 ) = "Free Memory = " + STR$( INT( ^GetFreeSpace( 0 ) / 1024 ) ) + " KB" msg$( 2 ) = "" // combine into 1 line msg$( 3 ) = "Initial Contiguous Global Memory = " + STR$( InitGbl% ) + " KB" msg$( 4 ) = "Compacted Global Memory = " + STR$( FinlGbl% ) + " KB" msg$( 5 ) = "Local Global Memory = " + STR$( InitLcl% ) + " KB" msg$( 6 ) = "" IF Flags% AND WF_CPU286 THEN msg$( 7 ) = "CPU is an 80286" IF Flags% AND WF_CPU386 THEN msg$( 7 ) = "CPU is an 80386" IF Flags% AND WF_CPU486 THEN msg$( 7 ) = "CPU is an 80486" lastline& = 7 // combine into 1 line IF Flags% AND WF_80x87 THEN msg$( lastline& ) = msg$( lastline& ) + " with a Math Coprocessor" IF Flags% AND WF_PAGING THEN lastline& ++ msg$( lastline& ) = "Paged Memory is Present" ENDIF RETURN

Get Drive Type
'GetDriveType() ' getdriv.lst ' Source code is // from sysinfo.gfw // Michael K. Kroeger 26 May 93 // Declare Windows API call. DIM msg$(20) DLL #1, "kernel" DECL WORD GetDriveType( w ) ENDDLL FULLW #1 drives() FOR i& = 0 TO lastline& TEXT 0,i& * 20, msg$(i&) NEXT i& KEYGET K% FREEDLL 1 CLOSEW #1 END PROCEDURE drives Title$ = "Drives" lastline& = -1 FOR j% = 0 TO 25 SELECT ^GetDriveType( j% ) CASE DRIVE_REMOVABLE lastline& ++ msg$( lastline& ) = "Drive " + CHR$( 65 + j% ) + " is removable" CASE DRIVE_FIXED lastline& ++ msg$( lastline& ) = "Drive " + CHR$( 65 + j% ) + " is fixed with " // combine into 1 line msg$( lastline& ) = msg$( lastline& ) + STR$( INT( DFREE( 65 + j% ) / 1024 ) ) + " KB free" CASE DRIVE_REMOTE lastline& ++ msg$( lastline& ) = "Drive " + CHR$( 65 + j% ) + " is remote" DEFAULT ENDSELECT NEXT j% RETURN

Text In A Rectangle
OPENW #1 hdc& = _DC(1) hBrush& = GetStockObject(NULL_BRUSH) hPen& = GetStockObject(BLACK_PEN) ~SelectObject(hdc&,hBrush&) ~SelectObject(hdc&,hPen&) ~Rectangle(hdc&,40,40,400,300) to$ = "Text In A Rectangle" ~TextOut(hdc&,50,45,V:to$,LEN(to$)) KEYGET k% CLOSEW #1

Drawing A Bezier Curve
' Bezier /// Michael Sejfried // 05/19/2001 OPENW #1,0,0,640,480,0 RGBCOLOR RGB(255,255,0) PBOX 0,0,_X,_Y RGBCOLOR RGB(0,0,0) 'GOSUB Curve(100,150,300,50,218,400,250,320,32) 'CURVE 100,150,300,50,218,400,250,320 a = RANDOM(_X) b = RANDOM(_Y) c = RANDOM(_X) d = RANDOM(_Y) e = RANDOM(_X) f = RANDOM(_Y) g = RANDOM(_X) h = RANDOM(_Y) 'CURVE a,b,c,d,e,f,g,h GOSUB Curve(a,b,c,d,e,f,g,h,128) KEYGET a% CLOSEW #1 ' PROCEDURE Curve(x1,y1,x2,y2,x3,y3,x4,y4,Segments) IF Segments < 1 THEN EXPROC IF Segments > 128 THEN Segments = 128 mudelta = 1 / Segments mu = 0 tx1 = -x1 + 3 * x2 - 3 * x3 + x4 ty1 = -y1 + 3 * y2 - 3 * y3 + y4 tx2 = 3 * x1 - 6 * x2 + 3 * x3 ty2 = 3 * y1 - 6 * y2 + 3 * y3 tx3 = -3 * x1 + 3 * x2 ty3 = -3 * y1 + 3 * y2 xstart = x1 ystart = y1 mu = mu + mudelta FOR n = 1 TO Segments mu2 = mu * mu mu3 = mu2 * mu xend = ROUND(mu3 * tx1 + mu2 * tx2 + mu * tx3 + x1) yend = ROUND(mu3 * ty1 + mu2 * ty2 + mu * ty3 + y1) LINE xstart,ystart,xend,yend mu = mu + mudelta xstart = xend ystart = yend NEXT n RETURN

Array Fill	Array fill With A Value
Available Drives	Available Drives On System
Arrow Keys	Monitoring The Arrow Keys

Bezier Curve	Drawing A Bezier Curve
Bitmap Inflo	All Bitmap Information
Bitmap Load	Bitmap Loading And Displaying
Bitmap Load With User.dll	Bitmap Loading And Displaying Using USER.DLL
Bitmap Rotate	This Will Load and Rotate a Bitmap of Certain Sizes
Bload	Bloading A Data File
Bmove	Bmove a Block of Data
Browse	Bowsing For a Folder

*Calling .Hlp**	Calling A Programs Wnhelp .HLP File
CallBack	Using A CallBack Routine
Call NotePad	Calling NotePad Exe
CD Drive	Finding The Lettter Of Your CD Drive
Change To Caps	Capitalizing The The First Letter Of Each Word In A Strings
Change Cursor	Changing A Programs Cursor To A Different Shape (GFA 16)
Change Dialog	Changing a Dialogs Color
Chart Menu	Charting A Menu
CHAR{}	Using CHAR{}
Child Window	Creating A Child Window -Hi Mommy
Choose Font	Chooseing a New Font For Your Program
ClipBoard API	Using The ClipBoard API
ClipBoard API2	Another Example Of Using The ClipBoard API
ClipBoard	Copying To The ClipBoard
Copy Files Fast	Copy BIG Files :Very Fast
Create BItmap	Create A Compatible Bitmap (GFA)
Create Polygon	Create A Polygon Region (GFA)
Create Pop Menu	Create A PopUp Menu (GFA)

Delete Element	Deleting A Elemenet From A Array (GFA 16)
Dialog CallBack	Usin A CallBack For A Dialog (GFA 16)
Dialog Font	Changing Fonts In A Dialog Box (GFA 16)
Drive Type	Displaying The Type Of Drives On A System
DRAWTEXT	Using DRAWTEXT In (GFA 16)
Drive Ready	Checking If A Drive Is Ready
Dupe Disk	Duplicating A Floppy From GFA

EditBox Fonts	Changing Edit Box Fonts (GFA 16)
Edit Array	Editing A String Array (GFA 16)
Enum Fonts	Enumerate System Fonts (GFA 16)
Evaluate Key	Evaluate Key (F1-F12) (GFA 16)

FilesLast4	Inserting The Last Four FIles Accessed Into Your Menu
Fonts	Using GetStockObject For System Fonts (GFA 16)
Fonts- Diagonal	Displaying Diagonal Fonts (GFA 16)
Fonts- Mixed	Displaying Diagonal Fonts (GFA 16)
Fonts- Shadowed	Displaying Shadowed and Outlined Fonts(GFA 16)
Fonts- Sizes	Displaying Font Information
Fonts- Selecting	Selecting And Displaying Any Font (GFA 16)
Fonts- Setting	Selecting A New Windows Font
Format	Format A Floppy Disk-Full or Quick
Function Keys	Reading The Function Keys

Icon Dialog	Putting Icons In A Dialog Box (GFA 16) by Eberhard Funck
INSTR	Using The Instr Command (GFA 16)

Free Memory	Shows amount Of Free Memory
Menu Charting	Check Marking Menu Items (GFA 16)

Play Meta	Playing A Meta File From Disk
Progress Bar	Making A Progress Bar (Roland Walter)

Random Access	Random Access File Handling
Rectangle	Drawing A Rectangle
RoundRect	Drawing A Round RecTangle
Rectangle Text	Using Textout To Put Text In A Rectangle

Searching	A Fast Binary Search Routine
Searching Multiple	Searching For All Occurrences Of A Record With A Binary Search
Select Switch	Using SELECT or SWITCH
Set Cursor	Setting The Cursors Position
Set Font	Setting The Height Of A Font
Set Text	Setting The Alignment Of Text
Sound	The SOUND Command
Sub Menu	Adding A SubMenu To A Menu

TextOut	Using TextOut Instead Of PRINT To Display Text
TextOut2	Using TextOut With A Different Font
TrackPopUpMenu	Using TrackPopUpMenu For A PopUp Menu
TRIM$	Using TRIM To Remove Spaces From Both Ends Of a String
Type Array	Using a TYPE Array For Strings

WINDGET	Using WINDGET to Find A Windows Attributes
WINDGET2	Using WINDGET to Find A Windows Attributes by Alan Shura
Window Help	Displaying A Windows .HLP File
Window Fonts	Windows Fonts

Zeropad	Padding A String WIrh Zeros
ZTRIM$	Trimming Chr$(0) From A String With ZTRIM$