sound.bas

超级C&C有没有搞错,VB还能编出这种即时策略游戏来!没错,这就是我们的超级C&C!虽然游戏经常无故退出,但是原码仍有很多可圈可点的地方.祝你早日编出中国的超级RA,超级KKND,超级星际,超级家园

Attribute VB_Name = "Sound"
Public Const LOOPSOUNDINDEX = 8
Global Const SoundEvent_Fire = 1
Global Const SoundEvent_Explode = 2
Global Const SoundEvent_Spawn = 3
Global Const SoundEvent_BuildObject = 3

Type SoundObj
  EventSounds(10) As Integer
End Type

Global Const NOSOUND = -1
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal source As Long, ByVal length As Long)
Private Declare Function lstrcpy Lib "Kernel32" (ByVal lpszDestinationString1 As Any, ByVal lpszSourceString2 As Any) As Long

Public Const MaxSndFiles = 100
Public SoundOn As Boolean
Const NOSOUNDFILE = ""
Private Type sndfiles
  Filename As String
  SoundName As String
End Type
Private Type Snd
  SoundFiles(MaxSndFiles) As sndfiles
  MaxSoundFiles As Integer
  CurrentFile  As String
  DeviceOn As Boolean
End Type
Public SoundData As Snd
Dim DS As DirectSound
Public Const MaxSoundsPlaying = 7
Public CurrentSoundChannel As Integer
Dim SoundsPlaying(1 To MaxSoundsPlaying + 1) As DirectSoundBuffer
Public Sub LoadSoundData()
Call FileFunctions.OpenGameFile(File_SoundDefinitions, 1)
Do
  Line Input #1, a$
  If a$ = FILETAG_ENDFILE Then Exit Do
  If a$ = "[SOUNDDEF]" Then
    soundfilenum = soundfilenum + 1
    Line Input #1, a$
    propvalue$ = MiscFunctions.GetPropertyValue(a$)
    SoundData.SoundFiles(soundfilenum).SoundName = propvalue$
    Line Input #1, a$
    propvalue$ = MiscFunctions.GetPropertyValue(a$)
    SoundData.SoundFiles(soundfilenum).Filename = Directory_GameData & Directory_Sound & propvalue$
  End If
Loop
Close #1
SoundData.MaxSoundFiles = soundfilenum
End Sub
Sub InitializeSound()
DirectSoundCreate ByVal 0&, DS, Nothing
DS.SetCooperativeLevel ViewForm.hwnd, DSSCL_NORMAL
End Sub
Public Sub UnInitializeSound()
For I = 1 To MaxSoundsPlaying
  Set SoundsPlaying(I) = Nothing
Next I
Set SoundsPlaying(LOOPSOUNDINDEX) = Nothing
Set DS = Nothing
End Sub

'
' Loads a Wave file into a direct sound buffer
'
Public Sub LoadWAVIntoDSB(Lds As DirectSound, ByVal fName As String, Ldsb As DirectSoundBuffer)
    
    Dim hWave As Long
    Dim pcmwave As WAVEFORMATEX
    Dim lngSize As Long
    Dim lngPosition As Long
    Dim ptr1 As Long, ptr2 As Long, lng1 As Long, lng2 As Long
    Dim aByte() As Byte
    
    ReDim aByte(1 To FileLen(fName))
    hWave = FreeFile
    Open fName For Binary As hWave
    Get hWave, , aByte
    Close hWave
    lngPosition = 1
    While Chr$(aByte(lngPosition)) + Chr$(aByte(lngPosition + 1)) + Chr$(aByte(lngPosition + 2)) <> "fmt"
        lngPosition = lngPosition + 1
    Wend
    CopyMemory VarPtr(pcmwave), VarPtr(aByte(lngPosition + 8)), Len(pcmwave)
    While Chr$(aByte(lngPosition)) + Chr$(aByte(lngPosition + 1)) + Chr$(aByte(lngPosition + 2)) + Chr$(aByte(lngPosition + 3)) <> "data"
        lngPosition = lngPosition + 1
    Wend
    CopyMemory VarPtr(lngSize), VarPtr(aByte(lngPosition + 4)), Len(lngSize)
    Dim dsbd As DSBUFFERDESC
    With dsbd
        .dwSize = Len(dsbd)
        .dwFlags = DSBCAPS_CTRLDEFAULT
        .dwBufferBytes = lngSize
        .lpwfxFormat = VarPtr(pcmwave)
    End With
    Lds.CreateSoundBuffer dsbd, Ldsb, Nothing
    Ldsb.Lock 0&, lngSize, ptr1, lng1, ptr2, lng2, 0&
    CopyMemory ptr1, VarPtr(aByte(lngPosition + 4 + 4)), lng1
    If lng2 <> 0 Then
        CopyMemory ptr2, VarPtr(aByte(lngPosition + 4 + 4 + lng1)), lng2
    End If
    
End Sub
Function GetSoundIndex(SoundName)
For I = 1 To MaxSndFiles
  If SoundData.SoundFiles(I).SoundName = SoundName Then
    GetSoundIndex = I
    Exit For
  End If
Next I
End Function
'
' Plays a sound
'
Public Sub Play_Sound(SChannel As Integer, Pan, Volume)
  If SoundData.DeviceOn = True Then
    On Error Resume Next
    Dim lngFlag As Long, tempVol As Long
    tempVol = Volume
    CurrentSoundChannel = CurrentSoundChannel + 1
    If CurrentSoundChannel > MaxSoundsPlaying Then CurrentSoundChannel = 1
    SoundsPlaying(CurrentSoundChannel).Stop
    Set SoundsPlaying(CurrentSoundChannel) = Nothing
    Sound.LoadWAVIntoDSB DS, SoundData.SoundFiles(SChannel).Filename, SoundsPlaying(CurrentSoundChannel)
    SoundsPlaying(CurrentSoundChannel).SetPan Pan
    SoundsPlaying(CurrentSoundChannel).Play 0, 0, 0
  End If
End Sub
Public Sub Play_LoopSound(SChannel As Integer, Volume)
    Dim tempVol As Long
    tempVol = Volume
    Set SoundsPlaying(LOOPSOUNDINDEX) = Nothing
    Sound.LoadWAVIntoDSB DS, SoundData.SoundFiles(SChannel).Filename, SoundsPlaying(LOOPSOUNDINDEX)
    SoundsPlaying(LOOPSOUNDINDEX).Play 0, 0, DSBPLAY_LOOPING
End Sub

'
' Stops a sound
'
Public Sub Stop_Sounds()
    On Error Resume Next
    Dim lngFlag As Long
    For I = 1 To MaxSoundsPlaying
      SoundsPlaying(I).Stop
    Next I
    SoundsPlaying(LOOPSOUNDINDEX).Stop
End Sub