frmmain.frm

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

    ImgMap(CurEditImg).Tag = TagImgType & TagImgIndex & TagPath & TagPac
End Sub

Private Sub OptionPac_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    sbStatusBar.Panels.Item(1).Text = PackageType(IIf(Index = 0, 0, 1)) & "  包裹名称:" & Index
    
End Sub

Private Sub OptionPath_Click(Index As Integer)
If Not IsEditMap Then Exit Sub
    IsNewMap = True
    TagPath = Index
    ImgMap(CurEditImg).Tag = TagImgType & TagImgIndex & TagPath & TagPac
End Sub

Private Sub OptionPath_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    sbStatusBar.Panels.Item(1).Text = PathType(IIf(Index > 8, 9, Index))
End Sub

Private Sub RunPic_Click()
    RunPic.ZOrder 0
End Sub

Private Sub RunPic_DblClick()
    If IsRunning Then MainPic_DblClick
End Sub

Private Sub RunPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If IsRunning Then CurMouseX = X: CurMouseY = Y
    sbStatusBar.Panels.Item(1).Text = "Seat:" & X & "," & Y & "    Total:" & RunPic.ScaleWidth & "x" & RunPic.ScaleHeight
End Sub

Private Sub ScrList_Change()
    SingleList.Top = -120 - ScrList.Value * (ImageList(0).Height + 120)
End Sub

Private Sub ScrList_Scroll()
    ScrList_Change
End Sub



Private Sub ScrMap_Change()
    MainPic.Top = -ScrMap.Value
    lblTitle(1).Caption = "垂直位置:" & ScrMap.Value & "/" & Map.HeadMapFile.HeightTotal
    Call ChangeImgPic
End Sub

Private Sub ScrMap_Scroll()
Static SM As Integer
SM = Abs(Sgn(SM) - 1)
    If SM Then ScrMap_Change
End Sub

Private Sub ScrMap2_Change()
    MainPic.Left = -ScrMap2.Value
    lblTitle(1).Caption = "水平位置:" & ScrMap2.Value & "/" & Map.HeadMapFile.WidthTotal
End Sub

Private Sub ScrMap2_Scroll()
    ScrMap2_Change
End Sub

Private Sub SliFps_Scroll()
Static FRun As Integer
    If IsRunning = True Then Exit Sub
        RunPic.Cls
        BitBlt RunPic.Hdc, 0, 0, RunPic.ScaleWidth, RunPic.ScaleHeight, MainPic.Hdc, (SliFps.Value - 1) * RunPic.ScaleWidth, 0, vbSrcCopy
        'RunPic.Refresh
End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)

    On Error Resume Next
    Select Case Button.Key
        'Case "剪切"
        '    mnuEditCut_Click
        Case "复制"
            mnuEditCopy_Click
        Case "粘贴"
            mnuEditPaste_Click
        Case "删除"
            '应做:添加 '删除' 按钮代码。
            'MsgBox "添加 '删除' 按钮代码。"
        Case "播放"
            '应做:添加 '向前' 按钮代码。
            'MsgBox "添加 '向前' 按钮代码。"
            
            MainPic_DblClick
        Case "大图标"
            'EditMain.View = lvwIcon
        Case "小图标"
        Case "SaveObj"
            If IsEditMap Then
                mnuFileSave_Click
            Else
                frmPro.CmdSave_Click
            End If
            'EditMain.View = lvwSmallIcon
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
    frmAbout.Show vbModal, Me
End Sub

Private Sub mnuHelpSearchForHelpOn_Click()
    Dim nRet As Integer


    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "暂时没有相关联的帮助。", vbInformation, Me.Caption
    Else

    On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 261, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub


Private Sub mnuWindowObjectWin_Click()
    '应做:添加 'mnuWindowObjectWin_Click' 代码。
    'MsgBox "添加 'mnuWindowObjectWin_Click' 代码。"
    mnuWindowObjectWin.Checked = True ' Not mnuWindowObjectWin.Checked
    FrmMap.Show vbModal, Me
End Sub

Private Sub mnuWindowPropertyWin_Click()
    '应做:添加 'mnuWindowPropertyWin_Click' 代码。
    frmPro.Show
    frmPro.WindowState = 0
    frmPro.ZOrder 0
End Sub

Private Sub mnuSetObjectRunX_Click()
    '应做:添加 'mnuSetObjectRunX_Click' 代码。
    'MsgBox "添加 'mnuSetObjectRunX_Click' 代码。"
    MainPic_DblClick
End Sub

Private Sub mnuViewOptions_Click()
    '应做:添加 'mnuViewOptions_Click' 代码。
    'MsgBox "添加 'mnuViewOptions_Click' 代码。"
End Sub

Private Sub mnuViewStatusBar_Click()
    mnuViewStatusBar.Checked = Not mnuViewStatusBar.Checked
    sbStatusBar.Visible = mnuViewStatusBar.Checked
    SizeControls imgSplitter.Left
    Form_Resize
End Sub

Private Sub mnuViewToolbar_Click()
    mnuViewToolbar.Checked = Not mnuViewToolbar.Checked
    tbToolBar.Visible = mnuViewToolbar.Checked
    SizeControls imgSplitter.Left
    Form_Resize
End Sub

Private Sub mnuEditPaste_Click()
    '应做:添加 'mnuEditPaste_Click' 代码。
    'MsgBox "添加 'mnuEditPaste_Click' 代码。"
    'MainPic.Picture = Nothing
    Dim A As Integer
    On Error Resume Next
    If Not IsNew Then
        A = MsgBox("将覆盖原物体,是否继续?", vbOKCancel, "修改")
        If A = vbCancel Then Exit Sub
    End If
    MainPic.Picture = Clipboard.GetData(vbCFBitmap)
    '''''''此处有严重问题
    Call ReLoadImage
    Call ReSeatMainpic
End Sub
Private Sub ReLoadImage()
    Screen.MousePointer = 11
    SavePicture MainPic.Image, GetPath(ComboObj.ListIndex) & CurImageIndex & ".ebj"
    ImageList(CurImageIndex).Picture = LoadPicture(GetPath(ComboObj.ListIndex) & CurImageIndex & ".ebj")
    MainPic.Picture = ImageList(CurImageIndex).Picture
    Screen.MousePointer = 0
End Sub
Private Sub mnuEditCopy_Click()
'
Dim HBitMap As Long
If CurrentType <> -1 And CurListObj > 0 Then
    HBitMap = LoadImage(App.hInstance, GetPath(CurrentType) & CurListObj & ".Ebj", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
    If HBitMap = 0 Then MsgBox "Load Bitmap Error!", vbCritical, "复制错误": Exit Sub
    OpenClipboard Me.hwnd
    EmptyClipboard
    SetClipboardData CF_BITMAP, HBitMap
    If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then
        MsgBox "There was an error while pasting the bitmap to the clipboard!"
    End If
    CloseClipboard
    DeleteObject HBitMap
End If
End Sub

'Private Sub mnuEditCut_Click()
    '应做:添加 'mnuEditCut_Click' 代码。
    'MsgBox "添加 'mnuEditCut_Click' 代码。"
'    MainPic.Picture = MainPic.Image
'    OpenClipboard Me.hwnd
'        EmptyClipboard
'        SetClipboardData CF_BITMAP, MainPic.Picture

'    CloseClipboard
'    MainPic.Picture = Nothing
'End Sub

'Private Sub mnuEditUndo_Click()
    '应做:添加 'mnuEditUndo_Click' 代码。
'    MsgBox "实在抱歉,该项还没做!"
'End Sub

Private Sub mnuFileClose_Click()
    '卸载窗体
    Unload Me

End Sub

Private Sub mnuFilePWord_Click()
    '应做:添加 'mnuFilePWord_Click' 代码。
    MsgBox "添加 'mnuFilePWord_Click' 代码。"
End Sub

Private Sub mnuFileOpen_Click()

    Dim sFile As String
    Dim A As Integer

    LabBack2.Visible = False
    If IsNewMap Then
        A = MsgBox("原来的地图还没保存，要保存吗?", vbYesNoCancel)
        If A = vbYes Then
            Call mnuFileSave_Click
        ElseIf A = vbCancel Then
            Exit Sub
        End If
    End If
    
    
    With dlgCommonDialog
        .InitDir = App.Path & "\Map\"
        .DialogTitle = "打开"
        .CancelError = True
        'ToDo: 设置 common dialog 控件的标志和属性
        .Filter = "Map for SkyWar (*.Smp)|*.Smp"
On Error Resume Next
        .ShowOpen
        If Err.Number = 32755 Then Exit Sub
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        If IsExistFile(.FileName) = False Then MsgBox "Load SkyWarMap Error" & Chr(13) & Chr(10) & "File not exist or Read file I/O error", vbCritical, "Error": Exit Sub
        sFile = .FileName
    End With
    
    Call UnloadMapImgObject
    Call UnloadAllObject
    Call LoadMapFile(sFile)
    'ToDo: 添加处理打开的文件的代码
    'MsgBox "skdjf"
End Sub
Private Sub LoadMapFile(ByVal sFile As String)
    Dim HStr As String * 20
    Dim PwStr As String
    Dim A As Byte
    Open sFile For Binary As #1
        Get #1, 1, HStr
        If HStr = "I'm a map for SkyWar" Then
            Get #1, 1, Map.HeadMapFile
            
            PwStr = ReadPW(Map.HeadMapFile)
            If PwStr <> "" Then
                For A = 1 To 4
                    If A = 4 Then MsgBox "密码不正确,你无权编辑该地图": Close #1: Exit Sub
                    PwStr = InputBox("请输入密码", "打开地图")
                    If PwStr = "" Then
                        If Command = "" Then
                            Close #1
                            Exit Sub
                        Else
                            End
                        End If
                    End If
                    If PwStr = ReadPW(Map.HeadMapFile) Then Exit For
                Next A
            End If
            
            ReDim Map.ObjMap(1 To Map.HeadMapFile.HeightTotal \ 20)
            Get #1, 1, Map
        Else
            MsgBox "文件格式不正确", vbCritical, "文件读取错误"
            If Command <> "" Then End
        End If
    Close #1
    IsNewMap = False
    IsEditMap = True
    If IsRunning Then MainPic_DblClick:
    Call FrmMap.InitEditMapfrmMain
    
    FrmMap.Show vbModal, Me
    '''debug**********
    Call LoadAllObject
    '''debug*********
    
    Call LoadMapImgObject
    
    ImgDel = 0
    Call Form_Resize
End Sub
Public Sub LoadMapImgObject()
    For N = 1 To Map.HeadMapFile.HeightTotal \ 20
        For M = 1 To 40
            If Map.ObjMap(N).SingleObj(M).IsUsed = 0 Then Exit For
            
            If Map.ObjMap(N).SingleObj(M).IsUsed = 1 Then
                ''注意之前要卸载imgmap
                Load ImgMap(ImgMap.Count)
                With ImgMap(ImgMap.UBound)
                    '.Picture = LoadPicture(GetPath(Map.ObjMap(N).SingleObj(M).TypeObj) & Map.ObjMap(N).SingleObj(M).IndexOjb & ".Ebj")
                    TagImgType = Map.ObjMap(N).SingleObj(M).TypeObj
                    TagImgIndex = Map.ObjMap(N).SingleObj(M).IndexOjb
                    TagPath = Map.ObjMap(N).SingleObj(M).MoveType
                    TagPac = Map.ObjMap(N).SingleObj(M).IsPac
                    .Tag = TagImgType & TagImgIndex & TagPath & TagPac
                    .Visible = True
                    '.Left = Map.ObjMap(N).SingleObj(M).SeatX
                    Select Case Val(TagImgType)     '以免存储和读入不同步
                        Case 0
                            .Height = ImgAll0(TagImgIndex).Height \ 15
                            .Width = ImgAll0(TagImgIndex).Width \ 15
                        Case 1
                            .Height = ImgAll1(TagImgIndex).Height \ 15
                            .Width = ImgAll1(TagImgIndex).Width \ 15
                        Case 4
                            .Height = ImgAll4(TagImgIndex).Height \ 15
                            .Width = ImgAll4(TagImgIndex).Width \ 15
                    End Select
                    '.Top = N * 20 - .Height
                    .Move Map.ObjMap(N).SingleObj(M).SeatX, N * 20 - .Height
                    If TagImgType = 0 Or TagImgType = 1 Then .ZOrder 0
                End With
            End If
        Next M
    Next N
Call ScrMap_Change

End Sub

Public Sub UnloadMapImgObject()
    For N = 1 To ImgMap.UBound
        ImgMap(N).Picture = Nothing
        Unload ImgMap(N)
    Next N
End Sub

Public Sub LoadAllObject()
On Error Resume Next
    Dim N As Integer
    Dim LA As Integer
    Open GetPath(0) & "All.con" For Binary As #1
        Get #1, Len(HeadStr) + 1, LA
        For N = 1 To LA
            Get #1, LenHead + 1 + (N - 1) * Len(LoadObj), LoadObj
            PicLoad.Picture = LoadPicture(GetPath(0) & N & ".ebj")
            PicLoad.Width = LoadObj.Width
            PicLoad.Height = LoadObj.Height
            Load ImgAll0(N)
            ImgAll0(N).Picture = PicLoad.Image
        Next N
    Close #1
    
    Open GetPath(1) & "