frmmain.frm

游戏《家园》源码

         Caption         =   "&Copy Object"
      End
      Begin VB.Menu mnuPUTreeObjPaste 
         Caption         =   "&Paste Objects/Attribute"
      End
   End
   Begin VB.Menu mnuPUTreeAttrib 
      Caption         =   "Popup menu for attribute item in tree window"
      Visible         =   0   'False
      Begin VB.Menu mnuPUTreeAttribProp 
         Caption         =   "Attribute P&roperties..."
      End
      Begin VB.Menu mnuPUTreeAttribBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUTreeAttribDel 
         Caption         =   "&Delete Attribute"
      End
      Begin VB.Menu mnuPUTreeAttribBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUTreeAttribCut 
         Caption         =   "Cu&t Attribute"
      End
      Begin VB.Menu mnuPUTreeAttribCopy 
         Caption         =   "&Copy Attribute"
      End
   End
   Begin VB.Menu mnuPUTreeSel 
      Caption         =   "Popup menu for selection of tree window"
      Visible         =   0   'False
      Begin VB.Menu mnuPUTreeSelCollapse 
         Caption         =   "Coll&apse selection [-]"
      End
      Begin VB.Menu mnuPUTreeSelExpand 
         Caption         =   "&Expand sellection [*]"
      End
      Begin VB.Menu mnuPUTreeSelDesel 
         Caption         =   "De&select"
      End
      Begin VB.Menu mnuPUTreeSelClear 
         Caption         =   "Cl&ear Selection"
      End
      Begin VB.Menu mnuPUTreeSelBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUTreeSelProp 
         Caption         =   "Selection P&roperties"
      End
      Begin VB.Menu mnuPUTreeSelBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUTreeSelDel 
         Caption         =   "&Delete selection"
      End
      Begin VB.Menu mnuPUTreeSelBar3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUTreeSelCut 
         Caption         =   "Cu&t selection"
      End
      Begin VB.Menu mnuPUTreeSelCopy 
         Caption         =   "&Copy selection"
      End
   End
   Begin VB.Menu mnuPUList 
      Caption         =   "Popup menu for item in the list window"
      Visible         =   0   'False
      Begin VB.Menu mnuPUListProp 
         Caption         =   "Attribute P&roperties..."
      End
      Begin VB.Menu mnuPUListBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUListNew 
         Caption         =   "New &Attribute..."
      End
      Begin VB.Menu mnuPUListDel 
         Caption         =   "&Delete Attribute"
      End
      Begin VB.Menu mnuPUListBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUListCut 
         Caption         =   "Cu&t Attribute"
      End
      Begin VB.Menu mnuPUListCopy 
         Caption         =   "&Copy Attribute"
      End
      Begin VB.Menu mnuPUListPaste 
         Caption         =   "&Paste Attribute"
      End
   End
   Begin VB.Menu mnuPUGraphObj 
      Caption         =   "Popup menu for object item in graphic windows"
      Visible         =   0   'False
      Begin VB.Menu mnuPUGraphObjProp 
         Caption         =   "Object P&roperties..."
      End
      Begin VB.Menu mnuPUGraphObjFind 
         Caption         =   "&Find Object"
      End
      Begin VB.Menu mnuPUGraphObjList 
         Caption         =   "Attributes &List..."
      End
      Begin VB.Menu mnuPUGraphObjBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUGraphObjSel1 
         Caption         =   "Select Glo&bal"
      End
      Begin VB.Menu mnuPUGraphObjSel2 
         Caption         =   "&Select Objects"
      End
      Begin VB.Menu mnuPUGraphObjSel3 
         Caption         =   "Select Pat&h"
      End
      Begin VB.Menu mnuPUGraphObjBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUGraphObjNew 
         Caption         =   "New &Attribute..."
      End
      Begin VB.Menu mnuPUGraphObjDup 
         Caption         =   "D&uplicate Object Here"
      End
      Begin VB.Menu mnuPUGraphObjDel 
         Caption         =   "&Delete Object"
      End
      Begin VB.Menu mnuPUGraphObjBar3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUGraphObjCut 
         Caption         =   "Cu&t Object"
      End
      Begin VB.Menu mnuPUGraphObjCopy 
         Caption         =   "&Copy Object"
      End
      Begin VB.Menu mnuPUGraphObjPaste 
         Caption         =   "&Paste Attribute"
      End
   End
   Begin VB.Menu mnuPUGraphSel 
      Caption         =   "Popup menu for selection of graphic windows"
      Visible         =   0   'False
      Begin VB.Menu mnuPUGraphSelProp 
         Caption         =   "Selection P&roperties"
      End
      Begin VB.Menu mnuPUGraphSelBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUGraphSelDel 
         Caption         =   "&Delete selection"
      End
      Begin VB.Menu mnuPUGraphSelBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUGraphSelCut 
         Caption         =   "Cu&t selection"
      End
      Begin VB.Menu mnuPUGraphSelCopy 
         Caption         =   "&Copy selection"
      End
   End
   Begin VB.Menu mnuPUGraphDef 
      Caption         =   "Popup menu for default in graphic windows"
      Visible         =   0   'False
      Begin VB.Menu mnuPUGraphDefNew 
         Caption         =   "New &Object"
      End
      Begin VB.Menu mnuPUGraphDefBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUGraphDefPaste 
         Caption         =   "&Paste Object"
      End
   End
   Begin VB.Menu mnuPUAttribVal 
      Caption         =   "Popup menu for value in attrib window"
      Visible         =   0   'False
      Begin VB.Menu mnuPUAttribValBrowse 
         Caption         =   "&Browse..."
      End
      Begin VB.Menu mnuPUAttribValBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUAttribValOpen 
         Caption         =   "Shell &Open"
      End
   End
   Begin VB.Menu mnuPUObjFile 
      Caption         =   "Popup menu for file in object window"
      Visible         =   0   'False
      Begin VB.Menu mnuPUObjFileBrowse 
         Caption         =   "&Browse"
      End
      Begin VB.Menu mnuPUObjFileBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUObjFileOpen 
         Caption         =   "Shell &Open"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Sub ShowStatus(ByVal sKey As String)
    Dim nType As Integer
    
    Dim sStat As String
    Dim sTxt As String
    Dim sVal As String

    'Set default
    sStat = ""
    
    ' Check key
    If Left(sKey, 1) = "m" Then
        'Set status
        sStat = "Mission " + frmMission.GetName + ": " + frmMission.GetType
    End If
        
    ' Check key
    If Left(sKey, 1) = "l" Then
        'Set status
        sStat = "Level " + frmLevels.GetName(Val(Mid(sKey, 2)))
    End If
        
    ' Check key
    If Left(sKey, 1) = "o" Then
        'Get name
        sTxt = frmObjects.GetName(Val(Mid(sKey, 2)))
    
        'Get type
        nType = frmObjects.GetType(Val(Mid(sKey, 2)))
        Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_TYPE, sVal, MIS_MOD_CFG)
        sVal = TruncStr(sVal)
        If sVal <> "" Then sTxt = sVal + ": " + sTxt
                
        'Set status
        sStat = "Object " + sTxt
    End If
        
    ' Check key
    If Left(sKey, 1) = "a" Then
        'Get name
        sTxt = frmAttribs.GetName(Val(Mid(sKey, 2)))
    
        'Get value
        sVal = frmAttribs.GetValue(Val(Mid(sKey, 2)))
        
        'Check type
        If sVal <> "" Then sTxt = sTxt + ": " + sVal
                
        'Set status
        sStat = "Attribute " + sTxt
    End If
    
    'Show status
    sbStatusBar.Panels.Item(1).Text = sStat
    
    'Set status
    sStat = " "
    If bGridFlag = 1 Then sStat = sStat + "Grd "
    If bRotFlag = 1 Then sStat = sStat + "Ang "
    If bScaleFlag = 1 Then sStat = sStat + "Obj "
    If bCamFlag = 1 Then sStat = sStat + "Cam "
    
    'Show status
    sbStatusBar.Panels.Item(2).Text = sStat
End Sub

Sub GetFlags()
    'Check and set toolbar flag
    If bToolFlag = 1 Then
        mnuToolsToolbar.Checked = True
        tbToolBar.Visible = True
    Else
        mnuToolsToolbar.Checked = False
        tbToolBar.Visible = False
    End If

    'Check and set statusbar flag
    If bStatFlag = 1 Then
        mnuToolsStatusBar.Checked = True
        sbStatusBar.Visible = True
    Else
        mnuToolsStatusBar.Checked = False
        sbStatusBar.Visible = False
    End If

    'Check and set grid flag
    If bGridFlag = 1 Then
        mnuToolsGrid.Checked = True
    Else
        mnuToolsGrid.Checked = False
    End If

    'Check and set rotation flag
    If bRotFlag = 1 Then
        mnuToolsAngle.Checked = True
    Else
        mnuToolsAngle.Checked = False
    End If

    'Check and set scale flag
    If bScaleFlag = 1 Then
        mnuToolsScale.Checked = True
    Else
        mnuToolsScale.Checked = False
    End If

    'Check and set camera flag
    If bCamFlag = 1 Then
        mnuToolsCamera.Checked = True
    Else
        mnuToolsCamera.Checked = False
    End If
    
    'Show status
    ShowStatus (sCurKey)
End Sub

Sub DelList(ByVal sPKey As String, ByVal sLKey As String, ByVal sFile As String)
    Dim nPos As Long
    Dim sCurK As String
    Dim sParK As String
    Dim sListK As String
    
    'Set list
    sListK = sLKey
    
    'Set parent key
    sParK = sPKey
    
    'Loop thru types
    Do
        'Get position of space character in string
        nPos = InStr(sListK, " ")
        
        'If possible, truncate string at space character
        If nPos > 0 Then
            'Check parent key
            If sListK = sLKey Then
                'Inform user
                If MsgBox("Delete selection?", vbYesNo Or vbQuestion, "MissionMan") = vbNo Then Exit Sub
            End If
            
            'Reset parent key
            sParK = ""
                
            'Set key
            sCurK = Left(sListK, nPos - 1)
            sListK = Mid(sListK, nPos + 1, Len(sListK))
        Else
            'Set key
            sCurK = sListK
        End If
        
        'Check key
        If Left(sCurK, 1) = "l" Then
            'Delete item
            Call frmLevels.DelLevel(sParK, sCurK, sFile)
        End If
        
        'Check key
        If Left(sCurK, 1) = "o" Then
            'Delete item
            Call frmObjects.DelObject(sParK, sCurK, sFile)
        End If
        
        'Check key
        If Left(sCurK, 1) = "a" Then
            'Delete item
            Call frmAttribs.DelAttrib(sParK, sCurK, sFile)
        End If
        
        'Check position
        If nPos = 0 Then Exit Do
    Loop
    
    'Check list
    If sListK = sLKey Then Exit Sub
      
    'Select in tree
    Call frmTree.SelTree(sPKey)
    
    'Refresh
    frmFront.Render
    frmTop.Render
    frmSide.Render
    frmCamera.Render
End Sub

Sub CopyList(ByVal sLKey As String, ByVal sCKey As String, ByVal sPKey As String, ByVal bFlag As Boolean, ByVal sFile As String)
    Dim nPos As Long
    Dim sCopyK As String
    Dim sListK As String
    
    'Check list
    If InStr(sLKey + " ", sCKey + " ") > 0 Then sCKey = sPKey
    
    'Set list
    sListK = sLKey
    
    'Loop thru types
    Do
        'Get position of space character in string
        nPos = InStr(sListK, " ")
        
        'If possible, truncate string at space character
        If nPos > 0 Then
            'Check list key
            If sListK = sLKey Then
                'Inform user
                If MsgBox("Paste selection?", vbYesNo Or vbQuestion, "MissionMan") = vbNo Then Exit Sub
            End If
            
            'Set key
            sCopyK = Left(sListK, nPos - 1)
            sListK = Mid(sListK, nPos + 1, Len(sListK))
        Else
            'Set key
            sCopyK = sListK
        End If
        
        'Check key
        If Left(sCopyK, 1) = "l" Then
            'Copy item
            Call frmLevels.CopyLevel(sCopyK, sCKey, bFlag, sFile)
        End If
        
        'Check key
        If Left(sCopyK, 1) = "o" Then
            'Copy item
            Call frmObjects.CopyObject(sCopyK, sCKey, bFlag, sFile)
        End If
        
        'Check key
        If Left(sCopyK, 1) = "a" Then
            'Copy item
            Call frmAttribs.CopyAttrib(sCopyK, sCKey, bFlag, sFile)
        End If
        
        'Check position
        If nPos = 0 Then Exit Do
    Loop
    
    'Refresh graphics
    frmFront.Render
    frmTop.Render
    frmSide.Render
    frmCamera.Render
End Sub

Sub GetListProp()
    'Check list key
    If sListKey = sCurKey Then
        'Check key
        If Left(sCurKey, 1) = "m" Then
            'Show form
            frmMission.Show
            frmMission.GetMission
            frmMission.SetFocus
            Exit Sub
        End If
            
        'Check key
        If Left(sCurKey, 1) = "l" Then
            'Show form
            frmLevels.Show
            Call frmLevels.GetLevel(sParKey, sCurKey)
            frmLevels.SetFocus
            Exit Sub
        End If
            
        'Check key
        If Left(sCurKey, 1) = "o" Then
            'Show form
            frmObjects.Show
            Call frmObjects.GetObject(sParKey, sCurKey, 0, 0, 0)
            frmObjects.SetFocus
            Exit Sub
        End If
            
        'Check key
        If Left(sCurKey, 1) = "a" Then
            'Show form
            frmAttribs.Show
            Call frmAttribs.GetAttrib(sParKey, sCurKey)
            frmAttribs.SetFocus
            Exit Sub
        End If
    End If
    
    'Check key