Make your own free website on Tripod.com
| Home | Ruff-In | MTutor | GradientFill | FB code | FBLoan | TW-Form | JaxGUI | Other DownLoads | PBCC Code | GW Code | Fix 2000/ XP | Text Screen Shots | QB code
FreeBasic Example Win Console Code

ConASCII


 Here's some routines that I wrote to use in the Windows Console only.
 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