frmgame.frm

Vsiual Basic编写的人工智能坦克游戏

         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   375
      Index           =   1
      Left            =   10080
      TabIndex        =   33
      Top             =   6240
      Width           =   1575
   End
   Begin VB.Label Label2 
      BackStyle       =   0  'Transparent
      Caption         =   "Random Method"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   255
      Index           =   0
      Left            =   10080
      TabIndex        =   32
      Top             =   5760
      Width           =   1575
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "Lives Remaining:"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   -1  'True
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   255
      Left            =   9840
      TabIndex        =   22
      Top             =   3240
      Width           =   1575
   End
   Begin VB.Shape Shape1 
      BorderStyle     =   6  'Inside Solid
      FillColor       =   &H00C0C000&
      FillStyle       =   0  'Solid
      Height          =   2055
      Left            =   9600
      Shape           =   4  'Rounded Rectangle
      Top             =   3120
      Width           =   1815
   End
   Begin VB.Image missright 
      Height          =   180
      Left            =   2205
      Picture         =   "frmGame.frx":C858
      Top             =   15
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image missleft 
      Height          =   180
      Left            =   2175
      Picture         =   "frmGame.frx":C922
      Top             =   195
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image missup 
      Height          =   480
      Left            =   1965
      Picture         =   "frmGame.frx":C9EB
      Top             =   30
      Visible         =   0   'False
      Width           =   180
   End
   Begin VB.Image missdown 
      Height          =   480
      Left            =   2640
      Picture         =   "frmGame.frx":CAC9
      Top             =   120
      Visible         =   0   'False
      Width           =   180
   End
   Begin VB.Label map 
      Appearance      =   0  'Flat
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   8055
      Left            =   60
      TabIndex        =   15
      Top             =   60
      Width           =   9135
   End
End
Attribute VB_Name = "frmGame"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim i, j As Integer
Dim gamestarted As Boolean
Dim dirplayer As Integer
Dim bombarray(100) As Integer
Dim bombcount As Integer

Public Sub getnextgrid(direct As Integer, indx As Integer)

 If direct = 1 Then
  getgrid block1(indx).left, block1(indx).top - gridheight
  nextgridx = grx + 1
  nextgridy = gry + 1
 End If
 If direct = 2 Then
  getgrid block1(indx).left + gridwidth, block1(indx).top
  nextgridx = grx + 1
  nextgridy = gry + 1
 End If
 If direct = 3 Then
  getgrid block1(indx).left, block1(indx).top + gridheight
  nextgridx = grx + 1
  nextgridy = gry + 1
 End If
 If direct = 4 Then
  getgrid block1(indx).left - gridwidth, block1(indx).top
  nextgridx = grx + 1
  nextgridy = gry + 1
 End If
 
If (nextgridx < 1) Or (nextgridx > 10) Or (nextgridy < 1) Or (nextgridy > 10) Then
 nextgridx = 0
 nextgridy = 0
End If
 
End Sub

Public Sub shoot(direct As Integer, indx As Integer)

 'Clone enemy missile picture according to indx
 load missileenemy(indx)
 
 'Set the correct picture for the missile
 'Up
 If direct = 1 Then
  missileenemy(indx).Picture = missup.Picture
 End If
 'Right
 If direct = 2 Then
  missileenemy(indx).Picture = missright.Picture
 End If
 'Down
 If direct = 3 Then
  missileenemy(indx).Picture = missdown.Picture
 End If
 'Left
 If direct = 4 Then
  missileenemy(indx).Picture = missleft.Picture
 End If
 
 'Places initial missile position
 'Up
 If direct = 1 Then missileenemy(indx).Move _
  block1(indx).left + (block1(indx).Width / 2) - (missileenemy(indx).Width / 2), block1(indx).top - _
  missileenemy(indx).Height - 30, missileenemy(indx).Width, _
  missileenemy(indx).Height
 'Right
 If direct = 2 Then missileenemy(indx).Move _
  block1(indx).left + block1(indx).Width + 30, block1(indx).top + _
  (block1(indx).Height / 2) - (missileenemy(indx).Height / 2), missileenemy(indx).Width, _
  missileenemy(indx).Height
 'Down
 If direct = 3 Then missileenemy(indx).Move _
  block1(indx).left + (block1(indx).Width / 2) - (missileenemy(indx).Width / 2), block1(indx).top + _
  block1(indx).Height + 30, missileenemy(indx).Width, _
  missileenemy(indx).Height
 'Left
 If direct = 4 Then missileenemy(indx).Move _
  block1(indx).left - missileenemy(indx).Width - 30, block1(indx).top + _
  (block1(indx).Height / 2) - (missileenemy(indx).Height / 2), missileenemy(indx).Width, _
  missileenemy(indx).Height
  
 missileenemy(indx).Visible = True
 PlaySound App.Path + "\sounds\shoot.wav", 0, SND_ASYNC
 
 load timmissileenemy(indx)
 timmissileenemy(indx).Enabled = True
 
End Sub
Public Sub gen2()
 
 rand2 = Int((10 * Rnd) + 1)
 
End Sub

Public Sub gen()
 
 rand = Int((5 * Rnd) + 1)
 
End Sub

Public Function readline(filename As String) As String
Dim descr As String

 Open filename For Input As #1
  Input #1, descr
 Close #1
 
 readline = descr
End Function
Public Sub getgrid(X As Integer, Y As Integer)

 grx = X \ block1(0).Width
 gry = Y \ block1(0).Height
 'indexnum = (gry * grdy) + grx

End Sub
Public Sub drawblocks()
 
 'Unloading any previous images
 If blockcount > 0 Then
  For i = 1 To blockcount
   Unload block1(i)
   tankleft.Visible = False
   tankup.Visible = False
   tankright.Visible = False
   tankdown.Visible = False
  Next
  blockcount = 0
 End If
 
 'Set height and width of each block
 block1(0).Width = map.Width / grdx
 block1(0).Height = map.Height / grdy
 gridwidth = block1(0).Width
 gridheight = block1(0).Height
 
 enemyind = 0
 'Set other properties of each block
 For j = 0 To grdy - 1
  For i = 0 To grdx - 1
   If mainarr(i + 1, j + 1) <> 3 Then
    blockcount = blockcount + 1
    load block1(blockcount)
    block1(blockcount).left = i * block1(0).Width + map.left
    block1(blockcount).top = j * block1(0).Height + map.top
    If mainarr(i + 1, j + 1) = 0 Then block1(blockcount).Picture = emptyblock.Picture
    If mainarr(i + 1, j + 1) = 1 Then block1(blockcount).Picture = wall1.Picture
    If mainarr(i + 1, j + 1) = 2 Then block1(blockcount).Picture = tank1pic.Picture
    block1(blockcount).Visible = True
    'Create array of enemy tank indexes
    If mainarr(i + 1, j + 1) = 2 Then
     block1(blockcount).AutoSize = True
     enemycount = enemycount + 1
     
     '' array of enemy tank indexes only:
     enemyind = enemyind + 1
     ReDim Preserve enemytank(1 To enemycount)
     ReDim Preserve enemyindexes(1 To enemyind)
     enemytank(enemycount) = blockcount
     enemyindexes(enemyind) = blockcount
     '' initialise enemy tracking array
     enemytrack(blockcount).direction = 1
     enemytrack(blockcount).distance = gridwidth
     enemytrack(blockcount).IndexOfTank = blockcount
    End If
    
   Else
    tankup.left = i * block1(0).Width + map.left
    tankup.top = j * block1(0).Height + map.top
    tankup.Visible = True
   End If
  Next
 Next
 
 ''Loads the enemy timers
 For i = 1 To enemyind
  load frmGame.timEnemy(enemyindexes(i))
 Next
 
End Sub

Private Sub aimethod_Click(Index As Integer)
 aimeth = Index
  
 If aimethod(Index).Picture = check.Picture Then Exit Sub
 
 If aimethod(Index).Picture = uncheck.Picture Then
  aimethod(Index).Picture = check.Picture
  
  If Index = 0 Then
   aimethod(1).Picture = uncheck.Picture
  Else
   aimethod(0).Picture = uncheck.Picture
  End If
  
 Else
  aimethod(Index).Picture = uncheck.Picture
  
  If Index = 1 Then
   aimethod(0).Picture = check.Picture
  Else
   aimethod(1).Picture = check.Picture
  End If

 End If
 
 Text1.SetFocus
 
End Sub


Private Sub avoid_Click()
 Text1.SetFocus
End Sub

Private Sub block1_GotFocus(Index As Integer)
 Text1.SetFocus
End Sub


Private Sub block1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
getgrid block1(Index).left + Int(X) - map.left, block1(Index).top + Int(Y) - map.top
'Text2.Text = str(grx + 1)
'Text3.Text = str(gry + 1)
'Text5.Text = str(Index)
End Sub

Private Sub blowupplayer_Timer()

 bombcount = bombcount + 1
 
 If bombcount = 1 Then
  tankup.Picture = LoadPicture(App.Path + "\pictures\tankexplode.bmp")
  tankright.Picture = LoadPicture(App.Path + "\pictures\tankexplode.bmp")
  tankdown.Picture = LoadPicture(App.Path + "\pictures\tankexplode.bmp")
  tankleft.Picture = LoadPicture(App.Path + "\pictures\tankexplode.bmp")
 End If
 
 If bombcount = 3 Then
  bombcount = 0
  If numlives = 0 Then
   tankup.Visible = False
   tankright.Visible = False
   tankdown.Visible = False
   tankleft.Visible = False
  End If
  tankup.Picture = LoadPicture(App.Path + "\myup2.gif")
  tankright.Picture = LoadPicture(App.Path + "\myright2.gif")
  tankdown.Picture = LoadPicture(App.Path + "\mydown2.gif")
  tankleft.Picture = LoadPicture(App.Path + "\myleft2.gif")
  blowupplayer.Enabled = False
 End If
 
End Sub

Private Sub cmdload_Click()
Dim arrdescr(1 To 223) As String
Dim counter As Integer
Dim j As Integer
Dim myfile As String

 '' Unloads previous enemy timers before loading scene
 For i = 1 To enemyind
  timEnemy(enemyindexes(i)).Enabled = False
  Unload timEnemy(enemyindexes(i))
 Next

myfile = Dir(App.Path + "\maps\*.map")

If myfile = "" Then
 MsgBox "No maps available", vbCritical
 Exit Sub
Else
 counter = counter + 1
 arrfile(counter) = myfile
 arrdescr(counter) = readline(App.Path + "\maps\" + myfile)
End If

Do
 myfile = Dir
 If myfile <> "" Then
  counter = counter + 1
  arrfile(counter) = myfile
  arrdescr(counter) = readline(App.Path + "\maps\" + myfile)
 End If
Loop Until myfile = ""

frmloadmap.lstMaps.Clear
For j = 1 To UBound(arrdescr)
 If arrdescr(j) <> "" Then frmloadmap.lstMaps.AddItem arrdescr(j)
Next

frmloadmap.Show vbModal

End Sub

Private Sub endgame_Click()
 endgame.Enabled = False
 start.Enabled = True
 cmdload.Enabled = True
 
 update.Enabled = False
 gamestarted = False
 Text1.SetFocus
 
 ''Disables the timers of the enemy tanks
 For i = 1 To enemyind
  timEnemy(enemyindexes(i)).Enabled = False
 Next
 
 Text1.SetFocus
 
End Sub

Private Sub exit_Click()
 
 '' Unloads previous enemy timers before exiting
 For i = 1 To enemyind
  timEnemy(enemyindexes(i)).Enabled = False
  Unload timEnemy(enemyindexes(i))
 Next
 
 'Unloading any previous images
 If blockcount > 0 Then
  For i = 1 To blockcount
   Unload block1(i)
   tankleft.Visible = False
   tankup.Visible = False
   tankright.Visible = False
   tankdown.Visible = False
  Next
  blockcount = 0
 End If
 
 End
 
End Sub


Private Sub Form_Activate()
 Text1.Enabled = False
 Text1.Visible = False
 Text1.Visible = True
 Text1.Enabled = True
 Text1.SetFocus
End Sub

Private Sub Form_Load()
 'block1(0).ZOrder (1)
 gamestarted = False
 aimeth = 0

End Sub

Private Sub Label2_Click(Index As Integer)
 Text1.SetFocus
End Sub

Private Sub map_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Text1.SetFocus
End Sub

Private Sub start_Click()