frmobjects.frm

游戏《家园》源码

    Call rendFindObj(nLink, GetLink(nKey, nRLev, nRObj, nType))
    Call rendSetObjLink(nObj, nLink)
    
    'Copy objects
    Call CopyObjects(sSrcKey, "o" + Trim(Str(nKey)), sSrcFile)
    
    'Check flag
    If bFlag = True Then Call DelObject("", sSrcKey, sSrcFile)
    
    'Select in tree
    Call frmTree.SelTree("o" + Trim(Str(nKey)))
End Sub

Sub CopyObjects(ByVal sSrcKey As String, ByVal sDstKey As String, ByVal sSrcFile As String)
    Dim nType As Integer
    
    Dim nDstKey As Long
    Dim nSrcKey As Long
    Dim nObj As Long
    Dim nLink As Long
    Dim nMode As Long
    Dim nCol As Long
    Dim nRLev As Long
    Dim nRObj As Long
    
    Dim sQuery As String
    Dim sFile As String
    
    Dim rsTemp As Recordset
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Check destination
    If sDstKey = "" Then Exit Sub
    If Left(sDstKey, 1) = "m" Then Exit Sub
    If Left(sDstKey, 1) = "a" Then Exit Sub
    
    'Check source file
    If sSrcFile = "" Then
        'Check recordset
        If rsObjects.BOF = True Then Exit Sub
    End If
    
    'Reset Query
    sQuery = ""
    
    'Check source
    If Left(sSrcKey, 1) = "l" Then
        'Set query
        sQuery = "SELECT * FROM Objects WHERE Level = " + Mid(sSrcKey, 2) + " AND Object = 0 ORDER BY Key"
    End If
    
    'Check source
    If Left(sSrcKey, 1) = "o" Then
        'Set query
        sQuery = "SELECT * FROM Objects WHERE Level = 0 AND Object = " + Mid(sSrcKey, 2) + " ORDER BY Key"
    End If
    
    'Check query
    If sQuery = "" Then Exit Sub
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, sSrcFile) = False Then Exit Sub
        
    'Get data from recordset
    rsTemp.MoveFirst
    Do Until rsTemp.EOF
        nSrcKey = rsTemp!Key
        
        'Add data to recordset
        rsObjects.AddNew
        nDstKey = rsObjects!Key
    
        'Check destination
        If Left(sDstKey, 1) = "l" Then
            rsObjects!Level = Val(Mid(sDstKey, 2))
        Else
            rsObjects!Level = 0
        End If
    
        'Check destination
        If Left(sDstKey, 1) = "o" Then
            rsObjects!Object = Val(Mid(sDstKey, 2))
        Else
            rsObjects!Object = 0
        End If
    
        'Copy data
        rsObjects!NumObjs = rsTemp!NumObjs
        rsObjects!NumAttribs = rsTemp!NumAttribs
        rsObjects!PosX = rsTemp!PosX
        rsObjects!PosY = rsTemp!PosY
        rsObjects!PosZ = rsTemp!PosZ
        rsObjects!ScaleX = rsTemp!ScaleX
        rsObjects!ScaleY = rsTemp!ScaleY
        rsObjects!ScaleZ = rsTemp!ScaleZ
        rsObjects!RotX = rsTemp!RotX
        rsObjects!RotY = rsTemp!RotY
        rsObjects!RotZ = rsTemp!RotZ
        rsObjects!Type = rsTemp!Type
        rsObjects!Layer = rsTemp!Layer
        rsObjects!Name = rsTemp!Name
        rsObjects!Info = rsTemp!Info
        rsObjects!File = rsTemp!File
    
        'Get full filename
        sFile = rsObjects!File
        
        'Check filename
        If sFile <> "" Then
            If InStr(sFile, ":") = 0 Then
                'Validate and hash file
                If Dir(sObjDir + sFile) = "" Then sFile = Trim(Str(misGetHash(rsObjects!File))) + MIS_EXT_OBJ
                
                'Append filename to object dir
                sFile = sObjDir + sFile
            End If
        End If
            
        'Create object
        If rendNewObj(nObj, rsObjects!Key, sFile) Then Call MsgBox("DLL error: Unable to create object!", vbOKOnly Or vbExclamation, "MissionMan")
        
        'Set mode and color
        Call frmLayers.GetColor(rsObjects!Layer, nMode, nCol)
        Call rendSetObjMode(nObj, nMode)
        Call rendSetObjCol(nObj, nCol)
    
        'Position object
        Call rendRotObj(nObj, rsObjects!RotX, rsObjects!RotY, rsObjects!RotZ)
        Call rendScaleObj(nObj, rsObjects!ScaleX, rsObjects!ScaleY, rsObjects!ScaleZ)
        Call rendTransObj(nObj, rsObjects!PosX, rsObjects!PosY, rsObjects!PosZ)
        
        'Update data
        rsObjects.Update
        
        'Add to tree
        Call frmTree.AddTree(sDstKey, "o" + Trim(Str(nDstKey)))
    
        'Copy attrib
        Call frmAttribs.CopyAttribs("o" + Trim(Str(nSrcKey)), "o" + Trim(Str(nDstKey)), sSrcFile)
   
        'Set link
        Call GetAll(nDstKey, nRLev, nRObj, nType)
        Call rendFindObj(nLink, GetLink(nDstKey, nRLev, nRObj, nType))
        Call rendSetObjLink(nObj, nLink)
        
        'Copy objects
        Call CopyObjects("o" + Trim(Str(nSrcKey)), "o" + Trim(Str(nDstKey)), sSrcFile)
        rsTemp.MoveNext
    Loop
    
    'Close temporary recordset
    Call CloseRecordSetByQuery(rsTemp, sSrcFile)
End Sub

Sub DupObjects(ByVal X As Single, ByVal Y As Single, ByVal Z As Single)
    Dim nType As Integer
    
    Dim nLev As Long
    Dim nObj As Long
    Dim nPos As Long
    
    Dim fPosX As Single
    Dim fPosY As Single
    Dim fPosZ As Single
    
    Dim sKey As String
    Dim sInList As String
    Dim sOutList As String
    
    ' Check current key
    If Left(sCurKey, 1) <> "o" Then Exit Sub
    
    'Get object position
    Call rendFindObj(nObj, Val(Mid(sCurKey, 2)))
    Call rendGetObjTrans(nObj, fPosX, fPosY, fPosZ)
    
    'Translate object
    X = X - fPosX
    Y = Y - fPosY
    Z = Z - fPosZ
    
    'Check grid flag
    If bGridFlag = 1 Then
        'Snap x translation to grid
        If Abs(X) Mod fGridSize < fGridSize / 2 Then
            X = -(X Mod fGridSize) + X
        Else
            X = Sgn(X) * fGridSize - (X Mod fGridSize) + X
        End If
    
        'Snap y translation to grid
        If Abs(Y) Mod fGridSize < fGridSize / 2 Then
            Y = -(Y Mod fGridSize) + Y
        Else
            Y = Sgn(Y) * fGridSize - (Y Mod fGridSize) + Y
        End If
    
        'Snap z translation to grid
        If Abs(Z) Mod fGridSize < fGridSize / 2 Then
            Z = -(Z Mod fGridSize) + Z
        Else
            Z = Sgn(Z) * fGridSize - (Z Mod fGridSize) + Z
        End If
    End If
    
    'Initialize Lists
    sInList = sListKey
    sOutList = ""
    
    'Loop thru types
    Do
        'Get position of space character in string
        nPos = InStr(sInList, " ")
        
        'If possible, truncate string at space character
        If nPos > 0 Then
            'Set key
            sKey = Left(sInList, nPos - 1)
            sInList = Mid(sInList, nPos + 1, Len(sInList))
        Else
            'Set key
            sKey = sInList
        End If
        
        'Check key
        If Left(sKey, 1) = "o" Then
            'Get parent
            Call GetAll(Val(Mid(sKey, 2)), nLev, nObj, nType)
        
            'Duplicate object
            If nLev > 0 And nObj = 0 Then Call CopyObject(sKey, "l" + Trim(Str(nLev)), False, "")
            If nLev = 0 And nObj > 0 Then Call CopyObject(sKey, "o" + Trim(Str(nObj)), False, "")
            
            'Append list
            If sOutList <> "" Then sOutList = sOutList + " "
            sOutList = sOutList + sCurKey
            
            'Get object
            Call rendFindObj(nObj, Val(Mid(sCurKey, 2)))
            
            'Translate object
            Call rendTransObj(nObj, X, Y, Z)
            
            'Set object position
            Call EditObject(Val(Mid(sCurKey, 2)))
        End If
        
        'Check position
        If nPos = 0 Then Exit Do
    Loop
    
    'Select in tree
    Call frmTree.ShowTree(sOutList)
    
    'Refresh graphics
    frmFront.Render
    frmTop.Render
    frmSide.Render
    frmCamera.Render
End Sub

Sub EditObject(ByVal nKey As Long)
    Dim nObj As Long
    
    Dim fPosX As Single
    Dim fPosY As Single
    Dim fPosZ As Single
    Dim fScaleX As Single
    Dim fScaleY As Single
    Dim fScaleZ As Single
    Dim fRotX As Single
    Dim fRotY As Single
    Dim fRotZ As Single

    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Check recordset
    If rsObjects.BOF = True Then Exit Sub
    
    'Set query
    sQuery = "SELECT * FROM Objects WHERE Key = " + Trim(Str((nKey)))
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Get object
    Call rendFindObj(nObj, nKey)
        
    'Get position
    Call rendGetObjTrans(nObj, fPosX, fPosY, fPosZ)
    Call rendGetObjScale(nObj, fScaleX, fScaleY, fScaleZ)
    Call rendGetObjRot(nObj, fRotX, fRotY, fRotZ)
    Call rendAngCheck(fRotX, fRotY, fRotZ)
                    
    'Put data in recordset
    rsTemp.MoveFirst
    
    'Set data
    rsTemp.Edit
    rsTemp!PosX = fPosX
    rsTemp!PosY = fPosY
    rsTemp!PosZ = fPosZ
    rsTemp!ScaleX = fScaleX
    rsTemp!ScaleY = fScaleY
    rsTemp!ScaleZ = fScaleZ
    rsTemp!RotX = fRotX
    rsTemp!RotY = fRotY
    rsTemp!RotZ = fRotZ
    rsTemp.Update

    'Close temporary recordset
    rsTemp.Close
    
    'Update form
    If fMainForm.mnuViewTabObject.Checked = True And Val(Mid(sCurK, 2)) = nKey Then
        'Put default data in controls
        txtPosX.Text = Format(fPosX, "0;-#")
        txtPosY.Text = Format(fPosY, "0;-#")
        txtPosZ.Text = Format(fPosZ, "0;-#")
        txtScaleX.Text = Format(fScaleX * 100, "0;-#")
        txtScaleY.Text = Format(fScaleY * 100, "0;-#")
        txtScaleZ.Text = Format(fScaleZ * 100, "0;-#")
        txtRotX.Text = Format(fRotX, "0;-#")
        txtRotY.Text = Format(fRotY, "0;-#")
        txtRotZ.Text = Format(fRotZ, "0;-#")
    End If
End Sub

Sub GenObject(ByVal sKey As String, ByVal sFile As String)
    Dim bFlag As Boolean

    Dim n As Integer
    Dim nType As Integer
    Dim nErr As Integer
    Dim nCount As Integer
    Dim nNum As Integer
    Dim nInd As Integer
    
    Dim nPos As Long
    Dim nObj As Long
    Dim nKey As Long
    Dim nStream As Long
    
    Dim fAngX As Single
    Dim fAngY As Single
    Dim fAngZ As Single
    Dim fAngH As Single
    Dim fAngV As Single
    Dim fSizeX As Single
    Dim fSizeY As Single
    Dim fSizeZ As Single
        
    Dim sQuery As String
    Dim sName As String
    Dim sAlias As String
    Dim sInfo As String
    Dim sExt As String
    Dim sType As String
    Dim sForm As String
    Dim sMsg As String
    Dim sList As String
    Dim sVal As String
    
    Dim rsTemp As Recordset
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Check key
    If sKey = "" Then Exit Sub
    If Left(sKey, 1) <> "o" Then Exit Sub
    
    'Check recordset
    If rsObjects.BOF = True Then Exit Sub
    
    'Set query
    sQuery = "SELECT * FROM Objects WHERE Key = " + Mid(sKey, 2)
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Get data from recordset
    rsTemp.MoveFirst
    nType = rsTemp!Type
    sName = rsTemp!Name
    sInfo = rsTemp!Info
    
    'Close temporary recordset
    rsTemp.Close
    
    'Get extension
    Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_EXT, sExt, MIS_MOD_CFG)
    sExt = TruncStr(sExt)
    If sExt = "" Then Exit Sub
    
    'Set progress bar
    Call frmProgress.Init("Generating object " + sName + "...", 100)
    
    'Check file
    If sFile = "" Then sFile = sName + sExt
    
    'Open file
    nErr = misOpen(nStream, sFile)
    If nErr < 0 Then
        'Reset progress bar
        Call frmProgress.Clean
        
        'Inform user
        Call misGetErr(nErr, sMsg)
        Call MsgBox("Error: " + TruncStr(sMsg) + " " + sFile + " (Check attributes and directories)!", vbOKOnly Or vbExclamation, "MissionMan")
        Exit Sub
    End If
    
    'Get type
    Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_TYPE, sType, MIS_MOD_CFG)
    sType = TruncStr(sType)
    
    'Write data
    Call misWriteInfo(nStream, "MissionMan script, " + Format(Date, "dddd, mmm d yyyy") + ", " + Format(Time, "h:mm:ss AMPM"))
    Call misWriteInfo(nStream, "Copyright (c) 1998-99, Relic Entertainment Inc.")
    If sType <> "" Then
        Call misWriteInfo(nStream, sType + " Object: " + sName)
    Else
        Call misWriteInfo(nStream, "Object: " + sName)
    End If
    If sInfo <> "" Then Call misWriteInfo(nStream, "Info: " + sInfo)
    misWriteNew (nStream)
    
    'Reset flag
    bFlag = False
    
    'Set query
    sQuery = "SELECT * FROM Objects WHERE Level = 0 AND Object = " + Mid(sKey, 2) + " ORDER BY Key"
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = True Then
        'Get data from recordset
        rsTemp.MoveFirst
        Do Until rsTemp.EOF
            'Update status bar
            Call frmProgress.Update(rsTemp