Clase para manipular el volumen de la tarjeta de sonido

 

Actualizado el 09/Jul/99


Con este c�digo podr�s manejar el volumen del sistema... el de la tarjeta de sonido, que con esto del volumen, puede parecer que es el volumen de una unidad de disco...

Este c�digo est� basado en un ejemplo de la Knowledge Base de Microsoft, en ese ejemplo tambi�n se manipula el volumen de entrada, el del micr�fono, pero en esta clase s�lo se maneja el volumen de salida... adem�s, le he a�adido una funci�n para hacer fade... es decir, desvanecer el sonido, adem�s de algunas otras cosillas... pocas, esa es la verdad, pero creo que es interesante, adem�s de que de vez en cuando se hacen consultas sobre este tema... por tanto, espero que te pueda ser de utilidad.

Aqu� tienes el c�digo de la clase y un ejemplo de c�mo usarla.
Los listados puedes bajarlo pulsando en este link (volumen.zip 6.55 KB)

'
'------------------------------------------------------------------------------
' cVolumen                                                          (09/Jul/99)
' Clase para manejar el volumen del sistema
'
' Las propiedades, m�todos y eventos son:
'   Fade            Para hacer fade (desvanecer el volumen)
'   MaxVol          Valor m�ximo para el volumen (s�lo lectura)
'   MinVol          Valor m�nimo para el volumen (s�lo lectura)
'   Volumen         Para asignar u obtener el valor del volumen
'   CambioVolumen   Evento producido cada vez que se cambia el volumen
'
' �Guillermo 'guille' Som, 1999
'------------------------------------------------------------------------------
' El c�digo est� basado en un ejemplo de la Knowledge Base de Microsoft:
'   FILE: VOLUME.EXE: Set Volume Control Levels Using Visual Basic
'   Article ID: Q178456
'------------------------------------------------------------------------------
Option Explicit

' Evento para notificar el cambio del volumen
Public Event CambioVolumen(ByVal VolumenActual As Long)


'------------------------------------------------------------------------------
' Variables, constantes, tipos y declaraciones para el control del volumen
'
Private VolActual As Long       ' Volumen actual
Private hMixer As Long          ' mixer handle
Private volCtrl As MIXERCONTROL ' waveout volume control
Private rc As Long              ' return code
Private ok As Boolean           ' boolean return code

Private Const MIXER_SETCONTROLDETAILSF_VALUE = &H0&

Private Const MMSYSERR_NOERROR = 0
Private Const MAXPNAMELEN = 32
Private Const MIXER_LONG_NAME_CHARS = 64
Private Const MIXER_SHORT_NAME_CHARS = 16
Private Const MIXER_GETLINEINFOF_COMPONENTTYPE = &H3&
Private Const MIXER_GETCONTROLDETAILSF_VALUE = &H0&
Private Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2&
Private Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0&
Private Const MIXERLINE_COMPONENTTYPE_SRC_FIRST = &H1000&

Private Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = _
               (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4)
               
Private Const MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE = _
               (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 3)

Private Const MIXERLINE_COMPONENTTYPE_SRC_LINE = _
               (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 2)

Private Const MIXERCONTROL_CT_CLASS_FADER = &H50000000
Private Const MIXERCONTROL_CT_UNITS_UNSIGNED = &H30000

Private Const MIXERCONTROL_CONTROLTYPE_FADER = _
               (MIXERCONTROL_CT_CLASS_FADER Or _
               MIXERCONTROL_CT_UNITS_UNSIGNED)

Private Const MIXERCONTROL_CONTROLTYPE_VOLUME = _
               (MIXERCONTROL_CONTROLTYPE_FADER + 1)

Private Declare Function mixerClose Lib "winmm.dll" _
               (ByVal hmx As Long) As Long
   
Private Declare Function mixerGetControlDetails Lib "winmm.dll" _
               Alias "mixerGetControlDetailsA" _
               (ByVal hmxobj As Long, _
               pmxcd As MIXERCONTROLDETAILS, _
               ByVal fdwDetails As Long) As Long
   
Private Declare Function mixerGetDevCaps Lib "winmm.dll" _
               Alias "mixerGetDevCapsA" _
               (ByVal uMxId As Long, _
               ByVal pmxcaps As MIXERCAPS, _
               ByVal cbmxcaps As Long) As Long
   
Private Declare Function mixerGetID Lib "winmm.dll" _
               (ByVal hmxobj As Long, _
               pumxID As Long, _
               ByVal fdwId As Long) As Long
               
Private Declare Function mixerGetLineControls Lib "winmm.dll" _
               Alias "mixerGetLineControlsA" _
               (ByVal hmxobj As Long, _
               pmxlc As MIXERLINECONTROLS, _
               ByVal fdwControls As Long) As Long
               
Private Declare Function mixerGetLineInfo Lib "winmm.dll" _
               Alias "mixerGetLineInfoA" _
               (ByVal hmxobj As Long, _
               pmxl As MIXERLINE, _
               ByVal fdwInfo As Long) As Long
               
Private Declare Function mixerGetNumDevs Lib "winmm.dll" () As Long

Private Declare Function mixerMessage Lib "winmm.dll" _
               (ByVal hmx As Long, _
               ByVal uMsg As Long, _
               ByVal dwParam1 As Long, _
               ByVal dwParam2 As Long) As Long
               
Private Declare Function mixerOpen Lib "winmm.dll" _
               (phmx As Long, _
               ByVal uMxId As Long, _
               ByVal dwCallback As Long, _
               ByVal dwInstance As Long, _
               ByVal fdwOpen As Long) As Long
               
Private Declare Function mixerSetControlDetails Lib "winmm.dll" _
               (ByVal hmxobj As Long, _
               pmxcd As MIXERCONTROLDETAILS, _
               ByVal fdwDetails As Long) As Long
               
Private Declare Sub CopyStructFromPtr Lib "kernel32" _
               Alias "RtlMoveMemory" _
               (struct As Any, _
               ByVal ptr As Long, ByVal cb As Long)
               
Private Declare Sub CopyPtrFromStruct Lib "kernel32" _
               Alias "RtlMoveMemory" _
               (ByVal ptr As Long, _
               struct As Any, _
               ByVal cb As Long)
               
Private Declare Function GlobalAlloc Lib "kernel32" _
               (ByVal wFlags As Long, _
               ByVal dwBytes As Long) As Long
               
Private Declare Function GlobalLock Lib "kernel32" _
               (ByVal hMem As Long) As Long
               
Private Declare Function GlobalFree Lib "kernel32" _
               (ByVal hMem As Long) As Long

Private Type MIXERCAPS
    wMid As Integer                   '  manufacturer id
    wPid As Integer                   '  product id
    vDriverVersion As Long            '  version of the driver
    szPname As String * MAXPNAMELEN   '  product name
    fdwSupport As Long                '  misc. support bits
    cDestinations As Long             '  count of destinations
End Type

Private Type MIXERCONTROL
    cbStruct As Long           '  size in Byte of MIXERCONTROL
    dwControlID As Long        '  unique control id for mixer device
    dwControlType As Long      '  MIXERCONTROL_CONTROLTYPE_xxx
    fdwControl As Long         '  MIXERCONTROL_CONTROLF_xxx
    cMultipleItems As Long     '  if MIXERCONTROL_CONTROLF_MULTIPLE set
    szShortName As String * MIXER_SHORT_NAME_CHARS  ' short name of control
    szName As String * MIXER_LONG_NAME_CHARS        ' long name of control
    lMinimum As Long           '  Minimum value
    lMaximum As Long           '  Maximum value
    reserved(10) As Long       '  reserved structure space
End Type

Private Type MIXERCONTROLDETAILS
    cbStruct As Long       '  size in Byte of MIXERCONTROLDETAILS
    dwControlID As Long    '  control id to get/set details on
    cChannels As Long      '  number of channels in paDetails array
    item As Long           '  hwndOwner or cMultipleItems
    cbDetails As Long      '  size of _one_ details_XX struct
    paDetails As Long      '  pointer to array of details_XX structs
End Type

Private Type MIXERCONTROLDETAILS_UNSIGNED
    dwValue As Long        '  value of the control
End Type

Private Type MIXERLINE
    cbStruct As Long               '  size of MIXERLINE structure
    dwDestination As Long          '  zero based destination index
    dwSource As Long               '  zero based source index (if source)
    dwLineID As Long               '  unique line id for mixer device
    fdwLine As Long                '  state/information about line
    dwUser As Long                 '  driver specific information
    dwComponentType As Long        '  component type line connects to
    cChannels As Long              '  number of channels line supports
    cConnections As Long           '  number of connections (possible)
    cControls As Long              '  number of controls at this line
    szShortName As String * MIXER_SHORT_NAME_CHARS
    szName As String * MIXER_LONG_NAME_CHARS
    dwType As Long
    dwDeviceID As Long
    wMid  As Integer
    wPid As Integer
    vDriverVersion As Long
    szPname As String * MAXPNAMELEN
End Type

Private Type MIXERLINECONTROLS
    cbStruct As Long       '  size in Byte of MIXERLINECONTROLS
    dwLineID As Long       '  line id (from MIXERLINE.dwLineID)
                           '  MIXER_GETLINECONTROLSF_ONEBYID or
    dwControl As Long      '  MIXER_GETLINECONTROLSF_ONEBYTYPE
    cControls As Long      '  count of controls pmxctrl points to
    cbmxctrl As Long       '  size in Byte of _one_ MIXERCONTROL
    pamxctrl As Long       '  pointer to first MIXERCONTROL array
End Type

Private Sub Class_Initialize()
    ' Abrir el �mezclador?
    Call AbrirMixer
End Sub

Private Sub Class_Terminate()
    On Local Error Resume Next
    
    ' Cerrar el mixer
    Call mixerClose(hMixer)
    
    Err = 0
End Sub

Public Sub Fade(Optional ByVal Segundos As Long = 3&, _
                    Optional ByVal Pasos As Long = 8&, _
                    Optional ByVal Restaurar As Boolean = True, _
                    Optional ByVal Inverso As Boolean = True, _
                    Optional ByVal VolMin As Long = 1000&)
    '--------------------------------------------------------------------------
    ' Hacer fade llevando el volumen hasta cero         ( 1/Ago/98)
    '
    ' Par�metros:
    '   Segundos    Tiempo m�ximo de la duraci�n del fade, (de 0 a Segundos)
    '   Pasos       el valor de Pasos es para la cuenta hacia atr�s
    '   Restaurar   Para dejar el volumen que hab�a antes de hacer Fade
    '   Inverso     Para hacer fade de mayor a menor
    '   VolMin      Ser� el volumen m�nimo al que se llegar� haciendo el Fade
    '--------------------------------------------------------------------------
    Dim i As Long
    Dim horaActual As Date
    Static tmpVolActual As Long
    Dim j As Long, k As Long
    
    ' Siempre debe ser un n�mero negativo
    Pasos = -Abs(Pasos)
    
    horaActual = Now
    '
    tmpVolActual = ObtenerVolumen(hMixer, volCtrl)
    '
    If Inverso Then
        ' Obtener el valor actual del volumen, por si se cambia
        ' mientras se est� tocando
        VolActual = ObtenerVolumen(hMixer, volCtrl)
        tmpVolActual = VolActual
        j = tmpVolActual
        If VolMin < 0 Then VolMin = 0
        k = VolMin
    Else
        j = tmpVolActual
        k = VolActual
        Pasos = Abs(Pasos)
    End If
    For i = j To k Step Pasos
        Call SetVolumeControl(hMixer, volCtrl, i)
        DoEvents
        If Second(Now - horaActual) >= Segundos Then
            Exit For
        End If
    Next
    
    tmpVolActual = ObtenerVolumen(hMixer, volCtrl)
    If Restaurar Then
        Call SetVolumeControl(hMixer, volCtrl, VolActual)
    End If
End Sub

Private Function GetVolumeControl(ByRef hMixer As Long, _
                        ByVal componentType As Long, _
                        ByVal ctrlType As Long, _
                        ByRef mxc As MIXERCONTROL) As Boolean
                        
    ' This function attempts to obtain a mixer control.
    ' Returns True if successful.
    Dim mxlc As MIXERLINECONTROLS
    Dim mxl As MIXERLINE
    Dim hMem As Long
    
    mxl.cbStruct = Len(mxl)
    mxl.dwComponentType = componentType
    
    ' Obtain a line corresponding to the component type
    rc = mixerGetLineInfo(hMixer, mxl, MIXER_GETLINEINFOF_COMPONENTTYPE)
    
    If (MMSYSERR_NOERROR = rc) Then
        mxlc.cbStruct = Len(mxlc)
        mxlc.dwLineID = mxl.dwLineID
        mxlc.dwControl = ctrlType
        mxlc.cControls = 1
        mxlc.cbmxctrl = Len(mxc)
        
        ' Allocate a buffer for the control
        hMem = GlobalAlloc(&H40, Len(mxc))
        mxlc.pamxctrl = GlobalLock(hMem)
        mxc.cbStruct = Len(mxc)
        
        ' Get the control
        rc = mixerGetLineControls(hMixer, _
                                  mxlc, _
                                  MIXER_GETLINECONTROLSF_ONEBYTYPE)
        
        If (MMSYSERR_NOERROR = rc) Then
            GetVolumeControl = True
            
            ' Copy the control into the destination structure
            CopyStructFromPtr mxc, mxlc.pamxctrl, Len(mxc)
                         
        Else
            GetVolumeControl = False
        End If
        
        GlobalFree (hMem)
        Exit Function
    End If
    
    GetVolumeControl = False
End Function

Private Function ObtenerVolumen(ByRef hMixer As Long, _
                                ByRef mxc As MIXERCONTROL) As Long
    ' Obtiene el volumen actual                         ( 1/Ago/98)
    '
    Dim mxcd As MIXERCONTROLDETAILS
    Dim vol As MIXERCONTROLDETAILS_UNSIGNED
    Dim hMem2 As Long
    
    mxcd.item = 0
    mxcd.dwControlID = mxc.dwControlID
    mxcd.cbStruct = Len(mxcd)
    mxcd.cbDetails = Len(vol)
    
    ' Allocate a buffer for the control value buffer
    hMem2 = GlobalAlloc(&H40, Len(vol))
    mxcd.paDetails = GlobalLock(hMem2)
    mxcd.cChannels = 1
    
    ' Get the control value
    rc = mixerGetControlDetails(hMixer, _
                               mxcd, _
                               MIXER_GETCONTROLDETAILSF_VALUE)
    
    '
    ' Copy the data into the control value buffer
    CopyStructFromPtr vol, mxcd.paDetails, Len(vol)
    '
    GlobalFree (hMem2)
    
    If (rc = MMSYSERR_NOERROR) Then
        ObtenerVolumen = vol.dwValue
        RaiseEvent CambioVolumen(vol.dwValue)
    Else
        ObtenerVolumen = -1&
        RaiseEvent CambioVolumen(-1&)
    End If
End Function

Private Function SetVolumeControl(ByVal hMixer As Long, _
                        mxc As MIXERCONTROL, _
                        ByVal volume As Long) As Boolean
    ' This function sets the value for a volume control.
    ' Returns True if successful
    Dim mxcd As MIXERCONTROLDETAILS
    Dim vol As MIXERCONTROLDETAILS_UNSIGNED
    Dim hMem As Long
    
    mxcd.item = 0
    mxcd.dwControlID = mxc.dwControlID
    mxcd.cbStruct = Len(mxcd)
    mxcd.cbDetails = Len(vol)
    
    ' Allocate a buffer for the control value buffer
    hMem = GlobalAlloc(&H40, Len(vol))
    mxcd.paDetails = GlobalLock(hMem)
    mxcd.cChannels = 1
    vol.dwValue = volume
    
    ' Copy the data into the control value buffer
    CopyPtrFromStruct mxcd.paDetails, vol, Len(vol)
    
    ' Set the control value
    rc = mixerSetControlDetails(hMixer, _
                               mxcd, _
                               MIXER_SETCONTROLDETAILSF_VALUE)
    
    GlobalFree (hMem)
    If (MMSYSERR_NOERROR = rc) Then
        SetVolumeControl = True
    Else
        SetVolumeControl = False
    End If
    RaiseEvent CambioVolumen(volume)
End Function

Private Function AbrirMixer() As Long
    '
    ' Abre el Mixer y devuelve el valor del volumen actual
    ' Si no se puede abrir, devolver� -1
    '                                                   ( 1/Ago/98)
    '
'
'    // Open the mixer. This opens the mixer with a deviceID of 0. If you
'    // have a single sound card/mixer, then this will open it. If you have
'    // multiple sound cards/mixers, the deviceIDs will be 0, 1, 2, and
'    // so on.
'    rc = mixerOpen(&hMixer, 0,0,0,0);
'    if (MMSYSERR_NOERROR == rc) {
'           // Couldn't open the mixer.
'    }
'
    ' Open the mixer with deviceID 0.
    rc = mixerOpen(hMixer, 0, 0, 0, 0)
    If ((MMSYSERR_NOERROR <> rc)) Then
        AbrirMixer = -1
        Exit Function
    End If
        
    ' Get the waveout volume control
    ok = GetVolumeControl(hMixer, _
                         MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, _
                         MIXERCONTROL_CONTROLTYPE_VOLUME, _
                         volCtrl)
       
    If (ok = True) Then
        AbrirMixer = ObtenerVolumen(hMixer, volCtrl)
    Else
        AbrirMixer = -1
    End If
End Function

Private Sub CerrarMixer()
    ' Cerrar el mixer
    Call mixerClose(hMixer)
End Sub

Public Property Get Volumen() As Long
    ' Obtener el volumen del sistema
    Volumen = ObtenerVolumen(hMixer, volCtrl)
End Property

Public Property Let Volumen(ByVal NewValue As Long)
    ' Asignar un nuevo valor para el volumen
    '
    ' Los valores m�ximo y m�nimo estar�n dentro del rango de:
    ' volCtrl.lMinimum y volCtrl.lMaximum
    If Not (NewValue > volCtrl.lMaximum Or NewValue < volCtrl.lMinimum) Then
        Call SetVolumeControl(hMixer, volCtrl, NewValue)
    End If
End Property

Public Property Get MinVol() As Long
    ' Devuelve el valor m�nimo del volumen (suele ser cero)
    MinVol = volCtrl.lMinimum
End Property

Public Property Get MaxVol() As Long
    ' Devuelve el valor m�ximo del mixer, normalmente 65535
    MaxVol = volCtrl.lMaximum
End Property

El c�digo del ejemplo, con una imagen del formulario:

'
'------------------------------------------------------------------------------
' Prueba de la clase cVolumen                                       (09/Jul/99)
'
' �Guillermo 'guille' Som, 1999
'------------------------------------------------------------------------------
Option Explicit

Private WithEvents m_cVol As cVolumen  	' Clase para manipular el volumen
Private m_VolIni As Long    		' Valor del volumen al iniciar el programa

Private Sub cmdFade_Click(Index As Integer)
    ' Hacer fade
    ' Si Index = 0 se har� descendiendo el volumen
    ' Si Index = 1 se har� aumentando   el volumen
    If Index = 0 Then
        m_cVol.Fade Restaurar:=False, Inverso:=True, VolMin:=4000
        'm_cVol.Fade 3, 8, False, True, 4000
    Else
        m_cVol.Fade Segundos:=2, Pasos:=16, Inverso:=False
        'm_cVol.Fade 2, 16, True, False
    End If
    
    ' Mostrar el volumen actual
    ' (usarlo si no se quiere declarar con WithEvents)
    'txtVol = m_cVol.Volumen
End Sub

Private Sub cmdRestaurar_Click()
    ' Restaurar el volumen inicial
    m_cVol.Volumen = m_VolIni
    txtVol = m_VolIni
End Sub

Private Sub cmdVolumen_Click()
    m_cVol.Volumen = txtVol
End Sub

Private Sub Form_Load()
    Set m_cVol = New cVolumen
    
    With m_cVol
        ' Leer el volumen inicial, por si se restaura
        m_VolIni = .Volumen
        ' asignar el volumen actual, si no se ha declarado con WintEvents
        'txtVol = m_VolIni
        ' Mostrar los valores m�nimo y m�ximo del nivel de volumen
        Label1(1) = "Min: " & .MinVol & " - Max: " & .MaxVol
    End With
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    ' Restaurar el volumen inicial
    cmdRestaurar_Click
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set m_cVol = Nothing
    
    Set fTestVol = Nothing
End Sub

Private Sub m_cVol_CambioVolumen(ByVal VolumenActual As Long)
    txtVol = VolumenActual
End Sub

Private Sub txtVol_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        cmdVolumen_Click
    End If
End Sub

la Luna del Guille o... el Guille que está en la Luna... tanto monta...