frmmain.frm

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

End Sub

Private Sub TreeView1_DragDrop(Source As Control, X As Single, Y As Single)
    If Source = imgSplitter Then
        SizeControls X
    End If
End Sub

Sub SizeControls(X As Single)
    On Error Resume Next
    

    '设置 Width 属性
    If X < 1500 Then X = 1500
    If X > (Me.Width - 1500) Then X = Me.Width - 1500
    ObjList.Width = X
    imgSplitter.Left = X
    EditMain.Left = X + 40
    EditMain.Width = Me.Width - (ObjList.Width + 170)
    
    SliFps.Width = Me.Width - SliFps.Left - 50

    lblTitle(0).Width = ObjList.Width
    lblTitle(1).Left = EditMain.Left + 20
    lblTitle(1).Width = EditMain.Width - 40
    PicPath.Move lblTitle(1).Left + 2000, lblTitle(1).Top, (EditMain.Width - 2000) / 2, lblTitle(1).Height
    'PicPath.Left = lblTitle(1).Left
    'PicPath.Width =
    'PicPac.Left =
    'PicPac.Width =
    PicPac.Move PicPath.Width + PicPath.Left + 10, lblTitle(1).Top, (EditMain.Width - 2000) / 2, lblTitle(1).Height
    '设置 Top 属性
  

    If tbToolBar.Visible Then
        ObjList.Top = tbToolBar.Height + picTitles.Height
    Else
        ObjList.Top = picTitles.Height
    End If

  EditMain.Top = ObjList.Top
    

    '设置 height 属性
    If sbStatusBar.Visible Then
        ObjList.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height + sbStatusBar.Height)
    Else
        ObjList.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height)
    End If
    

    EditMain.Height = ObjList.Height
    imgSplitter.Top = ObjList.Top
    imgSplitter.Height = ObjList.Height
End Sub

Private Sub MainPic_Click()
If ComboObj.ListIndex = -1 Then Exit Sub
If CurImageIndex = -1 Then Exit Sub
    MainPic.ZOrder 0
    LabBack.Top = -2000
    Call LoadProperty(CurrentType, frmPro.Pro, True)
End Sub

Private Sub MainPic_DblClick()
    If ComboObj.ListIndex = -1 Then Exit Sub
    If IsEditMap Then Exit Sub
    IsRunning = Not IsRunning
        If IsRunning Then
            lblTitle(1).Caption = "正在运行......(要切换物体,请先停止运行(DblClick Running Image))"
            tbToolBar.Buttons(6).Value = tbrPressed
            mnuSetObjectRunX.Caption = "停止"
        Else
            lblTitle(1).Caption = "当前编辑:"
            tbToolBar.Buttons(6).Value = tbrUnpressed
            mnuSetObjectRunX.Caption = "运行"
        End If
    
    Select Case CurrentType
        Case 0
            If EditObj.AllFps = 1 Then IsRunning = Not IsRunning: Exit Sub
            Call RunEditObject(Me, RunPic, MainPic, EditObj.AllFps, EditObj.DelayFps, EditObj.Width, EditObj.Height, EditObj.MaskColor, SliFps)
        Case 1
            With RunPic
                .Width = EditMain.ScaleWidth
                .Height = EditMain.ScaleHeight
            End With
            RunPic.ZOrder 0
            Call RunEditStaticObject(Me, RunPic, MainPic, EditSta, ChkOption, PicCreateHdc)
        Case 2
            Call RunEditObject(Me, RunPic, MainPic, EditPla.AllFps, 3, EditPla.Width, EditPla.Height, EditPla.MaskColor, SliFps)
        Case 3
        Case 4
            Call RunEditObject(Me, RunPic, MainPic, EditBackObj.AllFps, EditBackObj.DelayFps, EditBackObj.Width, EditBackObj.Height, EditBackObj.MaskColor, SliFps)
        Case 6
            With RunPic
                .Width = EditMain.ScaleWidth
                .Height = EditMain.ScaleHeight
            End With
            RunPic.ZOrder 0
            Call RunEditBullet(Me, RunPic, MainPic, ChkOption)
        Case 7
        Case 8
            Call RunEditObject(Me, RunPic, MainPic, EditExp.AllFps, EditExp.DelayFps, EditExp.Width, EditExp.Height, EditExp.MaskColor, SliFps)
        Case 9
            Call RunEditObject(Me, RunPic, MainPic, EditCra.AllFps, EditCra.DelayFps, EditCra.Width, EditCra.Height, EditCra.MaskColor, SliFps)
        Case 10
            Call RunEditObject(Me, RunPic, MainPic, EditPac.AllFps, EditPac.DelayFps, EditPac.Width, EditPac.Height, EditPac.MaskColor, SliFps)
        Case 11
        
    End Select
    

End Sub

Private Sub MainPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not IsEditMap Then sbStatusBar.Panels.Item(1).Text = "Color:&H" & Hex(MainPic.Point(X, Y)) & "    Seat:" & X & "," & Y & "   Total:" & MainPic.ScaleWidth & "x" & MainPic.ScaleHeight
End Sub

Private Sub MainPic_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If IsEditMap Then Exit Sub
    If Button = 2 Then
         mnuEditPaste.Enabled = IsClipboardFormatAvailable(CF_BITMAP)
         mnuEditCopy.Enabled = MainPic.Picture
         DelObject.Enabled = IsEditMap
         'mnuEdit
        PopupMenu mnuEdit, 2
    End If
End Sub

Private Sub mnuCloseMap_Click()
    Dim A As Integer
    If Not IsEditMap Then Exit Sub
    If IsNewMap Then
        A = MsgBox("保存修改后的地图吗", vbYesNoCancel, "CloseMap")
        If A = vbYes Then
            mnuFileSave_Click
        ElseIf A = vbCancel Then
            Exit Sub
        End If
    End If
    
    IsEditMap = False
    IsNewMap = False
    Call UnloadMapImgObject
    Call UnloadAllObject
    RunPic.Visible = True
    MainPic.Cls
    MainPic.Width = 20
    MainPic.Height = 20
    MainPic.BackColor = &H80000000
    Call ReSeatMainpic
    ScrMap.Visible = False
    ScrMap2.Visible = False
    PicPath.Visible = False
    PicPac.Visible = False
    LabBack2.Visible = False
    
End Sub

Private Sub mnuEdit_Click()
    DelObject.Enabled = IsEditMap
End Sub

Private Sub mnuFileSave_Click()
On Error GoTo EX
    If Not IsEditMap Then Exit Sub
    ReDim Map.ObjMap(1 To Map.HeadMapFile.HeightTotal \ 20)     '零为不存‘从20 位起
    '声明

    Dim ImgTop As Integer
        For N = 1 To ImgMap.UBound
            For M = 1 To 40
                ImgTop = ImgMap(N).Top + ImgMap(N).Height
                    If ImgTop < 20 Or ImgTop > Map.HeadMapFile.HeightTotal Or ImgMap(N).Tag = "0" Then Exit For
                    
                    If Map.ObjMap(ImgTop \ 20).SingleObj(M).IsUsed = 0 Then
                        Map.ObjMap(ImgTop \ 20).SingleObj(M).IsUsed = 1
                        Map.ObjMap(ImgTop \ 20).SingleObj(M).TypeObj = Val(Left(ImgMap(N).Tag, 5))
                        Map.ObjMap(ImgTop \ 20).SingleObj(M).IndexOjb = Val(Mid(ImgMap(N).Tag, 6, 5))
                        Map.ObjMap(ImgTop \ 20).SingleObj(M).MoveType = Val(Mid(ImgMap(N).Tag, 11, 2))
                        Map.ObjMap(ImgTop \ 20).SingleObj(M).IsPac = Val(Right(ImgMap(N).Tag, 2))
                        Map.ObjMap(ImgTop \ 20).SingleObj(M).SeatX = Val(ImgMap(N).Left)
                        
                        Exit For
                    End If
            Next M
        Next N
        Open App.Path & "\Map\" & Trim(Map.HeadMapFile.NameMap) & ".Smp" For Binary As #1
            Put #1, 1, Map
        Close #1
 
IsNewMap = False
Exit Sub

EX:
MsgBox Err.Description
End Sub

Private Sub mnuMap_Click()
Dim A As Integer
    If IsNewMap Then
        A = MsgBox("原来的地图还没保存，要保存吗?", vbYesNoCancel)
        If A = vbYes Then
            Call mnuFileSave_Click
        ElseIf A = vbCancel Then
            Exit Sub
        End If
    End If


    If IsRunning Then MainPic_DblClick:
    IsNewMap = True
    IsEditMap = True
    FrmMap.Show vbModal, Me
End Sub

Private Sub mnuObj_Click()
If IsEditMap Or IsNewMap Then MsgBox "编辑地图时不能同时新建物体", vbCritical, "Edit Error": Exit Sub

    If ComboObj.ListIndex = -1 Then MsgBox "请先选择一个类型......", vbOKOnly, "创建对象": Exit Sub
    'Call InitSaveObject(EditObj)
    Screen.MousePointer = 11
    IsNew = True
    If IsRunning = True Then IsRunning = False
    MainPic.Picture = Nothing
    RunPic.Picture = Nothing
    RunPic.Cls
    With MainPic
        If ComboObj.ListIndex = 6 Or ComboObj.ListIndex = 7 Then
            .Width = 6
            .Height = 6
        Else
            .Width = 40
            .Height = 40
        End If
    End With
    MainPic.Line (0, 0)-(MainPic.ScaleWidth, MainPic.ScaleHeight), &HFF00FF, BF
    ReSeatMainpic
    Dim CurAllCon As Integer
        Open GetPath(ComboObj.ListIndex) & "All.con" For Binary As #1
            Get #1, Len(HeadStr) + 1, CurAllCon
            CurAllCon = CurAllCon + 1
            Put #1, Len(HeadStr) + 1, CurAllCon
        Close #1
    Select Case ComboObj.ListIndex
        Case 0
            With EditObj
                .SaveName = CurAllCon
                .AllFps = 1
                .DelayFps = 1
                .Life = 1
            End With
        Case 4
            With EditBackObj
                .SaveName = CurAllCon
                .AllFps = 1
                .DelayFps = 1
            End With
        Case 8
            With EditExp
                .SaveName = CurAllCon
                .AllFps = 1
                .DelayFps = 1
            End With
        Case 9
            With EditCra
                .SaveName = CurAllCon
                .AllFps = 1
                .DelayFps = 1
            End With
        Case 10
            With EditPac
                .SaveName = CurAllCon
                .AllFps = 1
                .DelayFps = 1
            End With
        Case Else
            EditPla.AllFps = 1
            EditPla.SaveName = CurAllCon
            EditSta.SaveName = CurAllCon
            EditBul.SaveName = CurAllCon
            EditMyBul.SaveName = CurAllCon
    End Select
    SavePicture MainPic.Image, GetPath(ComboObj.ListIndex) & CurAllCon & ".Ebj"
    
    ComboObj_Click
    ImageList_Click (CurAllCon)
    ScrList.Max = CurAllCon
    ScrList.Value = CurAllCon
    Screen.MousePointer = 0
End Sub
Private Sub EditMain_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call MainPic_MouseUp(Button, Shift, X, Y)
End Sub


Private Sub mnuOpenWith_Click()
On Error GoTo EX
Dim Directory As String
Dim L As Long
Dim WhErr As Byte
Dim WE As Byte
Dim FN As String
    If CurrentEditType < 0 Or CurImageIndex < 1 Then MsgBox "你还没选任何东西呢": Exit Sub
    FN = GetPath(CurrentEditType) & CurImageIndex & ".ebj"
    If IsExistFile(App.Path & "\ListPro\Directory.ini") Then
        Open App.Path & "\ListPro\Directory.ini" For Input As #1
            If Not EOF(1) Then Input #1, Directory
        Close #1
    Else
        WE = 3
        MsgBox "\ListPro\Directory.Ini  文件丢失,请创建该文件"
    End If
    If Trim(Directory) = "" Then
        WhErr = 1
        Directory = Space(255)
        L = GetSystemDirectory(Directory, 255)
        Directory = Left(Directory, L)
        Directory = Left(Directory, Len(Directory) - 7)
        For L = Len(Directory) To 1 Step -1
            If Mid(Directory, L, 1) = "\" Then Exit For
        Next L
        Directory = Left(Directory, L - 1) & "\Program Files\Accessories\MSPAINT.EXE"

        Shell Directory & " " & FN, vbNormalFocus
    Else
        WhErr = 2
        Shell Directory & " " & FN, vbNormalFocus
    End If
Exit Sub
EX:
If Err.Number = 53 Then
    If WhErr = 1 Then
        Directory = InputBox("程序无法搜索到正确的画图程序路径，请自行设定", "路径设定")
    ElseIf WhErr = 2 Then
        Directory = InputBox("画图程序路径设定有误，如果不想设定，可以设定为空，让程序自行搜索", "路径设定")
    Else
        MsgBox "遇到不可预料的错误"
        Exit Sub
    End If
    
    If WE = 3 Then
        MsgBox "无法创建文件，丢失 \ListPro\Directory.Ini"
        Exit Sub
    End If
        If Trim(Directory) <> "" Or WhErr = 2 Then
            Open App.Path & "\ListPro\Directory.ini" For Output As #2
                Print #2, Directory
            Close #2
        End If
End If
End Sub

Private Sub mnuSetBColor_Click()
On Error Resume Next
    dlgCommonDialog.ShowColor
    If Err.Number = 32755 Then Exit Sub
    EditMain.BackColor = dlgCommonDialog.Color

End Sub

Private Sub mnuSetColor_Click()
On Error Resume Next
    dlgCommonDialog.ShowColor
    If Err.Number = 32755 Then Exit Sub
    RunPic.BackColor = dlgCommonDialog.Color
End Sub

Private Sub mnuSetStage_Click()
    FrmStageSet.Show vbModal
End Sub

Private Sub mnuWindow_Click()
    mnuWindowObjectWin.Enabled = IsEditMap
End Sub

Private Sub OptionPac_Click(Index As Integer)
If Not IsEditMap Then Exit Sub
    IsNewMap = True
    TagPac = Index