frmmain.frm

游戏《家园》源码

    If InStr(sListKey, "m") > 0 Then
        'Show table
        frmMission.Show
        frmMission.GetMission
        frmMission.SetFocus
    End If
        
    'Check key
    If InStr(sListKey, "l") > 0 Then
        'Show table
        frmLevels.Show
        Call frmLevels.GetLevel("", sListKey)
        frmLevels.SetFocus
    End If
    
    'Check key
    If InStr(sListKey, "o") > 0 Then
        'Show table
        frmObjects.Show
        Call frmObjects.GetObject("", sListKey, 0, 0, 0)
        frmObjects.SetFocus
    End If
    
    'Check key
    If InStr(sListKey, "a") > 0 Then
        'Show table
        frmAttribs.Show
        Call frmAttribs.GetAttrib("", sListKey)
        frmAttribs.SetFocus
    End If
End Sub

Private Sub OpenFile(ByVal sFile As String)
    Dim nPos As Long

    Dim sVal As String
    Dim sName As String
    Dim sExt As String
    
    'Close file
    Call CloseFile
    
    'Set database file
    sDBFile = sFile
    
    'Set work directory
    sName = Dir(sDBFile)
    If sName = "" Then
        'Inform user
        Call MsgBox("Error: Unable to open mission database (Check path " + sDBFile + ")!", vbOKOnly Or vbExclamation, "MissionMan")
        Exit Sub
    End If
    
    'Remove name from DB path
    nPos = InStr(sDBFile, sName)
    If nPos > 0 Then
        sWorkDir = Left(sDBFile, nPos - 1)
    Else
        sWorkDir = sWDir
    End If
    
    'Set data directory
    sDataDir = sDDir
    If sDataDir = "" Then
        'Set data dir to work dir if data dir not set
        sDataDir = sWorkDir
    Else
        'Check work dir
        If InStr(1, sWorkDir, sWDir, vbTextCompare) > 0 Then
            'Remove extension from DB name
            nPos = InStr(sName, ".")
            If nPos > 0 Then sExt = Left(sName, nPos - 1)
            
            'Set data dir to partial mirror work dir plus mission DB name
            sDataDir = sDataDir + Mid(sWorkDir, Len(sWDir) + 1) + sExt + "\"
        Else
            'Set data dir to full work dir if unable to mirror partial work dir
            sDataDir = sWorkDir
        End If
    End If
    
    'Set objects directory
    sObjDir = sODir
    If sObjDir = "" Then sObjDir = sWorkDir
    
    'Set caption
    Me.Caption = "MissionMan - " + sDBFile
    
    'Open database
    OpenDB
    If bDBFlag = False Then Exit Sub
    
    'Check type
    If frmMission.CheckType = False Then
        'Inform user
        Call MsgBox("Error: Invalid mission database (Check type)!", vbOKOnly Or vbExclamation, "MissionMan")
        Exit Sub
    End If
    
    'Append MRU list
    Call AppendMRUList(sDBFile)
    
    'Get tree
    frmTree.Hide
    frmTree.GetTree ("m")
    
    'Get objects
    frmObjects.GetObjects
    
    'Show tree view
    frmTree.Show
        
    'Show views
    frmCamera.Show
    frmFront.Show
    frmTop.Show
    frmSide.Show
    
    'Set focus
    frmTree.SetFocus
End Sub

Private Sub MDIForm_Load()
    Dim sCommand As String

    'Maximize form
    Me.WindowState = vbMaximized
    
    'Get MRU list
    GetMRUList
    
    'Get flags
    GetFlags
    
    'Show form
    Me.Show
    
    'Check command line and open file
    sCommand = Command
    If sCommand <> "" Then Call OpenFile(sCommand)
End Sub

Sub CloseFile()
    'Hide views
    Unload frmTree
    Unload frmCamera
    Unload frmSide
    Unload frmTop
    Unload frmFront
    
    'Hide other views
    Unload frmList
    Unload frmLayers
    Unload frmMission
    Unload frmLevels
    Unload frmObjects
    Unload frmAttribs
    
    'Re-initialize renderer
    rendClean
    rendInit
    
    'Close database
    CloseDB
    
    'Reset caption
    Me.Caption = "MissionMan"
    
    'Reset keys
    sParKey = ""
    sCurKey = ""
    sCopyKey = ""
    sListKey = ""
    
    'Get status
    ShowStatus (sCurKey)
End Sub

Sub GetMRUList()
    Dim n As Integer
    Dim nPos As Long
        
    Dim sList As String
    
    'Reset count
    nMRUCount = 0
    
    'Get window
    Call misGetListByKey(MIS_SEC_COM, MIS_KEY_MRU, sList, nMRUCount, MIS_MOD_INI)
    
    'Check count
    If nMRUCount > 0 Then
        'Truncate list
        sList = TruncStr(sList)
        
        'Loop thru list
        For n = 0 To nMRUCount - 1
            'Get position of | character in string
            nPos = InStr(sList, "|")
        
            'If possible, truncate string at | character
            If nPos > 0 Then
                'Set position
                mnuFileMRU(n).Caption = Left(sList, nPos - 1)
                mnuFileMRU(n).Visible = True
                sList = Mid(sList, nPos + 1, Len(sList))
            Else
                'Set position
                mnuFileMRU(n).Caption = sList
                mnuFileMRU(n).Visible = True
            End If
        Next n
        
        'Set MRU index
        nMRUIndex = nMRUCount
        If nMRUIndex >= MIS_MRU_COUNT Then nMRUIndex = 0
    End If
End Sub

Sub AppendMRUList(ByVal sFile As String)
    Dim n As Integer

    'Check for existing file
    For n = 0 To nMRUCount - 1
        If mnuFileMRU(n).Caption = sFile Then Exit Sub
    Next n

    'Append file
    mnuFileMRU(nMRUIndex).Caption = sDBFile
    mnuFileMRU(nMRUIndex).Visible = True
    
    'Increment index
    nMRUIndex = nMRUIndex + 1
    If nMRUCount < nMRUIndex Then nMRUCount = nMRUIndex
    If nMRUIndex >= MIS_MRU_COUNT Then nMRUIndex = 0
End Sub

Sub PutMRUList()
    Dim n As Integer
    
    Dim sList As String
    
    'Reset list
    sList = ""
    For n = 0 To nMRUCount - 1
        'Append list
        sList = sList + "|" + mnuFileMRU(n).Caption
    Next n
    
    'Put window
    Call misPutListByKey(MIS_SEC_COM, MIS_KEY_MRU, sList, MIS_MOD_INI)
End Sub

Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    'Cancel unload
    Cancel = 1
    
    'End program
    AntiMain
End Sub

Private Sub mnuEditFind_Click()
    Dim nObj As Long
    
    Dim X As Single
    Dim Y As Single
    Dim Z As Single
    
    'Check key
    If Left(sCurKey, 1) <> "o" Then Exit Sub

    'Get object position
    Call rendFindObj(nObj, Val(Mid(sCurKey, 2)))
    Call rendGetObjTrans(nObj, X, Y, Z)

    'Set offset
    aOffset(0) = -X * fViewScale
    aOffset(1) = -Y * fViewScale
    aOffset(2) = -Z * fViewScale
    
    'Set focus
    aFocus(0) = X
    aFocus(1) = Y
    aFocus(2) = Z
    
    'Refresh
    frmFront.SetView (False)
    frmFront.SetCamera (True)
    frmTop.SetView (False)
    frmTop.SetCamera (True)
    frmSide.SetView (False)
    frmSide.SetCamera (True)
    frmCamera.SetCamera (True)
End Sub

Private Sub mnuEditUndo_Click()
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'CHeck undo flag
    If bUndoFlag = False Then Exit Sub

    'Promp user
    If MsgBox("Undo " + sUndoInfo + "?", vbYesNo Or vbQuestion, "MissionMan") = vbNo Then Exit Sub
    
    'Undo
    RollbackDB
    
    'Hide list view
    Unload frmList
       
    'Refresh tree
    frmTree.GetTree (sListKey)
    
    'Re-initialize renderer
    rendClean
    rendInit
    frmObjects.GetObjects
    Call rendSetSel("o", sListKey)
       
    'Show views
    frmCamera.Render
    frmFront.Render
    frmTop.Render
    frmSide.Render
    
    'Refresh layers
    frmLayers.GetLayers (0)
    
    'Refresh list
    Call frmList.GetList(sCurKey, "")
    
    'Set focus
    frmTree.SetFocus
End Sub

Private Sub mnuFileCreate_Click()
    Dim nAttribs As Integer

    Dim sFile As String
    Dim sPath As String

    'Get reference file
    sFile = App.Path
    If Mid(sFile, Len(sFile)) <> "\" Then sFile = sFile + "\"
    sFile = sFile + MIS_FILE_DEF
    
    'Check and change attribs
    nAttribs = GetAttr(sFile)
    If (nAttribs And vbReadOnly) <> 0 Then Call SetAttr(sFile, nAttribs And (Not vbReadOnly))
   
    'Set handler for Cancel button
    On Error GoTo Cancel
    
    'Show common dialog
    cdMission.FileName = "New Folder"
    cdMission.InitDir = sWDir
    cdMission.DialogTitle = "Create Mission Database Folder"
    cdMission.Filter = "Folders|Dir"
    cdMission.ShowSave
        
    'Reset handler for Cancel button
    On Error GoTo 0
    
    'Create directory
    sPath = cdMission.FileName
    Call MkDir(sPath)
    
    'Check directory
    If Dir(sPath, vbDirectory) = "" Then
        'Inform user
        Call MsgBox("Error: Unable to create folder " + sPath + "!", vbOKOnly Or vbExclamation, "MissionMan")
        Exit Sub
    End If
    
    'Append file name
    If Mid(sPath, Len(sPath)) <> "\" Then sPath = sPath + "\"
    sPath = sPath + MIS_FILE_DEF
    
    'Copy reference file
    Call FileCopy(sFile, sPath)
    
    'Open file
    Call OpenFile(sPath)
    Exit Sub
    
    'Cancel button handler
Cancel:
    Exit Sub
End Sub

Private Sub mnuFileMRU_Click(Index As Integer)
    'Open file
    Call OpenFile(mnuFileMRU(Index).Caption)
End Sub

Private Sub mnuHelpAbout_Click()
    Dim sDll As String
    Dim sIni As String

    'Get DLL version
    Call misGetVer(sDll)
    sDll = TruncStr(sDll)
    If sDll = "" Then sDll = "N/A"
    
    'Get config version
    Call misGetVal(MIS_SEC_COM, MIS_KEY_VER, sIni, MIS_MOD_CFG)
    sIni = TruncStr(sIni)
    If sIni = "" Then sIni = "N/A"

    'Show version
    Call MsgBox("MissionMan version " + MIS_VER_NUM + Chr(13) + "DLL version " + sDll + Chr(13) + "Config version " + sIni + Chr(13) + Chr(13) + "Copyright (c) 1998-99, Relic Entertainment Inc." + Chr(13) + Chr(13) + "This program is freeware and freely distributable." + Chr(13) + Chr(13) + "There is absolutely NO WARRANTY and" + Chr(13) + "NO SUPPORT for this software, you use it" + Chr(13) + "at your own risk.", vbOKOnly Or vbInformation, "MissionMan")
End Sub

Private Sub mnuHelpHelp_Click()
    Dim sFile As String

    'Set help file
    sFile = App.Path
    If Mid(sFile, Len(sFile)) <> "\" Then sFile = sFile + "\"
    sFile = sFile + MIS_FILE_HLP
    
    'Attempt to open
    Call misShellExec(sFile)
End Sub

Private Sub mnuPUAttribValBrowse_Click()
    'Browse
    frmAttribs.BrowseAttrib
End Sub

Private Sub mnuPUAttribValOpen_Click()
    Dim sValue As String

    'Get path
    sValue = frmAttribs.cmbValue.Text
    
    'Check path
    If InStr(sValue, ":") = 0 Then
        'Update path
        sValue = sDataDir + sValue
    End If
    
    'Attempt to open
    Call misShellExec(sValue)
End Sub

Private Sub mnuPUGraphDefNew_Click()
    'Check current key
    If Left(sCurKey, 1) = "m" Then Exit Sub
    If Left(sCurKey, 1) = "a" Then Exit Sub
    
    'New object
    frmObjects.Show
    Call frmObjects.GetObject(sCurKey, "", aCursor(0), aCursor(1), aCursor(2))
    frmObjects.SetFocus
End Sub

Private Sub mnuPUGraphDefPaste_Click()
    Dim nObj As Long
    
    Dim fPosX As Single
    Dim fPosY As Single
    Dim fPosZ As Single
    
    'Get data from clipboard
    FromClipboard
    
    'Check copy key
    If InStr(sCopyKey, "l") > 0 Then Exit Sub
    If InStr(sCopyKey, "a") > 0 Then Exit Sub
        
    'Commit
    Call CommitDB("Paste")
    
    'Copy item(s)
    Call CopyList(sCopyKey, sCurKey, sParKey, bDelFlag, sCopyFile)
    
    'Check copy key
    If InStr(sCopyKey, " ") > 0 Then Exit Sub
    
    'Get object position
    Call rendFindObj(nObj, Val(Mid(sCurKey, 2)))
    Call rendGetObjTrans(nObj, fPosX, fPosY, fPosZ)
    
    'Translate object
    fPosX = aCursor(0) - fPosX
    fPosY = aCursor(1) - fPosY
    fPosZ = aCursor(2) - fPosZ
    Call rendTransObj(nObj, fPosX, fPosY, fPosZ)
    
    If bGridFlag = 1 Then
        'Snap x translation to grid
        If Abs(fPosX) Mod fGridSize < fGridSize / 2 Then
            fPosX = -(fPosX Mod fGridSize)
        Else
            fPosX = Sgn(fPosX) * fGridSize - (fPosX Mod fGridSize)
        End If
    
        'Snap y translation to grid
        If Abs(fPosY) Mod fGridSize < fGridSize / 2 Then