gsPlayWMP

Una utilidad para reproducir listas de ficheros de audio (WAV y MP3),
usando el Windows Media Player del IE5

 

Publicado: 24/Dic/1999
Actualizado: 18/Abr/2001


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:

gsPlayWMP 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...

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...

 


ir al índice