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
