frmlevels.frm

游戏《家园》源码

VERSION 5.00
Begin VB.Form frmLevels 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Level"
   ClientHeight    =   1575
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4650
   Icon            =   "frmLevels.frx":0000
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   1575
   ScaleWidth      =   4650
   Begin VB.TextBox txtName 
      Height          =   285
      Left            =   1020
      TabIndex        =   0
      Top             =   120
      Width           =   3495
   End
   Begin VB.TextBox txtInfo 
      Height          =   285
      Left            =   1020
      TabIndex        =   1
      Top             =   600
      Width           =   3495
   End
   Begin VB.CommandButton cmdApply 
      Caption         =   "&Apply"
      Height          =   375
      Left            =   3420
      TabIndex        =   4
      Tag             =   "Apply"
      Top             =   1080
      Width           =   1095
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   375
      Left            =   2220
      TabIndex        =   3
      Tag             =   "Cancel"
      Top             =   1080
      Width           =   1095
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "&OK"
      Default         =   -1  'True
      Height          =   375
      Left            =   1020
      TabIndex        =   2
      Tag             =   "OK"
      Top             =   1080
      Width           =   1095
   End
   Begin VB.Label lblInfo 
      Caption         =   "Info:"
      Height          =   195
      Left            =   120
      TabIndex        =   6
      Top             =   660
      Width           =   795
   End
   Begin VB.Label lblName 
      Caption         =   "Name:"
      Height          =   195
      Left            =   120
      TabIndex        =   5
      Top             =   180
      Width           =   795
   End
End
Attribute VB_Name = "frmLevels"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim bSel As Boolean

Dim aPos(4) As Single

Dim sParK As String
Dim sCurK As String
Dim sListK As String

Sub GetLevel(ByVal sPKey As String, ByVal sLKey As String)
    Dim nInd As Integer

    Dim nPos As Long
    
    Dim sCKey As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Reset color
    txtName.BackColor = vbWindowBackground
    txtInfo.BackColor = vbWindowBackground
    
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Set local keys
    sParK = sPKey
    sListK = sLKey
    sCurK = ""
    
    'Check keys
    If sParK = "" Then
        'Set selection flag
        bSel = True
    Else
        'Clear slection flag
        bSel = False
    End If
    
    'Check key
    If sListK = "" Then
        'Put default data in controls
        txtName.Text = MIS_NAM_LEV
        txtInfo.Text = ""
        Exit Sub
    End If
    
    'Check recordset
    If rsLevels.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) = "l" Then
            'Set query
            sQuery = "SELECT * FROM Levels 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
                txtName.Text = rsTemp!Name
                txtInfo.Text = rsTemp!Info
            Else
                'Compare data and set colors
                If txtName.Text <> rsTemp!Name Then txtName.BackColor = vbButtonFace
                If txtInfo.Text <> rsTemp!Info Then txtInfo.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

Function GetName(ByVal nKey As Long) As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Set default
    GetName = ""
    
    'Check recordset
    If rsLevels.BOF = True Then Exit Function
    
    'Set query
    sQuery = "SELECT * FROM Levels 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

Function GetFile(ByVal sKey As String, ByVal nInd As Integer) As String
    Dim nType As Integer
    
    Dim nKey As Long
    Dim nPos As Long
    
    Dim sExt As String
    Dim sVal As String
    
    'Set default
    GetFile = ""
    
    'Check DB
    If bDBFlag = False Then Exit Function
    
    'Check key
    If sKey = "" Then Exit Function
    If Left(sKey, 1) <> "l" Then Exit Function
    
    'Get extension
    Call misGetVal(frmMission.GetPrefix + MIS_SEC_LEV, MIS_KEY_EXT, sExt, MIS_MOD_CFG)
    sExt = TruncStr(sExt)
    If sExt = "" Then Exit Function
    
    'Set value
    sVal = GetName(Mid(sKey, 2))
    
    'Check value
    nPos = InStr(sVal, ",")
    If nPos > 0 Then
        'Truncate value at comma
        sVal = Mid(sVal, nPos + 1)
    End If
        
    'Set File
    GetFile = sDataDir + sVal + sExt
End Function

Sub PutLevel()
    Dim nPos As Long

    Dim sCKey As String
    Dim sLKey As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
            
    'Check DB
    If bDBFlag = False Then Exit Sub
    
    'Check key
    If sListK = "" Then
        'Add level
        AddLevel
        Exit Sub
    End If
    
    'Check recordset
    If rsLevels.BOF = True Then Exit Sub
    
    'Set list
    sLKey = sListK
    
    '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) = "l" Then
            'Set query
            sQuery = "SELECT * FROM Levels WHERE Key = " + Mid(sCKey, 2)
            
            'Open temporary recordset by query
            If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Sub
            
            'Put data in recordset
            rsTemp.MoveFirst
            rsTemp.Edit
            rsTemp!NumObjs = CountObjects(Val(Mid(sCKey, 2)))
            rsTemp!NumAttribs = CountAttribs(Val(Mid(sCKey, 2)))
            If txtName.BackColor = vbWindowBackground Then rsTemp!Name = Trim(txtName.Text)
            If txtInfo.BackColor = vbWindowBackground Then rsTemp!Info = Trim(txtInfo.Text)
            rsTemp.Update
            
            'Close temporary recordset
            rsTemp.Close
        
            'Edit and select in tree
            frmTree.EditTree (sCKey)
        End If
        
        'Check position
        If nPos = 0 Then Exit Do
    Loop
            
    'Select in tree
    frmTree.SelTree ("")
End Sub

Sub AddLevel()
    'Add data to recordset
    rsLevels.AddNew
    sCurK = "l" + Trim(Str(rsLevels!Key))
    sListK = sCurK
    rsLevels!NumObjs = 0
    rsLevels!NumAttribs = 0
    rsLevels!Name = Trim(txtName.Text)
    rsLevels!Info = Trim(txtInfo.Text)
    rsLevels.Update

    'Add to tree
    Call frmTree.AddTree(sParK, sCurK)
    
    'Add attribs
    AddAttribs
    
    'Select in tree
    Call frmTree.SelTree(sCurK)
End Sub

Sub AddAttribs()
    Dim n As Integer

    Dim nCount As Integer
    
    Dim nPos As Long
    
    Dim sList As String
    Dim sVal As String
    
    'Reset count