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