Planet Source Code Jumbo …e CD Visual Basic 1 to 7/5_2007-2008.ISO/data/Zips/Lengine_(C20326511232006.psc/LEngine_B755/Battle/usrBattle.ctl

Text File | 2006-11-18 | 21KB | 755 lines

VERSION 5.00
Object = "{0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}#1.0#0"; "msscript.ocx"
Begin VB.UserControl usrBattle
   BackColor       =   &H00808080&
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   BeginProperty Font
      Name            =   "Lucida Console"
      Size            =   9
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   Begin prjLEngine.usrSprite SFX
      Height          =   3600
      Left            =   0
      TabIndex        =   11
      Top             =   0
      Width           =   4800
      _ExtentX        =   8467
      _ExtentY        =   6350
   End
   Begin VB.Timer timDied
      Enabled         =   0   'False
      Interval        =   3500
      Left            =   4200
      Top             =   960
   End
   Begin VB.Timer timTurnFinished
      Enabled         =   0   'False
      Interval        =   2000
      Left            =   480
      Top             =   120
   End
   Begin VB.Timer timNotify
      Enabled         =   0   'False
      Interval        =   2200
      Left            =   0
      Top             =   120
   End
   Begin prjLEngine.usrTransPic imgSlash
      Height          =   495
      Left            =   600
      TabIndex        =   8
      Top             =   600
      Visible         =   0   'False
      Width           =   495
      _ExtentX        =   873
      _ExtentY        =   873
      MaskColor       =   -2147483633
   End
   Begin prjLEngine.usrTransPic imgEnemy
      Height          =   30
      Index           =   0
      Left            =   0
      TabIndex        =   7
      Top             =   0
      Width           =   30
      _ExtentX        =   53
      _ExtentY        =   53
      MaskColor       =   -2147483633
   End
   Begin prjLEngine.usrTransPic imgNumbers
      Height          =   120
      Index           =   0
      Left            =   3000
      TabIndex        =   6
      Top             =   240
      Visible         =   0   'False
      Width           =   120
      _ExtentX        =   212
      _ExtentY        =   212
      MaskColor       =   16777215
   End
   Begin prjLEngine.usrTransPic Char
      Height          =   30
      Index           =   0
      Left            =   0
      TabIndex        =   5
      Top             =   0
      Width           =   30
      _ExtentX        =   53
      _ExtentY        =   53
      MaskColor       =   -2147483633
   End
   Begin VB.Timer timWin
      Enabled         =   0   'False
      Interval        =   200
      Left            =   1560
      Top             =   2280
   End
   Begin VB.Timer timFloat
      Enabled         =   0   'False
      Interval        =   200
      Left            =   1080
      Tag             =   "0"
      Top             =   2280
   End
   Begin VB.Timer timATM
      Enabled         =   0   'False
      Index           =   3
      Left            =   480
      Top             =   2280
   End
   Begin VB.Timer timATM
      Enabled         =   0   'False
      Index           =   2
      Left            =   360
      Top             =   2280
   End
   Begin VB.Timer timATM
      Enabled         =   0   'False
      Index           =   1
      Left            =   240
      Top             =   2280
   End
   Begin VB.Timer timATM
      Enabled         =   0   'False
      Index           =   0
      Left            =   120
      Top             =   2280
   End
   Begin prjLEngine.usrMenu MnuEnemies
      Height          =   720
      Left            =   75
      TabIndex        =   1
      Top             =   2805
      Width           =   4725
      _ExtentX        =   8334
      _ExtentY        =   1270
      Begin prjLEngine.usrMenu MnuActions
         Height          =   735
         Left            =   1080
         TabIndex        =   3
         Top             =   0
         Width           =   1215
         _ExtentX        =   2143
         _ExtentY        =   1270
      End
      Begin prjLEngine.usrMenu MnuCustom
         Height          =   735
         Left            =   600
         TabIndex        =   9
         Top             =   0
         Visible         =   0   'False
         Width           =   1215
         _ExtentX        =   2143
         _ExtentY        =   1270
      End
      Begin prjLEngine.usrCharMenu MnuCharacters
         Height          =   705
         Left            =   2295
         TabIndex        =   2
         Top             =   0
         Width           =   2430
         _ExtentX        =   3863
         _ExtentY        =   1244
      End
      Begin VB.Image imgCur
         Height          =   195
         Index           =   0
         Left            =   1800
         Picture         =   "usrBattle.ctx":0000
         Top             =   360
         Visible         =   0   'False
         Width           =   240
      End
   End
   Begin prjLEngine.keyReciever keys
      Left            =   3000
      Top             =   1680
      _ExtentX        =   1429
      _ExtentY        =   1429
   End
   Begin VB.Timer timShowAttack
      Enabled         =   0   'False
      Interval        =   80
      Left            =   2520
      Tag             =   "0"
      Top             =   1080
   End
   Begin VB.Timer timShowDamage
      Enabled         =   0   'False
      Interval        =   1
      Left            =   3000
      Top             =   1080
   End
   Begin VB.Timer timAnim
      Enabled         =   0   'False
      Index           =   0
      Left            =   2520
      Top             =   2280
   End
   Begin prjLEngine.usrMenu MnuItems
      Height          =   720
      Left            =   75
      TabIndex        =   4
      Top             =   2805
      Width           =   4695
      _ExtentX        =   8281
      _ExtentY        =   1270
   End
   Begin MSScriptControlCtl.ScriptControl Script
      Left            =   4200
      Top             =   0
      _ExtentX        =   1005
      _ExtentY        =   1005
   End
   Begin prjLEngine.usrNotify Notify
      Height          =   240
      Left            =   120
      TabIndex        =   10
      Top             =   0
      Visible         =   0   'False
      Width           =   4575
      _ExtentX        =   8070
      _ExtentY        =   423
   End
   Begin VB.Shape shpShadow
      FillStyle       =   0  'Solid
      Height          =   375
      Index           =   0
      Left            =   600
      Shape           =   2  'Oval
      Top             =   1680
      Visible         =   0   'False
      Width           =   855
   End
   Begin VB.Label Numbers
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "3"
      BeginProperty Font
         Name            =   "Lucida Console"
         Size            =   11.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   225
      Index           =   0
      Left            =   120
      TabIndex        =   0
      Tag             =   "0"
      Top             =   3360
      Width           =   150
   End
   Begin VB.Image imgCur
      Height          =   195
      Index           =   1
      Left            =   0
      Picture         =   "usrBattle.ctx":03A0
      Top             =   0
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imgBack
      Height          =   3600
      Left            =   0
      Stretch         =   -1  'True
      Top             =   0
      Width           =   4800
   End
End
Attribute VB_Name = "usrBattle"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const Mnu_Custom As Integer = 4
Private Const Mnu_Items As Integer = 3
Private Const Mnu_Characters As Integer = 2
Private Const Mnu_Enemies As Integer = 1
Private Const Mnu_Action As Integer = 0

Private Const Act_Attack As String = "A"
Private Const Act_Item As String = "I"
Private Const Act_Steal As String = "S"
Private Const Act_Custom As String = "C"

Private Const Sta_Attack As Integer = 10

Private pSlashSize(3) As picSize

Private iAniStart(40) As Integer
Private iAniEnd(40) As Integer

Private imenuState As Integer
Private sMnuAnswers(4) As String
Private cMnuHistory As New Collection

Private bTakingTurn As Boolean
Private bTurnFinished As Boolean
Private bAnimationBusy As Boolean

Private bFirstMember As Boolean 'Special Conditions for firsts
Private bFirstEnemy As Boolean '0 is already loaded
Private bMagic As Boolean

Private cNeedsActivation As New Collection

Private iPartyIndex As Integer
Private iEnemyIndex As Integer

Private iFloatState As Integer

Private bAttackAi As Boolean
Private bTargetAi As Boolean

Private iWinState As Integer
Private bBattleEnd As Boolean

Private CurrentMnu

Private imgKill(7)
Private b_imgKillUsed(7) As Boolean
Private b_imgKillAI(7) As Boolean
Private i_HuIndex(7) As Integer

Private bKill As Boolean

Private iSubjectIndex As Integer
Private iOffenderIndex As Integer

Private LastTarget As New clsBattlePlayer
Private LastOffender As New clsBattlePlayer

Private cBattleActions As New Collection
Private cCharsReady As New Collection
Private cNotifications As New Collection
Private bAttackFin As Boolean
Private sLastSpell As String

Private pParty(1) As New clsParty
Private iAiATM(3) As Integer

Private sSFXFinished As Boolean
Private bWaitNotify As Boolean

Public Event BattleFinished(iRes As Integer)
Private WithEvents ScriptDef As clsScript
Attribute ScriptDef.VB_VarHelpID = -1

Private bBoss As Boolean
Private sBattlePath As String

Public Property Get PartyCount() As Integer
    PartyCount = MnuCharacters.ListCount
End Property

Public Property Let Boss(bNewBoss As Boolean)
    bBoss = bNewBoss
End Property

Public Property Get Boss() As Boolean
    Boss = bBoss
End Property

Sub DigGrave(ByRef imgSrc, bAI As Boolean, Optional charIndex As Integer = -1)

Dim I As Integer

    For I = 0 To UBound(imgKill)
        If b_imgKillUsed(I) = False Then
            b_imgKillUsed(I) = True
            b_imgKillAI(I) = bAI
            i_HuIndex(I) = charIndex

            Set imgKill(I) = imgSrc
            Exit Sub
        End If
    Next

End Sub

Sub BerryDead()

Dim I As Integer

    For I = 0 To UBound(imgKill)
        If b_imgKillUsed(I) = True Then

            b_imgKillUsed(I) = False

            If b_imgKillAI(I) = True Then
                DealWithDeadAI i_HuIndex(I)
            Else
                DealWithDeadHuman i_HuIndex(I)
            End If

            b_imgKillAI(I) = False
        End If
    Next

End Sub

Sub DumpParty(ByRef bcIni As clsIniObj)

Dim I As Integer, sIds As String

    bcIni.Section = "Battle_Party"

    For I = 0 To MnuCharacters.ListUbound
        sIds = sIds & pBattleHu(I).ID & ","
    Next

    If Len(sIds) > 0 Then
        sIds = Mid(sIds, 1, Len(sIds) - 1)
    End If

    bcIni.WriteData sIds, "Members"

    bcIni.Section = "Battle_Aliases"
    DumpSuperCollection bcIni, Aliases

End Sub

Sub RestoreParty(ByRef bcIni As clsIniObj)

Dim I As Integer, sIds() As String

    bcIni.Section = "Battle_Aliases"
    RestoreSuperCollection bcIni, Aliases

    bcIni.Section = "Battle_Party"
    sIds = Split(bcIni.Read("Members"), ",")

    For I = 0 To UBound(sIds)
        Me.CreatePlayer sIds(I)
    Next

End Sub

Sub RemoveAllPlayers()

Dim I As Integer

    For I = 0 To MnuCharacters.ListUbound
        RemovePlayer I
    Next

End Sub

Sub UpdateCharDisplay(charIndex As Integer)

    If pBattleHu(charIndex).Hp > pBattleHu(charIndex).MaxHp Then
        pBattleHu(charIndex).Hp = pBattleHu(charIndex).MaxHp
    End If

    MnuCharacters.UpdateATB charIndex, pBattleHu(charIndex).ATB
    MnuCharacters.UpdateHP charIndex, pBattleHu(charIndex).Hp

End Sub

Sub NextNotify()

    '! I should only be called, when the previous notify is
    'gone [implying the notify object is invisisble]

    If cNotifications.Count > 0 Then
        NotifyAction cNotifications(1)
        cNotifications.Remove 1
    ElseIf bWaitNotify = True Then
        bWaitNotify = False
        timShowAttack.Enabled = True
    End If

End Sub

Sub NotifyAction(sCaption As String)

    If Notify.Visible = False Then
        Notify.Caption = sCaption
        Notify.Visible = True

        'Max visiable 2secs
        timNotify.Enabled = True
    Else
        'Que
        cNotifications.Add sCaption
    End If

End Sub

Sub InitialiseActions(BattleChar As clsBattlePlayer, Optional bCompare As Boolean)

    On Error GoTo Catch_E

Dim sPath As String, cActions As New Collection, sRes As String, I As Integer, actionIndex As Integer
Dim CActionNode As New Collection, sIniPath As String, iniMp As New clsIniObj, iniLvl As New clsIniObj

    sPath = Vars.sPath_BattleChars & BattleChar.ID & "\Actions\"

    With frmLib.Dir1
        .Path = sPath
    End With

    If frmLib.Dir1.ListCount > 0 Then
        For I = 0 To frmLib.Dir1.ListCount - 1
            sRes = StrEnd(frmLib.Dir1.List(I), "\")
            If sRes <> "False" Then
                cActions.Add sRes
            End If
        Next

        If bCompare = False Then
            'start an array
            BattleChar.Actions = cActions
        End If

        If cActions.Count > 0 Then
            actionIndex = 1

            iniMp.Key = "MP Cost"
            iniMp.Default = 0

            iniLvl.Key = "Level"
            iniLvl.Default = 0

            While actionIndex <= cActions.Count
                'sIniPath = sPath & cActions(actionIndex) & ".ini"
                Set CActionNode = BattleChar.ActionNode(actionIndex)

                iniMp.File = sPath & cActions(actionIndex) & ".ini"
                iniLvl.File = iniMp.File

                With frmLib.File1
                    .Path = sPath & cActions(actionIndex)
                    .Pattern = "*.def"
                End With

                For I = 0 To frmLib.File1.ListCount - 1
                    sRes = StrFront(frmLib.File1.List(I), ".")

                    If BattleChar.Level >= iniLvl.Read(, sRes) Then
                        If ColExists(CActionNode, iniMp.Key & "_" & sRes) = False Then
                            CActionNode.Add sRes & ":" & iniMp.Read(, sRes), iniMp.Key & "_" & sRes

                            If bCompare = True Then
                                NotifyAction BattleChar.Name & " has learnt Spell '" & sRes & "'"
                            End If
                        End If
                    End If
                Next

                BattleChar.ActionNode(actionIndex) = CActionNode

                actionIndex = actionIndex + 1
            Wend
        End If
    End If

    Exit Sub

Catch_E:
    'MsgBox ":("

    'MsgBox pBattleHu(Index).Actions.Count

End Sub

Sub InitialiseItems()
'Lists all available items in item menu

Dim cTypes As SuperCollection

    MnuItems.ClearList

    Set cTypes = Inventory.Types

    Dim sItem As String, I As Integer

    For I = 1 To cTypes.Count
        If Inventory.TypeCount(cTypes.Key(I)) > 0 Then
            sItem = CStr(cTypes.Key(I))

            MnuItems.AddItem sItem & " x " & Inventory.TypeCount(sItem), sItem
        End If
    Next

End Sub

Sub InitialiseSteals(BattleChar As clsBattlePlayer)
'all available steals

Dim cSteals As New Collection, cIni As New clsIniObj, _
    iSlotIndex As Integer

    cIni.File = BattleChar.Path & "inventory.ini"

    For iSlotIndex = 1 To 16
        cIni.Section = "Slot " & CStr(iSlotIndex)

        If cIni.Read("Name") <> "" Then
            cSteals.Add cIni.Read("Type") & ":" & cIni.Read("Name") & ":" & Replace(cIni.Read("Steal Chance"), "%", "") & ":" & Replace(cIni.Read("Drop Chance"), "%", "")
        End If
    Next

    BattleChar.Steals = cSteals

End Sub

Sub InitialiseKeys()

    'Notified on these key changes
    keys.AddKey Control_Cancel
    keys.AddKey Control_Select

    keys.AddKey Control_Down
    keys.AddKey Control_Up
    keys.AddKey Control_Right
    keys.AddKey Control_Left

End Sub

Private Function RunScript(sStatement As String)

    On Error Resume Next

    Script.ExecuteStatement sStatement
    If Err Then
        With Script.Error
            MsgBox "Syntax Error : " & .Number & ": " & .Description & " at line " & .Line & " column " & .Column & ": " & vbCrLf, vbCritical, "Script Error"
        End With
    End If

End Function

Private Function SetScript(ByRef pTarget As clsBattlePlayer, ByRef pOfender As clsBattlePlayer, Optional bSpell As Boolean = False)

    Set LastTarget = pTarget
    Set LastOffender = pOfender

    'Setup variables in script
    If pOfender.Enemy = False Then
        Script.ExecuteStatement "Set Offender = HumanBattle_" & pOfender.Index
        Script.ExecuteStatement "Set OffensiveParty = HumanParty"

        SFX.ExecuteStatement "Set OffensiveParty = HumanParty"
        SFX.ExecuteStatement "Set Offender = HumanBattle_" & pOfender.Index
    Else
        Script.ExecuteStatement "Set Offender = AIBattle_" & pOfender.Index
        Script.ExecuteStatement "Set OffensiveParty = AiParty"

        SFX.ExecuteStatement "Set OffensiveParty = AiParty"
        SFX.ExecuteStatement "Set Offender = AIBattle_" & pOfender.Index
    End If

    If pTarget.Enemy = False Then
        Script.ExecuteStatement "Set Target = HumanBattle_" & pTarget.Index
        Script.ExecuteStatement "Set TargetParty = HumanParty"

        SFX.ExecuteStatement "Set TargetParty = HumanParty"
        SFX.ExecuteStatement "Set Target = HumanBattle_" & pTarget.Index
    Else
        Script.ExecuteStatement "Set Target = AIBattle_" & pTarget.Index
        Script.ExecuteStatement "Set TargetParty = AiParty"

        SFX.ExecuteStatement "Set TargetParty = AiParty"
        SFX.ExecuteStatement "Set Target = AIBattle_" & pTarget.Index
    End If

End Function

Private Function SetScriptDef(pOfender As clsBattlePlayer)

Dim iAttackIndex As Integer

    'Get Next Avail
    iAttackIndex = RandomNumber(Char.UBound, 0)
    While pBattleHu(iAttackIndex).Alive = False
        iAttackIndex = RandomNumber(Char.UBound, 0)
    Wend

    ScriptDef.Index = pOfender.Index

    'Setup variables in script
    If pOfender.Enemy = False Then
        Script.ExecuteStatement "Set Offender = HumanBattle_" & pOfender.Index
        Script.ExecuteStatement "Set OffensiveParty = HumanParty"
    Else
        Script.ExecuteStatement "Set Offender = AIBattle_" & pOfender.Index
        Script.ExecuteStatement "Set OffensiveParty = AiParty"
    End If

    Script.ExecuteStatement "Set Self = AIBattle_" & pOfender.Index
    Script.ExecuteStatement "Set RandomPlayer = HumanBattle_" & iAttackIndex

End Function

Private Function DoQuedActions() As Boolean

Dim bTargetIsAI As Boolean, bOfenderIsAI As Boolean, pTarget As clsBattlePlayer, pOfender As clsBattlePlayer, _
sP() As String

    If cBattleActions.Count = 0 Then
        'Allow normal gameplay to continue

        SelectNextReadyChar
        bAnimationBusy = False

        Exit Function
    End If

    'Determine the qued actions
    sP = Split(cBattleActions(1), ":")
    cBattleActions.Remove 1

    If Mid(sP(2), 1, 1) = "H" Then
        bTargetIsAI = False

        Set pTarget = pBattleHu(sP(0))
    Else
        bTargetIsAI = True

        Set pTarget = pBattleAI(sP(0))
    End If

    If Mid(sP(2), 2, 1) = "A" Then
        bOfenderIsAI = True

        Set pOfender = pBattleAI(sP(1))
    Else
        bOfenderIsAI = False

        Set pOfender = pBattleHu(sP(1))
        iPartyIndex = CInt(sP(1))
    End If

    If pOfender.Alive = False Then
        'Ofender cant attack if they are dead
        DoQuedActions
        Exit Function
    End If

    'Execute the determined actions
    Select Case sP(3)

    Case Act_Attack
        'Attack
        AttackTarget pTarget, pOfender

    Case Act_s() As B