Some were used in other Basics to speed up the print process for
screens and boxes. I see where I can
use them in FB also, so I made
copies in case others might be interested in them.
These first 3 routines does Block copy as do the last two. They will do the whole thing in one swoop, color
screen and all, without using any FORNEXT loops to process the characters and its colors one character at a time into
memory.
' For FreeBasic,
' You can use these launchers to Launch screens made with Conascii.
' Most launchers are generated with the screens made by Conascii, but here's a few more.
#Include Once "windows.bi"
Sub PCopys(Source As Integer, Dest As Integer)
Dim As Integer w = Width
Dim As Integer
row = w Shr 16, col = w And &HFFFF
Dim lpReadRegion As SMALL_RECT
Dim size As coord, ul
As coord
Static As String sBuffer(50) '= 50 pages
lpReadRegion.Right = col - 1
lpReadRegion.Bottom = row - 1
size.x = col+1 : size.y = row+1 : ul.x = 0 : ul.y = 0
If Source
= 1 Then
sBuffer(Dest) = Space((row+1) * (col+1) * 4)
ReadConsoleOutput(GetStdHandle(STD_OUTPUT_HANDLE), _
cast(CHAR_INFO Ptr,
Strptr(sBuffer(Dest))),_
size, ul, Varptr(lpReadRegion))
Else
WriteConsoleOutput(GetStdHandle(STD_OUTPUT_HANDLE),_
cast(CHAR_INFO Ptr, Strptr(sBuffer(source))),_
size, ul, Varptr(lpReadRegion))
End If
End Sub
'------------------------------------------------------------------
BSAVE
Sub Bsaves(FileN As String)
Dim
As Integer w = Width
Dim As Integer row = w Shr 16, col = w And &HFFFF
Dim sBuffer As String, lpReadRegion As SMALL_RECT
Dim size As coord, ul As coord, ff As
Integer
sBuffer = Space$((row+1) * (col+1) * 4)
lpReadRegion.Right
= col - 1
lpReadRegion.Bottom = row - 1
size.x = col+1
: size.y = row+1 : ul.x = 0 : ul.y = 0
ReadConsoleOutput GetStdHandle(STD_OUTPUT_HANDLE),
_
StrPtr(sBuffer), size, ul, Varptr(lpReadRegion)
ff = FreeFile
Open FileN For Binary As #ff
Put #ff,, sbuffer
Close #ff
End Sub
'------------------------------------------------------------------
BLOAD
Sub Bloads(FileN As String)
Dim As Integer
w = Width
Dim As Integer row = w Shr 16, col = w And &HFFFF
Dim sBuffer As String, lpReadRegion As SMALL_RECT
Dim length As Long, size As coord, ul
As coord
lpReadRegion.Right = col - 1
lpReadRegion.Bottom
= row - 1
size.x = col + 1 : size.y = row + 1 : ul.x = 0 : ul.y = 0
ff = FreeFile
Open FileN For Binary As #ff
sBuffer = Space$(Lof(ff))
Get #ff,, sBuffer
Close #ff
WriteConsoleOutput GetStdHandle(STD_OUTPUT_HANDLE), StrPtr(sBuffer), _
size, ul, Varptr(lpReadRegion)
End Sub
'---------------------------------------------------------
' Test program below
'---------------------------------------------------------
Dim As Integer w = Width
Dim As Integer row = w Shr 16, col = w And &HFFFF
Dim x As Long
Color 1, 11
For x = 1 To row ' Fill screen up with junk
Locate x, x * 2 - 2
Print "Row" + Str$(x);
Next
Locate row, col-2 : Print "END";
Sleep 2000
bsaves "test.bsa"
'Save the full screen to file
Cls: Locate 10, 1
Print " Erasing Screen and will display it back "
Sleep 3000
'Bloads should only be used on same width as it was
Bsaved
bloads "test.bsa" :Sleep 3000
'Put the full screen back
'-------------------------------------------------------
' doing Pcopy now
'-------------------------------------------------------
Locate 27, 20 : Print " This is page one copied back from page two "
pcopys 1, 2 : Cls : Sleep 2000 'Copy page 1 to page
2
pcopys 2, 1: Sleep 3000
'Copy page 2 to page 1
Locate 27, 20 : Print " This is page one copied back from page three "
pcopys 1, 3
: Cls : Sleep 2000
pcopys 3, 1 : Sleep 3000
Locate 27, 20 : Print " This is page one copied back from page Four "
pcopys 1, 4 : Cls : Sleep 2000
pcopys 4, 1 : Sleep 3000
Locate 27, 20 : Print " This is page one copied back from page Five "
pcopys 1, 5 : Cls : Sleep 2000
pcopys 5, 1 : Sleep 3000
______________________________________________________________________
GetKeys
Getkeys is a Routine that gives a Keynumber for each key you hit on
the
Keyboard. The ones that already uses Ascii numbers keeps those numbers,
but the rest are assigned a
special number, which you will have to hit
the key to see what it is in the test program. It also gives Mouse
Buttons
and locations.
I got the CVI example from off one of the forums, but I forgot where.
I use examples
similiar to it in other Basics. CVI(k$ + CHR$(0)) works
with QB, PBdos and PBCC .
Sub GetKeys (Keynumber As Integer, k As String, Rgt As Integer, _
Lft As Integer, cRow As Integer, cCol As Integer)
Dim buttons As Integer
Keynumber=0 : Rgt=0 : Lft=0 : cRow=0 : cCol=0
Locate 1, 1, 0
Do
GetMouse cCol, cRow,, buttons
If buttons And 1 Then lft = 1 : Exit Sub
If buttons And 2 Then Rgt = 1 : Exit
Sub
k = Inkey$
Sleep 1
Loop While k = ""
If Asc(k) > 31 And Asc(k) < 127 Then
keynumber = Asc(k)
ElseIf Asc(k) = 27 Then
keynumber =
27
ElseIf Asc(k) = 8 then
keynumber = 8
ElseIf Asc(k) = 9 Then
keynumber = 9
ElseIf Asc(k) = 13
Then
keynumber = 13
Else
keynumber = Cvi(k +k+ k+k) : Sleep 10
End If
End Sub
Dim As Integer kn, rt, lt, rw, cl
Dim ch As String
Do
GetKeys kn, ch, rt, lt, rw, cl
If rt Then Print " Right button", rw, cl
If lt Then Print " Left button" , rw, cl
If kn Then Print Kn , ch
Loop
Until kn = 27
End
Note: This was written for earlier versions of
Freebasic, Freebasic may now have better key getting routines.
_________________________________________________________________
' LocatePRINT tested with Freebasic 20
' use no compiler settings like -s Gui...etc
' Locate Print is about twice As fast As the regular Print, but it
' has to use the Windows API.
#include once "windows.bi"
Function LocatePrint(ByVal row As LONG, ByVal col As LONG, ByVal
_
fgColr As LONG, ByVal bgcolr As Long, Txt As String)As Long
dim Colr As Long, hStdOut As Long, ul As Coord
If FgColr=0 And BgColr = 0 Then FgColr =
7
Colr = BgColr * 16& + FgColr
ul.x = col : ul.y
= row
hStdOut = GetStdHandle(STD_OUTPUT_HANDLE)
WriteConsoleOutputCharacter
hStdOut, Txt, Len(Txt), ul, 0
FillConsoleOutputAttribute hStdOut, colr, Len(Txt), ul, 0
End Function
dim As long y, x, bgColr, fgColr, row, col
For y = 1 to 1000
For x = 1 to 20
bgColr=16
For
row = 1 to 25
For col = 1 to 79
Locate row, col: color fgcolr, bgcolr: Print Chr$(254);
bgcolr=bgcolr-1
fgcolr=fgcolr+1
If bgcolr = 0 Then bgcolr = 16
If fgcolr=16 Then fgcolr = 0
Next col
Next row
Locate 12, 29: color 15, 4: Print
"Regular Print"
Next x
' LocatePrint
For x = 1 to 20
bgcolr = 16
For
row = 1 to 25
For col = 1 to 79
Locateprint row, col, fgcolr, bgcolr,
Chr$(254)
bgcolr=bgcolr-1
fgcolr=fgcolr+1
If bgcolr = 0 Then bgcolr = 16
If fgcolr=16 Then fgcolr = 0
Next col
Next row
Locateprint 12, 44, 15, 4, " LocatePrint "
Next x
Next y
Sleep
__________________________________________________________________
TextGet, TextPut
TextGet will copy the whole area or screen and its colors into memory at one time. No fornext loops needed
to process single characters or its attributes into memory.
Sub TextPut (Lside As Long, Rside As Long, _
Top As Long,
Bottom As Long, scr As String)
Dim lpReadRegion As SMALL_RECT', sBuffer As String
Dim x As Long, y As Long, size As COORD, ul As COORD
lpReadRegion.Left = Lside - 1
lpReadRegion.Right = Rside - 1
lpReadRegion.Top = Top - 1
lpReadRegion.Bottom = Bottom- 1
size.x = Rside - Lside + 1
size.y = Bottom
- Top + 1
ul.x = 0 : ul.y = 0
'upper left
WriteConsoleOutput GetStdHandle(STD_OUTPUT_HANDLE), StrPtr(scr), _
size, ul, Varptr(lpReadRegion)
End Sub
Sub TextGet (Lside As Long, Rside As Long, _
Top As Long, Bottom As Long, sBuffer As String)
Dim lpReadRegion As SMALL_RECT
Dim x As Long, y As Long, size As COORD, ul As COORD
sBuffer = Space$((Rside-Lside)
* (Bottom-Top) * 4)
lpReadRegion.Left = Lside - 1
lpReadRegion.Right = Rside - 1
lpReadRegion.Top = Top
- 1
lpReadRegion.Bottom = Bottom- 1
size.x
= Rside - Lside + 1
size.y = Bottom - Top + 1
ul.x = 0 : ul.y = 0
' or for Write.
hStdOut = GetStdHandle(STD_OUTPUT_HANDLE)
ReadConsoleOutput
hSTDOUT, StrPtr(sBuffer), Size, ul, Varptr(lpReadRegion)
End sub
