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