frmobjects.frm

游戏《家园》源码

    
    Dim nPos As Long
    
    Dim sList As String
    
    'Clear combo
    cmbName.Clear
    cmbName.Text = sName
        
    'Reset count
    nCount = 0
    
    'Get Names
    Call misGetListByKey(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_NAME, sList, nCount, MIS_MOD_CFG)
    
    'Check count
    If nCount = 0 Then Exit Sub
    
    'Truncate names
    sList = TruncStr(sList)

    'Loop thru names
    For n = 0 To nCount - 1
        'Get position of | character in string
        nPos = InStr(sList, "|")
        
        'If possible, truncate string at | character
        If nPos > 0 Then
            'Add name to combo
            cmbName.AddItem (Left(sList, nPos - 1))
            cmbName.ItemData(cmbName.NewIndex) = n + 1
            sList = Mid(sList, nPos + 1, Len(sList))
        Else
            'Add name to combo
            cmbName.AddItem (sList)
            cmbName.ItemData(cmbName.NewIndex) = n + 1
        End If
    Next n
End Sub

Function GetFile(ByVal sKey As String, ByVal nInd As Integer) As String
    Dim nType As Integer
    Dim nKey As Long
    Dim nPos As Long
    
    Dim sExt As String
    Dim sName As String
    Dim sVal As String
    Dim sInfo As String
    
    'Set default
    GetFile = ""
    
    'Check DB
    If bDBFlag = False Then Exit Function
    
    'Check key
    If sKey = "" Then Exit Function
    If Left(sKey, 1) <> "o" Then Exit Function
    
    'Get type
    nType = frmObjects.GetType(Val(Mid(sKey, 2)))
    
    '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 Function
    
    'Get name
    Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_REF, sName, MIS_MOD_CFG)
    sName = TruncStr(sName)
    
    'Reset key
    nKey = 0

    'Get key
    Call frmAttribs.GetAll(sKey, sName, nKey, sVal, sInfo)
        
    'Check value
    If sVal <> "" Then
        'Check path
        If InStr(sVal, ":") = 0 Then
            'Update path
            sVal = sDataDir + sVal
        End If
    Else
        'Set value
        sVal = GetName(Mid(sKey, 2))
    
        'Check value
        nPos = InStr(sVal, ",")
        If nPos > 0 Then
            'Truncate value at comma
            sVal = Mid(sVal, nPos + 1)
        End If
        
        'Check index
        If nInd >= 0 Then sVal = sVal + "_" + Trim(Str(nInd))
        
        'Set File
        GetFile = sDataDir + sVal + sExt
        Exit Function
    End If
        
    'Set file
    GetFile = sVal
End Function

Function CheckFile(ByVal nType As Integer, ByVal sName As String, ByVal sFile As String)
    Dim n As Integer

    Dim nInd As Integer
    Dim nCount As Integer
    
    Dim nPos As Long
    
    Dim sVal As String
    Dim sList As String
    
    'Set default
    CheckFile = sFile

    'Reset count
    nCount = 0
    
    'Get Names
    Call misGetListByKey(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_NAME, sList, nCount, MIS_MOD_CFG)
    
    'Check count
    If nCount = 0 Then Exit Function
    
    'Truncate names
    sList = TruncStr(sList)

    'Reset index
    nInd = 0
    
    'Loop thru names
    For n = 0 To nCount - 1
        'Get position of | character in string
        nPos = InStr(sList, "|")
        
        'If possible, truncate string at | character
        If nPos > 0 Then
            'Check name
            If (sName = Left(sList, nPos - 1)) Then
                'Set index
                nInd = n + 1
                Exit For
            End If
            sList = Mid(sList, nPos + 1, Len(sList))
        Else
            'Check name
            If (sName = sList) Then
                'Set index
                nInd = n + 1
                Exit For
            End If
        End If
    Next n
    
    'Check index
    If (nInd = 0) Then Exit Function
    
    'Get file
    Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_FILE + Trim(Str(nInd - 1)), sVal, MIS_MOD_CFG)
    sVal = TruncStr(sVal)
    If sVal <> "" Then CheckFile = sVal
End Function

Sub PutFile(ByVal sKey As String, ByVal sFile As String)
    Dim nType As Integer
    Dim nKey As Long
    
    Dim sName As String
    Dim sVal As String
    Dim sInfo As String
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Check key
    If sKey = "" Then Exit Sub
    If Left(sKey, 1) <> "o" Then Exit Sub
    
    'Get type
    nType = frmObjects.GetType(Val(Mid(sKey, 2)))
    
    'Get name
    Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_REF, sName, MIS_MOD_CFG)
    sName = TruncStr(sName)
        
    'Reset Key
    nKey = 0
    
    'Get key
    Call frmAttribs.GetAll(sKey, sName, nKey, sVal, sInfo)
        
    'Check value
    If sVal = "" Then
        'Put file
        sVal = sFile
        
        'Find data directory in value
        If InStr(1, sVal, sDataDir, vbTextCompare) > 0 Then
            'Remove data directory
            sVal = Mid(sVal, Len(sDataDir) + 1, Len(sVal))
        End If
        
        Call frmAttribs.EditAttrib(nKey, sName, sVal, sInfo)
    End If
End Sub

Sub PutObject()
    Dim nPos As Long
    Dim nObj As Long
    Dim nLink As Long
    Dim nMode As Long
    Dim nCol As Long
    
    Dim fRotX As Single
    Dim fRotY As Single
    Dim fRotZ As Single
    
    Dim sCKey As String
    Dim sLKey As String
    Dim sFile As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Check list
    If sListK = "" Then
        'Add object
        AddObject
        Exit Sub
    End If
    
    'Check recordset
    If rsObjects.BOF = True Then Exit Sub
    
    'Set list
    sLKey = sListK
    
    'Loop thru types
    Do
        'Get position of space character in string
        nPos = InStr(sLKey, " ")
        
        'If possible, truncate string at space character
        If nPos > 0 Then
            'Set key
            sCKey = Left(sLKey, nPos - 1)
            sLKey = Mid(sLKey, nPos + 1, Len(sLKey))
        Else
            'Set key
            sCKey = sLKey
        End If
        
        'Check key
        If Left(sCKey, 1) = "o" Then
            'Set query
            sQuery = "SELECT * FROM Objects WHERE Key = " + Mid(sCKey, 2)
            
            'Open temporary recordset by query
            If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
                
            'Put data in recordset
            rsTemp.MoveFirst
            rsTemp.Edit
            
            'Get file
            sFile = rsTemp!File
            
            'Get data from controls
            rsTemp!NumObjs = CountObjects(Val(Mid(sCKey, 2)))
            rsTemp!NumAttribs = CountAttribs(Val(Mid(sCKey, 2)))
            If txtPosX.BackColor = vbWindowBackground Then rsTemp!PosX = Val(txtPosX.Text)
            If txtPosY.BackColor = vbWindowBackground Then rsTemp!PosY = Val(txtPosY.Text)
            If txtPosZ.BackColor = vbWindowBackground Then rsTemp!PosZ = Val(txtPosZ.Text)
            If txtScaleX.BackColor = vbWindowBackground Then rsTemp!ScaleX = Val(txtScaleX.Text) / 100
            If txtScaleY.BackColor = vbWindowBackground Then rsTemp!ScaleY = Val(txtScaleY.Text) / 100
            If txtScaleZ.BackColor = vbWindowBackground Then rsTemp!ScaleZ = Val(txtScaleZ.Text) / 100
            fRotX = Val(txtRotX.Text)
            fRotY = Val(txtRotY.Text)
            fRotZ = Val(txtRotZ.Text)
            Call rendAngCheck(fRotX, fRotY, fRotZ)
            If txtRotX.BackColor = vbWindowBackground Then rsTemp!RotX = fRotX
            If txtRotY.BackColor = vbWindowBackground Then rsTemp!RotY = fRotY
            If txtRotZ.BackColor = vbWindowBackground Then rsTemp!RotZ = fRotZ
            If cmbType.BackColor = vbWindowBackground Then rsTemp!Type = cmbType.ItemData(cmbType.ListIndex)
            If cmbLayer.BackColor = vbWindowBackground Then rsTemp!Layer = cmbLayer.ItemData(cmbLayer.ListIndex)
            If cmbName.BackColor = vbWindowBackground Then rsTemp!Name = Trim(cmbName.Text)
            If txtInfo.BackColor = vbWindowBackground Then rsTemp!Info = Trim(txtInfo.Text)
            If txtFile.BackColor = vbWindowBackground Then rsTemp!File = Trim(txtFile.Text)
            
            'Find object
            Call rendFindObj(nObj, rsTemp!Key)
            
            'Check file
            If sFile <> rsTemp!File Then
                'Delete object
                Call rendDelObj(nObj)
           
                'Get full filename
                sFile = rsTemp!File
                
                'Check filename
                If sFile <> "" Then
                    If InStr(sFile, ":") = 0 Then
                        'Validate and hash file
                        If Dir(sObjDir + sFile) = "" Then sFile = Trim(Str(misGetHash(rsTemp!File))) + MIS_EXT_OBJ
                        
                        'Append filename to object dir
                        sFile = sObjDir + sFile
                    End If
                End If
                    
                'Recreate object
                If rendNewObj(nObj, rsTemp!Key, sFile) Then Call MsgBox("DLL error: Unable to create object!", vbOKOnly Or vbExclamation, "MissionMan")
                
                'Set link
                Call rendFindObj(nLink, GetLink(rsTemp!Key, rsTemp!Level, rsTemp!Object, rsTemp!Type))
                Call rendSetObjLink(nObj, nLink)
            Else
                'Reset object
                Call rendResetObj(nObj)
            End If
        
            'Get mode
            Call frmLayers.GetColor(rsTemp!Layer, nMode, nCol)
            
            'Set mode and color
            Call rendSetObjMode(nObj, 2)
            Call rendSetObjCol(nObj, nCol)
            Call frmLayers.SetLayer(rsTemp!Layer, 1)
            
            'Position object
            Call rendRotObj(nObj, rsTemp!RotX, rsTemp!RotY, rsTemp!RotZ)
            Call rendScaleObj(nObj, rsTemp!ScaleX, rsTemp!ScaleY, rsTemp!ScaleZ)
            Call rendTransObj(nObj, rsTemp!PosX, rsTemp!PosY, rsTemp!PosZ)
        
            'Update data
            rsTemp.Update
            
            'Close temporary recordset
            rsTemp.Close
            
            'Edit in tree
            frmTree.EditTree (sCKey)
        End If
        
        'Check position
        If nPos = 0 Then Exit Do
    Loop
            
    'Select in tree
    frmTree.SelTree ("")
    
    'Refresh graphics
    frmFront.Render
    frmTop.Render
    frmSide.Render
    frmCamera.Render
End Sub

Sub PutColor(ByVal nKey As Long, ByVal nMode As Long, ByVal nCol As Long)
    Dim nCount As Integer

    Dim nObj 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
        If nMode > 0 Then
            Call rendGetObjMode(nObj, nMode)
            If nMode = 0 Then nMode = 1
        End If
        
        'Set mode and color
        Call rendSetObjMode(nObj, nMode)
        Call rendSetObjCol(nObj, nCol)
        rsTemp.MoveNext
    Loop
    
    'Close temporary recordset
    rsTemp.Close
End Sub

Sub AddObject()
    Dim nType As Integer

    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 fRotX As Single
    Dim fRotY As Single
    Dim fRotZ As Single
    
    Dim sFile As String
    
    'Add data to recordset
    rsObjects.AddNew
    
    'Get key
    sCurK = "o" + Trim(Str(rsObjects!Key))
    sListK = sCurK
    
    'Check parent
    If Left(sParK, 1) = "l" Then
        rsObjects!Level = Val(Mid(sParK, 2))
    Else
        rsObjects!Level = 0
    End If
    
    'Check parent
    If Left(sParK, 1) = "o" Then
        rsObjects!Object = Val(Mid(sParK, 2))
    Else
        rsObjects!Object = 0
    End If
    
    'Get data from controls
    rsObjects!NumObjs = 0
    rsObjects!NumAttribs = 0