modmain.bas

一款飞机射击游戏的源代码

        For Cr = 1 To MaxMyBul
            If PlayMyBul(Cr).IndexR > 0 Then
                'If IsCrash(LObj.HdcBack, PObj.CurFps * LObj.Width + PlayMyBul(Cr).CurX + LoadMyBul(PlayMyBul(Cr).IndexR).Width \ 2 - PObj.CurX, PlayMyBul(Cr).CurY + LoadMyBul(PlayMyBul(Cr).IndexR).Height \ 2 - PObj.CurY) Then
                 If IsFpsCrash(LObj.HdcBack, PObj.CurX, PObj.CurY, LObj.Width, LObj.Height, PObj.CurFps, PlayMyBul(Cr).CurX, PlayMyBul(Cr).CurY) Then
                 
                    Call SetCrash(PlayMyBul(Cr).CurX, PlayMyBul(Cr).CurY)
                    Call SetCrash(PlayMyBul(Cr).CurX, PlayMyBul(Cr).CurY - LoadMyBul(PlayMyBul(Cr).IndexR).Height)
                    '注意playmybul还没有reset
                    PObj.CurLife = PObj.CurLife - LoadMyBul(PlayMyBul(Cr).IndexR).Power
                    
                    ScoreP(PlayMyBul(Cr).WhichPlayer) = ScoreP(PlayMyBul(Cr).WhichPlayer) + LoadMyBul(PlayMyBul(Cr).IndexR).Power * 9
                    PlayMyBul(Cr).IndexR = 0
                    
                    
'Debug.Print PlayMyBul(Cr).CurX, PlayMyBul(Cr).CurY,
                    
                    CrN = CrN + 1       '因为能同时打到同一个物体的子弹不会超过 15
                    If CrN = 15 Then Exit Sub
                End If
            End If
        Next Cr
        
End Sub
Public Sub CrashStaMybul(PSta As RunStaticObject, LSta As SaveStaticEObject)
    Dim SM As Byte
    Dim SMN As Byte
    Dim ToCrashed As Boolean
    For SM = 1 To MaxMyBul
        If PlayMyBul(SM).IndexR > 0 Then
            'Select Case RunEffect
            '    Case 1, 3
            If (LoadSta(PSta.IndexR).IsFlick Or LoadSta(PSta.IndexR).IsRotate) And RunEffect = 2 Then
                    ToCrashed = IsFpsCrash(LSta.HdcBack, PSta.CurX, PSta.CurY, CSng(LSta.RotateWidth), CSng(LSta.RotateWidth), ((PSta.CurAutoAngle + 720) Mod 360) \ 10, PlayMyBul(SM).CurX, PlayMyBul(SM).CurY)
            Else
                    ToCrashed = IsCrash(LSta.HdcBack, PlayMyBul(SM).CurX + LoadMyBul(PlayMyBul(SM).IndexR).Width \ 2 - PSta.CurX, PlayMyBul(SM).CurY + LoadMyBul(PlayMyBul(SM).IndexR).Height \ 2 - PSta.CurY)
            End If
            '    Case 2
            'End Select
            If ToCrashed Then
                
                Call SetCrash(PlayMyBul(SM).CurX, PlayMyBul(SM).CurY)
                Call SetCrash(PlayMyBul(SM).CurX, PlayMyBul(SM).CurY - LoadMyBul(PlayMyBul(SM).IndexR).Height)
                
                PSta.CurLife = PSta.CurLife - LoadMyBul(PlayMyBul(SM).IndexR).Power
                
                ScoreP(PlayMyBul(SM).WhichPlayer) = ScoreP(PlayMyBul(SM).WhichPlayer) + LoadMyBul(PlayMyBul(SM).IndexR).Power * 9
                PlayMyBul(SM).IndexR = 0
                
                
                SMN = SMN + 1
                If SMN = 15 Then Exit Sub
            End If
        End If
    Next SM
End Sub
Public Sub CrashObjPla(PObj As RunObject)
    Dim CP As Byte
        For CP = 1 To 2
            If IsLoadP(CP) And FlashFpsP(CP) = 0 Then
                '''在此只是粗略的检测
                'If IsCrash(LoadObj(PObj.IndexR).HdcBack, PObj.CurFps * LoadObj(PObj.IndexR).Width + CurMyXp(CP) - PObj.CurX, CurMyYp(CP) - PObj.CurY) Then
                If IsFpsCrash(LoadObj(PObj.IndexR).HdcBack, PObj.CurX, PObj.CurY, LoadObj(PObj.IndexR).Width, LoadObj(PObj.IndexR).Height, PObj.CurFps, CurMyXp(CP), CurMyYp(CP)) Then
                    PlayPla(CP).CurLife = PlayPla(CP).CurLife - LoadObj(PObj.IndexR).Life
                    PObj.CurLife = PObj.CurLife - LoadPla(CP).Life         '两个同时减
                    ''''''Call SetExplode(Curmyxp(WhPlayer), Curmyyp(WhPlayer))       '在drawplane时才用
                    Exit Sub
                End If
            End If
        Next CP
        
End Sub

Public Sub CrashStaPla(PSta As RunStaticObject)
    Dim SP As Byte
    Dim ToCrashed As Boolean
    For SP = 1 To 2                 ''注意在此只是调试，还没精确检测
        If IsLoadP(SP) And FlashFpsP(SP) = 0 Then
            'Select Case RunEffect
            '    Case 1, 3
            If (LoadSta(PSta.IndexR).IsFlick Or LoadSta(PSta.IndexR).IsRotate) And RunEffect = 2 Then
                    ToCrashed = IsFpsCrash(LoadSta(PSta.IndexR).HdcBack, PSta.CurX, PSta.CurY, LoadSta(PSta.IndexR).Width, LoadSta(PSta.IndexR).Height, ((PSta.CurAutoAngle + 720) Mod 360) \ 10, CurMyXp(SP), CurMyYp(SP))
            Else
                    ToCrashed = IsCrash(LoadSta(PSta.IndexR).HdcBack, CurMyXp(SP) - PSta.CurX, CurMyYp(SP) - PSta.CurY)
            End If
            '    Case 2
            'End Select
            If ToCrashed Then
                PlayPla(SP).CurLife = PlayPla(SP).CurLife - LoadSta(PSta.IndexR).Life
                PSta.CurLife = PSta.CurLife - LoadPla(SP).Life
                
    'Call SetCrash(PSta.CurX, PSta.CurY)
    ''''''''
                Exit Sub
            End If
        End If
    Next SP
    
End Sub


Public Sub CrashBulPla(PBul As RunBullet)

'Exit Sub

'**********************
    Dim BP As Byte
    
'Debug.Print PBul.CurX, PBul.CurY

        For BP = 1 To 2 '''''2
            If IsLoadP(BP) And FlashFpsP(BP) = 0 Then
                If IsFpsCrash(PlayPla(BP).HdcBack, PlayPla(BP).CurX, PlayPla(BP).CurY, LoadPla(BP).Width, LoadPla(BP).Height, PlayPla(BP).CurFps, PBul.CurX + LoadBul(PBul.IndexR).Width \ 2, PBul.CurY + LoadBul(PBul.IndexR).Height \ 2) Then
                    PlayPla(BP).CurLife = PlayPla(BP).CurLife - LoadBul(PBul.IndexR).Power
                    
                    ''''''
                    'FrmMain.Text1.Text = PlayPla(BP).CurLife
                    'If PlayPla(BP).CurLife <= 0 Then PlayPla(BP).CurLife = 40
                    ''''''''''''
                    'debug '此处有错
    'Debug.Print PBul.CurX, PBul.CurY
                    PBul.IndexR = 0
                    Call SetCrash(PBul.CurX, PBul.CurY)
                    Call SetExplode(PBul.CurX - 5 + Rnd * 10, PBul.CurY - 5 + Rnd * 10, 1)
                    Exit Sub
                End If
            End If
        Next BP
End Sub

Public Sub CrashPacPla(PPac As RunPac)
Dim PP As Byte
Dim CPacType As Byte
    For PP = 1 To 2
        If IsLoadP(PP) Then
            If IsFpsCrash(PlayPla(PP).HdcBack, PlayPla(PP).CurX, PlayPla(PP).CurY, LoadPla(PP).Width, LoadPla(PP).Height, PlayPla(PP).CurFps, PPac.CurX + LoadPac(PPac.IndexR).Width \ 2, PPac.CurY + LoadPac(PPac.IndexR).Height \ 2) Then
                ''''''debug
                Select Case LoadPac(PPac.IndexR).TypePac
                    Case 0 To 3
                        CPacType = IIf(LoadPac(PPac.IndexR).TypePac = 0, 1, LoadPac(PPac.IndexR).TypePac)
                        If PlayPla(PP).CurPower < 4 And PlayPla(PP).CurFireType = CPacType Then PlayPla(PP).CurPower = PlayPla(PP).CurPower + 1
                        PlayPla(PP).CurFireType = CPacType
                    Case 4
                        If PlayPla(PP).CurBombNum < 8 Then PlayPla(PP).CurBombNum = PlayPla(PP).CurBombNum + 1
                    Case 5
                        If PlayPla(PP).CurLife < LoadPla(PP).Life Then PlayPla(PP).CurLife = PlayPla(PP).CurLife + 1
                    Case 6
                        PlayPla(PP).CurLife = LoadPla(PP).Life
                End Select
                ScoreP(PP) = ScoreP(PP) + 1000
                If SoundPac = 0 Then SoundPac = 1: GameSound.PlaySound CStr(LoadPac(PPac.IndexR).Sound), 4
                PPac.IndexR = 0
                Exit Sub
            End If
        End If
    Next PP
    
End Sub





'*************************************************************************************************
Public Function IsCrash(HdcBC As Long, Px As Single, Py As Single) As Boolean
    If GetPixel(HdcBC, Px, Py) <= 0 Then
        IsCrash = False
    Else
        IsCrash = True
    End If
    'IsCrash = Not CBool(GetPixel(HdcBC, Px, Py))
End Function

Public Function IsFpsCrash(HdcBC As Long, SeatXbc As Single, SeatYbc As Single, Widthbc As Single, Heightbc As Single, CurFpsbc As Byte, Px As Single, Py As Single) As Boolean
    If Abs(Px - (SeatXbc + Widthbc \ 2)) > Widthbc \ 2 Then
        IsFpsCrash = False
    ElseIf Abs(Py - (SeatYbc + Heightbc \ 2)) > Heightbc \ 2 Then
        IsFpsCrash = False
    Else
        IsFpsCrash = IsCrash(HdcBC, (CurFpsbc - 1) * Widthbc + Px - SeatXbc, Py - SeatYbc)
    End If
    '用于多帧动画撞击检测
End Function

'因为各物体的画法不同,所以有多个
Public Sub BltObjToBuf(PObj As RunObject, LObj As SaveObject)
    BitBlt HdcViewBuf, PObj.CurX, PObj.CurY, LObj.Width, LObj.Height, LObj.HdcE, PObj.CurFps * LObj.Width, LObj.Height, SrcCopy
    BitBlt HdcViewBuf, PObj.CurX, PObj.CurY, LObj.Width, LObj.Height, LObj.HdcBack, PObj.CurFps * LObj.Width, LObj.Height, SrcScan
End Sub

Public Sub BltToBuf(HdcFore As Long, HdcBack As Long, SeatX As Single, SeatY As Single, WidthX As Single, HeightY As Single, Optional StartX As Single, Optional StartY As Single)
    BitBlt HdcViewBuf, SeatX, SeatY, WidthX, HeightY, HdcFore, StartX, StartY, SrcCopy
    BitBlt HdcViewBuf, SeatX, SeatY, WidthX, HeightY, HdcBack, StartX, StartY, SrcScan
    ''''''''''''''''''''''''''0000000000000000000000000'seaty
End Sub

Public Sub RotateToBuf(ByVal HdcE As Long, ByVal HdcBack As Long, ByVal SeatX As Single, ByVal SeatY As Single, ByVal WidthX As Single, ByVal HeightY As Single, ByVal MyAngle As Integer, ByVal MaskColor As Long, ByVal RotWid As Integer, Optional ByVal RotTimes As Integer = 360)
    '注意传入的是左上角位置，而不是中心位置
    Select Case RunEffect
        Case 1, 3
            FoxRotate HdcViewBuf, SeatX + WidthX \ 2, SeatY + HeightY \ 2, WidthX, HeightY, HdcBack, 0, 0, MyAngle, MaskColor, RunEffect ''BAD 'Good '
        Case 2
            MyAngle = ((MyAngle + 720) Mod RotTimes) \ 10
                        'CStaSeat = CStaSeat * LoadSta(PlaySta(CountA).IndexR).RotateWidth

            'MyAngle = (MyAngle \ 10) * 10
            BltToBuf HdcE, HdcBack, SeatX, SeatY, CSng(RotWid), CSng(RotWid), CSng(MyAngle * RotWid), 0
        
    End Select
End Sub

'''''''''''''''''''''''''''''''''''

Public Sub DrawMapToViewBuf()
Static DrawStartY As Integer
'Static SeatRndY As Integer
'Static SeatRndX As Integer
'Static CurRndPic As Byte

    BitBlt HdcViewBuf, 0, 0, Map.HeadMapFile.WidthTotal, DrawStartY, HdcMapRandom, 0, 480 - DrawStartY, vbSrcCopy
    BitBlt HdcViewBuf, 0, DrawStartY, Map.HeadMapFile.WidthTotal, 480 - DrawStartY, HdcMapRandom, 0, 0, vbSrcCopy
    If Not IsPaused Then
        'If MapSpeed = 0.5 Then
        '    Jk = (Jk + 1) Mod 4
        '    If Jk = 1 Then DrawStartY = DrawStartY + 1
        'ElseIf MapSpeed <> 0.5 Then
        '    DrawStartY = DrawStartY + Int(MapSpeed)
        'End If
        Select Case BackSpeed
            'Case 0
            Case 1
               If GameFps Mod 4 = 0 Then DrawStartY = DrawStartY + 1
            Case 2
                If GameFps Mod 2 = 0 Then DrawStartY = DrawStartY + 1
            Case 4
                DrawStartY = DrawStartY + 1
            Case 8
                DrawStartY = DrawStartY + 2
        End Select
    End If
            'If MapSpeed > 0 Then ' 0.5 '
            'SeatRndY = SeatRndY - 1
            'CurRndPic = IIf((SeatRndY = 0), 0, CurRndPic)
            'If CurRndPic > 0 Then Call DrawRandomPic(SeatRndY, SeatRndX, 480 - DrawStartY, CurRndPic)
            'End If
    If DrawStartY = 480 Then DrawStartY = 0
    'If DrawStartY Mod 120 = 0 Then
        'CurRndPic = Int(Rnd * MaxLoadRandom) + 1
        'SeatRndX = ((Int(Rnd * (Map.HeadMapFile.WidthTotal - 40)) + 40) \ 60) * 60
        'SeatRndY = PicRandom(CurRndPic).Height
    'End If
End Sub
Public Sub DrawBufToView()                                          ''debug
'Static LRX As Single
    BitBlt HdcView, 0, 0, Map.HeadMapFile.WidthShow, 480, HdcViewBuf, StartDrawX, 0, vbSrcCopy
End Sub
Public Sub LeftToRight(ByVal Mxx As Integer)
    If (IsLoadP(1) And Abs(PlayPla(1).CurX + LoadPla(1).Width \ 2 - (StartDrawX + Map.HeadMapFile.WidthShow \ 2)) > Map.HeadMapFile.WidthShow \ 2) Or (IsLoadP(2) And Abs(PlayPla(2).CurX + LoadPla(2).Width \ 2 - (StartDrawX + Map.HeadMapFile.WidthShow \ 2)) > Map.HeadMapFile.WidthShow \ 2) Then StartDrawX = Mxx + LR: Exit Sub
        If (IsLoadP(1) And IsKeyLeft(1)) Or (IsLoadP(2) And IsKeyLeft(2)) Then
            If LR > -Mxx Then LR = LR - 1                ' 0.5

        ElseIf (IsLoadP(1) And IsKeyRight(1)) Or (IsLoadP(2) And IsKeyRight(2)) Then
            If LR < Mxx Then LR = LR + 1 ' 0.5
        End If
    'LtoR = LR
    StartDrawX = Mxx + LR ' LtoR(StartDrawX0)
End Sub

Public Sub GetIsKey(ByVal WhP As Byte)
Static ResFps As Long
Dim GetSeat As POINTAPI
ResFps = (ResFps + 1) Mod 2
    If CtrlPlay(WhP) = 0 Then
        IsKeyLeft(WhP) = GetAsyncKeyState(KeyLeft(WhP))
        IsKeyRight(WhP) = GetAsyncKeyState(KeyRight(WhP))
        IsKeyUp(WhP) = GetAsyncKeyState(KeyUp(WhP))
        IsKeyDown(WhP) = GetAsyncKeyState(KeyDown(WhP))
        IsKeyFire(WhP) = GetAsyncKeyState(KeyFire(WhP))
        IsKeyBomb(WhP) = GetAsyncKeyState(KeyBomb(WhP))
    Else

        Call ResetKey(WhP)
        GetCursorPos GetSeat
        With GetSeat
            If .X < 315 Then
                IsKeyLeft(WhP) = True
            ElseIf .X > 325 Then
                IsKeyRight(WhP) = True
            End If
            If .Y < 235 Then
                IsKeyUp(WhP) = True
            ElseIf .Y > 246 Then
                IsKeyDown(WhP) = True
            End If
            .X = .X + Sgn(320 - .X)
            .Y = .Y + Sgn(240 - .Y)
        'SetCursorPos .X, .Y
        End With
    End If
    
    IsKeyFireHold(WhP) = GetAsyncKeyState(KeyFireHold(WhP))
End Sub

Public Sub ResetKey(ByVal WhP As Byte)
    IsKeyLeft(WhP) = False
    IsKeyRight(WhP) = False
    IsKeyUp(WhP) = False
    IsKeyDown(WhP) = False
    IsKeyFire(WhP) = False
    IsKeyFireHold(WhP) = False
    IsKeyBomb(WhP) = False

End Sub