frmobjects.frm

游戏《家园》源码

    rsObjects!PosX = Val(txtPosX.Text)
    rsObjects!PosY = Val(txtPosY.Text)
    rsObjects!PosZ = Val(txtPosZ.Text)
    rsObjects!ScaleX = Val(txtScaleX.Text) / 100
    rsObjects!ScaleY = Val(txtScaleY.Text) / 100
    rsObjects!ScaleZ = Val(txtScaleZ.Text) / 100
    fRotX = Val(txtRotX.Text)
    fRotY = Val(txtRotY.Text)
    fRotZ = Val(txtRotZ.Text)
    Call rendAngCheck(fRotX, fRotY, fRotZ)
    rsObjects!RotX = fRotX
    rsObjects!RotY = fRotY
    rsObjects!RotZ = fRotZ
    rsObjects!Type = cmbType.ItemData(cmbType.ListIndex)
    rsObjects!Layer = cmbLayer.ItemData(cmbLayer.ListIndex)
    rsObjects!Name = Trim(cmbName.Text)
    rsObjects!Info = Trim(txtInfo.Text)
    rsObjects!File = Trim(txtFile.Text)
    
    '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)
    
    'Set selection
    Call frmLayers.SetLayer(rsObjects!Layer, 1)
    Call rendSetSel("o", sCurK)
    
    '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(sParK, sCurK)
    
    'Add attribs
    AddAttribs
    
    'Set link
    Call GetAll(Val(Mid(sCurK, 2)), nRLev, nRObj, nType)
    Call rendFindObj(nLink, GetLink(Val(Mid(sCurK, 2)), nRLev, nRObj, nType))
    Call rendSetObjLink(nObj, nLink)
    
    'Check reference key
    If sRefK <> "" Then
        'Move objects
        Call MoveObjects(sCurK, sRefK, sParK)
        
        'Reset refernce key
        sRefK = ""
        
        'Show tree
        frmTree.ShowTree (sCurK)
        Exit Sub
    End If
    
    'Select in tree
    Call frmTree.SelTree(sCurK)
    
    'Refresh graphics
    frmFront.Render
    frmTop.Render
    frmSide.Render
    frmCamera.Render
End Sub

Sub AddAttribs()
    Dim n As Integer

    Dim nCount As Integer
    
    Dim nPos As Long
    
    Dim sList As String
    Dim sVal As String
    
    'Reset count
    nCount = 0
    
    'Get attribs
    Call misGetListByKey(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(cmbType.ItemData(cmbType.ListIndex) - 1)), MIS_KEY_ATTRIB, sList, nCount, MIS_MOD_CFG)
    
    'Check count
    If nCount = 0 Then Exit Sub
    
    'Truncate attribs
    sList = TruncStr(sList)

    'Loop thru attribs
    For n = 0 To nCount - 1
        'Get position of | character in string
        nPos = InStr(sList, "|")
        
        'Get default
        Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(cmbType.ItemData(cmbType.ListIndex) - 1)), MIS_KEY_DEF + Trim(Str(n)), sVal, MIS_MOD_CFG)
        
        'Truncate default
        sVal = TruncStr(sVal)

        'If possible, truncate string at | character
        If nPos > 0 Then
            'Create new attrib
            Call frmAttribs.NewAttrib(sCurK, Left(sList, nPos - 1), sVal, "")
            sList = Mid(sList, nPos + 1, Len(sList))
        Else
            'Create new attrib
            Call frmAttribs.NewAttrib(sCurK, sList, sVal, "")
        End If
    Next n
End Sub

Sub DelObject(ByVal sPKey As String, ByVal sCKey As String, ByVal sFile As String)
    Dim nType As Integer
    
    Dim nObj As Long
        
    Dim sTxt As String
    Dim sVal As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check file
    If sFile = "" Then
        'Check DB
        If bDBFlag = False Then Exit Sub
    End If
    
    'Check key
    If sCKey = "" Then Exit Sub
    If Left(sCKey, 1) <> "o" Then Exit Sub
    
    'Check parent
    If sPKey <> "" And sFile = "" Then
        'Get name
        sTxt = frmObjects.GetName(Val(Mid(sCKey, 2)))
    
        'Get type
        nType = frmObjects.GetType(Val(Mid(sCKey, 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
                
        'Prompt user
        If MsgBox("Delete object " + sTxt + "?", vbYesNo Or vbQuestion, "MissionMan") = vbNo Then Exit Sub
    End If
    
    'Del attrib
    Call frmAttribs.DelAttribs(sCKey, sFile)
   
    'Del objects
    Call DelObjects(sCKey, sFile)
    
    'Check file
    If sFile = "" Then
        'Check recordset
        If rsObjects.BOF = True Then Exit Sub
    End If
    
    'Set query
    sQuery = "SELECT * FROM Objects WHERE Key = " + Mid(sCKey, 2)
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, sFile) = False Then Exit Sub
        
    'Delete data in recordset
    rsTemp.MoveFirst
    
    'Find object
    Call rendFindObj(nObj, rsTemp!Key)
    
    'Delete object
    Call rendDelObj(nObj)
    
    'Delete data
    rsTemp.Delete
    
    'Close temporary recordset
    Call CloseRecordSetByQuery(rsTemp, sFile)
    
    'Check file
    If sFile <> "" Then Exit Sub
    
    'Delete from tree
    Call frmTree.DelTree(sCKey)
    
    'Check parent
    If sPKey = "" Then Exit Sub
    
    'Select in tree
    Call frmTree.SelTree(sPKey)
    
    'Refresh graphics
    frmFront.Render
    frmTop.Render
    frmSide.Render
    frmCamera.Render
End Sub

Sub DelObjects(ByVal sKey As String, ByVal sFile As String)
    Dim nObj As Long
       
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check file
    If sFile = "" Then
        'Check DB
        If bDBFlag = False Then Exit Sub
    End If
    
    'Check key
    If sKey = "" Then Exit Sub
    If Left(sKey, 1) = "m" Then Exit Sub
    If Left(sKey, 1) = "a" Then Exit Sub
    
    'Check file
    If sFile = "" Then
        'Check recordset
        If rsObjects.BOF = True Then Exit Sub
    End If
        
    'Check key
    If Left(sKey, 1) = "l" Then
        'Set query
        sQuery = "SELECT * FROM Objects WHERE Level = " + Mid(sKey, 2) + " AND Object = 0 ORDER BY Key"
    End If
    
    'Check key
    If Left(sKey, 1) = "o" Then
        'Set query
        sQuery = "SELECT * FROM Objects WHERE Level = 0 AND Object = " + Mid(sKey, 2) + " ORDER BY Key"
    End If
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, sFile) = False Then Exit Sub
        
    'Find data in recordset
    rsTemp.MoveFirst
    Do Until rsTemp.EOF
        'Del attribs
        Call frmAttribs.DelAttribs("o" + Trim(Str(rsTemp!Key)), sFile)
        
        'Del objects
        Call DelObjects("o" + Trim(Str(rsTemp!Key)), sFile)
        
        'Find object
        Call rendFindObj(nObj, rsTemp!Key)

        'Delete object
        Call rendDelObj(nObj)

        'Delete data
        rsTemp.Delete
        rsTemp.MoveNext
    Loop
    
    'Close temporary recordset
    Call CloseRecordSetByQuery(rsTemp, sFile)
End Sub

Sub DelLayer(ByVal nKey As Long)
    Dim nObj As Long
    Dim nMode As Long
       
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Set query
    sQuery = "SELECT * FROM Objects WHERE Layer = " + Str(nKey) + " ORDER BY Key"
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Find data in recordset
    rsTemp.MoveFirst
    Do Until rsTemp.EOF
        'Find object
        Call rendFindObj(nObj, rsTemp!Key)
        
        'Get mode
        Call rendGetObjMode(nObj, nMode)
        If nMode = 0 Then nMode = 1
        
        'Set mode and color
        Call rendSetObjMode(nObj, nMode)
        Call rendSetObjCol(nObj, nViewCol)
        
        'Edit data in recordset
        rsTemp.Edit
        rsTemp!Layer = 0
        rsTemp.Update
        rsTemp.MoveNext
    Loop
    
    'Close temporary recordset
    rsTemp.Close
End Sub

Sub CopyObject(ByVal sSrcKey As String, ByVal sDstKey As String, ByVal bFlag As Boolean, ByVal sSrcFile As String)
    Dim nType As Integer
    
    Dim nKey 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 source
    If sSrcKey = "" Then Exit Sub
    If Left(sSrcKey, 1) <> "o" 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
    
    'Set query
    sQuery = "SELECT * FROM Objects WHERE Key = " + Mid(sSrcKey, 2)
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, sSrcFile) = False Then Exit Sub
        
    'Get data from recordset
    rsTemp.MoveFirst

    'Add data to recordset
    rsObjects.AddNew
    nKey = 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
        
    'Close temporary recordset
    Call CloseRecordSetByQuery(rsTemp, sSrcFile)
    
    '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, nKey, 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)
    
    'Set selection
    Call frmLayers.SetLayer(rsObjects!Layer, 1)
    Call rendSetSel("o", "o" + Trim(Str(nKey)))
    
    '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(nKey)))
    
    'Copy attrib
    Call frmAttribs.CopyAttribs(sSrcKey, "o" + Trim(Str(nKey)), sSrcFile)
   
    'Set link
    Call GetAll(nKey, nRLev, nRObj, nType)