skymain.frm

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

    Me.WindowState = 2
    MapWid = 420 '410    '测试用
    MapHei = 6000
    Me.AutoRedraw = True
    Me.ScaleMode = 3
    Me.Caption = "天空战记_gy"
    Me.Show

    With PicView
        .AutoRedraw = False
        .ScaleMode = 3
        .Move (640 - MapWid) \ 2, 0, MapWid, 480  '该值已固定
    End With
    With PicBuf
        .AutoRedraw = True
        .ScaleMode = 3
        '.Move (640 - MapWid) \ 2, -2, MapWid, 480
    End With
    With PicShowScore
        .Move (640 - 300) \ 2, (480 - 400) \ 2, 300, 400
        HdcShowScore = .Hdc
        HwndShowScore = .hwnd
    End With
    With PicShowScoreBuf
        .Move (640 - 300) \ 2, (480 - 400) \ 2, 300, 400
        HdcShowScoreBuf = .Hdc
    End With
    Call LoadGame
    Call InitScreen
    
    If CurOption.GSound = 1 Then GameSound.InitPlaySound 2  '''''') Then ''''''''MsgBox "声音设备正在使用", vbCritical, "Initialize error"
    GameSound.InitSoundDir = App.Path & "\Sound\"
    GameSound.InitMusicDir = App.Path & "\Music\"
    ChDir App.Path & "\Sound\"
    'GameSound.PlaySound "02", 0, 1
    If CurOption.GMusic = 1 Then GameSound.PlayMusic LoadMusicList(Int(UBound(LoadMusicList) * Rnd) + 1)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim i As Integer
On Error Resume Next
    For i = Forms.Count - 1 To 1 Step -1
        Unload Forms(i)
    Next
    If IsUnloadAll Then Exit Sub    '加该句的理由请看Form_Load开始的说明
    Call StopDemoPlay
    'Set StartSky = Nothing
    Set GameSound = Nothing
    'IsPause = False
    IsPlaying = False
    TimerMain.Enabled = False
    UnloadGame
    Call ResetScreen
    Call ChangeDisplay(False)
End Sub
Public Sub CmdMimiFrm_Click()
    FrmMenu.Show vbModal, Me
End Sub
Public Sub ClosePicView()
    Dim CloseX As Integer
    Dim Colo As Long
    If PicView.Visible = False Then Exit Sub
    Colo = FrmMain.BackColor
    For CloseX = 0 To PicView.Width \ 2
        PicView.Line (CloseX, 0)-(CloseX, 480), Colo
        PicView.Line (PicView.Width - CloseX, 0)-(PicView.Width - CloseX, 480), Colo
        DelayTime 1000
    Next CloseX
    PicView.Visible = False

End Sub

Public Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
If IsPlaying And CurContinueAll = 1 Then Exit Sub
If KeyCode = vbKeyF2 Then
    PlayName(1) = InputBox("Please enter your name:", "Player Name")
    If Len(Trim(PlayName(1))) = 0 Then
        PlayName(1) = "匿名玩家"
    ElseIf Len(PlayName(1)) > 16 Then
        PlayName(1) = Left(PlayName(1), 16)
    End If
    
    IsLoadP(1) = True                       '''debug 4
    If Not IsPlaying Then CurContinueP(1) = 4: CurContinueAll = 6: Call StopDemoPlay: IsBeforeStart = True: Call InitScreen: Exit Sub ''此处造成堆笺
    If CurContinueP(1) = 0 Then CurContinueP(1) = 4: CurContinueAll = CurContinueAll - 1: Call InitScreen
ElseIf KeyCode = vbKeyF3 Then
    PlayName(2) = InputBox("Please enter your name:", "Player Name")
    If Len(Trim(PlayName(2))) = 0 Then
        PlayName(2) = "匿名玩家"
    ElseIf Len(PlayName(2)) > 16 Then
        PlayName(2) = Left(PlayName(2), 16)
    End If
    
    IsLoadP(2) = True
    If Not IsPlaying Then CurContinueP(2) = 4: CurContinueAll = 6: Call StopDemoPlay: IsBeforeStart = True: Call InitScreen: Exit Sub
    If CurContinueP(2) = 0 Then CurContinueP(2) = 4: CurContinueAll = CurContinueAll - 1: Call InitScreen
'ElseIf KeyCode = vbKeyF4 Then
'    IsShowScore = Not IsShowScore
'    If IsShowScore Then Call ShowWindow(HwndShowScore, SW_NORMAL) Else Call ShowWindow(HwndShowScore, SW_HIDE)
ElseIf KeyCode = vbKeyEscape Then
    FrmMenu.Show vbModal, Me
End If

End Sub

Public Sub ResetScreen()
    Do While ShowCursor(1) < 0
    Loop
    
    SystemParametersInfo 97, False, vbNullString, 0
    ClipCursor ByVal 0&
End Sub
Public Sub InitScreen()
Dim SetMouseRect As RECT
    Do While ShowCursor(0) >= 0
    Loop

    SystemParametersInfo 97, True, vbNullString, 0
    With SetMouseRect
        .Left = 305 ' 319
        .Top = 225 ' 239
        .Bottom = 256 ' 242
        .Right = 336 ' 322
    End With
    ClipCursor SetMouseRect
    
End Sub
Private Sub UnloadGame()
On Error Resume Next
    Me.Picture = Nothing
    MapRandom.Picture = Nothing
    PicBuf.Picture = Nothing
    MapRandom.Picture = Nothing
    MapObj.Picture = Nothing
    PicShowScore.Picture = Nothing
    PicShowScoreBuf.Picture = Nothing
    Picture1.Picture = Nothing
    Picture2.Picture = Nothing
    Picture3.Picture = Nothing
    For SeatX = 1 To PicLoadRnd.UBound
        PicLoadRnd(SeatX).Picture = Nothing
        Unload PicLoadRnd
    Next SeatX
    For SeatX = 1 To ObjBuf.UBound
        ObjBuf(SeatX).Picture = Nothing
        ObjBac(SeatX).Picture = Nothing
        Unload ObjBuf(SeatX)
        Unload ObjBac(SeatX)
    Next SeatX
    For SeatX = 1 To StaBuf.UBound
        StaBuf(SeatX).Picture = Nothing
        StaBac(SeatX).Picture = Nothing
        Unload StaBuf(SeatX)
        Unload StaBac(SeatX)
    Next SeatX
    For SeatX = 1 To PlaBuf.UBound
        PlaBuf(SeatX).Picture = Nothing
        PlaBac(SeatX).Picture = Nothing
        Unload PlaBuf(SeatX)
        Unload PlaBac(SeatX)
    Next SeatX
    For SeatX = 1 To ExpBuf.UBound
        ExpBuf(SeatX).Picture = Nothing
        ExpBac(SeatX).Picture = Nothing
        Unload ExpBuf(SeatX)
        Unload ExpBac(SeatX)
    Next SeatX
    For SeatX = 1 To CraBuf.UBound
        CraBuf(SeatX).Picture = Nothing
        CraBac(SeatX).Picture = Nothing
        Unload CraBuf(SeatX)
        Unload CraBac(SeatX)
    Next SeatX
    For SeatX = 1 To BulBuf.UBound
        BulBuf(SeatX).Picture = Nothing
        BulBac(SeatX).Picture = Nothing
        Unload BulBuf(SeatX)
        Unload BulBac(SeatX)
    Next SeatX
    For SeatX = 1 To MyBulBuf.UBound
        MyBulBuf(SeatX).Picture = Nothing
        MyBulBac(SeatX).Picture = Nothing
        Unload MyBulBuf(SeatX)
        Unload MyBulBac(SeatX)
    Next SeatX

End Sub

Private Sub LoadGame()
    'BasSpeed = 2
    'BasAngle = 4
    StaFps = 60
    
    'P1 = 1
    '***************************
    
    LenHead = Len(HeadStr) + Len(AllCon) '自定义的文件头长度
    Open App.Path & "\Map\StageSet" For Input As #1
        For N = 1 To 20
            If EOF(1) Then Exit For
            Line Input #1, MapName(N)
        Next N
    Close #1
        LoadOptions
        LoadMap '(App.Path & "\Map\demo.smp") '''demo
        LoadPlane 1, 2
        LoadObject
        LoadStaticObject
        LoadBackObject
        LoadBullet
        LoadMyBullet
        LoadExplode
        LoadCrash
        LoadPackage
        LoadScore
        LoadMusic
        PicLoad.Picture = Nothing
End Sub

Public Sub LoadMap()
On Error Resume Next
    
    MapIndex = MapIndex Mod 20 + 1
    If Trim(MapName(1)) = "" Then
        MsgBox "There is no map for game", vbCritical, "LoadMap Error": IsPlaying = False: Exit Sub
    ElseIf Trim(MapName(MapIndex)) = "" Then
        MapIndex = 1
    End If
    Open App.Path & "\Map\" & MapName(MapIndex) & ".smp" For Binary As #1
        Get #1, 1, Map.HeadMapFile
        ReDim Map.ObjMap(1 To Map.HeadMapFile.HeightTotal \ 20)
        Get #1, 1, Map
    Close #1
    'PicView.Width = Map.HeadMapFile.WidthShow       '需要修改
    PicView.Move (640 - Map.HeadMapFile.WidthShow) \ 2, 0, Map.HeadMapFile.WidthShow, 480
    
    PicBuf.Width = Map.HeadMapFile.WidthTotal
    PicBuf.Height = PicView.Height
        
    MapRandom.Width = PicBuf.Width
    MapRandom.Height = PicBuf.Height
    
    MapObj.Width = PicBuf.Width
    MapObj.Height = 20
    
    PicView.BackColor = Map.HeadMapFile.BackColor
    PicBuf.BackColor = Map.HeadMapFile.BackColor
    MapRandom.BackColor = Map.HeadMapFile.BackColor
    MapObj.BackColor = Map.HeadMapFile.BackColor
    ''''''''''''''''''''''''*********************注意：改变backcolor会导致前面的hdc不起作用
    HdcView = PicView.Hdc
    HdcViewBuf = PicBuf.Hdc '*********************所以这几项必须放到后面
    HdcMapRandom = MapRandom.Hdc
    HdcMapObj = MapObj.Hdc
    
    MaxLeft = (Map.HeadMapFile.WidthTotal - Map.HeadMapFile.WidthShow) \ 2 '' 以picview为参照
    MaxRight = (Map.HeadMapFile.WidthTotal + Map.HeadMapFile.WidthShow) \ 2
    MidX = PicBuf.Width \ 2
    MidY = PicBuf.Height \ 2
    
    
    CurMapSeat = Map.HeadMapFile.HeightTotal
    CurMapSeatObj = Int(CurMapSeat)
    StartDrawX0 = Int((Map.HeadMapFile.WidthTotal - Map.HeadMapFile.WidthShow) \ 2)
    
    If Map.HeadMapFile.SpeedMap = 0 Then Map.HeadMapFile.SpeedMap = 1
    MapSpeed = Map.HeadMapFile.SpeedMap / 4
    BackSpeed = Map.HeadMapFile.SpeedBack

    'CurMapSeat = MapRandom.Height - PicView.Height
    'MapHei = MapRandom.Height
    'MapWid = MapRandom.Width
    'MaxLeft = PicView.Left - 20
    'MaxRight = PicView.Left + PicView.Width + 20
    Call LoadRandomPic
End Sub
'注意该两项装载不同
Private Sub LoadPlane(Optional ByVal P1 As Byte, Optional ByVal P2 As Byte)
On Error Resume Next
    ReDim LoadPla(1 To 2)
    Load PlaBuf(1)
    Load PlaBuf(2)
    Load PlaBac(1)
    Load PlaBac(2)

    Open App.Path & "\BatPlane\All.Con" For Binary As #1
        If P1 <> 0 Then Get #1, LenHead + 1 + (P1 - 1) * Len(LoadPla(1)), LoadPla(1)
'MsgBox LoadPla(1).Width & " " & LoadPla(1).Height & " " & LoadPla(1).AllFps
'Stop
        If P2 <> 0 Then Get #1, LenHead + 1 + (P2 - 1) * Len(LoadPla(2)), LoadPla(2)
    Close #1
    If P1 <> 0 Then
        PicLoad.Picture = LoadPicture(App.Path & "\Batplane\" & P1 & ".ebj")
        
                PlaBuf(1).Width = LoadPla(1).Width * LoadPla(1).AllFps
                PlaBuf(1).Height = LoadPla(1).Height
                PlaBac(1).Width = LoadPla(1).Width * LoadPla(1).AllFps
                PlaBac(1).Height = LoadPla(1).Height
        
        Call CFB(PicLoad, PlaBuf(1), PlaBac(1), LoadPla(1).MaskColor)
        'LoadPla(1).HdcE = PlaBuf(1).hdc
        'LoadPla(1).HdcBack = PlaBac(1).hdc
        PlayPla(1).HdcRun = PlaBuf(1).Hdc
        PlayPla(1).HdcBack = PlaBac(1).Hdc
    End If
    If P2 <> 0 Then
        PicLoad.Picture = LoadPicture(App.Path & "\BatPlane\" & P2 & ".ebj")
        
                PlaBuf(2).Width = LoadPla(2).Width * LoadPla(2).AllFps
                PlaBuf(2).Height = LoadPla(2).Height
                PlaBac(2).Width = LoadPla(2).Width * LoadPla(2).AllFps
                PlaBac(2).Height = LoadPla(2).Height
        
        Call CFB(PicLoad, PlaBuf(2), PlaBac(2), LoadPla(1).MaskColor)
        'LoadPla(2).HdcE = PlaBuf(2).hdc
        'LoadPla(2).HdcBack = PlaBac(2).hdc
        PlayPla(2).HdcRun = PlaBuf(2).Hdc
        PlayPla(2).HdcBack = PlaBac(2).Hdc
    End If
    'IsLoadP(1) = CBool(P1)
    'IsLoadP(2) = CBool(P2)
    ''debug
    'Curmyxp(WhPlayer) = 210
    'Curmyyp(WhPlayer) = 460
End Sub
'''''''注：以下已经将初值该为 1
Private Sub LoadObject()
On Error Resume Next
    Open App.Path & "\EObject\All.con" For Binary As #1
            Get #1, Len(HeadStr) + 1, AllCon
            MaxLoadObj = AllCon
            
        ReDim LoadObj(1 To AllCon)
            Get #1, LenHead + 1, LoadObj
    Close #1
        For SeatX = 1 To AllCon
            Load ObjBuf(SeatX)
            Load ObjBac(SeatX)
            PicLoad.Picture = LoadPicture(App.Path & "\EObject\" & SeatX & ".ebj")
            
                    ObjBuf(SeatX).Width = LoadObj(SeatX).Width * LoadObj(SeatX).AllFps     ''注意还有*allfps
                    ObjBuf(SeatX).Height = LoadObj(SeatX).Height