frmlayers.frm

游戏《家园》源码

    
    'Get layers
    Call GetLayers(lstList.ItemData(lstList.ListIndex))
    
    'Refresh graphics
    frmFront.Render
    frmTop.Render
    frmSide.Render
    frmCamera.Render
End Sub

Sub TogLayer(ByVal nKey As Long)
    Dim n As Integer
    Dim nItem As Integer
    Dim nCount As Integer
    
    Dim nMode As Long
    Dim nCol As Long
    
    Dim sList As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check list index
    If lstList.ListCount = 0 Then Exit Sub
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Check recordset
    If rsLayers.BOF = True Then Exit Sub
    
    'Set query
    sQuery = "SELECT * FROM Layers WHERE Key = " + Str(nKey)
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Loop thru list
    For n = 0 To lstList.ListCount - 1
        'Check list items
        If lstList.ItemData(n) = nKey Then
            nItem = n
            Exit For
        End If
    Next n

    'Find data in recordset
    rsTemp.MoveFirst
    nCol = Abs(rsTemp!Color)
    
    'Edit data in recordset
    rsTemp.Edit
    If lstList.Selected(nItem) = False Then rsTemp!Color = -nCol
    If lstList.Selected(nItem) = True Then rsTemp!Color = nCol
    rsTemp.Update
    
    'Close temporary recordset
    rsTemp.Close
    
    'Update objects
    If lstList.Selected(nItem) = False Then Call frmObjects.PutColor(nKey, 0, nCol)
    If lstList.Selected(nItem) = True Then Call frmObjects.PutColor(nKey, 1, nCol)
    
    'Get selection
    Call rendGetSel("o", nCount, sList)
    
    'Check count
    If nCount > 1 Then
        'Truncate list
        sList = TruncStr(sList)

        'Select in tree
        frmTree.SelTree (sList)
    End If
    
    'Refresh graphics
    frmFront.Render
    frmTop.Render
    frmSide.Render
    frmCamera.Render
End Sub

Sub AddLayer()
    Dim nKey As Long

    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Add new data to recordset
    rsLayers.AddNew
    nKey = rsLayers!Key
    
    'Default data
    rsLayers!Name = "New Layer"
    rsLayers!Color = nViewCol
    rsLayers!Info = ""
    rsLayers.Update
    
    'Get layers
    Call GetLayers(nKey)
End Sub

Sub DelLayer(ByVal nKey As Long)
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check list index
    If lstList.ListCount = 0 Then Exit Sub
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Check recordset
    If rsLayers.BOF = True Then Exit Sub
    
    'Prompt user
    If MsgBox("Delete layer " + GetName(lstList.ItemData(lstList.ListIndex)) + "?", vbYesNo Or vbQuestion, "MissionMan") = vbNo Then Exit Sub
    
    'Set query
    sQuery = "SELECT * FROM Layers WHERE Key = " + Str(nKey)
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Delete data in recordset
    rsTemp.MoveFirst
    rsTemp.Delete
    
    'Close temporary recordset
    rsTemp.Close
        
    'Update object
    Call frmObjects.DelLayer(nKey)
    
    'Get layers
    Call GetLayers(lstList.ItemData(lstList.ListIndex))

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

Sub SetLayer(ByVal nKey As Long, ByVal nMode As Long)
    Dim n As Integer
    Dim nItem As Integer
    
    Dim nCol As Long
    
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Check recordset
    If rsLayers.BOF = True Then Exit Sub
    
    'Set query
    sQuery = "SELECT * FROM Layers WHERE Key = " + Str(nKey)
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
        
    'Find data in recordset
    rsTemp.MoveFirst
    nCol = Abs(rsTemp!Color)
    
    'Edit data in recordset
    rsTemp.Edit
    If nMode = 0 Then rsTemp!Color = -nCol
    If nMode = 1 Then rsTemp!Color = nCol
    rsTemp.Update
    
    'Close temporary recordset
    rsTemp.Close
    
    'Update objects
    Call frmObjects.PutColor(nKey, nMode, nCol)
    
    'Update form
    If fMainForm.mnuViewTabLayer.Checked = True Then
        'Get layers
        Call GetLayers(lstList.ItemData(lstList.ListIndex))
    End If
End Sub

Private Sub chkAll_Click()
    Dim n As Integer

    'Check checkbox
    If chkAll.Value = 0 Then
        'Loop thru list
        For n = 0 To lstList.ListCount - 1
            'Check list items
            lstList.Selected(n) = False
        Next n
        Exit Sub
    End If
    
    'Check checkbox
    If chkAll.Value = 1 Then
        'Loop thru list
        For n = 0 To lstList.ListCount - 1
            'Check list items
            lstList.Selected(n) = True
        Next n
        Exit Sub
    End If
End Sub

Private Sub cmdApply_Click()
    'Check list
    If lstList.ListCount > 0 Then
        'Commit
        Call CommitDB("Edit Layer")
        
        'Put layer
        Call PutLayer(lstList.ItemData(lstList.ListIndex))
    End If
End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdDelete_Click()
    'Check list
    If lstList.ListCount > 0 Then
        'Commit
        Call CommitDB("Delete Layer")
    
        'Delete Layer
        Call DelLayer(lstList.ItemData(lstList.ListIndex))
    End If
End Sub

Private Sub cmdNew_Click()
    'Commit
    Call CommitDB("New Layer")
    
    'Add Layer
    AddLayer
End Sub

Private Sub cmdOK_Click()
    'Check list
    If lstList.ListCount > 0 Then
        'Commit
        Call CommitDB("Edit Layer")
        
        'Put layer
        Call PutLayer(lstList.ItemData(lstList.ListIndex))
    End If
    
    Unload Me
End Sub

Private Sub Form_Load()
    Dim n As Integer
    Dim nCount As Integer
    
    Dim nPos As Long
        
    Dim sList As String

    'Clear flag
    bList = False
        
    'Set tree view position
    aPos(0) = fMainForm.ScaleWidth / 4
    aPos(1) = fMainForm.ScaleHeight / 4
    
    'Reset count
    nCount = 0
    
    'Get window
    Call misGetListByKey(MIS_SEC_COM, MIS_KEY_LAYERT, sList, nCount, MIS_MOD_INI)
    
    'Check count
    If nCount > 0 Then
        'Truncate list
        sList = TruncStr(sList)

        'Loop thru list
        For n = 0 To 1
            'Get position of | character in string
            nPos = InStr(sList, "|")
        
            '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))
    On Error GoTo 0
    fMainForm.mnuViewTabLayer.Checked = True
End Sub

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

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

Private Sub cmdColor_Click()
    'Set handler for Cancel button
    On Error GoTo Cancel
    
    'Show open common dialog
    cdColor.Color = picColor.BackColor
    cdColor.Flags = &H1
    cdColor.ShowColor
    
    'Set color
    picColor.BackColor = cdColor.Color
    
    'Set change
    cmdApply_Click
    Exit Sub
    
    'Cancel button handler
Cancel:
    Exit Sub
End Sub

Private Sub lstList_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyDelete Then cmdDelete_Click
End Sub

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

Private Sub lstList_Click()
    'Check flag
    If bList = True Then Exit Sub
    
    'Get layer
    If lstList.ListCount > 0 Then Call GetLayer(lstList.ItemData(lstList.ListIndex))
End Sub

Private Sub lstList_ItemCheck(Item As Integer)
    'Check flag
    If bList = True Then Exit Sub
        
    'Check list
    If lstList.ListCount > 0 Then
        'Toggle layer
        Call TogLayer(lstList.ItemData(Item))
    End If
End Sub