Espero que esta utilidad os resulte interesante, sobre todo porque "encapsula" la funcionalidad del control Media Player (antes conocido como ActiveMovie) que incluye el Internet Explorer a partir de la versión 5.0
El programa usa una clase: cPlayWMP que a su
vez usa un formulario en el que hay insertado un control WMP que es el encargado
de reproducir los ficheros de audio con extensión WAV y MP3, si tienes el IE4,
tendrás que sustituirlo por el control ActiveMovie, pero no reproducirá
ficheros con extensión MP3.
Si no quieres usar el control Windows Media Player, podrías usar llamadas a las
funciones del API contenidas en la librería dinámica WINMM.DLL, lo mismo en
otra ocasión creo una clase que use esa librería, ya que así te evitas el
tener el formulario ese que contiene el control... pero para que la winmm.dll
"entienda" el formato MP3, necesitarás el IE5 o superior...
Esta utilidad además de permitir que se
arrastren y suelten ficheros con extensión WAV, MP3 y accesos directos a estos
tipos, permite seleccionar y crear listas de reproducción con la extensión que
quieras, pero la "recomendable" es la estándard: M3U.
También encontrarás un método, (por la cuenta de la vieja), que te permitirá
entender ficheros de accesos directos, al menos si NO son del tipo MS-DOS...
pero algo es algo... sé que se puede hacer lo mismo (o mejor) usando el API,
pero... esto es lo que hay...
Si te fijas en el código, el control WMP en el formulario se llama ActiveMovie1, esto es porque inicialmente lo hice con ese control, incluido en el IE4, pero cuando Microsoft decidió cambiar el nombre del control, así como la funcionalidad... en fin... fue un pequeño calvario, ya que aunque hay una referencia para "compatibilidad" con el ActiveMovie, realmente no se podía cargar el formulario que contenía el susodicho control ActiveMovie, ya que daba error; además de que algunos eventos no se producen en la nueva versión, que seguramente estará mejorada, pero que a mí particularmente me "jodió" un poquito... ya que el evento que yo usaba para saber si había acabado era el Timer... pero bueno, la cosa ya está arreglada y espero que tú no tengas que esforzarte en buscar el funcionamiento de dicho control... (aunque seguramente, si lo buscas, puede que hasta mejores el que yo le he dado)
Al final tienes los links a los ficheros ZIP
Los listados, etc.
Este es el aspecto de la utilidad en funcionamiento:
Explicación de las opciones del formulario
Como puedes comprobar, además de poder reproducir, hacer pausa y detener un sólo fichero, también permite hacer esas mismas operaciones con la lista creada...
- En la parte superior se mostrará el fichero que se está tocando actualmente, pulsando en el botón se puede seleccionar el que se quiera, si la extensión es M3U, se cargará en el listbox la lista contenida en dicho fichero.
- La etiqueta de la izquierda, (la que tiene el color verde), nos indica el tiempo restante y el estado actual de reproducción.
- La barra de desplazamiento de la izquierda, (la que está debajo de la etiqueta que muestra el tiempo), permite desplazar la posición actual de reproducción.
- La etiqueta con letras amarillas nos muestra el volumen asignado al control, la barra de desplazamiento permite cambiar ese volumen, (el volumen no es el del sistema, es el del control Windows Media Player).
- El botón con la etiqueta "Hacer Fade", permite hacer un desvanecimiento y restauración del volumen.
- Los tres botones sirven para reproducir desde el principio, hacer pausa/reanudar y detener.
- La lista muestra los ficheros a reproducir, usando los tres botones de la parte inferior.
- La caja de texto de la parte inferior (Unidad), es para que al escribir una unidad de disco, con los dos puntos, se cambie automáticamente en los ficheros de la lista y el actual. Esto lo hice porque uso un disco extraíble y el nombre de la unidad cuando lo inserto en otro equipo.
- La caja de textos "Lista" es el nombre del fichero con la lista de reproducción... el botó "Guardar lista..." pregunta el nombre del fichero en el que se guardará la susodicha lista.
Como ves, no tiene mayor complicación. Además de todo esto, se permite usar Arrastrar y soltar (Drag & Drop), tanto dentro de la lista como de la lista a la caja de textos del fichero actual, además de permitir arrastrar ficheros de audio y accesos directos...
El código de la clase csPlayWMP y de los formularios:
Este es el código de la clase:
Este link te llevará a la función para "interpretar" los accesos directos (LNK)
'------------------------------------------------------------------------------
' cPlayWMP (12/Dic/99)
' Clase para "tocar" ficheros usando el Windows Media Player (quartz.dll)
'
' ©Guillermo 'guille' Som, 1999
'------------------------------------------------------------------------------
Option Explicit
Option Compare Text
Public Enum ecspEstado
ecsStopped
ecsPaused
ecsRunning
' Valores del Windows Media Player: (12/Dic/99)
mpStopped = 0 ' Playback is stopped.
mpPaused = 1 ' Playback is paused.
mpPlaying = 2 ' Stream is playing.
mpWaiting = 3 ' Waiting for stream to begin.
mpScanForward = 4 ' Stream is scanning forward.
mpScanReverse = 5 ' Stream is scanning in reverse.
mpSkipForward = 6 ' Skipping to next.
mpSkipReverse = 7 ' Skipping to previous
mpClosed = 8 ' Stream is not open.
End Enum
Private m_FileName As String
Private m_HayFichero As Boolean
Public Property Get FileName() As String
FileName = m_FileName
End Property
Public Property Let FileName(ByVal NewValue As String)
' Asignar el nombre del fichero a tocar
'
Dim i As Long
On Local Error Resume Next
Err = 0
' Comprobar si existe
' Es mejor hacer una asignación, por si el path da error (31/May/99)
i = Len(Dir$(NewValue))
If Err Then
i = 0
Err = 0
End If
If i Then
' Asignar el nombre del fichero a la variable y al control
' Tener en cuenta si es acceso directo
m_FileName = Me.Lnk2Path(NewValue)
fcsPlay.ActiveMovie1.FileName = m_FileName
m_HayFichero = True
Else
m_HayFichero = False
m_FileName = ""
fcsPlay.ActiveMovie1.FileName = ""
fcsPlay.Terminado = True
End If
If Err Then
m_HayFichero = False
m_FileName = ""
fcsPlay.ActiveMovie1.FileName = ""
fcsPlay.Terminado = True
End If
Err = 0
End Property
Private Sub Class_Initialize()
' Cargar el formulario
Load fcsPlay
End Sub
Private Sub Class_Terminate()
' Descargar el formulario
Unload fcsPlay
End Sub
Public Sub Tocar(Optional sFileName As String = "")
' Empezar a tocar el fichero
'
Dim t1 As Double, t2 As Double
On Local Error Resume Next
Err = 0
' Si se especifica un fichero como parámetro, usar ese fichero
If Len(sFileName) Then
' En la propiedad Let FileName se tiene en cuenta si es un acceso directo
Me.FileName = sFileName
End If
'
If m_HayFichero Then
With fcsPlay
t2 = TimeSerial(Hour(Now), Minute(Now), Second(Now) + 2)
' Esperar a que se cargue el fichero
Do While .FicheroCargado = False
DoEvents
' Si pasan 2 segundos y no se ha terminado de cargar...
t1 = TimeSerial(Hour(Now), Minute(Now), Second(Now))
If t1 > t2 Then
Exit Do
End If
Loop
If .FicheroCargado Then
' Empezar a tocarlo
' Antes era .ActiveMovie.Run (24/Jul/99)
' Ahora no es .Run sino .Play
.ActiveMovie1.Play
End If
End With
Else
fcsPlay.Terminado = True
End If
Err = 0
End Sub
Public Sub Parar()
' Parar de tocar el fichero
On Local Error Resume Next
Err = 0
With fcsPlay.ActiveMovie1
.Stop
' Posicionarlo al principio
.CurrentPosition = 0
End With
Err = 0
End Sub
Public Sub Pausa()
' Hacer una pausa o reanudar
On Local Error Resume Next
Err = 0
With fcsPlay
If .EstadoActual = ecsPaused Then
.ActiveMovie1.Play
ElseIf .EstadoActual = ecsRunning Then
.ActiveMovie1.Pause
End If
End With
' Si se produce aquí un error es que no se puede tocar
' o no hay fichero que se pueda tocar
If Err Then
fcsPlay.Terminado = True
End If
Err = 0
End Sub
Public Property Get TiempoTotal() As String
TiempoTotal = fcsPlay.TiempoTotal
End Property
Public Property Get TiempoRestante() As String
TiempoRestante = fcsPlay.TiempoRestante
End Property
Public Property Get Terminado() As Boolean
Terminado = fcsPlay.Terminado
End Property
Public Property Get FicheroCargado() As Boolean
FicheroCargado = fcsPlay.FicheroCargado
End Property
Public Property Get SegundosRestantes() As Long
SegundosRestantes = fcsPlay.SegundosRestantes
End Property
Public Property Get EstadoActual() As ecspEstado
' Devuelve el estado actual del fichero que se está tocando
EstadoActual = fcsPlay.EstadoActual
End Property
Public Property Get Volumen() As Long
' Devuelve el volumen actual
On Local Error Resume Next
Volumen = fcsPlay.ActiveMovie1.Volume
Err = 0
End Property
Public Property Let Volumen(ByVal NewValue As Long)
' Establece el volumen
Dim VolumenAnt As Long
On Local Error Resume Next
Err = 0
With fcsPlay.ActiveMovie1
VolumenAnt = .Volume
.Volume = NewValue
If Err Then
.Volume = VolumenAnt
End If
End With
Err = 0
End Property
Public Sub HacerFade(Optional ByVal nSegundos As Long = 3&, _
Optional ByVal lngPasos As Long = 1&, _
Optional ByVal MinVol As Long = -5000&)
' Hace fade en el volumen, llevandolo desde el actual a cero,
' también permite hacerlo de menor a mayor
' En el control ActiveMovie, el volumen va desde -10000 a 0
' Siendo -10000 silencio total y 0 el volumen máximo
'
' Hacer fade llevando el volumen hasta cero ( 1/Ago/98)
' o durantes los segundos indicados
' por defecto es 3 seg.
' el valor de lngPasos es para la cuenta hacia atrás
' por defecto es -1
'
' Ejemplo para hacer un fade para bajar el volumen:
' HacerFade 2, 1, -5000
' Ejemplo para hacer un fade para aumentar el volumen:
' HacerFade 2, 2, 0
'
Dim i As Long
Dim j As Long, k As Long
Dim horaActual As Date
Dim tmpVolActual As Long
On Local Error Resume Next
Err = 0
' Siempre será un número positivo
' ya que el nivel de volumen va desde -10000 a 0
lngPasos = Abs(lngPasos)
horaActual = Now
'
tmpVolActual = Me.Volumen
'
' El bucle se hará siempre desde el volumen actual al mínimo indicado
j = tmpVolActual
k = MinVol
If j > k Then lngPasos = -lngPasos
For i = j To k Step lngPasos
Me.Volumen = i
DoEvents
If Second(Now - horaActual) > nSegundos Then
Exit For
End If
Next
If Err Then
Me.Volumen = 0
End If
Err = 0
End Sub
Public Function Lnk2Path(ByVal sFic As String) As String
'--------------------------------------------------------------------------
' Convertir un fichero con extensión .LNK en el nombre completo (14/May/99)
'--------------------------------------------------------------------------
'
' Devuelve el path y nombre del fichero de un fichero .LNK
' La estructura de un fichero de extensión .LNK es:
' >>>Empezando por el final:<<<
' (Esto no es válido para los links de MS-DOS)
' 4 Nulos
' Path de inicio completo
' 1 Nulo
' 1 byte con la longitud del path
'
' Si el byte que precede a longitud no es un nulo:
' Nombre del fichero
' 1 Nulo
' 1 byte con la longitud del nombre
' (el nombre seguramente empezará con .\)
' Si el byte que precede a la longitud es un nulo:
' 1 Nulo (este byte comprobado)
' Nombre completo
' 1 Nulo
' Nombre del Path en formato UNC (\\Computadora\Recurso)
' 1 Nulo
'--------------------------------------------------------------------------
'
Dim nFic As Long
Dim sTmp As String
Dim i As Long
On Error Resume Next
' Leer el contenido del fichero .LNK
If InStr(sFic, ".lnk") = 0 Then
' Si no tiene la extensión LNK devolver el mismo fichero
Lnk2Path = sFic
Err = 0
Exit Function
End If
nFic = FreeFile
Open sFic For Binary As nFic
i = LOF(nFic)
' Esto puede dar error de fin de fichero
'sTmp = input$(LOF(nFic), nFic)
sTmp = Space$(i)
Get nFic, , sTmp
Close nFic
Dim j As Long
Dim c As Long
Dim s1 As String ' s1 será el path
Dim s2 As String ' s2 será el nombre del fichero
' Recorrerlo desde el final
' pero saltarse los cuatro últimos
For i = Len(sTmp) - 4 To 1 Step -1
c = Asc(Mid$(sTmp, i, 1))
' Si es un Nulo...
If c = 0 Then
If Len(s1) = 0 Then
' Es el path
j = Asc(Mid$(sTmp, i - 1, 1))
s1 = Mid$(sTmp, i + 1, j)
i = i - 1
j = 1
nFic = 0
If Asc(Mid$(sTmp, i - 1, 1)) = 0 Then
i = i - 1
j = 0
nFic = i
End If
ElseIf Len(s2) = 0 Then
' Es el nombre del fichero
If j = 0 And nFic > 0 Then
s2 = Mid$(sTmp, i + 1, nFic - i - 1)
nFic = i
Else
j = Asc(Mid$(sTmp, i - 1, 1))
s2 = Mid$(sTmp, i + 1, j)
nFic = 0
End If
Else
Exit For
End If
End If
Next
' El path devuelto será:
' El path de inicio + el nombre del fichero
'
' Añadirle la barra de directorios a s1 y quitarle la que tenga s2
If Right$(s1, 1) <> "\" Then
s1 = s1 & "\"
End If
' Tomar sólo el nombre del fichero sin el path
For i = Len(s2) To 1 Step -1
If Mid$(s2, i, 1) = "\" Then
s2 = Mid$(s2, i + 1)
Exit For
End If
Next
Lnk2Path = s1 & s2
Err = 0
End Function
Public Property Get CurrentPosition() As Double
CurrentPosition = fcsPlay.ActiveMovie1.CurrentPosition
End Property
Public Property Let CurrentPosition(ByVal NewValue As Double)
On Error Resume Next
fcsPlay.ActiveMovie1.CurrentPosition = NewValue
If Err Then
fcsPlay.ActiveMovie1.CurrentPosition = 0
End If
Err = 0
End Property
Public Property Get Duration() As Double
' Devuelve la duración total del fichero (15/Dic/99)
Duration = fcsPlay.ActiveMovie1.Duration
End Property
Este es el código del formulario con el control WMP: (fcsPlay)
'
'------------------------------------------------------------------------------
' fcsPlay (24/Jul/99)
' Formulario para tocar los ficheros usando el Windows Media Player del IE5
'
' ©Guillermo 'guille' Som, 1999
'------------------------------------------------------------------------------
Option Explicit
Private m_SegundosRestantes As Long
Private m_Terminado As Boolean
Private m_TiempoRestante As String
Private m_TiempoTotal As String
Private m_durMin As Double
Private m_durSec As Double
Private Resto As Long
Private durMinutos As Double
Private durSegundos As Double
Private m_EstadoActual As ecspEstado
Private m_FicheroCargado As Boolean
Private Sub ActiveMovie1_OpenComplete()
' Este evento ya no se produce en el control Windows Media Player
' Se recomienda usar ReadyStateChange.
' Desde ese evento llamo a este procedimiento (24/Jul/99)
On Local Error Resume Next
' Aunque Microsoft dice que este evento está obsoleto, se usa...
' además también está en ReadyStateChange
m_FicheroCargado = True
m_Terminado = False
' Aquí se puede producir un error si no se puede tocar (28/Jun/99)
Err = 0
' Asignar la duración total en minutos y segundos
Resto = ActiveMovie1.Duration
If Err Then
m_Terminado = True
Resto = 0
End If
' Los segundos restantes siempre serán los segundos por tocar
m_SegundosRestantes = Resto
m_durMin = Fix(Resto / 60)
m_durSec = Resto - m_durMin * 60
m_TiempoTotal = Format$(m_durMin, "00") & "." & Format$(m_durSec, "00")
' Estos valores son para el tiempo restante
durMinutos = 0
durSegundos = 0
m_TiempoRestante = Format$(durMinutos, "00") & "." & Format$(durSegundos, "00")
If Err Then
m_TiempoRestante = "00:00 (ERROR)"
End If
Err = 0
End Sub
Private Sub ActiveMovie1_Timer()
' Este evento ya no está disponible en el Windows Media Player control
' Se llama desde ActiveMovie1_PositionChange
On Local Error Resume Next
' En este evento se procesa la información a mostrar
With ActiveMovie1
Resto = .Duration - .CurrentPosition
If Err Then
Resto = 0
End If
' Los segundos restantes siempre serán los segundos por tocar
m_SegundosRestantes = Resto
durMinutos = Fix(Resto / 60)
durSegundos = Resto - durMinutos * 60
m_TiempoRestante = Format$(durMinutos, "00") & "." & Format$(durSegundos, "00")
End With
Err = 0
End Sub
Private Sub ActiveMovie1_PlayStateChange(ByVal OldState As Long, ByVal NewState As Long)
' ' Este evento no se produce en el Windows Media Player (24/Jul/99)
' ' En su lugar usar PlayStateChange
'
'
' Posibles valores de los parámetros xxxState
' mpStopped 0 Playback is stopped.
' mpPaused 1 Playback is paused.
' mpPlaying 2 Stream is playing.
' mpWaiting 3 Waiting for stream to begin.
' mpScanForward 4 Stream is scanning forward.
' mpScanReverse 5 Stream is scanning in reverse.
' mpSkipForward 6 Skipping to next.
' mpSkipReverse 7 Skipping to previous
' mpClosed 8 Stream is not open.
'
' newState = 0-Stop, 1-Pausa, 2-Play
' Valores del ActiveMovie
' amvStopped 0 The player is stopped.
' amvPaused 1 The player is paused.
' amvRunning 2 The player is playing the multimedia file.
'
m_EstadoActual = NewState
' Nueva comprobación (12/Dic/99)
Select Case m_EstadoActual
Case mpPaused, mpPlaying
m_Terminado = False
Case Else
m_Terminado = True
End Select
End Sub
Private Sub ActiveMovie1_ReadyStateChange(ReadyState As MediaPlayerCtl.ReadyStateConstants)
' Los valores posibles de ReadyState son:
' amvUninitialized 1 The FileName property has not been initialized.
' amvLoading 0 The ActiveMovie Control is asynchronously loading a file.
' amvInteractive 3 The control loaded a file,
' and downloaded enough data to play the file,
' but has not yet received all data.
' amvComplete 4 All data has been downloaded.
'
' Los nombres y valores de la enumeración no han cambiado (24/Jul/99)
Select Case ReadyState
Case amvInteractive
m_FicheroCargado = True
Case amvComplete
ActiveMovie1_OpenComplete
Case Else
m_FicheroCargado = False
End Select
End Sub
Private Sub Form_Initialize()
' Por si se cierra el formulario y se accede a alguna propiedad (28/Jun/99)
m_Terminado = True
End Sub
Private Sub Form_Terminate()
m_Terminado = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
' Dejar de tocar el fichero
On Local Error Resume Next
ActiveMovie1.Stop
m_Terminado = True
Err = 0
Set fcsPlay = Nothing
End Sub
Friend Property Get FicheroCargado() As Boolean
' Propiedad de sólo lectura
' El valor se asignará al cargarse completamente el fichero
FicheroCargado = m_FicheroCargado
End Property
Friend Property Get EstadoActual() As ecspEstado
' Devuelve el estado actual del fichero que se está tocando
EstadoActual = m_EstadoActual
End Property
Friend Property Get TiempoTotal() As String
On Local Error Resume Next
' Asignar la duración total en minutos y segundos
Resto = ActiveMovie1.Duration
m_durMin = Fix(Resto / 60)
m_durSec = Resto - m_durMin * 60
m_TiempoTotal = Format$(m_durMin, "00") & "." & Format$(m_durSec, "00")
TiempoTotal = m_TiempoTotal
Err = 0
End Property
Friend Property Get TiempoRestante() As String
' Ahora hay que "forzar" a crear la información:
ActiveMovie1_Timer
TiempoRestante = m_TiempoRestante
End Property
Friend Property Let Terminado(ByVal NewValue As Boolean)
m_Terminado = NewValue
End Property
Friend Property Get Terminado() As Boolean
Terminado = m_Terminado
End Property
Friend Property Get SegundosRestantes() As Long
' Devuelve los segundos que quedan por tocar
On Local Error Resume Next
Err = 0
' En este evento se procesa la información a mostrar
With ActiveMovie1
' Sólo si está tocando
If .PlayState = mpPlaying Then
m_SegundosRestantes = .Duration - .CurrentPosition
If Err Then
m_SegundosRestantes = 0
End If
End If
End With
Err = 0
SegundosRestantes = m_SegundosRestantes
End Property
Este es el código del programa:
'
'------------------------------------------------------------------------------
' Prueba de csPlayWMP (12/Dic/99)
'
' ©Guillermo 'guille' Som, 1999
'------------------------------------------------------------------------------
Option Explicit
Option Compare Text
Private CambiandoPos As Boolean
Private dPos As Double
Private sLista As String
Private sEstadoActual() As String
Private sUnidad As String
Private m_Tocando As Boolean
Private m_TocandoLista As Boolean
Private m_queFichero As Long
' Clase para manejar el fichero a tocar
Private m_csPlay As cPlayWMP
Private m_CD As cComDlg
Private Sub cmdExaminar_Click(Index As Integer)
On Local Error Resume Next
With m_CD
.hWnd = Me.hWnd
.FileName = Text1
.Filter = "Tipos admitidos (*.wav; *.mp3; *.m3u)|*.wav;*.mp3;*.m3u|Ficheros Wav (*.wav)|*.wav|Ficheros MP3 (*.mp3)|*.mp3|Lista de ficheros (*.m3u)|*.m3u"
.CancelError = True
.ShowOpen
If Err = 0 Then
Text1 = .FileName
If InStr(.FileName, ".m3u") = 0 Then
m_csPlay.FileName = .FileName
Else
sLista = .FileName
' abrir la lista
AbrirLista
End If
End If
End With
Err = 0
End Sub
Private Sub cmdFade_Click()
Static Invertir As Boolean
If Invertir Then
cmdFade.Caption = "&Fade"
DoEvents
m_csPlay.HacerFade 4, 1, 0
Else
cmdFade.Caption = "&Restaurar"
DoEvents
m_csPlay.HacerFade 3, 1, -5000
End If
HScrollVol.Value = m_csPlay.Volumen
Invertir = Not Invertir
End Sub
Private Sub cmdFic_Click(Index As Integer)
' Comandos para tocar la lista
Select Case Index
Case 0 ' Tocar
m_TocandoLista = True
TocarLista
Case 1 ' Pausa
If m_csPlay.EstadoActual = ecsPaused Then
m_csPlay.Tocar
Else
m_csPlay.Pausa
End If
Case 2 ' Parar
m_TocandoLista = False
End Select
End Sub
Private Sub cmdFic1_Click(Index As Integer)
' Tocar el fichero
On Error Resume Next
Select Case Index
Case 0
m_csPlay.Tocar Text1
' El valor de cada paso del HScrollPos
dPos = m_csPlay.Duration / HScrollPos.Max
HScrollPos.Value = 0
HScrollVol.Value = m_csPlay.Volumen
m_Tocando = True
Case 1
' Pausa
If m_csPlay.EstadoActual = ecsPaused Then
m_csPlay.Tocar
Else
m_csPlay.Pausa
End If
Case 2
' Parar
m_csPlay.Parar
m_Tocando = False
End Select
'
Err = 0
End Sub
Private Sub cmdGuardar_Click()
' Guardar el contenido de la lista (22/Ago/99)
Dim sFic As String
Dim nFic As Long
Dim i As Long
On Error Resume Next
With m_CD
.hWnd = Me.hWnd
.DialogTitle = "Guardar lista"
.FileName = txtLista
.Filter = "Lista MP3 y TXT (*.m3u; *.txt)|*.m3u;*.txt|Lista MP3 (*.m3u)|*.m3u|Ficheros de texto (*.txt)|*.txt"
.CancelError = True
.ShowSave
If Err Then
Err = 0
Exit Sub
Else
sLista = .FileName
txtLista = sLista
End If
End With
On Local Error GoTo ErrGuardar
If lstLista.ListCount Then
sFic = sLista
nFic = FreeFile
Open sFic For Output As nFic
For i = 0 To lstLista.ListCount - 1
Print #nFic, lstLista.List(i)
Next
Close nFic
End If
Exit Sub
ErrGuardar:
Close
MsgBox "Se ha producido el error:" & vbCrLf & _
Err.Number & " " & Err.Description
Err = 0
End Sub
Private Sub Form_Load()
Const cSonidos As String = "C:\Sonidos\"
Dim sFic As String
Dim sTmp As String
Dim nFic As Long
Const cMsg As String = "Prueba de csPlayWMP"
Dim i As Long
HScrollPos.Max = 100
HScrollVol.min = -10000&
HScrollVol.Max = 0&
' Para mostrar el estado actual (12/Dic/99)
' ecspEstado.mpStopped =0, ecspEstado.mpClosed = 8
ReDim sEstadoActual(ecspEstado.mpStopped To ecspEstado.mpClosed)
sEstadoActual(ecspEstado.mpClosed) = "Closed"
sEstadoActual(ecspEstado.mpPaused) = "Paused"
sEstadoActual(ecspEstado.mpPlaying) = "Playing"
sEstadoActual(ecspEstado.mpScanForward) = "ScanForward"
sEstadoActual(ecspEstado.mpScanReverse) = "ScanReverse"
sEstadoActual(ecspEstado.mpSkipForward) = "SkipForward"
sEstadoActual(ecspEstado.mpSkipReverse) = "SkipReverse"
sEstadoActual(ecspEstado.mpStopped) = "Stopped"
sEstadoActual(ecspEstado.mpWaiting) = "Waiting"
'-------------------------------------------------------------- (22/Ago/99)
' Comprobar si los ficheros de prueba están en la unidad indicada
txtUnidad = "E:"
ComprobarUnidad
Text1 = sUnidad & "\Sonidos\Jennifer Lopez-If you had my love mini.wav"
Timer1.Enabled = False
lblTiempo = ""
lblVolumen = " vol: "
' Crear los objetos
Set m_CD = New cComDlg
Set m_csPlay = New cPlayWMP
' Asignar el volumen a 0 (normal), ya que en el IE5 se asigna a -600
m_csPlay.Volumen = 0
' Llenar la lista de ficheros
' (también se admiten ficheros de texto con los ficheros a tocar)
sFic = AppPath & "\Lista.m3u"
sLista = sFic
txtLista = sFic
If Len(Dir$(sFic)) Then
AbrirLista
Else
With lstLista
.Clear
sFic = Dir$(cSonidos & "*.wav")
Do While Len(sFic)
.AddItem cSonidos & sFic
sFic = Dir$
Loop
End With
End If
Timer1.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set m_csPlay = Nothing
Set m_CD = Nothing
Set ftPlayAM = Nothing
End Sub
Private Sub HScrollPos_Change()
On Error Resume Next
If CambiandoPos = False Then
CambiandoPos = True
m_csPlay.CurrentPosition = HScrollPos.Value * dPos
CambiandoPos = False
End If
Err = 0
End Sub
Private Sub HScrollVol_Change()
m_csPlay.Volumen = HScrollVol.Value
End Sub
Private Sub lstLista_DragDrop(Source As Control, X As Single, Y As Single)
ListRowMove Source, DragIndex, ListRowCalc(Source, Y)
End Sub
Private Sub lstLista_KeyDown(KeyCode As Integer, Shift As Integer)
Dim i As Long
If KeyCode = vbKeyDelete Then
With lstLista
For i = .ListCount - 1 To 0 Step -1
If .Selected(i) Then
.RemoveItem i
End If
Next
End With
End If
End Sub
Private Sub lstLista_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
DragIndex = ListRowCalc(lstLista, Y)
lstLista.Drag
End Sub
Private Sub lstLista_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
' Añadir los ficheros soltados
Dim i As Long
Dim j As Long
' Posicionarlos antes del que está seleccionado (22/Ago/99)
j = lstLista.ListIndex
If j < 0 Then j = 0
With Data
For i = 1 To .Files.Count
lstLista.AddItem .Files(i), j
Next
End With
End Sub
Private Sub Text1_DragDrop(Source As Control, X As Single, Y As Single)
If TypeName(Source) = "ListBox" Then
Text1 = Source.List(Source.ListIndex)
End If
End Sub
Private Sub Text1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Text1 = Data.Files(1)
End Sub
Private Sub Timer1_Timer()
On Local Error Resume Next
With m_csPlay
' Si se está tocando el fichero...
If m_Tocando Then
' mostrar el tiempo restante
lblTiempo = .TiempoRestante & " (" & sEstadoActual(.EstadoActual) & ")"
' Mostrar el valor de la barra de desplazamiento,
' (si no se está cambiando en este momento)
If CambiandoPos = False Then
CambiandoPos = True
HScrollPos.Value = .CurrentPosition / dPos
CambiandoPos = False
End If
' Si se ha terminado
If .Terminado Then
m_Tocando = False
End If
Else
' Si no se está tocando, mostrar el tiempo total,
' si hay un fichero cargado
If .FicheroCargado Then
lblTiempo = .TiempoTotal & " (" & sEstadoActual(.EstadoActual) & ")"
Else
lblTiempo = "---"
End If
End If
' El 0 es el valor máximo del volumen
If .Volumen = 0 Then
lblVolumen = " vol: " & .Volumen & " (max)"
Else
lblVolumen = " vol: " & .Volumen
End If
End With
Err = 0
End Sub
Private Sub TocarLista()
' Tocar los ficheros de la lista
Dim i As Long, j As Long
Dim sFic As String
j = lstLista.ListCount - 1
i = 0
Label1(0).BackColor = vbRed
Do While i <= j
If Not lstLista.Selected(i) Then
sFic = lstLista.List(i)
lstLista.Selected(i) = True
' Comprobar si es un link y hay que modificar la unidad (14/Dic/99)
If InStr(sFic, ".lnk") Then
sFic = m_csPlay.Lnk2Path(sFic)
If Left$(sFic, 2) <> sUnidad Then
sFic = sUnidad & Mid$(sFic, 3)
End If
End If
m_csPlay.FileName = sFic
' Sólo si es un fichero "aceptable"
If m_csPlay.TiempoTotal > 0 Then
m_Tocando = True
'
m_csPlay.Tocar sFic
Text1 = sFic
' El valor de cada paso del HScrollPos
dPos = m_csPlay.Duration / HScrollPos.Max
HScrollPos.Value = 0
HScrollVol.Value = m_csPlay.Volumen
'
' Esperar a que termine de tocar
With m_csPlay
Do While .Terminado = False
If m_TocandoLista = False Then
.Parar
' Obligar a salir del bucle de tocar las canciones
i = j
Exit Do
End If
DoEvents
Loop
End With
End If
End If
i = i + 1
Loop
Label1(0).BackColor = vbButtonFace
End Sub
Private Sub ComprobarUnidad()
' Comprueba si la unidad indicada está disponible (22/Ago/99)
' (se buscará el directorio \Sonidos y algún fichero WAV)
Dim sFic As String
Dim i As Long
Dim j As Long
Static YaEstoy As Boolean
' No permitir la reentrada
If YaEstoy Then Exit Sub
YaEstoy = True
On Local Error Resume Next
sUnidad = Trim$(txtUnidad)
sFic = sUnidad & "\Sonidos\*.wav"
i = Len(Dir$(sFic))
If Err <> 0 Or i = 0 Then
' No está disponible, buscar otra unidad
For j = Asc("C") To Asc("Z")
Err = 0
sUnidad = Chr$(j) & ":"
sFic = sUnidad & "\Sonidos\*.wav"
i = Len(Dir$(sFic))
' Si no se produce error es que hemos encontrado algo
If Err = 0 And i <> 0 Then
txtUnidad = sUnidad
YaEstoy = False
Exit Sub
End If
Next
' Si se llega aquí es que no hemos hallado nada...
txtUnidad = Left$(CurDir$, 2)
' Asignar también sUnidad, (12/Dic/99)
' sino se quedaría la última comprobada
sUnidad = txtUnidad
End If
Err = 0
YaEstoy = False
End Sub
Private Sub txtUnidad_KeyPress(KeyAscii As Integer)
' Si se pulsa INTRO, comprobar la unidad escrita (22/Ago/99)
If KeyAscii = 13 Then
KeyAscii = 0
ComprobarUnidad
AsignarFicheros
End If
End Sub
Private Sub AsignarFicheros()
' Asignar la nueva unidad a los ficheros (22/Ago/99)
Dim j As Long
Dim sFic As String
sFic = Text1
If Left$(sFic, 2) <> sUnidad Then
Text1 = sUnidad & Mid$(sFic, 3)
End If
With lstLista
For j = 0 To .ListCount - 1
sFic = .List(j)
If Left$(sFic, 2) <> sUnidad Then
.List(j) = sUnidad & Mid$(sFic, 3)
End If
Next
End With
End Sub
Private Sub AbrirLista()
Dim nFic As Long
Dim sFic As String
Dim i As Long
Dim sTmp As String
sFic = sLista
nFic = FreeFile
If Len(Dir$(sFic)) Then
lstLista.Clear
On Local Error Resume Next
Open sFic For Input As nFic
Do While Not EOF(nFic)
Line Input #nFic, sTmp
Err = 0
' Si no existe ese fichero,
i = Len(Dir$(sTmp))
If Err <> 0 Or i = 0 Then
' quitar el nombre de la unidad y asignar la hallada
i = InStr(sTmp, ":")
If i Then
sTmp = Mid$(sTmp, i + 1)
End If
sTmp = sUnidad & sTmp
End If
lstLista.AddItem sTmp
Loop
Close nFic
Err = 0
End If
End Sub
Private Function AppPath() As String
' Quita la barra de directorios, (20/Dic/99)
' y lo devuelve con la primera en mayúsculas y el resto en minúsculas
Dim sTmp As String
sTmp = App.Path
If Right$(sTmp, 1) = "\" Then
sTmp = Left$(sTmp, Len(sTmp) - 1)
End If
AppPath = StrConv(sTmp, vbProperCase)
End Function
Los links al código en formato ZIP (y un par de ficheros en formato MP3)
El código de gsPlayWMP
y las clases usadas (gsPlayWMP.zip 21.6 KB)
Nota del 18/Abr/2001: Se incluye una versión revisada de la clase de
diálogos comunes.
Los ficheros de muestra:
Jennifer.zip (257 KB, Jennifer Lopez-If you had my
love mini.mp3)
Lou.zip (286 KB, Lou Bega-Mambo Nº 5 mini.mp3)
Estos ficheros no son canciones completas, sino
simples muestras de menos de 30 segundos...
Lo siento por los fans de alguno de ellos...
