frmattribs.frm

游戏《家园》源码

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmAttribs 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Attribute"
   ClientHeight    =   2124
   ClientLeft      =   48
   ClientTop       =   336
   ClientWidth     =   4644
   Icon            =   "frmAttribs.frx":0000
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   2124
   ScaleWidth      =   4644
   Begin VB.ComboBox cmbValue 
      Height          =   288
      Left            =   1200
      Sorted          =   -1  'True
      TabIndex        =   1
      Top             =   120
      Width           =   3312
   End
   Begin VB.ComboBox cmbName 
      Height          =   315
      Left            =   1020
      Sorted          =   -1  'True
      TabIndex        =   2
      Top             =   600
      Width           =   3495
   End
   Begin VB.CommandButton cmdBrowse 
      Caption         =   "4"
      BeginProperty Font 
         Name            =   "Webdings"
         Size            =   8.4
         Charset         =   2
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   300
      Left            =   1020
      TabIndex        =   0
      Tag             =   "Apply"
      ToolTipText     =   "Browse"
      Top             =   120
      Width           =   192
   End
   Begin VB.TextBox txtInfo 
      Height          =   285
      Left            =   1020
      TabIndex        =   3
      Top             =   1080
      Width           =   3495
   End
   Begin VB.CommandButton cmdApply 
      Caption         =   "&Apply"
      Height          =   375
      Left            =   3420
      TabIndex        =   6
      Tag             =   "Apply"
      Top             =   1620
      Width           =   1095
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   375
      Left            =   2220
      TabIndex        =   5
      Tag             =   "Cancel"
      Top             =   1620
      Width           =   1095
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "&OK"
      Default         =   -1  'True
      Height          =   375
      Left            =   1020
      TabIndex        =   4
      Tag             =   "OK"
      Top             =   1620
      Width           =   1095
   End
   Begin MSComDlg.CommonDialog cdBrowse 
      Left            =   120
      Top             =   1560
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      CancelError     =   -1  'True
      DialogTitle     =   "Open File"
      Filter          =   "All Files|*.*"
   End
   Begin VB.Label lblValue 
      Caption         =   "Value:"
      Height          =   195
      Left            =   120
      TabIndex        =   9
      Top             =   180
      Width           =   795
   End
   Begin VB.Label lblInfo 
      Caption         =   "Info:"
      Height          =   195
      Left            =   120
      TabIndex        =   8
      Top             =   1140
      Width           =   795
   End
   Begin VB.Label lblName 
      Caption         =   "Name:"
      Height          =   195
      Left            =   120
      TabIndex        =   7
      Top             =   660
      Width           =   795
   End
End
Attribute VB_Name = "frmAttribs"
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 GetAttrib(ByVal sPKey As String, ByVal sLKey As String)
    Dim nType As Integer
    Dim nInd As Integer
    
    Dim nPos As Long
    
    Dim sCKey As String
    Dim sQuery As String
    Dim sTxt As String
    Dim sVal As String
    
    Dim rsTemp As Recordset
    
    'Reset caption
    Me.Caption = "Attribute"
    
    'Reset color
    cmbValue.BackColor = vbWindowBackground
    cmbName.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
        
        'Set caption
        Me.Caption = "Attribute selection"
    Else
        'Clear slection flag
        bSel = False
            
        'Check parent
        If Left(sParK, 1) = "l" Then
            'Set caption
            Me.Caption = "Attribute of " + frmLevels.GetName(Val(Mid(sParK, 2)))
        End If
    
        'Check parent
        If Left(sParK, 1) = "o" Then
            'Get name
            sTxt = frmObjects.GetName(Val(Mid(sParK, 2)))
        
            'Get type
            nType = frmObjects.GetType(Val(Mid(sParK, 2)))
            Call misGetVal(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_TYPE, sVal, MIS_MOD_CFG)
            
            'Truncate type
            sVal = TruncStr(sVal)
            
            'Check type
            If sVal <> "" Then sTxt = sVal + ": " + sTxt
                    
            'Set caption
            Me.Caption = "Attribute of " + sTxt
        End If
    End If
    
    'Check key
    If sListK = "" Then
        'Put default data in controls
        cmbName.Text = MIS_NAM_ATTRIB
        cmbValue.Text = ""
        txtInfo.Text = ""
    
        'Get names
        GetNames (cmbName.Text)
    
        'Get values
        GetValues (cmbValue.Text)
        Exit Sub
    End If
    
    'Check recordset
    If rsAttribs.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) = "a" Then
            'Set query
            sQuery = "SELECT * FROM Attrib 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
                cmbName.Text = rsTemp!Name
                cmbValue.Text = rsTemp!Value
                txtInfo.Text = rsTemp!Info
                
                'Get names
                GetNames (cmbName.Text)
                
                'Get values
                GetValues (cmbValue.Text)
            Else
                'Compare data at set colors
                If cmbName.Text <> rsTemp!Name Then cmbName.BackColor = vbButtonFace
                If cmbValue.Text <> rsTemp!Value Then cmbValue.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 rsAttribs.BOF = True Then Exit Function
    
    'Set query
    sQuery = "SELECT * FROM Attrib 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 GetValue(ByVal nKey As Long) As String
    Dim sQuery As String
    
    Dim rsTemp As Recordset
    
    'Set default
    GetValue = ""
    
    'Check recordset
    If rsAttribs.BOF = True Then Exit Function
    
    'Set query
    sQuery = "SELECT * FROM Attrib WHERE Key = " + Trim(Str(nKey))
    
    'Open temporary recordset by query
    If OpenRecordSetByQuery(sQuery, rsTemp, "") = False Then Exit Function
        
    'Get data from recordset
    rsTemp.MoveFirst
    GetValue = rsTemp!Value
    
    'Close temporary recordset
    rsTemp.Close
End Function

Sub GetNames(ByVal sName As String)
    Dim n As Integer

    Dim nCount As Integer
    
    Dim nPos As Long
    Dim nType As Integer
    
    Dim sList As String
    
    'Clear combo
    cmbName.Clear
    cmbName.Text = sName
        
    'Reset count
    nCount = 0
    
    'Check parent
    If Left(sParK, 1) = "l" Then
        'Get attribs
        Call misGetListByKey(frmMission.GetPrefix + MIS_SEC_LEV, MIS_KEY_ATTRIB, sList, nCount, MIS_MOD_CFG)
    End If
    
    'Check parent
    If Left(sParK, 1) = "o" Then
        'Get type reference
        nType = frmObjects.GetType(Val(Mid(sParK, 2)))
    
        'Get attribs
        Call misGetListByKey(frmMission.GetPrefix + MIS_SEC_OBJ + Trim(Str(nType - 1)), MIS_KEY_ATTRIB, sList, nCount, MIS_MOD_CFG)
    End If
    
    'Check count
    If nCount = 0 Then Exit Sub
    
    'Truncate attribs
    sList = TruncStr(sList)

    'Loop thru attribs
    For n = 0 To nCount - 1
        'Get position of | character in string
        nPos = InStr(sList, "|")
        
        'If possible, truncate string at | character
        If nPos > 0 Then
            'Add attrib to combo
            cmbName.AddItem (Left(sList, nPos - 1))
            sList = Mid(sList, nPos + 1, Len(sList))
        Else
            'Add attrib to combo
            cmbName.AddItem (sList)
        End If
    Next n
End Sub

Sub GetValues(ByVal sVal As String)
    Dim n As Integer

    Dim nCount As Integer
    
    Dim nPos As Long
    Dim nType As Integer
    
    Dim sList As String
    
    'Clear combo
    cmbValue.Clear
    cmbValue.Text = sVal
        
    'Reset count
    nCount = 0
    
    'Check parent
    If Left(sParK, 1) = "l" Then
        'Get constants
        Call misGetListByKey(frmMission.GetPrefix + MIS_SEC_LEV, MIS_KEY_CONST, sList, nCount, MIS_MOD_CFG)
    End If
    
    'Check parent
    If Left(sParK, 1) = "o" Then