frmtree.frm

游戏《家园》源码

        
    'Refresh graphics
    frmFront.Render
    frmTop.Render
    frmSide.Render
    frmCamera.Render
    Exit Sub
End Sub

Sub ExpandTree(ByVal bFlag As Boolean)
    Dim nPos As Long
    Dim sList As String
    Dim sKey As String
    
    'Set list
    sList = sListKey
    
    'Loop thru types
    Do
        'Get position of space character in string
        nPos = InStr(sList, " ")
        
        'If possible, truncate string at space character
        If nPos > 0 Then
            'Set key
            sKey = Left(sList, nPos - 1)
            sList = Mid(sList, nPos + 1, Len(sList))
        Else
            'Set key
            sKey = sList
        End If
        
        'Collapse or expand
        tvTree.Nodes.Item(sKey).Expanded = bFlag
        
        'Check position
        If nPos = 0 Then Exit Do
    Loop
End Sub

Sub ShowList(ByVal sList As String)
    Dim nType As Integer
    Dim nIndex As Integer
    Dim nSel As Integer
    
    Dim nPos As Long
    
    Dim sKey As String
    Dim sItem As String
    Dim sTxt As String
    Dim sVal As String

    'Check flag
    If Not fMainForm.mnuViewTree.Checked Then Exit Sub
    
    'Set selection
    nSel = lstTree.ListIndex
        
    'Clear list
    lstTree.Clear
    
    'Initialize index
    nIndex = 0
    
    'Loop thru types
    Do
        'Get position of space character in string
        nPos = InStr(sList, " ")
        
        'If possible, truncate string at space character
        If nPos > 0 Then
            'Set key
            sKey = Left(sList, nPos - 1)
            sList = Mid(sList, nPos + 1, Len(sList))
        Else
            'Set key
            sKey = sList
        End If
        
        'Reset item
        sItem = ""
        
        ' Check key
        If Left(sKey, 1) = "m" Then
            'Set item
            sItem = "Mission " + frmMission.GetName + ": " + frmMission.GetType
        End If
            
        ' Check key
        If Left(sKey, 1) = "l" Then
            'Set item
            sItem = "Level " + frmLevels.GetName(Val(Mid(sKey, 2)))
        End If
            
        ' Check key
        If Left(sKey, 1) = "o" Then
            'Get name
            sTxt = frmObjects.GetName(Val(Mid(sKey, 2)))
        
            'Get type
            nType = frmObjects.GetType(Val(Mid(sKey, 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
                    
            'Set item
            sItem = "Object " + sTxt
        End If
            
        ' Check key
        If Left(sKey, 1) = "a" Then
            'Get name
            sTxt = frmAttribs.GetName(Val(Mid(sKey, 2)))
        
            'Get value
            sVal = frmAttribs.GetValue(Val(Mid(sKey, 2)))
            
            'Check type
            If sVal <> "" Then sTxt = sTxt + ": " + sVal
                    
            'Set item
            sItem = "Attribute " + sTxt
        End If
        
        'Check item
        If sItem <> "" Then
            'Add item to list
            lstTree.AddItem (sItem)
            lstTree.ItemData(lstTree.NewIndex) = nIndex
            
            'Increment index
            nIndex = nIndex + 1
        End If
        
        'Check position
        If nPos = 0 Then Exit Do
    Loop
    
    'Check selection
    If nSel < 0 Then nSel = 0
    If nSel > lstTree.ListCount - 1 Then nSel = lstTree.ListCount - 1
        
    'Set list index
    lstTree.ListIndex = nSel
End Sub

Function EditList(ByVal sKey As String, ByVal sList As String) As String
    Dim nPos As Long
    
    'Set default
    EditList = ""
    
    'Check for key in list
    nPos = InStr(sList + " ", sKey + " ")
    If nPos = 0 Then Exit Function
    
    'Check position
    If nPos > 2 Then
        'Set beginning
        EditList = Left(sList, nPos - 2)
    Else
        'Set beginning
        EditList = ""
    End If
    
    'Check for space in list
    nPos = InStr(nPos, sList, " ")
    If nPos = 0 Then Exit Function
    
    'Check list
    If EditList = "" Then
        'Set list
        EditList = Mid(sList, nPos + 1)
    Else
        'Set list
        EditList = EditList + " " + Mid(sList, nPos + 1)
    End If
End Function

Sub DelTree(ByVal sCKey As String)
    'Check flag
    If Not fMainForm.mnuViewTree.Checked Then Exit Sub
    
    'Remove node
    tvTree.Nodes.Remove (sCKey)
End Sub

Sub GetMission()
    Dim sTxt As String
    
    'Check recordset
    If rsMission.BOF = True Then
        'Add mission
        frmMission.AddMission
    End If
        
    'Get data from recordset
    rsMission.MoveFirst
    Set nodTree = tvTree.Nodes.Add(, , "m", rsMission!Name + ": " + frmMission.GetType)
    nodTree.Expanded = True
End Sub

Sub GetLevels()
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check recordset
    If rsLevels.BOF = True Then Exit Sub
    
    'Set query
    sQuery = "SELECT * FROM Levels"
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Set progress bar
    Call frmProgress.Init("Loading levels...", 100)
    
    'Get data from recordset
    rsTemp.MoveFirst
    Do Until rsTemp.EOF
        Call frmProgress.Update(rsTemp.PercentPosition)
        Set nodTree = tvTree.Nodes.Add("m", tvwChild, "l" + Trim(Str(rsTemp!Key)), rsTemp!Name)
        nodTree.Expanded = True
        rsTemp.MoveNext
    Loop
    
    'Reset progress bar
    Call frmProgress.Clean
    
    'Close temporary recordset
    rsTemp.Close
End Sub

Sub GetObjects()
    Dim sTxt As String
    Dim sVal As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    '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 objects...", 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)
        
        'Truncate type
        sVal = TruncStr(sVal)
        
        'Check type
        If sVal <> "" Then sTxt = sVal + ": " + sTxt
                
        'Set node
        If rsTemp!Level > 0 Then
            Set nodTree = tvTree.Nodes.Add("l" + Trim(Str(rsTemp!Level)), tvwChild, "o" + Trim(Str(rsTemp!Key)), sTxt)
            nodTree.Expanded = True
        End If
        If rsTemp!Object > 0 Then
            Set nodTree = tvTree.Nodes.Add("o" + Trim(Str(rsTemp!Object)), tvwChild, "o" + Trim(Str(rsTemp!Key)), sTxt)
            nodTree.Expanded = False
        End If

        'Continue
        rsTemp.MoveNext
    Loop
    
    'Reset progress bar
    Call frmProgress.Clean
    
    'Close temporary recordset
    rsTemp.Close
End Sub

Sub GetAttribs()
    Dim sTxt As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check recordset
    If rsAttribs.BOF = True Then Exit Sub
    
    'Set query
    sQuery = "SELECT * FROM Attrib"
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Set progress bar
    Call frmProgress.Init("Loading attributes...", 100)
    
    'Get data from recordset
    rsTemp.MoveFirst
    Do Until rsTemp.EOF
        'Update progress bar
        Call frmProgress.Update(rsTemp.PercentPosition)
        
        sTxt = rsTemp!Name
        If rsTemp!Value <> "" Then sTxt = sTxt + ": " + rsTemp!Value
        If rsTemp!Level > 0 Then Set nodTree = tvTree.Nodes.Add("l" + Trim(Str(rsTemp!Level)), tvwChild, "a" + Trim(Str(rsTemp!Key)), sTxt)
        If rsTemp!Object > 0 Then Set nodTree = tvTree.Nodes.Add("o" + Trim(Str(rsTemp!Object)), tvwChild, "a" + Trim(Str(rsTemp!Key)), sTxt)
        nodTree.Expanded = False
        rsTemp.MoveNext
    Loop
    
    'Reset progress bar
    Call frmProgress.Clean
    
    'Close temporary recordset
    rsTemp.Close
End Sub

Sub DelKey()
    Dim sKey As String
    Dim sList As String

    'Get key
    sKey = GetKey(lstTree.ItemData(lstTree.ListIndex), sListKey)
    If sKey = "" Then Exit Sub
    
    'Check keys
    If sListKey = sKey Then Exit Sub
    
    'Set key list
    sList = EditList(sKey, sListKey)
                
    'Check list and show tree
    If sList <> "" Then ShowTree (sList)
End Sub

Function GetKey(ByVal nIndex As Integer, ByVal sList As String) As String
    Dim n As Integer
    
    Dim nStart As Long
    Dim nStop As Long
    
    'Set default
    GetKey = ""
    
    'Initialize end
    nStop = 1
    
    ' Loop through indexes
    For n = 0 To nIndex
        'Set start
        nStart = nStop
        
        'Set and check end
        nStop = InStr(nStop, sList, " ")
        If nStop = 0 Then Exit For
        nStop = nStop + 1
    Next
    
    'Adjust end
    If nStop = 0 Then nStop = Len(sList) + 2
    
    'Set key
    GetKey = Mid(sList, nStart, nStop - (nStart + 1))
End Function

Sub Reset()
    Dim aP(4) As Single
    
    'Set tree view position and size
    aP(0) = 0
    aP(1) = 0
    aP(2) = fMainForm.ScaleWidth / 4
    aP(3) = fMainForm.ScaleHeight
    
    'Move form
    On Error Resume Next
    Me.WindowState = vbNormal
    Call Me.Move(aP(0), aP(1), aP(2), aP(3))
    On Error GoTo 0
End Sub
    
Private Sub Form_Load()
    Dim n As Integer
    Dim nCount As Integer
    
    Dim nPos As Long
        
    Dim sList As String
      
    'Clear mouse down flag
    bClick = False
    
    'Set tree view position and size
    aPos(0) = 0
    aPos(1) = 0
    aPos(2) = fMainForm.ScaleWidth / 4
    aPos(3) = fMainForm.ScaleHeight
    
    'Reset count
    nCount = 0
    
    'Get window
    Call misGetListByKey(MIS_SEC_COM, MIS_KEY_TREEV, sList, nCount, MIS_MOD_INI)
    
    'Check count
    If nCount > 0 Then
        'Truncate list
        sList = TruncStr(sList)

        'Loop thru list
        For n = 0 To 3
            'Get position of | character in string
            nPos = InStr(sList, "|")