frmobjects.frm

游戏《家园》源码

            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 y 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
    
        'Put default data in controls
        txtPosX.Text = Format(X, "0;-#")
        txtPosY.Text = Format(Y, "0;-#")
        txtPosZ.Text = Format(Z, "0;-#")
        txtScaleX.Text = "100"
        txtScaleY.Text = "100"
        txtScaleZ.Text = "100"
        txtRotX.Text = "0"
        txtRotY.Text = "0"
        txtRotZ.Text = "0"
        SelType (0)
        SelLayer (0)
        cmbName.Text = MIS_NAM_OBJ
        txtInfo.Text = ""
        txtFile.Text = ""
    
        'Get Names
        Call GetNames(cmbName.Text, cmbType.ItemData(cmbType.ListIndex))
        Exit Sub
    End If
    
    'Check recordset
    If rsObjects.BOF = True Then Exit Sub
    
    'Reset index
    nInd = 0
    
    '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
                
            'Get data from recordset
            rsTemp.MoveFirst
            
            'Check index
            If nInd = 0 Then
                'Set current key
                sCurK = sCKey
                
                'Put data in controls
                txtPosX.Text = Format(rsTemp!PosX, "0;-#")
                txtPosY.Text = Format(rsTemp!PosY, "0;-#")
                txtPosZ.Text = Format(rsTemp!PosZ, "0;-#")
                txtScaleX.Text = Format(rsTemp!ScaleX * 100, "0;-#")
                txtScaleY.Text = Format(rsTemp!ScaleY * 100, "0;-#")
                txtScaleZ.Text = Format(rsTemp!ScaleZ * 100, "0;-#")
                txtRotX.Text = Format(rsTemp!RotX, "0;-#")
                txtRotY.Text = Format(rsTemp!RotY, "0;-#")
                txtRotZ.Text = Format(rsTemp!RotZ, "0;-#")
                SelType (rsTemp!Type)
                SelLayer (rsTemp!Layer)
                cmbName.Text = rsTemp!Name
                txtInfo.Text = rsTemp!Info
                txtFile.Text = rsTemp!File
        
                'Get Names
                Call GetNames(cmbName.Text, cmbType.ItemData(cmbType.ListIndex))
            Else
                'Compare data and set colors
                If txtPosX.Text <> Format(rsTemp!PosX, "0;-#") Then txtPosX.BackColor = vbButtonFace
                If txtPosY.Text <> Format(rsTemp!PosY, "0;-#") Then txtPosY.BackColor = vbButtonFace
                If txtPosZ.Text <> Format(rsTemp!PosZ, "0;-#") Then txtPosZ.BackColor = vbButtonFace
                If txtScaleX.Text <> Format(rsTemp!ScaleX * 100, "0;-#") Then txtScaleX.BackColor = vbButtonFace
                If txtScaleY.Text <> Format(rsTemp!ScaleY * 100, "0;-#") Then txtScaleY.BackColor = vbButtonFace
                If txtScaleZ.Text <> Format(rsTemp!ScaleZ * 100, "0;-#") Then txtScaleZ.BackColor = vbButtonFace
                If txtRotX.Text <> Format(rsTemp!RotX, "0;-#") Then txtRotX.BackColor = vbButtonFace
                If txtRotY.Text <> Format(rsTemp!RotY, "0;-#") Then txtRotY.BackColor = vbButtonFace
                If txtRotZ.Text <> Format(rsTemp!RotZ, "0;-#") Then txtRotZ.BackColor = vbButtonFace
                If cmbType.ItemData(cmbType.ListIndex) <> rsTemp!Type Then cmbType.BackColor = vbButtonFace
                If cmbLayer.ItemData(cmbLayer.ListIndex) <> rsTemp!Layer Then cmbLayer.BackColor = vbButtonFace
                If cmbName.Text <> rsTemp!Name Then cmbName.BackColor = vbButtonFace
                If txtInfo.Text <> rsTemp!Info Then txtInfo.BackColor = vbButtonFace
                If txtFile.Text <> rsTemp!File Then txtFile.BackColor = vbButtonFace
            End If
            
            'Close temporary recordset
            rsTemp.Close
            
            'Increment index
            nInd = nInd + 1
        End If
            
        'Check position
        If nPos = 0 Then Exit Do
    Loop
End Sub

Sub GetObjects()
    Dim nObj As Long
    Dim nLink As Long
    Dim nMode As Long
    Dim nCol As Long

    Dim sTxt As String
    Dim sVal As String
    Dim sFile As String
    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"
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Set progress bar
    Call frmProgress.Init("Loading graphics...", 100)
    
    'Get data from recordset
    rsTemp.MoveFirst
    Do Until rsTemp.EOF
        'Update progress bar
        Call frmProgress.Update(rsTemp.PercentPosition)
    
        'Get name
        sTxt = rsTemp!Name
        
        'Get type
        Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(rsTemp!Type - 1)), MIS_KEY_TYPE, sVal, MIS_MOD_CFG)
        sVal = TruncStr(sVal)
        If sVal <> "" Then sTxt = sVal + ": " + sTxt
        
        '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
                
                'Re=validate and update file according to config
                If Dir(sObjDir + sFile) = "" Then
                    sFile = CheckFile(rsTemp!Type, rsTemp!Name, rsTemp!File)
                
                    'Compare file
                    If (sFile <> rsTemp!File) Then
                        'Update data
                        rsTemp.Edit
                        rsTemp!File = sFile
                        rsTemp.Update
                    End If
                    
                    'Validate and hash file
                    If Dir(sObjDir + sFile) = "" Then sFile = Trim(Str(misGetHash(rsTemp!File))) + MIS_EXT_OBJ
                End If
                
                'Append filename to object dir
                sFile = sObjDir + sFile
            End If
        End If
            
        'Create object
        If rendNewObj(nObj, rsTemp!Key, sFile) Then Call MsgBox("DLL error: Unable to create object!", vbOKOnly Or vbExclamation, "MissionMan")
    
        'Set mode and color
        Call frmLayers.GetColor(rsTemp!Layer, nMode, nCol)
        Call rendSetObjMode(nObj, nMode)
        Call rendSetObjCol(nObj, nCol)

        '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)
    
        'Set link
        Call rendFindObj(nLink, GetLink(rsTemp!Key, rsTemp!Level, rsTemp!Object, rsTemp!Type))
        Call rendSetObjLink(nObj, nLink)
        
        'Continue
        rsTemp.MoveNext
    Loop
    
    'Reset progress bar
    Call frmProgress.Clean
    
    'Close temporary recordset
    rsTemp.Close
End Sub

Function GetLink(ByVal nKey As Long, ByVal nLev As Long, ByVal nObj As Long, ByVal nType As Integer) As Long
    Dim nRKey As Long
    
    Dim sVal As String
    Dim sName As String
    Dim sRVal As String
    Dim sInfo As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Set default
    GetLink = 0
    
    'Get link
    Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(GetType(nKey) - 1)), MIS_KEY_LINK, sVal, MIS_MOD_CFG)
    sVal = TruncStr(sVal)
    If sVal = "" Then Exit Function
    sName = sVal
    
    'Get value
    Call frmAttribs.GetAll("o" + Trim(Str(nKey)), sName, nRKey, sVal, sInfo)
    If sVal = "" Then Exit Function
    sRVal = sVal
    
    'Check recordset
    If rsObjects.BOF = True Then Exit Function
    
    'Set query
    sQuery = "SELECT * FROM Objects WHERE Key < " + Str(nKey) + " AND Level = " + Str(nLev) + " AND Object = " + Str(nObj) + " AND Type = " + Str(nType) + " ORDER BY Key"
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Function
        
    'Get data from recordset
    rsTemp.MoveFirst
    Do Until rsTemp.EOF
        'Reset key
        nRKey = 0
    
        'Get value
        Call frmAttribs.GetAll("o" + Trim(Str(rsTemp!Key)), sName, nRKey, sVal, sInfo)
        If sVal = sRVal Then GetLink = rsTemp!Key
        
        'Continue
        rsTemp.MoveNext
    Loop
    
    'Close temporary recordset
    rsTemp.Close
End Function

Sub GetAll(ByVal nKey As Long, nLev As Long, nObj As Long, nType As Integer)
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Reset all
    nLev = 0
    nObj = 0
    nType = 0
    
    '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 data from recordset
    rsTemp.MoveFirst
    nLev = rsTemp!Level
    nObj = rsTemp!Object
    nType = rsTemp!Type
    
    'Close temporary recordset
    rsTemp.Close
End Sub

Function GetType(ByVal nKey As Long) As Integer
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Set default
    GetType = 0
    
    'Check recordset
    If rsObjects.BOF = True Then Exit Function
    
    'Set query
    sQuery = "SELECT * FROM Objects WHERE Key = " + Trim(Str(nKey))
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Function
        
    'Get data from recordset
    rsTemp.MoveFirst
    GetType = rsTemp!Type
    
    'Close temporary recordset
    rsTemp.Close
End Function

Sub GetTypes()
    Dim n As Integer

    Dim nCount As Integer
    
    Dim nPos As Long
    
    Dim sList As String
    
    'Clear combo
    cmbType.Clear
    
    'Set blank name and key
    cmbType.AddItem ("(None)")
    cmbType.ItemData(cmbType.NewIndex) = 0
    
    'Reset count
    nCount = 0
    
    'Get types
    Call misGetListBySection(frmMission.GetPrefix + MIS_SEC_OBJ, MIS_KEY_TYPE, sList, nCount, MIS_MOD_CFG)
    
    'Check count
    If nCount = 0 Then Exit Sub
    
    'Truncate types
    sList = TruncStr(sList)

    'Loop thru types
    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 type to combo
            cmbType.AddItem (Left(sList, nPos - 1))
            cmbType.ItemData(cmbType.NewIndex) = n + 1
            sList = Mid(sList, nPos + 1, Len(sList))
        Else
            'Add type to combo
            cmbType.AddItem (sList)
            cmbType.ItemData(cmbType.NewIndex) = n + 1
        End If
    Next n
    
    'Reset combo index
    If cmbType.ListCount > 0 Then cmbType.ListIndex = 0
End Sub

Sub GetLayers()
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Clear combo
    cmbLayer.Clear
    
    'Set blank name and key
    cmbLayer.AddItem ("(None)")
    cmbLayer.ItemData(cmbLayer.NewIndex) = 0
    
    'Check recordset
    If rsLayers.BOF = True Then Exit Sub
    
    'Set query
    sQuery = "SELECT * FROM Layers"
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Find data in recordset
    rsTemp.MoveFirst
    Do Until rsTemp.EOF
        'Get layer data
        cmbLayer.AddItem (rsTemp!Name)
        cmbLayer.ItemData(cmbLayer.NewIndex) = rsTemp!Key
        rsTemp.MoveNext
    Loop
    
    'Close temporary recordset
    rsTemp.Close
    
    'Reset combo index
    If cmbLayer.ListCount > 0 Then cmbLayer.ListIndex = 0
End Sub

Function GetName(ByVal nKey As Long) As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Set default
    GetName = ""
    
    'Check recordset
    If rsObjects.BOF = True Then Exit Function
    
    'Set query
    sQuery = "SELECT * FROM Objects WHERE Key = " + Trim(Str(nKey))
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Function
        
    'Get data from recordset
    rsTemp.MoveFirst
    GetName = rsTemp!Name
    
    'Close temporary recordset
    rsTemp.Close
End Function

Sub GetNames(ByVal sName As String, ByVal nType As Integer)
    Dim n As Integer

    Dim nCount As Integer