|
|
|
|
|
|
|
|
Dicas
|
|
|
Visual Basic (Imagem/Som/Multimídia)
|
|
 |
Título da Dica: Aumentar ou baixar o volume do som ou do microfone no seu PC
|
 |
|
|
|
Postada em 12/3/2004 por Josefh Hennyere
'Requesitos:
'2 command Buttons
'2 TextBox
'2 labels
'Num módulo.bas, cole este código
Option Explicit
Public Const MMSYSERR_NOERROR = 0
Public Const MAXPNAMELEN = 32
Public Const MIXER_LONG_NAME_CHARS = 64
Public Const MIXER_SHORT_NAME_CHARS = 16
Public Const MIXER_GETLINEINFOF_COMPONENTTYPE = &H3&
Public Const MIXER_GETCONTROLDETAILSF_VALUE = &H0&
Public Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2&
Public Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0&
Public Const MIXERLINE_COMPONENTTYPE_SRC_FIRST = &H1000&
Public Const MIXER_SETCONTROLDETAILSF_VALUE = &H0&
Public Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4)
Public Const MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 3)
Public Const MIXERLINE_COMPONENTTYPE_SRC_LINE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 2)
Public Const MIXERCONTROL_CT_CLASS_FADER = &H50000000
Public Const MIXERCONTROL_CT_UNITS_UNSIGNED = &H30000
Public Const MIXERCONTROL_CONTROLTYPE_FADER = (MIXERCONTROL_CT_CLASS_FADER Or MIXERCONTROL_CT_UNITS_UNSIGNED)
Public Const MIXERCONTROL_CONTROLTYPE_VOLUME = (MIXERCONTROL_CONTROLTYPE_FADER + 1)
Public Declare Function mixerClose Lib "winmm.dll" (ByVal hmx As Long) As Long
Public Declare Function mixerGetControlDetails Lib "winmm.dll" Alias "mixerGetControlDetailsA" (ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long
Public Declare Function mixerGetDevCaps Lib "winmm.dll" Alias "mixerGetDevCapsA" (ByVal uMxId As Long, ByVal pmxcaps As MIXERCAPS, ByVal cbmxcaps As Long) As Long
Public Declare Function mixerGetID Lib "winmm.dll" (ByVal hmxobj As Long, pumxID As Long, ByVal fdwId As Long) As Long
Public Declare Function mixerGetLineControls Lib "winmm.dll" Alias "mixerGetLineControlsA" (ByVal hmxobj As Long, pmxlc As MIXERLINECONTROLS, ByVal fdwControls As Long) As Long
Public Declare Function mixerGetLineInfo Lib "winmm.dll" Alias "mixerGetLineInfoA" (ByVal hmxobj As Long, pmxl As MIXERLINE, ByVal fdwInfo As Long) As Long
Public Declare Function mixerGetNumDevs Lib "winmm.dll" () As Long
Public Declare Function mixerMessage Lib "winmm.dll" (ByVal hmx As Long, ByVal uMsg As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long) As Long
Public 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
Public Declare Function mixerSetControlDetails Lib "winmm.dll" (ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long
Public Declare Sub CopyStructFromPtr Lib "kernel32" Alias "RtlMoveMemory" (struct As Any, ByVal ptr As Long, ByVal cb As Long)
Public Declare Sub CopyPtrFromStruct Lib "kernel32" Alias "RtlMoveMemory" (ByVal ptr As Long, struct As Any, ByVal cb As Long)
Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
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
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
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
Type MIXERCONTROLDETAILS_UNSIGNED
dwValue As Long 'value of the control
End Type
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
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
Function GetVolumeControl(ByVal 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
Dim rc 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
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
Dim rc 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
End Function
'No form cole este código
Option Explicit
Dim hmixer As Long 'mixer handle
Dim volCtrl As MIXERCONTROL 'waveout volume control
Dim micCtrl As MIXERCONTROL 'microphone volume control
Dim rc As Long 'return code
Dim ok As Boolean 'boolean return code
Private Sub Form_Load()
'Open the mixer with deviceID 0.
rc = mixerOpen(hmixer, 0, 0, 0, 0)
If ((MMSYSERR_NOERROR <> rc)) Then
MsgBox "Couldn't open the mixer."
Exit Sub
End If
'Get the waveout volume control
ok = GetVolumeControl(hmixer, MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, MIXERCONTROL_CONTROLTYPE_VOLUME, volCtrl)
If (ok = True) Then
'If the function successfully gets the volume control,
'the maximum and minimum values are specified by
'lMaximum and lMinimum
Label1.Caption = volCtrl.lMinimum & " to " & volCtrl.lMaximum
End If
' Get the microphone volume control
ok = GetVolumeControl(hmixer, MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE, MIXERCONTROL_CONTROLTYPE_VOLUME, micCtrl)
If (ok = True) Then
Label2.Caption = micCtrl.lMinimum & " to " & micCtrl.lMaximum
End If
End Sub
Private Sub Command1_Click()
Dim Vol As Long
Vol = CLng(Text1.Text)
SetVolumeControl hmixer, volCtrl, Vol
End Sub
Private Sub Command2_Click()
Dim Vol As Long
Vol = CLng(Text2.Text)
SetVolumeControl hmixer, micCtrl, Vol
End Sub
'Josefh Hennyere
|
|
|
|
|
