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