B2B Code Show
This issue we have two bits of handy code from one coder by the name of D M J Cronje, and two from Kiyote Wolf. Both snippets from Cronje were written in QB 4.5 but should compile in FBlite or QB64. Kiyote's code was written for FreeBASIC.
INCBOUND.BAS
'This snippet demonstrates how to keep an
'increment or decrement within certain bounds
'It can be used for any other routine where an Inc or Decr is required. See
'the left and right arrow code
'A One liner - No IF..Then..END IF
'This code keeps the cursor between Row 1-24 and Column 1-80
'It can be used for any value requiring a limit
'Up, Down, Left, Right Arrows plus the following keys used as diagonal keys
'End (DownLeft), PgDn (DownRight), PgUp (UpRight), Home (UpLeft)
'When the diagonal keys reach Row 1 or 24 then they will go left or right
'until the Column limits are reached, (1-80).
'PLEASE NOTE Plus "+" actually does a minus and Minus "-" does a plus.
'Author : D M J Cronje
'Licence GPL - Which just means give
'me some credit as this is the source code.
'Freeware
'Based on a SUB from my program SHABRU.BAS (c) 1998 in QB4.5
'for completion of a fullscreen data page containing 28 fields.
' *********** End of Comments ************************************
DECLARE SUB PrintIt () 'Print a happy face
DIM SHARED Row%, Col% 'Shared for use in SUB PrintIt
SCREEN 12 'Set SCREEN
WIDTH 80, 25 'Set Screen 80 Columns,25 Rows
COLOR 14, 1 'Yellow on Blue background
CLS 'Clear the SCREEN
LOCATE , , 0 'Switch the cursor off
Row% = 12: Col% = 40
LOCATE Row%, Col%: PRINT CHR$(2); 'start at centre of Screen
LOCATE 25, 30: PRINT " Press Esc to Stop "; 'Message for user
'********** THE MAIN MODULE ***********************************
DO
GetIn$ = "" 'No problems with Inkey$
DO
GetIn$ = INKEY$ 'wait for a user key
LOOP UNTIL GetIn$ <> "" 'LOOP WHILE GetIn$="" causes problems
'It clears the buffer and then
'Continues not waiting for a key Press
'This way it waits
COLOR 0, 1
LOCATE Row%, Col%
PRINT " "; 'Delete happy face (old row,col)
SELECT CASE GetIn$ 'process the key
CASE CHR$(0) + CHR$(80) 'Down Arrow
Row% = Row% - (Row% < 24) 'Plus 1. Stops at 24
PrintIt 'Print happy face
CASE CHR$(0) + CHR$(72) 'Up arrow
Row% = Row% + (Row% > 1) 'Minus 1. Stops at 1
PrintIt
CASE CHR$(0) + CHR$(77) 'Right Arrow
Col% = Col% - (Col% < 80) 'Plus 1. Stops at 80
PrintIt
CASE CHR$(0) + CHR$(75) 'Left arrow
Col% = Col% + (Col% > 1) 'Minus 1. Stops at 1
PrintIt
CASE CHR$(0) + CHR$(73) 'PagUp ( Diagonal UpRight)
Row% = Row% + (Row% > 1)
Col% = Col% - (Col% < 80)
PrintIt
CASE CHR$(0) + CHR$(71) 'Home (Diagonal UpLeft)
Row% = Row% + (Row% > 1)
Col% = Col% + (Col% > 1)
PrintIt
CASE CHR$(0) + CHR$(79) 'End (Diagonal LeftDown)
Row% = Row% - (Row% < 24)
Col% = Col% + (Col% > 1)
PrintIt
CASE CHR$(0) + CHR$(81) 'PgDn (Diagonal RightDown)
Row% = Row% - (Row% < 24)
Col% = Col% - (Col% < 80)
PrintIt
END SELECT
LOOP UNTIL GetIn$ = CHR$(27) 'Exit if Esc pressed
RESET
CLOSE
END
SUB PrintIt
COLOR 14, 1 'Yellow on Blue BackGround
LOCATE Row%, Col%
PRINT CHR$(2); 'Print a happy face at the new co-ordinates
END SUB
Download it here.
MENUAROW.BAS
'A Menu program with highlights and up/Down arrow keys
'Programmed in QB4.5
'Freeware : Open source
'Licence GPL. Meaning give me credit, nothing else, this is the source.
'Snippet name MenuArow.BAS
'Author D M J Cronje
'This snippet demonstrates : How to use Arrow keys, CALL, SHARE
'CONST, DIM a STRING to a Fixed length
'It also shows how to CALL a SUB with or without using CALL
'The Menu Box size is calculated and the Box is centralized on the screen
REM $DYNAMIC 'Best utilization of memory for arrays
DEFINT A-Z
DECLARE SUB SenterTxt (YPos%, Senter$)
DECLARE SUB ChoiceGet (RowBeg, RowEnd)
DECLARE SUB ChoiceShow (Max)
DECLARE SUB FrameBox (BeginRow%, BeginKol%, EndRow%, EndKol%)
DECLARE SUB FrameScreen (Heading$)
DIM SHARED Choose$, Heading$, Author$, Choice$ 'SHARED between all SUBs
DIM SHARED Maks
CONST RowBeg = 6 'Begin Row - Offset
'Begin Col is calculated
OPTION BASE 1 'Set arrays to start at 1
'--------------------- Messages --------------------------------
Choose$ = " Press the letter of your choice or use Up/Down ArrowKey+Enter"
Author$ = " By D M J Cronj‚ "
'-------------------- MENU CHOICES -------------------------------
'The Max STRING length is 74 chars: Due to Offset and Box size
'MenuBox width is calculated using the STRING length
Maks = 6 'Number choices & Rows. Pos of MenuBox limits Max to 16
REDIM SHARED MENUS(Maks) AS STRING * 31 'Fixed Length of Menu item
'use length of longest item
MENUS(1) = " Input new member's data" 'A
MENUS(2) = " Change/view a member's data" 'B
MENUS(3) = " Make changes on the whole list" 'C
MENUS(4) = " Delete an entry" 'D
MENUS(5) = " Restore an entry" 'E
MENUS(6) = " Exit the program" 'F
1 :
'--------------------- Start/Restart here --------------------------------
RESET 'In case there are open files
CLOSE
SCREEN 0 'Set SCREEN, Width, Initial colors
WIDTH 80, 25
COLOR 14, 1 'Yellow on blue
CLS
'---------------------- PRINT THE MENU -----------------------------
Heading$ = " Sharleen Club Records " 'Set and reset the original Heading
COLOR 14, 1
FrameScreen Heading$ 'Call a SUB without using CALL
CALL ChoiceShow(Maks) 'Call a SUB using CALL
'---------------------- GET THE CHOICE -----------------------------
ChoiceGet RowBeg, Maks 'CALL SUB passing values by reference
'-------------------- PROCESS THE CHOICE ---------------------------
LOCATE , , 1 'Switch cursor back on
Gto = ASC(Choice$) - 64 'Convert A-F to 1-5
Heading$ = MENUS(Gto) 'Set heading to Choice
'------------------- GOTO THE CHOSEN MODULE ------------------------
'ON Gto GOTO MA, MB, MC, MD, ME, MF
'REMmed out to prevent errors
'Change the above labels to meet your requirements.
'----------------- YOUR CODE/MODULES GO HERE ----------------------
' GOTO 1 'Restart after Choice was processed
'--------- THE NEXT LINES ONLY CONFIRM YOUR CHOICE ---------
Chose:
CLS
PRINT "Your choice was : " + Choice$ + " -" + MENUS(Gto)
PRINT
PRINT "Press any key to continue"
SLEEP
CLOSE
RESET
END
'-------------------- END OF MAIN MODULE ----------------------------
REM $STATIC
SUB ChoiceGet (RowBeg, RowEnd)
LOCATE , , 0 'Cursor Off:Use highlights instead
'---------- KEEP ORIGINAL POSITIONS AND SET UP LIMITS ----------
OldRow = RowEnd 'Old POS for highlights &
RowEnd = RowEnd + 5 'restore limits etc
OldRow = RowEnd
Row = RowEnd
BegBox = 40 - (LEN(MENUS(1)) + 3) \ 2 'Calculate Box Begin Col
KolEnd = LEN(MENUS(1)) 'Calculate Box End Col
'---------- SET STARTING CHOICE TO "EXIT THE PROGRAM" ----------
COLOR 15, 2 'Highlight, White on Green
LOCATE RowEnd, BegBox + 3 '+ 3 is a Box Pos Offset
PRINT MENUS(RowEnd - 5); '- 5 is a Row Pos OffSet
'---------- GET KEYBOARD INPUT ----------
DO
Choice$ = ""
Choice$ = UCASE$(INKEY$) 'Change input to upper case
SELECT CASE Choice$
CASE "A" TO "F" 'Allow only "A" to "F"
EXIT DO
CASE CHR$(13) 'Chose a Highlighted item &
Choice$ = CHR$(Row + 65 - RowBeg) 'Converts Row to letter
EXIT DO
CASE CHR$(0) + CHR$(80) 'Down Arrow
IF Row = RowEnd THEN Row = RowBeg - 1 'Wraps to first Row
Row = Row - (Row < RowEnd) 'Plus 1 until Row=RowEnd
CASE CHR$(0) + CHR$(72) 'Up arrow etc.
IF Row = RowBeg THEN Row = RowEnd + 1 'Wraps to end Row
Row = Row + (Row > RowBeg) 'Minus 1 until Row=RowBeg
END SELECT
'---------- HIGHLIGHT THE ROW ----------
SELECT CASE Row
CASE RowBeg TO RowEnd
IF OldRow <> Row THEN 'Arrow Key was pressed
COLOR 15, 2 'Highlight. White on Green
LOCATE Row, BegBox + 3
PRINT MENUS(Row - 5); 'Print highlighted item
COLOR 14, 1 'Normal colours. Yellow on Blue
LOCATE OldRow, BegBox + 3
PRINT MENUS(OldRow - 5); 'Remove highlight
END IF
OldRow = Row
END SELECT
LOOP
COLOR 14, 1 'Reset to Yellow on Blue
LOCATE , , 1 'Switch cursor on
END SUB
SUB ChoiceShow (Max)
'---------- Calculate Box Size and then draw the box ----------
FixedLen = LEN(MENUS(1)) + 3
BegBox = 40 - (FixedLen \ 2) 'calculatye MenuBox start Col
LastCol = FixedLen + BegBox 'The size of the Box
LastRow = RowBeg + Max
CALL FrameBox(RowBeg - 1, BegBox - 1, LastRow, LastCol)
'---------- Print the Menu items ----------
FOR i = 1 TO Max
LOCATE i + 5, BegBox + 3 'Initial Row=i + Offset of 5 &
PRINT MENUS(i); 'Calculated Col + Offset of 3
NEXT
COLOR 0, 7 'Black on low White
FOR i = 1 TO Max
LOCATE i + 5, BegBox
PRINT " "; CHR$(i + 64); " "; 'Print A etc in front of items
NEXT
LOCATE 24, 10: PRINT Choose$; 'How to choose message
COLOR 14, 1 'Reset colour to yellow on blue
END SUB
SUB FrameBox (BeginRow, BeginKol, EndRow, EndKol)
' ÚÄ¿ Print Box using block graphics
' ÀÄÙ
BoxWide = EndKol - BeginKol + 1 'Calculate width of Box
'Print top row Ú Ä ¿
LOCATE BeginRow, BeginKol
PRINT CHR$(218); STRING$(BoxWide - 2, CHR$(196)); CHR$(191);
'Print sides of Box ³
FOR a = BeginRow + 1 TO EndRow - 1
LOCATE a, BeginKol
PRINT CHR$(179); TAB(EndKol); CHR$(179);
NEXT a
'Print bottom row À Ä Ù
LOCATE EndRow, BeginKol
PRINT CHR$(192); STRING$(BoxWide - 2, CHR$(196)); CHR$(217);
END SUB
SUB FrameScreen (Heading$) STATIC
RANDOMIZE TIMER
Vul$ = STRING$(78, (INT(RND * 28) + 98)) 'Randomize a Char to PRINT in Box
COLOR 0, 11
FrameBox 1, 1, 3, 80 ' Draw a Box at top of screen
FrameBox 23, 1, 25, 80 ' Draw a Box at bottom of screen
LOCATE 2, 2: PRINT Vul$; ' Fill Box with a letter
LOCATE 24, 2: PRINT Vul$;
COLOR 14, 11
SenterTxt 2, Heading$ ' CALL From within a SUB i.e replace a Gosub
COLOR 14, 1 ' in a SUB etc. (Preferred way)
SenterTxt 4, Author$
END SUB
SUB SenterTxt (YPos, Centre$) STATIC
LOCATE YPos, 41 - (LEN(Centre$) \ 2) ' Centre text on a 80 column screen
PRINT Centre$;
END SUB
Download it here
Polygon plotting routine
Kiyote has this to say about this chunck of code:
This is a routine I hatched awhile ago.
Since we are passing a bunch of point data to the routine to draw our n-gon, I use my string method with the semicolon delimeters to separate individual values.
The FUNCTION GridMulti extracts values from a string of data encoded as such.
“3;20;20;30;30;40;40”
A string like that, passed to the DrawPolygon routine, would tell it 3 points, a triangle, and to put the points at (20,20), (30,30), and (40,40).
Obviously, if you add more ordered pairs, you increase the count, the first value in the list.
I’m sure this can be optimized, but I’m not big on optimization. Not that I don’t like it, just I’m not very good at it.
It draws the polygon, and then once over itself, shifted by one pixel, to close up any gaps. I could’ve increased the precision on the loop which scales the points, but instead I overlap the polygons to do the same job quicker.
~Kiyote!
declare sub DrawPolygon (PointsIn as string, ColrIn as longint)
declare function vert4(ByVal innr As integer) As String
declare function GridMulti(ByVal InChar As String, Cnt As Integer) As Integer
declare FUNCTION AngleOut (Angx1 as integer, Angy1 as integer, Angx2 as integer, Angy2 as integer) as double
FUNCTION AngleOut (Angx1 as integer, Angy1 as integer, Angx2 as integer, Angy2 as integer) as double
dim Rise as double, Runn as double
dim m as double
IF Angx1 = Angx2 AND Angy1 = Angy2 THEN AngleOut = 0: EXIT FUNCTION
rise = Angy2 - Angy1
runn = Angx1 - Angx2
IF Angx1 = Angx2 THEN
IF SGN(rise) = 1 THEN m = 0
IF SGN(rise) = -1 THEN m = 180
END IF
IF Angx1 = Angx2 THEN AngleOut = m: EXIT FUNCTION
IF Angx1 <> Angx2 THEN
m = ATN(rise / runn) * 57.296
IF SGN(runn) = -1 THEN
m = m + 180
END IF
END IF
IF m < 0 THEN m = m + 360
AngleOut = m
END FUNCTION
function GridMulti(ByVal InChar As String, Cnt As Integer) As Integer
Dim in2 As String, w As Integer, z As Integer
If InChar = "" Then Exit Function
'ex.: All entries must have a ; after numerics--one two or 3
z = InStr(InChar, ";")
Select Case Cnt
Case 0
in2 = InChar
Case Else
in2 = InChar
For z = 1 To Cnt
w = InStr(in2, ";")
in2 = Mid$(in2, w + 1)
Next z
End Select
'IF z THEN
GridMulti = Val(in2)
' ELSE
' GridMulti = -1
'END IF
End Function
function vert4(ByVal innr As integer) As String
Dim in2 As Long
in2 = CLng(innr)
vert4 = LTrim(Str(in2)) + ";"
End Function
sub DrawPolygon (PointsIn as string, ColrIn as longint)
REM cnt,x,y,x,y,x,y,x,y
dim ministeps as double
dim Nulll as integer
dim xctr as integer, yctr as integer
dim xin(20) as integer, yin(20) as integer, ang(20) as double, dist(20) as double
dim cntcnt as integer
cntcnt = GridMulti(PointsIn,0)
for Nulll = 1 to cntcnt
xin(Nulll - 1) = GridMulti(PointsIn, (Nulll - 1) * 2 + 1)
yin(Nulll - 1) = GridMulti(PointsIn, (Nulll - 1) * 2 + 2)
next Nulll
xctr = xin(0)
yctr = yin(0)
for Nulll = 2 to cntcnt
xctr = int((xctr + xin(Nulll - 1)) / 2)
yctr = int((yctr + yin(Nulll - 1)) / 2)
next Nulll
for Nulll = 1 to cntcnt
ang(Nulll - 1) = AngleOut(xin(Nulll - 1), yin(Nulll - 1), xctr, yctr)
dist(Nulll - 1) = sqr((xin(Nulll - 1) - xctr) ^ 2 + (yin(Nulll - 1) - yctr) ^ 2)
next Nulll
for ministeps = 0 to 1 step .001
line(xctr + cos(ang(0) / 57.296) * Dist(0) * ministeps, yctr - sin(ang(0) / 57.296) * Dist(0) * ministeps) - _
(xctr + cos(ang(1) / 57.296) * Dist(1) * ministeps, yctr - sin(ang(1) / 57.296) * Dist(1) * ministeps), ColrIn
for Nulll = 3 to cntcnt
line-(xctr + cos(ang(Nulll - 1) / 57.296) * Dist(Nulll - 1) * ministeps, yctr - sin(ang(Nulll - 1) / 57.296) * Dist(Nulll - 1) * ministeps), ColrIn
next Nulll
line-(xctr + cos(ang(0) / 57.296) * Dist(0) * ministeps, yctr - sin(ang(0) / 57.296) * Dist(0) * ministeps), ColrIn
line(xctr + cos(ang(0) / 57.296) * Dist(0) * ministeps + 1, yctr - sin(ang(0) / 57.296) * Dist(0) * ministeps) - _
(xctr + cos(ang(1) / 57.296) * Dist(1) * ministeps + 1, yctr - sin(ang(1) / 57.296) * Dist(1) * ministeps), ColrIn
for Nulll = 3 to cntcnt
line-(xctr + cos(ang(Nulll - 1) / 57.296) * Dist(Nulll - 1) * ministeps + 1, yctr - sin(ang(Nulll - 1) / 57.296) * Dist(Nulll - 1) * ministeps), ColrIn
next Nulll
line-(xctr + cos(ang(0) / 57.296) * Dist(0) * ministeps + 1, yctr - sin(ang(0) / 57.296) * Dist(0) * ministeps), ColrIn
next ministeps
for Nulll = 1 to cntcnt
pset(xin(Nulll-1), yin(Nulll-1)), rgb(255,255,255)
line(xin(Nulll-1)-1, yin(Nulll-1)-1)-(xin(Nulll-1)+1, yin(Nulll-1)+1), rgb(255,255,255), bf
next Nulll
end sub
screen 18,32
dim MaxScrnX as integer = 640
dim MaxScrnY as integer = 480
dim repeater as integer
dim Nul as integer
cls
dim polystrg as string
do
Repeater = int(rnd(1)*20)
polystrg = vert4(Repeater + 1) + vert4(int(rnd(1)*MaxScrnX))
polystrg = polystrg + vert4(int(rnd(1)*MaxScrnY))
for Nul = 0 to Repeater - 1
polystrg = polystrg + vert4(int(rnd(1)*MaxScrnX))
polystrg = polystrg + vert4(int(rnd(1)*MaxScrnY))
next Nul
DrawPolygon polystrg, rgb(int(rnd(1)*256), int(rnd(1)*256), int(rnd(1)*256)) 'RGBclrout24(11)
sleep
cls
loop until multikey(1)
Virtual 3rd Mouse Button
This is a virtual 3rd button, for the mouse.
You intercept the mouse, and if you register a right click, then you call this routine.
To use this ‘virtual’ 3rd mouse button, you have to hold the right mouse button, and while holding it, press the left mouse button, then release the right, THEN, finally release the left.
You pass over the possession of the mouse buttons, while the right is being held constant, you activate the left, then release the right, and finally let go of the left as well.
There is a shareware package, MVP Paint, which uses this, just in case the user doesn’t have a 3 button mouse.
When alot of DOS programs came out, there was various methods of dealing with what perhipherals the user had.
This give your user an extra functionality, without having to make the user let go of the mouse.
I used this, to let my user adjust a magnifying glass ball, changing the size with the left and right buttons. When the user wanted to actually place the effect against the background, he has to use the 3rd mouse button to active and drop the effect on the workspace.
~Kiyote!
dim shared MouseX as integer, MouseY as integer, MouseLeft as integer
dim shared MouseRight as integer
dim shared MouseFontX as integer, MouseFontY as integer
declare sub UpdateMouse
declare function TripleClick () as integer
sub UpdateMouse
dim MseX as integer, MseY as integer, MseB as integer, MseOk as integer
MseOk = GetMouse(MseX,MseY,,MseB)
if MseX = -1 then
MseX = 0
MseY = 0
MseB = 0
end if
MouseX = MseX
MouseY = MseY
MouseFontX = int(MseX / 4)+1
MouseFontY = int(MseY / 6)+1
If MseB And 1 Then
MouseLeft = -1
else
MouseLeft = 0
End If
If MseB And 2 Then
MouseRight = -1
else
MouseRight = 0
End if
sleep 1,1
End Sub
function TripleClick () as integer
TripleClick = 0
if MouseRight then
do
updatemouse
if (MouseLeft = 0) and (MouseRight = 0) then
TripleClick = -1
end if
if (MouseLeft <> 0) and (MouseRight <> 0) then
do
UpdateMouse
TripleClick = -2
loop until MouseLeft = 0
end if
loop until MouseRight = 0
end if
end function
dim Reusable as integer
screen 18
do
UpdateMouse
if MouseRight then
Reusable = TripleClick
if Reusable = -1 then print "Right Button"
if Reusable = -2 then print "Middle Button"
end if
loop until MouseLeft