csession.cls

3D纵版射击程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cSession"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

Private I_oDXInstance As DirectX7
Private I_oDDInstance As DirectDraw7
Private I_oDSInstance As DirectSound

Public RenderTime As Long
Public UpdateTime As Long
Public ProcessTime As Long

Public Campaign As New cCampaign

Private I_sPlugin() As String
Public SoundPresent As Boolean

Private I_oViewport As cViewport
Private I_oLevel As cLevel
Private I_oMenu As cMenu
Private I_oFrames As cFrames
Private I_oSounds As cSounds
Private I_oEnemyTemplates As cEnemyTemplates
Private I_oPlayer As cPlayer

Private I_nWaveVolume As Integer
Private I_nMusicVolume As Integer

Public Detail As Boolean
Public Joystick As Boolean
Public JoystickDead As Long
Public Difficulty As Integer

Public Terminating As Boolean
Public Mode As Integer
Public DebugMode As Boolean

Public FrameCount As Long
Public FramesPerSecond As Long

Public Property Get Player() As cPlayer
    Set Player = I_oPlayer
End Property
Public Property Set Player(oPlayer As cPlayer)
    Set I_oPlayer = oPlayer
End Property
Public Sub RegisterPlugin(sName As String)
    ReDim Preserve I_sPlugin(UBound(I_sPlugin) + 1)
    I_sPlugin(UBound(I_sPlugin)) = sName
End Sub
Public Function PluginLoaded(sName As String) As Boolean

    Dim L_nRun As Long
    For L_nRun = 0 To UBound(I_sPlugin)
        If I_sPlugin(L_nRun) = sName Then
            PluginLoaded = True
            Exit Function
        End If
    Next
    
End Function

Public Property Get WaveVolume() As Integer
    WaveVolume = I_nWaveVolume
End Property
Public Property Let WaveVolume(nNew As Integer)
    If nNew > 100 Then nNew = 100
    If nNew < 0 Then nNew = 0
    SetWaveVolume nNew
    I_nWaveVolume = nNew
End Property

Public Property Get MusicVolume() As Integer
    MusicVolume = I_nMusicVolume
End Property
Public Property Let MusicVolume(nNew As Integer)
    If nNew > 100 Then nNew = 100
    If nNew < 0 Then nNew = 0
    SetMusicVolume nNew
    I_nMusicVolume = nNew
End Property

Public Sub SetMusicVolume(nVolume As Integer)
    On Error GoTo E_SetMusicVolume
    If SoundPresent Then
        If Not I_oMenu.MenuSound Is Nothing Then
            I_oMenu.MenuSound.SetVolume Int((DSBVOLUME_MIN / 100) * (100 - IIf(nVolume + 10 > 100, 100, nVolume + 10)))
        End If
    End If
    
    Dim L_nMidiDeviceHandle As Long
    Dim L_nVolume As Long
    L_nMidiDeviceHandle = mciGetDeviceID(I_oLevel.Music)
    L_nVolume = Int(327 * nVolume) + Int(327 * nVolume) * (2 ^ 16)
    midiOutSetVolume L_nMidiDeviceHandle, L_nVolume
    On Error GoTo 0
    Exit Sub
E_SetMusicVolume:
    
End Sub

Public Sub PlayMidiMusic(sFileName As String)

    Dim L_sFullPath As String * 255
    Dim L_sRealPath As String
    Dim L_nPathLength As String
    
    On Error GoTo E_IsPluginMusic
    Open App.Path + "\" + sFileName + ".mid" For Input As #4
    Close #4
    L_nPathLength = GetShortPathName(App.Path, L_sFullPath, 255)
    L_sRealPath = Left(L_sFullPath, L_nPathLength)
    GoTo E_IsStandardMusic
    
E_IsPluginMusic:
    L_nPathLength = GetShortPathName(App.Path + "\plugin\", L_sFullPath, 255)
    L_sRealPath = Left(L_sFullPath, L_nPathLength)
        
E_IsStandardMusic:
    On Error GoTo 0
    
    mciSendString "close " & sFileName, 0&, 0, 0
    mciSendString "open " + L_sRealPath + "\" + sFileName + ".mid type sequencer alias " & sFileName, 0&, 0, 0
    mciSendString "play " & sFileName, 0&, 0, 0

End Sub

Public Sub SetWaveVolume(nVolume As Integer)
    If Not SoundPresent Then Exit Sub
    Dim L_oFrame As cFrame
    For Each L_oFrame In I_oFrames
        If Not L_oFrame.Sound Is Nothing Then
            L_oFrame.Sound.SetVolume Int((DSBVOLUME_MIN / 100) * (100 - nVolume))
        End If
    Next
    
End Sub

Public Property Get DXInstance() As DirectX7
    Set DXInstance = I_oDXInstance
End Property
Public Property Set DXInstance(oDXInstance As DirectX7)
    Set I_oDXInstance = oDXInstance
End Property

Public Property Get DDInstance() As DirectDraw7
    Set DDInstance = I_oDDInstance
End Property
Public Property Set DDInstance(oDDInstance As DirectDraw7)
    Set I_oDDInstance = oDDInstance
End Property

Public Property Get DSInstance() As DirectSound
    Set DSInstance = I_oDSInstance
End Property
Public Property Set DSInstance(oDSInstance As DirectSound)
    Set I_oDSInstance = oDSInstance
End Property

Public Property Get EnemyTemplates() As cEnemyTemplates
    Set EnemyTemplates = I_oEnemyTemplates
End Property
Public Property Set EnemyTemplates(oEnemyTemplates As cEnemyTemplates)
    Set I_oEnemyTemplates = oEnemyTemplates
End Property

Public Property Get Viewport() As cViewport
    Set Viewport = I_oViewport
End Property
Public Property Set Viewport(oViewport As cViewport)
    Set I_oViewport = oViewport
End Property

Public Property Get Level() As cLevel
    Set Level = I_oLevel
End Property
Public Property Set Level(oLevel As cLevel)
    Set I_oLevel = oLevel
End Property

Public Property Get Sounds() As cSounds
    Set Sounds = I_oSounds
End Property
Public Property Set Sounds(oSounds As cSounds)
    Set I_oSounds = oSounds
End Property


Public Property Get Menu() As cMenu
    Set Menu = I_oMenu
End Property
Public Property Set Menu(oMenu As cMenu)
    Set I_oMenu = oMenu
End Property

Public Property Get Frames() As cFrames
    Set Frames = I_oFrames
End Property
Public Property Set Frames(oFrames As cFrames)
    Set I_oFrames = oFrames
End Property

Public Sub Initialize(nHWnd As Long)

    If Not HardwareCheck Then
        fMessage.Hide
        fMessage.lblMessage = "Wrong screen resolution and/or color depth detected. Zooom requires at least a resolution of 800x600 pixel and 16-bit color depth. Please change your system settings and restart Zooom."
        fMessage.Show 1
        Unload fZooom
        End
    End If
    
    Dim L_nValue As Long
    Dim L_nFactor As Long
    For L_nValue = 0 To 255
        G_nTranslucencyLookup(L_nValue, 100) = L_nValue
        For L_nFactor = 0 To 99
            G_nTranslucencyLookup(L_nValue, L_nFactor) = Int(L_nValue * ((100 - L_nFactor) / 100))
        Next
    Next
    
    ReDim I_sPlugin(0)
    Difficulty = 1
    
    On Error GoTo E_DirectX
    Set I_oDXInstance = New DirectX7
    Set I_oDDInstance = I_oDXInstance.DirectDrawCreate("")
    On Error GoTo 0
    
    On Error GoTo E_NoSound
    Set I_oDSInstance = I_oDXInstance.DirectSoundCreate("")
    I_oDSInstance.SetCooperativeLevel fZooom.hwnd, DSSCL_NORMAL
    SoundPresent = True
E_NoSound:
    On Error GoTo 0
    
    Set Campaign = New cCampaign
    Set Campaign.Parent = Me
    Campaign.Initialize
    
    Set I_oViewport = New cViewport
    Set I_oViewport.Parent = Me
    I_oViewport.Initialize nHWnd
    
    Set I_oSounds = New cSounds
    Set I_oSounds.Parent = Me
    
    Set I_oFrames = New cFrames
    Set I_oFrames.Parent = Me
    I_oFrames.Initialize
    
    Set I_oEnemyTemplates = New cEnemyTemplates
    Set I_oEnemyTemplates.Parent = Me
    I_oEnemyTemplates.Initialize
    
    WaveVolume = 80
    MusicVolume = 80
    
    Set I_oMenu = New cMenu
    Set I_oMenu.Parent = Me
    I_oMenu.Initialize
    
    Detail = True
    JoystickDead = 50
    Joystick = False
    Call LoadSettings
    WaveVolume = I_nWaveVolume
    MusicVolume = I_nMusicVolume
    Exit Sub
    
E_DirectX: