frmlayers.frm

游戏《家园》源码

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmLayers 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Layers"
   ClientHeight    =   6084
   ClientLeft      =   48
   ClientTop       =   336
   ClientWidth     =   4644
   Icon            =   "frmLayers.frx":0000
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   6084
   ScaleWidth      =   4644
   Begin VB.CheckBox chkAll 
      Caption         =   "All"
      Height          =   195
      Left            =   1020
      TabIndex        =   1
      Top             =   3780
      Width           =   1035
   End
   Begin VB.PictureBox picColor 
      Height          =   315
      Left            =   1200
      ScaleHeight     =   264
      ScaleWidth      =   3264
      TabIndex        =   14
      Top             =   4680
      Width           =   3315
   End
   Begin VB.CommandButton cmdColor 
      Caption         =   "4"
      BeginProperty Font 
         Name            =   "Webdings"
         Size            =   8.4
         Charset         =   2
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   315
      Left            =   1020
      TabIndex        =   5
      Tag             =   "Apply"
      ToolTipText     =   "Browse"
      Top             =   4680
      Width           =   195
   End
   Begin MSComDlg.CommonDialog cdColor 
      Left            =   120
      Top             =   3060
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      CancelError     =   -1  'True
   End
   Begin VB.TextBox txtInfo 
      Height          =   285
      Left            =   1020
      TabIndex        =   6
      Top             =   5160
      Width           =   3495
   End
   Begin VB.TextBox txtName 
      Height          =   285
      Left            =   1020
      TabIndex        =   4
      Top             =   4260
      Width           =   3495
   End
   Begin VB.CommandButton cmdDelete 
      Caption         =   "&Delete"
      Height          =   375
      Left            =   3420
      TabIndex        =   3
      Tag             =   "Delete"
      Top             =   3720
      Width           =   1095
   End
   Begin VB.CommandButton cmdNew 
      Caption         =   "&New"
      Height          =   375
      Left            =   2220
      TabIndex        =   2
      Tag             =   "OK"
      Top             =   3720
      Width           =   1095
   End
   Begin VB.CommandButton cmdApply 
      Caption         =   "&Apply"
      Height          =   375
      Left            =   3420
      TabIndex        =   9
      Tag             =   "Apply"
      Top             =   5580
      Width           =   1095
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   375
      Left            =   2220
      TabIndex        =   8
      Tag             =   "Cancel"
      Top             =   5580
      Width           =   1095
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "&OK"
      Default         =   -1  'True
      Height          =   375
      Left            =   1020
      TabIndex        =   7
      Tag             =   "OK"
      Top             =   5580
      Width           =   1095
   End
   Begin VB.ListBox lstList 
      Height          =   3288
      Left            =   1020
      Sorted          =   -1  'True
      Style           =   1  'Checkbox
      TabIndex        =   0
      Top             =   120
      Width           =   3495
   End
   Begin VB.Label lblList 
      Caption         =   "List:"
      Height          =   195
      Left            =   120
      TabIndex        =   13
      Top             =   180
      Width           =   795
   End
   Begin VB.Label lblInfo 
      Caption         =   "Info:"
      Height          =   195
      Left            =   120
      TabIndex        =   12
      Top             =   5220
      Width           =   795
   End
   Begin VB.Label lblCol0 
      Caption         =   "Color:"
      Height          =   195
      Left            =   120
      TabIndex        =   11
      Top             =   4740
      Width           =   795
   End
   Begin VB.Label lblName 
      Caption         =   "Name:"
      Height          =   195
      Left            =   120
      TabIndex        =   10
      Top             =   4320
      Width           =   795
   End
End
Attribute VB_Name = "frmLayers"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim bList As Boolean

Dim aPos(4) As Single

Sub GetLayers(ByVal nKey As Long)
    Dim n As Integer
    
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Check flag
    If Not fMainForm.mnuViewTabLayer.Checked Then Exit Sub
    
    'Clear list
    lstList.Clear
    
    'Reset data
    txtName.Text = ""
    picColor.BackColor = vbWhite
    txtInfo.Text = ""
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    '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
    
    'Set flag
    bList = True
        
    'Find data in recordset
    rsTemp.MoveFirst
    Do Until rsTemp.EOF
        'Get layer data
        lstList.AddItem (rsTemp!Name)
        lstList.ItemData(lstList.NewIndex) = rsTemp!Key
        If rsTemp!Color < 0 Then lstList.Selected(lstList.NewIndex) = False
        If rsTemp!Color > 0 Then lstList.Selected(lstList.NewIndex) = True
        rsTemp.MoveNext
    Loop
    
    'Clear flag
    bList = False
        
    'Close temporary recordset
    rsTemp.Close
    
    'Check list  index
    If lstList.ListCount > 0 Then
        'Loop thru list
        For n = 0 To lstList.ListCount - 1
            'Check list items
            If lstList.ItemData(n) = nKey Then
                lstList.ListIndex = n
                Exit For
            End If
        Next n
    
        'Reset list index
        If lstList.ListIndex < 0 Then lstList.ListIndex = 0
        
        'Get layer
        Call GetLayer(lstList.ItemData(lstList.ListIndex))
    End If
End Sub

Sub GetLayer(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
    
    '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
    txtName.Text = rsTemp!Name
    picColor.BackColor = Abs(rsTemp!Color)
    txtInfo.Text = rsTemp!Info
    
    'Close temporary recordset
    rsTemp.Close
End Sub

Sub GetColor(ByVal nKey As Long, nMode As Long, nCol As Long)
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Reset mode and color
    nMode = 1
    nCol = nViewCol
    
    '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
    If rsTemp!Color < 0 Then nMode = 0
    If rsTemp!Color > 0 Then nMode = 1
    nCol = Abs(rsTemp!Color)
    
    'Close temporary recordset
    rsTemp.Close
End Sub

Function GetName(ByVal nKey As Long) As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Set default
    GetName = ""
    
    'Check recordset
    If rsLayers.BOF = True Then Exit Function
    
    'Set query
    sQuery = "SELECT * FROM Layers WHERE Key = " + 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 PutLayer(ByVal nKey As Long)
    Dim n As Integer
    Dim nItem As Integer
    Dim nCount As Integer
    
    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
    
    'Edit data in recordset
    rsTemp.MoveFirst
    rsTemp.Edit
    rsTemp!Name = txtName.Text
    If lstList.Selected(nItem) = False Then rsTemp!Color = -picColor.BackColor
    If lstList.Selected(nItem) = True Then rsTemp!Color = picColor.BackColor
    rsTemp!Info = txtInfo.Text
    rsTemp.Update
    
    'Close temporary recordset
    rsTemp.Close
    
    'Update objects
    If lstList.Selected(nItem) = False Then Call frmObjects.PutColor(nKey, 0, picColor.BackColor)
    If lstList.Selected(nItem) = True Then Call frmObjects.PutColor(nKey, 1, picColor.BackColor)
        
    '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