modrun.bas

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

Attribute VB_Name = "ModRun"
Option Explicit
Type RunEditBullet                  '只用于本模块中的测试运行
    NameRun As Integer
    CurSeatX As Single
    CurSeatY As Single
    CurSpeedX As Single
    CurSpeedY As Single
    CurAngle As Single
    CurType As Byte
End Type

Public NN As Integer
Public MM As Integer
Public KeepTime As Long
Public RunTime As Long
Public RectAll As RECT
Public R As RunObject
'Public ReSetR As RunObject
Public CurMouseX As Single
Public CurMouseY As Single
Public FoxMask() As Long
Public FoxMask2() As Long
Public MultiRunBul() As RunEditBullet

Public FireLoad() As SaveBullet    '在此只有一个物体运行，并且每个物体最多有三种子弹
Public OldHdcObject() As Long
Public NumBul As Integer
Public MskColorRun As Long


Public Function RunEditObject(ByVal Frm As Form, ByVal PicShow As PictureBox, ByVal PicCon As PictureBox, ByVal AllFps As Integer, ByVal DelayFps As Integer, ByVal Width As Single, ByVal Height As Single, ByVal MaskColor As Long, Optional ByVal ShowFps As Slider)
On Error Resume Next            '*************避免Erase FoxMask 时产生重复错误
    Static Wl As Long
    Static IsNeedRun As Boolean
    'If AllFps = 1 Then Exit Function
    If DelayFps <= 0 Then DelayFps = 1
    IsNeedRun = Not IsNeedRun:  If Wl = 0 Then Wl = Frm.hwnd
    RunTime = 20
    '***Init:
    PicShow.AutoRedraw = True
    ShowFps.Visible = CBool(AllFps - 1) ' True
    'R = ReSetR
    'Dim R As RunObject
    Dim RCurFps As Integer
    Dim RDelayFps As Integer
    
    If IsNeedRun And (Frm.hwnd = Wl) Then
        ReDim FoxMask(0 To AllFps - 1)
        For N = 0 To AllFps - 1
            FoxMask(N) = FoxxCreateFastMask(PicCon.Hdc, N * Width, 0, Width, Height, 0, 0, MaskColor, 1)
        Next N
    End If
    '***
        Do While IsNeedRun = True And (Frm.hwnd = Wl)
            '*添加代码*
            KeepTime = timeGetTime()
                'BitBlt PicShow.HDC, 0, 0, PicShow.ScaleWidth, PicShow.ScaleHeight, PicCon.HDC, R.CurFps * (RunObj.ESize.X + 1), 0, vbSrcCopy
                If RDelayFps = 0 Then
                    PicShow.Cls
                    FoxxFastMask PicShow.Hdc, 0, 0, FoxMask(RCurFps)
                        ShowFps.Value = RCurFps + 1
                        RCurFps = (RCurFps + 1) Mod AllFps
                End If
                RDelayFps = (RDelayFps + 1) Mod DelayFps
                'InvalidateRect PicShow.hwnd, RectAll, 0
                'PicShow.Refresh
            DoEvents                ''避免系统处理慢时进入死循环
            While timeGetTime - KeepTime < RunTime
                DoEvents
            Wend
        Loop
    ''***Unload MaskPic
    For N = 0 To AllFps - 1
        FoxxDeleteMask FoxMask(N)
    Next N
    Erase FoxMask
    If (Frm.hwnd <> Wl) Then Unload Frm
End Function

Public Function RunEditStaticObject(ByVal Frm As Form, ByVal PicShow As PictureBox, ByVal PicCon As PictureBox, RunObj As SaveStaticEObject, ByVal ChkEffect As CheckBox, ByVal HdcPic As PictureBox)
    On Error Resume Next
    Static Wl As Long
    Static IsNeedRun As Boolean
    IsNeedRun = Not IsNeedRun:  If Wl = 0 Then Wl = Frm.hwnd
    If Not IsNeedRun Or Not (Frm.hwnd = Wl) Then Exit Function
    NumBul = 100
    ReDim MultiRunBul(1 To NumBul) As RunEditBullet
    ReDim FireLoad(1 To 3) As SaveBullet
    ReDim HdcLoad(1 To 3) As Long
    ReDim FoxMask2(1 To 3) As Long
    ReDim OldHdcObject(1 To 3) As Long
    
    RunTime = 20
    '**Init
    PicShow.AutoRedraw = True
    With ChkEffect
        .Caption = "优化"
        .Value = 1
        .Enabled = True
    End With
    Dim R As RunStaticObject
    Dim A As Integer                'Angle
    Dim ErrorA As Integer
    Dim ErrX As Integer
    Dim ErrY As Integer
    
    'If IsNeedRun And (Frm.hwnd = Wl) Then
        R.CurLife = RunObj.Life
        R.CurX = PicShow.ScaleWidth \ 2
        R.CurY = PicShow.ScaleHeight \ 2
    'End If
    Dim FT As Integer
        Open App.Path & "\Bullet\All.con" For Binary As #1
            For N = 1 To 3
                FT = RunObj.FireSet(N).FireType
                If FT <= 0 Then Exit For
                HdcPic.Picture = LoadPicture(App.Path & "\Bullet\" & FT & ".Ebj")
                'HdcLoad(N) = CreateCompatibleDC(HdcPic.hdc)
                'OldHdcObject(N) = SelectObject(HdcLoad(N), HdcPic.Picture)
                Get #1, LenHead + 1 + (FT - 1) * Len(FireLoad(1)), FireLoad(N)
                FoxMask2(N) = FoxxCreateFastMask(HdcPic.Hdc, 0, 0, HdcPic.ScaleWidth, HdcPic.ScaleHeight, 0, 0, FireLoad(N).MaskColor, 1)
            Next N
        Close #1
        Do While IsNeedRun And (Frm.hwnd = Wl)
            KeepTime = timeGetTime
                'Rotatepic
                If RunObj.IsRotate = True Then
                    ErrorA = (CurMouseY - R.CurY)
                    If ErrorA Then
                        A = -Atn((CurMouseX - R.CurX) / ErrorA) * 180 / 3.14
                    Else
                        A = -90 * Sgn(CurMouseX - R.CurX)
                    End If
                    If CurMouseY < R.CurY Then A = A + 180
                ElseIf RunObj.IsFlick Then
                    A = (A + RunObj.IsFlick) Mod 360
                End If
                PicShow.Cls ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                R.CurFps = (R.CurFps + 1) Mod &H1000
                '**********
                For N = 1 To 3
                    If RunObj.FireSet(N).DelayFps = 0 Then Exit For
                    
                    
                    '''''''''''''''''''''''''''''
                     If R.CurFps Mod RunObj.FireSet(N).DelayFps = 0 Then
                    '''中间插入的已经被更改
                        For NN = 1 To NumBul
                            ''''''''''''''''''''''''''''''''以下需根据 : RunObj.FireSet(N).FireType 更改
                            If MultiRunBul(NN).NameRun = 0 Then
                                MultiRunBul(NN).NameRun = N
                                MultiRunBul(NN).CurType = FireLoad(N).SaveName
                                
                                If RunObj.IsRotate Then
                                    MultiRunBul(NN).CurSeatX = R.CurX - FireLoad(N).Width / 2
                                    MultiRunBul(NN).CurSeatY = R.CurY - FireLoad(N).Height / 2
                                    '************************** 4 用于debug
                                            ErrX = (CurMouseX - R.CurX)
                                            ErrY = (CurMouseY - R.CurY)
                                            If ErrY = 0 Then
                                                MultiRunBul(NN).CurSpeedX = 4 * Sgn(ErrX)
                                                MultiRunBul(NN).CurSpeedY = 0
                                            ElseIf Abs(ErrX / ErrY) > 0.1 And Abs(ErrX / ErrY) < 10 Then
                                                MultiRunBul(NN).CurSpeedX = 4 * ErrX / Sqr(ErrX ^ 2 + ErrY ^ 2)
                                                MultiRunBul(NN).CurSpeedY = MultiRunBul(NN).CurSpeedX * ErrY / ErrX
                                            ElseIf Abs(ErrX) > Abs(ErrY) Then
                                                MultiRunBul(NN).CurSpeedY = 0
                                                MultiRunBul(NN).CurSpeedX = 4 * Sgn(ErrX)
                                            Else 'If Abs(ErrY) > Abs(ErrX) Then
                                                MultiRunBul(NN).CurSpeedX = 0
                                                MultiRunBul(NN).CurSpeedY = 4 * Sgn(ErrY)
                                            End If
                                Else
                                    MultiRunBul(NN).CurSeatX = R.CurX - RunObj.Width / 2 + RunObj.FireSet(N).FireSeat.X - FireLoad(N).Width / 2
                                    MultiRunBul(NN).CurSeatY = R.CurY - RunObj.Height / 2 + RunObj.FireSet(N).FireSeat.Y - FireLoad(N).Height / 2
                                    MultiRunBul(NN).CurSpeedX = 0
                                    MultiRunBul(NN).CurSpeedY = 4
                                End If
                                            
                                Exit For
                            End If
                        Next NN
                    End If
                    '''''''''''''''''''''''''''''''''外加的
                    '''''''''''''''''''''''''''''''''
                Next N
                
                If Not RunObj.IsRotate Then FoxRotate PicShow.Hdc, R.CurX, R.CurY, RunObj.Width, RunObj.Height, PicCon.Hdc, 0, 0, A, RunObj.MaskColor, ChkEffect.Value * 2 + 1  ' Good
                
                For NN = 1 To NumBul
                    If MultiRunBul(NN).NameRun <> 0 Then
                        If Abs(MultiRunBul(NN).CurSeatX - PicShow.ScaleWidth / 2) * 2 <= PicShow.ScaleWidth Then
                            If Abs(MultiRunBul(NN).CurSeatY - PicShow.ScaleHeight / 2) * 2 <= PicShow.ScaleHeight Then
                                FoxxFastMask PicShow.Hdc, MultiRunBul(NN).CurSeatX, MultiRunBul(NN).CurSeatY, FoxMask2(MultiRunBul(NN).NameRun)
                                MultiRunBul(NN).CurSeatX = MultiRunBul(NN).CurSeatX + MultiRunBul(NN).CurSpeedX
                                MultiRunBul(NN).CurSeatY = MultiRunBul(NN).CurSeatY + MultiRunBul(NN).CurSpeedY
                           
                                GoTo EXIF   '为了不让上两个if条件太长，不得已而为之
                            End If
                        End If
                        MultiRunBul(NN).NameRun = 0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''以上被更改
EXIF:
                    End If
                Next NN
                
                If RunObj.IsRotate Then FoxRotate PicShow.Hdc, R.CurX, R.CurY, RunObj.Width, RunObj.Height, PicCon.Hdc, 0, 0, A, RunObj.MaskColor, ChkEffect.Value * 2 + 1  ' Good
               
                
                
                
                
                
                
                
            DoEvents
            While timeGetTime - KeepTime < RunTime
                DoEvents
            Wend
        Loop
    For N = 1 To 3
        If FoxMask2(N) > 0 Then
            FoxxDeleteMask FoxMask2(N)
        End If
    Next N
    Erase FoxMask2
    Erase MultiRunBul
    With PicShow
        .Width = PicCon.Width
        .Height = PicCon.Height
        .Cls
    End With
    With ChkEffect
        .Caption = "选项"
        .Enabled = False
    End With
    If (Frm.hwnd <> Wl) Then Unload Frm
End Function

Public Sub RunEditBullet(ByVal Frm As Form, ByVal PicShow As PictureBox, ByVal PicCon As PictureBox, ByVal ChkEffect As CheckBox)  ', ByVal HdcPic As PictureBox)
    'On Error Resume Next
    Static Wl As Long
    Static IsNeedRun As Boolean
    Dim PB As Byte
    Dim DelayBul As Integer
    ReDim PlayBul(1 To 50)
    IsNeedRun = Not IsNeedRun:  If Wl = 0 Then Wl = Frm.hwnd
    If Not IsNeedRun Or Not (Frm.hwnd = Wl) Then Exit Sub
    PicShow.AutoRedraw = True
    With ChkEffect
        .Caption = "优化"
        .Value = 1
        .Enabled = True
    End With

    RunTime = 20
        Do While IsNeedRun And (Frm.hwnd = Wl)
            '*************************************************************
            KeepTime = timeGetTime()
            PicShow.Cls
            If DelayBul = 0 Then CreateBullet CurMouseX, CurMouseY
            DelayBul = (DelayBul + 1) Mod 50
            For PB = 1 To 50
                If PlayBul(PB).IndexR <> 0 Then
                    With PlayBul(PB)
                        If Abs(.CurX - PicShow.ScaleWidth / 2) * 2 <= PicShow.ScaleWidth Then
                            If Abs(.CurY - PicShow.ScaleHeight / 2) * 2 <= PicShow.ScaleHeight Then
                                FoxRotate PicShow.Hdc, PlayBul(PB).CurX, PlayBul(PB).CurY, EditBul.Width, EditBul.Height, PicCon.Hdc, 0, 0, PlayBul(PB).CurAngle * EditBul.IsRotate, EditBul.MaskColor, ChkEffect.Value * 2 + 1
                                .CurAngle = (.CurAngle + 10) Mod 360
                                .CurX = .CurX + .CurSpeedX
                                .CurY = .CurY + .CurSpeedY
                                GoTo EXRE
                            End If
                        End If
                        .IndexR = 0
EXRE:
                    End With
                End If
            Next PB
            '*************************************************************
            DoEvents
            While timeGetTime - KeepTime < RunTime
                DoEvents
            Wend
        Loop
    With PicShow
        .Width = PicCon.Width
        .Height = PicCon.Height
        .Cls
    End With
    With ChkEffect
        .Caption = "选项"
        .Enabled = False
    End With
    Erase PlayBul
    If (Frm.hwnd <> Wl) Then Unload Frm
End Sub

Public Function CF(Anglex As Single) As Single
    CF = Anglex * 3.14 / 180
End Function