KBdemo: Visual Basic Version

'*****************************************************************************
'                                                                            *
'  KBdemo.frm                                                                *
'                                                                            *
'  This program shows how to pan the contents of a virtual buffer through    *
'  a smaller window using the low-level keyboard handler.                    *
'                                                                            *
'*****************************************************************************
Const vbWidth = 640
Const vbHeight = 480
Dim hPal As Long
Dim hVB As Long
Dim cxClient As Long, cyClient As Long
Dim AppIsRunning As Boolean
Dim X As Long, Y As Long
Dim xLimit As Long, yLimit As Long
Dim CanGoLeft As Boolean, CanGoRight As Boolean
Dim CanGoUp As Boolean, CanGoDown As Boolean
Private Sub Form_Activate()
   Call fg_realize(hPal)
   Refresh
End Sub
Private Sub Form_Load()
   ScaleMode = 3
   Call fg_setdc(hDC)
   hPal = fg_defpal()
   Call fg_realize(hPal)
   Call fg_vbinit
   hVB = fg_vballoc(vbWidth, vbHeight)
   Call fg_vbopen(hVB)
   Call fg_vbcolors
   Call fg_showbmp(App.Path & "\PORCH.BMP", 0)
   X = 0
   Y = 0
   CanGoRight = True
   CanGoDown = True
   CanGoLeft = False
   CanGoUp = False
   Visible = True
   AppIsRunning = True
   While AppIsRunning
      DoEvents
      Call CheckForPanning
   Wend
End Sub
Private Sub Form_Paint()
   Call fg_vbpaste(X, X + (vbWidth - 1), Y, Y + (vbHeight - 1), 0, vbHeight - 1)
End Sub
Private Sub Form_Resize()
   cxClient = ScaleWidth
   cyClient = ScaleHeight
   If cxClient < vbWidth Then
      xLimit = vbWidth - cxClient
      If X > 0 Then CanGoLeft = True
      If X < xLimit Then CanGoRight = True
   Else
      xLimit = 0
      CanGoLeft = False
      CanGoRight = False
   End If
   If cyClient < vbHeight Then
      yLimit = vbHeight - cyClient
      If Y > 0 Then CanGoUp = True
      If Y < yLimit Then CanGoDown = True
   Else
      yLimit = 0
      CanGoUp = False
      CanGoDown = False
   End If
   Refresh
End Sub
Private Sub Form_Unload(Cancel As Integer)
   AppIsRunning = False
   Call fg_vbclose
   Call fg_vbfree(hVB)
   Call fg_vbfin
End Sub
'*****************************************************************************
'                                                                            *
' CheckForPanning()                                                          *
'                                                                            *
' The CheckForPanning subroutine checks if any of the four arrow keys are    *
' pressed, and if so, pans in that direction if possible. It is called from  *
' the message loop in Form_Load() when no messages are waiting.              *
'                                                                            *
'*****************************************************************************
Private Sub CheckForPanning()
   Const kbEscape = 1
   Const kbLeft = 75
   Const kbRight = 77
   Const kbUp = 72
   Const kbDown = 80
   If fg_kbtest(kbLeft) And CanGoLeft Then
      If X = xLimit Then CanGoRight = True
      X = X - 1
      Call fg_vbpaste(X, X + (vbWidth - 1), Y, Y + (vbHeight - 1), 0, vbHeight - 1)
      If X = 0 Then CanGoLeft = False
   ElseIf fg_kbtest(kbRight) And CanGoRight Then
      If X = 0 Then CanGoLeft = True
      X = X + 1
      Call fg_vbpaste(X, X + (vbWidth - 1), Y, Y + (vbHeight - 1), 0, vbHeight - 1)
      If X = xLimit Then CanGoRight = False
   ElseIf fg_kbtest(kbUp) And CanGoUp Then
      If Y = yLimit Then CanGoDown = True
      Y = Y - 1
      Call fg_vbpaste(X, X + (vbWidth - 1), Y, Y + (vbHeight - 1), 0, vbHeight - 1)
      If Y = 0 Then CanGoUp = False
   ElseIf fg_kbtest(kbDown) And CanGoDown Then
      If Y = 0 Then CanGoUp = True
      Y = Y + 1
      Call fg_vbpaste(X, X + (vbWidth - 1), Y, Y + (vbHeight - 1), 0, vbHeight - 1)
      If Y = yLimit Then CanGoDown = False
   ElseIf fg_kbtest(kbEscape) Then
      X = 0
      Y = 0
      Call fg_vbpaste(0, vbWidth - 1, 0, vbHeight - 1, 0, vbHeight - 1)
      If xLimit > 0 Then CanGoRight = True
      If yLimit > 0 Then CanGoDown = True
      CanGoLeft = False
      CanGoUp = False
   End If
End Sub