Attribute VB_Name = "Sonido" Option Explicit Const MIN_VOL = 0 ' volumen mínimo Const MAX_VOL = 64 ' volumen máximo Const NO_ID = -1 ' valor erróneo para IDs de sonido Const CANALES_MUSICA = 64 ' canales para música+samples Const CANALES_EFECTOS = 16 ' canales para samples (< CANALES_MUSICA) Type Sonido id As Long ' ID del módulo/"sample" cargado PlayID As Long ' ID de reproduccuón del módulo/"sample" End Type Private bSonidoInic As Boolean ' si se han inicializado las librerias Private Modulos() As Sonido ' para guardar los IDs de módulos cargados Private bHayModulos As Boolean ' si hay módulos cargados Private Samples() As Sonido ' para guardar los IDs de los "samples" cargados Private bHaySamples As Boolean ' si hay samples Public Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long ' comprueba si hay instalada una tarjeta de sonido, devuelve True si la hay ' o False si no Private Function TarjetaSonido() As Boolean Dim i As Long i = waveOutGetNumDevs() If i > 0 Then TarjetaSonido = True Else TarjetaSonido = False End If End Function ' inicializa las librerías de sonido, devuelve True si correcto o False si error ' (se llamará al entrar en el programa) Public Function InicializaSonido() As Boolean Dim iRet As Integer If bSonidoInic Then InicializaSonido = True Exit Function End If ' si no tiene tarjeta de sonido salimos sin error pero sin inicializar ' el sistema de sonido con lo cual cualquier llamada al resto de rutinas ' de sonido será ignorada If Not TarjetaSonido Then bSonidoInic = False InicializaSonido = True Exit Function End If iRet = MIDASstartup If iRet = 0 Then bSonidoInic = False InicializaSonido = False MsgBox "MIDASstartup: error", vbOKOnly + vbCritical, "Error MIDAS" Exit Function End If iRet = MIDASsetOption(MIDAS_OPTION_MIXRATE, 22050) If iRet = 0 Then bSonidoInic = False InicializaSonido = False MsgBox "MIDASsetOption: error MIDAS_OPTION_MIXRATE", vbOKOnly + vbCritical, "Error MIDAS" MIDASclose Exit Function End If ' sonido estéreo de 16 bits iRet = MIDASsetOption(MIDAS_OPTION_OUTPUTMODE, MIDAS_MODE_16BIT_STEREO) If iRet = 0 Then ' sonido estéreo de 8 bits iRet = MIDASsetOption(MIDAS_OPTION_OUTPUTMODE, MIDAS_MODE_8BIT_STEREO) If iRet = 0 Then ' sonido mono de 16 bits iRet = MIDASsetOption(MIDAS_OPTION_OUTPUTMODE, MIDAS_MODE_16BIT_MONO) If iRet = 0 Then ' sonido mono de 8 bits MIDASsetOption MIDAS_OPTION_OUTPUTMODE, MIDAS_MODE_8BIT_MONO End If End If End If iRet = MIDASsetOption(MIDAS_OPTION_DSOUND_MODE, MIDAS_DSOUND_DISABLED) If iRet = 0 Then bSonidoInic = False InicializaSonido = False MsgBox "MIDASsetOption: error MIDAS_OPTION_DSOUND_MODE", vbOKOnly + vbCritical, "Error MIDAS" MIDASclose Exit Function End If '''MIDASsetOption MIDAS_OPTION_FORCE_NO_SOUND ' se puede usar si falla MIDASinit iRet = MIDASinit If iRet = 0 Then bSonidoInic = False InicializaSonido = False MsgBox "MIDASinit: error", vbOKOnly + vbCritical, "Error MIDAS" MIDASclose Exit Function End If iRet = MIDASstartBackgroundPlay(0) If iRet = 0 Then bSonidoInic = False InicializaSonido = False MsgBox "MIDASstartBackgroundPlay: error", vbOKOnly + vbCritical, "Error MIDAS" MIDASclose Exit Function End If iRet = MIDASopenChannels(CANALES_MUSICA) If iRet = 0 Then bSonidoInic = False InicializaSonido = False MsgBox "MIDASopenChannels: error", vbOKOnly + vbCritical, "Error MIDAS" MIDASstopBackgroundPlay MIDASclose Exit Function End If iRet = MIDASallocAutoEffectChannels(CANALES_EFECTOS) If iRet = 0 Then bSonidoInic = False InicializaSonido = False MsgBox "MIDASallocAutoEffectChannels: error", vbOKOnly + vbCritical, "Error MIDAS" MIDASstopBackgroundPlay MIDASclose Exit Function End If ReDim Modulos(0) bHayModulos = False ReDim Samples(0) bHaySamples = False bSonidoInic = True InicializaSonido = True End Function ' finaliza el sistema de sonido (se llamará al salir del programa) Public Sub FinalizaSonido() Dim i As Long, lFin As Long If Not bSonidoInic Then Exit Sub End If ' descargamos todos los módulos de sonido y los "samples" If bHaySamples Then For i = 0 To UBound(Samples) If Samples(i).PlayID <> NO_ID Then MIDASstopSample Samples(i).PlayID End If MIDASfreeSample Samples(i).id Next bHaySamples = False ReDim Samples(0) End If If bHayModulos Then For i = 0 To UBound(Modulos) If Modulos(i).PlayID <> NO_ID Then MIDASstopModule Modulos(i).PlayID End If MIDASfreeModule Modulos(i).id Next bHayModulos = False ReDim Modulos(0) End If '''MIDASfreeAutoEffectChannels '''MIDAScloseChannels MIDASstopBackgroundPlay MIDASclose bSonidoInic = False End Sub ' carga un módulo de sonido y devuelve su ID (0 si error) ' el nombre del módulo 'sMod' puede ser el nombre de un fichero o ' el identificador del recurso de sonido "#nnnnn" Public Function CargarModulo(ByVal sMod As String) As Long Dim bRes As Boolean Dim i As Long, lMod As Long, lIDRes As Long Dim s As String, sFich As String, sFichRes As String If Not bSonidoInic Then CargarModulo = 0 Exit Function End If On Error GoTo Error_CargaModulo sFichRes = sFichAventura & EXT_DLL bRes = False ' si el sonido está en un recurso If Left(sMod, 1) = "#" Then If Len(sMod) < 2 Then CargarModulo = 0 Exit Function End If s = Right(sMod, Len(sMod) - 1) lIDRes = CLng(s) sFich = CargaResSonido(sFichRes, lIDRes) If sFich = "" Then CargarModulo = 0 Exit Function End If bRes = True Else sFich = sMod End If lMod = MIDASloadModule(sFich) If lMod = 0 Then CargarModulo = 0 Exit Function End If ' si el módulo estaba en un recurso, borra el fichero temporal If bRes Then On Error Resume Next Kill sFich End If ' guardamos el ID If Not bHayModulos Then Modulos(0).id = lMod Modulos(0).PlayID = NO_ID bHayModulos = True Else i = UBound(Modulos) + 1 ReDim Preserve Modulos(i) Modulos(i).id = lMod Modulos(i).PlayID = NO_ID End If CargarModulo = lMod Exit Function Error_CargaModulo: CargarModulo = 0 End Function ' carga un "sample" WAV y devuelve su ID (0 si error) ' el nombre del sample 'sWav' puede ser el nombre de un fichero o ' el identificador del recurso de sonido "#nnnnn" Public Function CargarSample(ByVal sWav As String) As Long Dim bRes As Boolean Dim i As Long, lWav As Long, lIDRes As Long Dim s As String, sFich As String, sFichRes As String If Not bSonidoInic Then CargarSample = 0 Exit Function End If On Error GoTo Error_CargaSample sFichRes = sFichAventura & EXT_DLL bRes = False ' si el sonido está en un recurso If Left(sWav, 1) = "#" Then If Len(sWav) < 2 Then CargarSample = 0 Exit Function End If s = Right(sWav, Len(sWav) - 1) lIDRes = CLng(s) sFich = CargaResSonido(sFichRes, lIDRes) If sFich = "" Then CargarSample = 0 Exit Function End If bRes = True Else sFich = sWav End If lWav = MIDASloadWaveSample(sFich, MIDAS_LOOP_NO) If lWav = 0 Then CargarSample = 0 Exit Function End If ' si el sample estaba en un recurso, borra el fichero temporal If bRes Then On Error Resume Next Kill sFich End If ' guardamos el ID If Not bHaySamples Then Samples(0).id = lWav Samples(0).PlayID = NO_ID bHaySamples = True Else i = UBound(Samples) + 1 ReDim Preserve Samples(i) Samples(i).id = lWav Samples(i).PlayID = NO_ID End If CargarSample = lWav Exit Function Error_CargaSample: CargarSample = 0 End Function ' toca un módulo cargado, devuelve False si error Public Function TocarModulo(ByVal lIDMod As Long) As Boolean Dim i As Long, lPlayID As Long If Not bSonidoInic Then TocarModulo = False Exit Function End If i = BuscaModulo(lIDMod) If i >= 0 Then lPlayID = MIDASplayModule(lIDMod, True) If lPlayID = 0 Then TocarModulo = False Else Modulos(i).PlayID = lPlayID TocarModulo = True End If Else TocarModulo = False End If End Function ' toca un "sample" cargado, devuelve False si error ' se puede especificar la frecuencia (Hz), el volumen ' si estos valores se dejan todos a 0 se usan valores por defecto Public Function TocarSample(ByVal lIDWav As Long, ByVal lFrec As Long, _ ByVal lVol As Long) As Boolean Dim i As Long, lCanal As Long, lPlayID As Long If Not bSonidoInic Then TocarSample = False Exit Function End If If lFrec = 0 And lVol = 0 Then lFrec = 22050 lVol = MAX_VOL Else ' ajustamos valores If lFrec < 0 Then lFrec = 0 End If If lVol < MIN_VOL Then lVol = 0 ElseIf lVol > MAX_VOL Then lVol = MAX_VOL End If End If i = BuscaSample(lIDWav) If i < 0 Then TocarSample = False Exit Function End If '''lCanal = MIDASallocateChannel '''If lCanal = MIDAS_ILLEGAL_CHANNEL Then ''' TocarSample = False '''Else ''' lPlayID = MIDASplaySample(lIDWav, lCanal, 0, lFrec, lVol, MIDAS_PAN_MIDDLE) ''' If lPlayID = 0 Then ''' TocarSample = False ''' Else ''' Samples(i).PlayID = lPlayID ''' TocarSample = True ''' End If ''' MIDASfreeChannel lCanal '''End If lPlayID = MIDASplaySample(lIDWav, MIDAS_CHANNEL_AUTO, 0, lFrec, lVol, MIDAS_PAN_MIDDLE) If lPlayID = 0 Then TocarSample = False Else Samples(i).PlayID = lPlayID TocarSample = True End If End Function ' cambia el volumen general de reproducción ' (en porcentaje, 50 la mitad, 100 nada, 200 doble, ...) Public Sub VolumenGeneral(ByVal lVol As Long) If Not bSonidoInic Then Exit Sub End If MIDASsetAmplification lVol End Sub ' descarga un módulo de memoria Public Sub DescargarModulo(ByVal lIDMod As Long) Dim bEncontrado As Boolean Dim i As Long, j As Long, lPlayIDMod As Long If Not bSonidoInic Then Exit Sub End If ' eliminamos el módulo de la lista bEncontrado = False i = 0 Do While i <= UBound(Modulos) If Modulos(i).id = lIDMod Then bEncontrado = True lPlayIDMod = Modulos(i).PlayID For j = i To UBound(Modulos) If j < UBound(Modulos) Then Modulos(j) = Modulos(j + 1) End If Next j = UBound(Modulos) - 1 If j < 0 Then j = 0 bHayModulos = False End If ReDim Preserve Modulos(j) End If i = i + 1 Loop If bEncontrado Then If lPlayIDMod <> NO_ID Then MIDASstopModule lPlayIDMod End If MIDASfreeModule lIDMod End If End Sub ' descarga un "sample" de memoria Public Sub DescargarSample(ByVal lIDWav As Long) Dim bEncontrado As Boolean Dim i As Long, j As Long, lPlayIDWav As Long If Not bSonidoInic Then Exit Sub End If ' eliminamos el ID de la lista bEncontrado = False i = 0 Do While i <= UBound(Samples) If Samples(i).id = lIDWav Then bEncontrado = True lPlayIDWav = Samples(i).PlayID For j = i To UBound(Samples) If j < UBound(Samples) Then Samples(j) = Samples(j + 1) End If Next j = UBound(Samples) - 1 If j < 0 Then j = 0 bHaySamples = False End If ReDim Preserve Samples(j) End If i = i + 1 Loop If bEncontrado Then If lPlayIDWav <> NO_ID Then MIDASstopSample lPlayIDWav End If MIDASfreeSample lIDWav End If End Sub ' busca un módulo por su ID y devuelve su posición en la tabla de módulos ' devuelve -1 si no lo encontró Private Function BuscaModulo(ByVal lID As Long) As Long Dim i As Long If bHayModulos Then For i = 0 To UBound(Modulos) If Modulos(i).id = lID Then BuscaModulo = i Exit Function End If Next End If BuscaModulo = -1 End Function ' busca un "sample" por su ID y devuelve su posición en la tabla de "samples" ' devuelve -1 si no lo encontró Private Function BuscaSample(ByVal lID As Long) As Long Dim i As Long If bHaySamples Then For i = 0 To UBound(Samples) If Samples(i).id = lID Then BuscaSample = i Exit Function End If Next End If BuscaSample = -1 End Function