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