frmtree.frm

游戏《家园》源码

        
            'If possible, truncate string at | character
            If nPos > 0 Then
                'Set position
                aPos(n) = Val(Left(sList, nPos - 1)) * fConvScale
                sList = Mid(sList, nPos + 1, Len(sList))
            Else
                'Set position
                aPos(n) = Val(sList) * fConvScale
            End If
        Next n
    End If
    
    'Initialize form
    On Error Resume Next
    Call Me.Move(aPos(0), aPos(1), aPos(2), aPos(3))
    On Error GoTo 0
    fMainForm.mnuViewTree.Checked = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim n As Integer
    
    Dim sList As String
    
    'Cleanup form
    fMainForm.mnuViewTree.Checked = False

    'Check position
    If aPos(0) = Me.Left And aPos(1) = Me.Top And aPos(2) = Me.Width And aPos(3) = Me.Height Then Exit Sub
    
    'Set position
    aPos(0) = Me.Left
    aPos(1) = Me.Top
    aPos(2) = Me.Width
    aPos(3) = Me.Height
    
    'Reset list
    sList = ""
    For n = 0 To 3
        'Append list
        sList = sList + "|" + Format(aPos(n) / fConvScale, "0.0;-0.0")
    Next n
    
    'Put window
    Call misPutListByKey(MIS_SEC_COM, MIS_KEY_TREEV, sList, MIS_MOD_INI)
End Sub

Private Sub Form_Resize()
    'Resize form
    On Error Resume Next
    Call pbTree.Move(0, 0, Me.ScaleWidth, Me.ScaleHeight)
    Call tvTree.Move(0, 0, Me.ScaleWidth, Me.ScaleHeight - lstTree.Height + 50)
    Call lstTree.Move(0, tvTree.Height + 50, Me.ScaleWidth, lstTree.Height)
    On Error GoTo 0
End Sub

Private Sub pbTree_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'Set mouse down flag
    bClick = True
    
    'Set height
    fHeight = lstTree.Height
    
    'Set mouse coordinates
    fRy = Y
End Sub

Private Sub pbTree_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'Check mouse down flag
    If (bClick = True) And (Y <> fRy) Then
        'Calculate height
        fHeight = fHeight + fRy - Y
        
        'Check height
        If fHeight < 500 Then fHeight = 500
        If fHeight > Me.ScaleHeight - 500 Then fHeight = Me.ScaleHeight - 500
        
        'Resize controls
        On Error Resume Next
        Call tvTree.Move(0, 0, Me.ScaleWidth, Me.ScaleHeight - fHeight + 50)
        Call lstTree.Move(0, tvTree.Height + 50, Me.ScaleWidth, fHeight)
        On Error GoTo 0
    End If
    
    'Set mouse coordinates
    fRy = Y
End Sub

Private Sub pbTree_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'Clear mouse down flag
    bClick = False
End Sub

Private Sub lstTree_Click()
    If nShift = 2 Then
        'Reset key
        nShift = 0
        
        'Deselect key
        DelKey
    End If
End Sub

Private Sub lstTree_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim sKey As String
    Dim sList As String

    'Check DB
    If bDBFlag = False Then Exit Sub
    
    If KeyCode = vbKeyReturn Then
        'Show selection property
        fMainForm.GetListProp
        Exit Sub
    End If
    
    If KeyCode = vbKeyDelete Then
        'Commit
        Call CommitDB("Delete")
        
        'Delete item(s)
        Call fMainForm.DelList(sParKey, sListKey, "")
    End If
End Sub

Private Sub lstTree_KeyPress(KeyAscii As Integer)
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    If KeyAscii = 13 Then KeyAscii = 0
    
    'Check key state
    If KeyAscii = Asc("-") Then
        'Collapse tree
        Call ExpandTree(False)
        Exit Sub
    End If
    
    'Check key state
    If KeyAscii = Asc("*") Then
        'Expand tree
        Call ExpandTree(True)
    End If
End Sub

Private Sub lstTree_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Set key
    nShift = Shift
    
    If Button = 2 Then
        ' Show popup menu
        Call PopupMenu(fMainForm.mnuPUTreeSel, 2)
        Exit Sub
    End If
End Sub

Private Sub tvTree_Collapse(ByVal Node As ComctlLib.Node)
    'Show tree
    ShowTree (Node.Key)
End Sub

Private Sub tvTree_DblClick()
    Dim nodItem As Node
    
    'Set error handler for node
    On Error GoTo NodeErr
    
    'Get and check node
    Set nodItem = tvTree.HitTest(fMx, fMy)
        
    'Toggle expand/collapse
    If nodItem.Expanded = True Then
        nodItem.Expanded = False
    Else
        nodItem.Expanded = True
    End If
    
    ' Check node key
    If Left(nodItem.Key, 1) = "m" Then
        'Show form
        frmMission.Show
        frmMission.GetMission
        frmMission.SetFocus
        Exit Sub
    End If
    
    ' Check node key
    If Left(nodItem.Key, 1) = "l" Then
        'Show form
        frmLevels.Show
        Call frmLevels.GetLevel(sParKey, sCurKey)
        frmLevels.SetFocus
        Exit Sub
    End If
    
    ' Check node key
    If Left(nodItem.Key, 1) = "o" Then
        'Select objects
        Call rendSetSel("o", sCurKey)
            
        'Show form
        frmObjects.Show
        Call frmObjects.GetObject(sParKey, sCurKey, 0, 0, 0)
        frmObjects.SetFocus
        Exit Sub
    End If
    
    ' Check node key
    If Left(nodItem.Key, 1) = "a" Then
        'Show form
        frmAttribs.Show
        Call frmAttribs.GetAttrib(sParKey, sCurKey)
        frmAttribs.SetFocus
        Exit Sub
    End If
    Exit Sub

NodeErr:
    Exit Sub
End Sub

Private Sub tvTree_KeyDown(KeyCode As Integer, Shift As Integer)
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    If KeyCode = vbKeyReturn Then
        ' Check node key
        If InStr(sListKey, " ") > 0 Then Exit Sub
      
        'Show selection property
        fMainForm.GetListProp
        Exit Sub
    End If
    
    If KeyCode = vbKeyDelete Then
        ' Check node key
        If InStr(sListKey, " ") > 0 Then
            'Commit
            Call CommitDB("Delete")
            
            'Delete item(s)
            Call fMainForm.DelList(sParKey, sListKey, "")
            Exit Sub
        End If
        
        ' Check node key
        If Left(sCurKey, 1) = "l" Then
            'Commit
            Call CommitDB("Delete Level")
            
            'Delete item
            Call frmLevels.DelLevel(sParKey, sCurKey, "")
            Exit Sub
        End If
        
        ' Check node key
        If Left(sCurKey, 1) = "o" Then
            'Commit
            Call CommitDB("Delete Object")
            
            'Delete item
            Call frmObjects.DelObject(sParKey, sCurKey, "")
            Exit Sub
        End If
        
        ' Check node key
        If Left(sCurKey, 1) = "a" Then
            'Commit
            Call CommitDB("Delete Attribute")
            
            'Delete item
            Call frmAttribs.DelAttrib(sParKey, sCurKey, "")
            Exit Sub
        End If
    End If
End Sub

Private Sub tvTree_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then KeyAscii = 0
End Sub

Private Sub tvTree_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim nodItem As Node
    
    ' Set error handler for node
    On Error GoTo NodeErr
    
    'Set key
    nShift = Shift
    
    'Get and check node
    Set nodItem = tvTree.HitTest(X, Y)
    
    If Button = 2 Then
        ' Select node
        nodItem.Selected = True
    
        'Show tree
        ShowTree (nodItem.Key)
            
        ' Check node key
        If Left(nodItem.Key, 1) = "o" Then
            'Select objects
            Call rendSetSel("o", sCurKey)
            
            'Refresh graphics
            frmFront.Render
            frmTop.Render
            frmSide.Render
            frmCamera.Render
        End If
            
        ' Check node key
        If Left(nodItem.Key, 1) = "m" Then
            ' Show popup menu
            Call PopupMenu(fMainForm.mnuPUTreeMis, 2)
            Exit Sub
        End If
        
        ' Check node key
        If Left(nodItem.Key, 1) = "l" Then
            ' Show popup menu
            Call PopupMenu(fMainForm.mnuPUTreeLev, 2)
            Exit Sub
        End If
        
        ' Check node key
        If Left(nodItem.Key, 1) = "o" Then
            'Select objects
            Call rendSetSel("o", sCurKey)
                
            ' Show popup menu
            Call PopupMenu(fMainForm.mnuPUTreeObj, 2)
            Exit Sub
        End If
        
        ' Check node key
        If Left(nodItem.Key, 1) = "a" Then
            ' Show popup menu
            Call PopupMenu(fMainForm.mnuPUTreeAttrib, 2)
            Exit Sub
        End If
    End If
    Exit Sub
    
NodeErr:
    Exit Sub
End Sub

Private Sub tvTree_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim nodItem As Node
    
    'Set mouse coordinates
    fMx = X
    fMy = Y

    'Set tooltip
    tvTree.ToolTipText = ""
    
    ' Set error handler for node
    On Error GoTo NodeErr
    
    ' Get and check node
    Set nodItem = tvTree.HitTest(X, Y)
        
    ' Check node key
    If Left(nodItem.Key, 1) = "m" Then
        'Set tooltip
        tvTree.ToolTipText = "Mission"
        Exit Sub
    End If
        
    ' Check node key
    If Left(nodItem.Key, 1) = "l" Then
        'Set tooltip
        tvTree.ToolTipText = "Level"
        Exit Sub
    End If
        
    ' Check node key
    If Left(nodItem.Key, 1) = "o" Then
        'Set tooltip
        tvTree.ToolTipText = "Object"
        Exit Sub
    End If
    
    ' Check node key
    If Left(nodItem.Key, 1) = "a" Then
        'Set tooltip
        tvTree.ToolTipText = "Attribute"
        Exit Sub
    End If
    Exit Sub
    
NodeErr:
    Exit Sub
End Sub

Private Sub tvTree_NodeClick(ByVal Node As ComctlLib.Node)
    Dim sList As String

    'Check key
    If nShift = 2 Then
        'Reset key
        nShift = 0
        
        'Check keys
        If sListKey = Node.Key Then
            sList = sListKey
        Else
            'Set key list
            sList = EditList(Node.Key, sListKey)
            If sList = "" Then sList = Node.Key + " " + sListKey
        End If
    Else
        'Set key list
        sList = Node.Key
    End If
    
    'Show tree
    ShowTree (sList)
    Exit Sub
End Sub