module1.bas

本程序较为完整的编写了一个名为"潜水艇大战飞机"的游戏,对于想用VB编写游戏的人有辅助作用.

Attribute VB_Name = "Publics"
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal nXPos As Long, ByVal nYPos As Long) As Long
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Const SRCAND = &H8800C6
Public Const SRCPAINT = &HEE0086
Public Const SRCCOPY = &HCC0020



Public Type Coor
 X As Integer
 Y As Integer
 Act As Boolean
 Tag As Integer
End Type

Public Type Player
 X As Integer
 Y As Integer
 Ammo As Integer
 Dire As Byte
 Health As Integer
 Score As Long
 Speed As Currency
 Firetime As Currency
 Killed As Integer
End Type

Public Type SubMarine
 X As Integer
 Y As Integer
 Act As Boolean
 Score As Integer
 Dire As Integer
 Speed As Integer
 Damaged As Integer
End Type

Public Type DropBombs
 X As Integer
 Y As Integer
 Act As Boolean
 Speed As Currency
End Type

Public Type Bomber
 X As Integer
 Y As Integer
 Act As Boolean
 Dire As Integer
 Speed As Integer
 BombLoad As Integer
 Droped As Boolean
End Type

Public Type HighScore
 PlName As String
 plScore As Long
 plDate As String
End Type

Public Type PointsSign
 Score As Integer
 X As Integer
 Y As Integer
 Tag As Byte
End Type

Public Const Bredde As Integer = 400
Public Const Hoyde As Integer = 360
Public Const ShipBredde = 53
Public Const ShipHoyde = 14
Public Const SubBredde = 36
Public Const SubHoyde = 10
Public Const PlaneBredde = 29
Public Const PlaneHoyde = 12
Public Const MaxAmmo = 7
Public P1 As Player
Public Shot(1 To 30) As Coor
Public Subs(1 To 30) As SubMarine
Public HighS(1 To 10) As HighScore
Public Planes(1 To 10) As Bomber
Public Bombs(1 To 30) As DropBombs
Public Explo(1 To 10) As Coor
Public Signs(1 To 10) As PointsSign
Public TheKing As Coor
Public NumPlanes As Integer
Public NumSubs As Integer
Public NumShots As Integer
Public NumBombs As Integer
Public DontClose As Boolean
Public MainPause As Boolean


Public Function PlaySound(File As String)
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_LOOP = &H8
Const SND_NOSTOP = &H10
    wFlags% = SND_ASYNC Or SND_NODEFAULT
    Svar = sndPlaySound(App.Path & "\" & File & ".wav", wFlags%) 'Send the sound to the big world
End Function

Public Sub Fire() 'This is what happens when the player fires
Dim A As Integer
    
    If (GetTickCount - P1.Firetime) < 300 Then Exit Sub 'A delay of 300 millisec between each shot
    If P1.Ammo = 0 Then Exit Sub 'out of ammo, don't fire
    If NumShots = 30 Then Exit Sub 'to many bombs active, don't fire
    
    P1.Firetime = GetTickCount 'set time till next fire
    P1.Ammo = P1.Ammo - 1 'remove one in ammo
    NumShots = NumShots + 1 'add a shot to the counting variable
    
    
    A = 1
    Do Until Not Shot(A).Act 'find an open shot slot
        A = A + 1
    Loop
    
    With Shot(A)
        .Act = True 'atctivate it
        .Y = P1.Y + ShipHoyde 'put it at the bottom of the ship
        .X = P1.X + (ShipBredde / 2) 'an in the middle of it
    End With
End Sub

Public Sub MakeSub() 'Triggerd every tick, it makes subs
Dim A As Integer
    If NumSubs = 30 Then Exit Sub 'Too many subs are active
    If Boss.Act Then Exit Sub 'Don't create subs when at the boss
    
    Randomize
    temp = (Rnd * 130)
    If temp < 2 + 30 - NumSubs Then 'if a small chance occures it creats a sub
    
        NumSubs = NumSubs + 1 'adds a sub to the subcounter
        
        A = 1
        Do Until Not Subs(A).Act Or A = 30 'finds a free slot
            A = A + 1
        Loop
        
        With Subs(A)
        .Act = True 'activates the sub
        
        If Int((Rnd * 2) + 1) = 1 Then 'put's it eighter at the left or right side of the screen
            .X = 0 - SubBredde - 2
            .Dire = 2
        Else
            .X = Bredde + 2
            .Dire = 1
        End If
        
        .Y = Int((Rnd * 200) + 130) 'Give a random Y point to enter
        Randomize
        temp = Int((Rnd * 100) + 1) 'Give a random speed
        Select Case temp
        Case 80 To 100
            .Speed = 3
        Case 50 To 80
            .Speed = 2
        Case Else
            .Speed = 1
        End Select
        
        
        .Score = (.Speed * 2) * (.Y / 8) 'calculate score for killing sub using speed and depth
        
        End With
    End If
End Sub
Public Sub Movesubs() 'moves all the subs
    For A = 1 To 30
    With Subs(A)
        If .Act Then
        'M is the speed at which the subs move
        If .Dire = 2 Then M = .Speed 'going right
        If .Dire = 1 Then M = -1 * .Speed 'going left
        
        If .Damaged <> 0 Then 'if it's hit and sinking:
            .Damaged = .Damaged + 1
            .Y = .Y + 3
            If .Damaged = 10 Then 'sunk deep enough, deactivate
                .Damaged = 0
                .X = 0
                .Y = 0
                .Dire = 0
                .Act = False
            End If
        Else 'if not, move it
            .X = .X + M
        End If
        'Reach end of screen?
        If .X < 0 - SubBredde - 2 Or .X > Bredde + 2 Then
            .Act = False
            .Dire = 0
            .Score = 0
            .Speed = 0
            .Damaged = 0
            .X = 0
            .Y = 0
            NumSubs = NumSubs - 1
        End If
                    
        End If
    End With
    Next A
End Sub
Public Sub MovePlanes()
    For A = 1 To 10
    With Planes(A)
        If .Act Then
        
        If .Dire = 2 Then M = .Speed
        If .Dire = 1 Then M = -1 * .Speed
        
        .X = .X + M
        
        'Reach the edge
        If .X < 0 - PlaneBredde - 2 Or .X > Bredde + 2 Then
            .Act = False
            .Dire = 0
            .Speed = 0
            .Droped = False
            .X = 0
            .Y = 0
            .BombLoad = 0
            NumPlanes = NumPlanes - 1
        End If
                    
        End If
    End With
    Next A
End Sub
Public Sub MoveShots()
    For A = 1 To 30
        With Shot(A)
        If .Act Then
            .Y = .Y + 1.8
            
            'Hit a sub?
            HitSubCheck (A)
            
            If .Y >= Hoyde Then 'Reach the bottom?
                .Act = False
                .X = 0
                .Y = 0
                NumShots = NumShots - 1
            End If
        End If
        End With
        
        
        With Bombs(A) 'Bombs dropped from planes
        If .Act Then
            .Speed = .Speed - (.Speed * 0.1)
            .X = .X + .Speed
            .Y = .Y + 2
            
            HitShipCheck (A)
            
            If .Y >= 117 Then 'Reach surface, deactivate
                .Act = False
                .X = 0
                .Y = 0
                .Speed = 0
                NumBombs = NumBombs - 1
            End If
            
        End If
        End With
    Next A
    'The King
    If TheKing.Act Then
        TheKing.X = TheKing.X - 1
        If TheKing.X <= -24 Then 'Deactivate
            PlaySound "elvis"
            TheKing.Act = False
            TheKing.X = 0
            TheKing.Y = 0
            TheKing.Tag = 0
        End If
        If TheKing.Tag = 0 Then
            TheKing.Tag = 2
        Else: TheKing.Tag = TheKing.Tag - 1
        End If
        
        If Rnd > 0.98 Then PlaySound "elvis2"
    End If
End Sub

Public Sub HitSubCheck(M)
Dim Svar(1 To 4)
    
    Svar(1) = GetPixel(Form1.Pic2.hdc, Shot(M).X, Shot(M).Y)
    Svar(2) = GetPixel(Form1.Pic2.hdc, Shot(M).X + 6, Shot(M).Y)
    Svar(3) = GetPixel(Form1.Pic2.hdc, Shot(M).X + 6, Shot(M).Y + 6)
    Svar(4) = GetPixel(Form1.Pic2.hdc, Shot(M).X, Shot(M).Y + 6)
    For A = 1 To 4
        If Svar(A) <> vbWhite And Not Svar(A) = -1 Then
            'Check the boss
            If Boss.Act Then
                Select Case A
                Case 1