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