Solved

How to set microphone recording levels

Posted on 2001-07-05
4
854 Views
Last Modified: 2010-08-05
My VB app uses the MCI control and a microphone to record wave files. But on some PC's, the microphone level may be turned way down, or the microphone is deselected.  In these cases, the recording doesn't work.

How can I control the record level and the microphone select from inside my program?

Thanks.
0
Comment
Question by:btwhite
4 Comments
 
LVL 1

Accepted Solution

by:
Aaron_Young earned 100 total points
Comment Utility
You can control the Microphones Record Volume Level using the API, i.e.


'In a Module:
'---------------------------------------------------------
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_GETLINEINFOF_SOURCE = &H1&
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 Const MIXERLINE_COMPONENTTYPE_DST_WAVEIN = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 7)
Private Const MIXER_SETCONTROLDETAILSF_VALUE = &H0&

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 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 lMixerHnd As Long
Private tMIC As MIXERCONTROL
Private bHasMic As Boolean

Private Function GetMixer() As Boolean
    ' Get a Handle to the Mixer
    ' If we've already got one, return
    If lMixerHnd Then
        GetMixer = True
        Exit Function
    End If
    ' Get a new handle to the Mizer
    lReturn = mixerOpen(lMixerHnd, 0, 0, 0, 0)
    If lReturn = MMSYSERR_NOERROR Then
        GetMixer = True
    Else
        ' Problems opening the Mixer
        MsgBox "Unable to open mixer."
    End If
End Function

Public Function GetMicrophoneRecordVolume() As Long
    ' Retreives the current volume of the Microphone control (Recording)
    Dim lResult As Long, lMemHnd As Long
    Dim tMIXERCONTROLDETAILS As MIXERCONTROLDETAILS
    Dim tVOLUME As MIXERCONTROLDETAILS_UNSIGNED
   
    ' If we haven't gotten the Microphone Control yet, do so.
    If Not bHasMic Then bHasMic = GetMicControl()
    If Not bHasMic Then
        ' Unable to get the Microphone
        MsgBox "Unable to open Microphone Control"
        Exit Function
    End If
       
    ' Prep a MICERCONTROLDETAILS structure for retreiving info. about a specific control
    tMIXERCONTROLDETAILS.item = 0
    tMIXERCONTROLDETAILS.dwControlID = tMIC.dwControlID
    tMIXERCONTROLDETAILS.cbStruct = Len(tMIXERCONTROLDETAILS)
    tMIXERCONTROLDETAILS.cbDetails = Len(tVOLUME)
   
    ' Allocate a buffer for the control's value
    lMemHnd = GlobalAlloc(&H40, Len(tVOLUME))
    tMIXERCONTROLDETAILS.paDetails = GlobalLock(lMemHnd)
    tMIXERCONTROLDETAILS.cChannels = 1
   
    ' Get the controls details
    Call mixerGetControlDetails(lMixerHnd, tMIXERCONTROLDETAILS, MIXER_GETCONTROLDETAILSF_VALUE)
   
    ' Copy the data into the control's VOLUME struct
    CopyStructFromPtr tVOLUME, tMIXERCONTROLDETAILS.paDetails, Len(tVOLUME)
   
    ' Release the memory buffer
    Call GlobalFree(lMemHnd)
   
    ' Return the current value
    GetMicrophoneRecordVolume = tVOLUME.dwValue
End Function

Public Sub SetMicrophoneRecordVolume(ByVal lVolume As Long)
    ' Set the Microphone volume used for recording
    Dim lResult As Long, lMemHnd As Long
    Dim tMIXERCONTROLDETAILS As MIXERCONTROLDETAILS
    Dim tVOLUME As MIXERCONTROLDETAILS_UNSIGNED
   
    ' If we haven't got the Microphone yet, do so..
    If Not bHasMic Then bHasMic = GetMicControl()
    If Not bHasMic Then
        MsgBox "Unable to open Microphone Control"
        Exit Sub
    End If
       
    ' Prep the MIXERCONTROLDETAILS struct to set info. about this control
    tMIXERCONTROLDETAILS.item = 0
    tMIXERCONTROLDETAILS.dwControlID = tMIC.dwControlID
    tMIXERCONTROLDETAILS.cbStruct = Len(tMIXERCONTROLDETAILS)
    tMIXERCONTROLDETAILS.cbDetails = Len(tVOLUME)
   
    ' Allocate a buffer for the control's volume value
    lMemHnd = GlobalAlloc(&H40, Len(tVOLUME))
    tMIXERCONTROLDETAILS.paDetails = GlobalLock(lMemHnd)
    tMIXERCONTROLDETAILS.cChannels = 1
    tVOLUME.dwValue = lVolume
   
    ' Copy the data from the VOLUME struct into the memory buffer
    CopyPtrFromStruct tMIXERCONTROLDETAILS.paDetails, tVOLUME, Len(tVOLUME)
   
    ' Set the new volume
    Call mixerSetControlDetails(lMixerHnd, tMIXERCONTROLDETAILS, MIXER_SETCONTROLDETAILSF_VALUE)
   
    ' Release the memory buffer
    Call GlobalFree(lMemHnd)
End Sub

Private Function GetMicControl() As Boolean
    ' Get the Microphone Control (from the Recording Line)
    Dim tMIXERLINECONTROLS As MIXERLINECONTROLS
    Dim tMIXERLINE As MIXERLINE
    Dim lMemHnd As Long
    Dim lReturn As Long
    Dim lConnections As Long
    Dim lIndex As Long
   
    ' Get a handle to the Mixer
    If Not GetMixer() Then Exit Function
       
    ' First find the WAVEIN Line
    tMIXERLINE.cbStruct = Len(tMIXERLINE)
    tMIXERLINE.dwComponentType = MIXERLINE_COMPONENTTYPE_DST_WAVEIN
   
    lReturn = mixerGetLineInfo(lMixerHnd, tMIXERLINE, MIXER_GETLINEINFOF_COMPONENTTYPE)
   
    If lReturn <> MMSYSERR_NOERROR Then Exit Function
   
    ' Next enumerate the connections for this line, checking for the Microphone
    lConnections = tMIXERLINE.cConnections - 1
   
    For lIndex = 0 To lConnections
        tMIXERLINE.dwSource = lIndex
        Call mixerGetLineInfo(lMixerHnd, tMIXERLINE, MIXER_GETLINEINFOF_SOURCE)
        If tMIXERLINE.dwComponentType = MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE Then
            Exit For
        End If
    Next
   
    ' If no microphone was found, exit
    If lIndex > lConnections Then Exit Function
   
    ' Extract the control for the Microphone from the line
    tMIXERLINECONTROLS.cbStruct = Len(tMIXERLINECONTROLS)
    tMIXERLINECONTROLS.dwLineID = tMIXERLINE.dwLineID
    tMIXERLINECONTROLS.dwControl = MIXERCONTROL_CONTROLTYPE_VOLUME
    tMIXERLINECONTROLS.cControls = 1
    tMIXERLINECONTROLS.cbmxctrl = Len(tMIC)
   
    ' Create a buffer for the Microphone
    lMemHnd = GlobalAlloc(&H40, Len(tMIC))
    tMIXERLINECONTROLS.pamxctrl = GlobalLock(lMemHnd)
    tMIC.cbStruct = Len(tMIC)
   
    ' Get the Microphone
    lReturn = mixerGetLineControls(lMixerHnd, tMIXERLINECONTROLS, MIXER_GETLINECONTROLSF_ONEBYTYPE)
         
    If (MMSYSERR_NOERROR = lReturn) Then
        GetMicControl = True
        ' Copy the Microphone control into the tMIC structure
        CopyStructFromPtr tMIC, tMIXERLINECONTROLS.pamxctrl, Len(tMIC)
    End If
   
    ' Release the buffer
    Call GlobalFree(lMemHnd)
End Function
'---------------------------------------------------------

'Example Usage:
'---------------------------------------------------------
' Set Microphone Record Volume to Max
Call SetMicrophoneRecordVolume(65535)
'---------------------------------------------------------

Regards,

- Aaron.
0
 
LVL 1

Expert Comment

by:ScottNero
Comment Utility
Hmmm. Isn't it kind of obscene that it requires 260+ lines of code to change the microphone volume? I haven't found any other way of doing it, however.
0
 

Expert Comment

by:costello
Comment Utility
Force accepting proposed answer.

costello
Community Support Moderator @ Experts-Exchange
0
 
LVL 5

Expert Comment

by:rajaamirapu
Comment Utility
Here is the VB.NET code
Option Strict Off
Option Explicit On
Module TEST
      Private Const MMSYSERR_NOERROR As Short = 0
      Private Const MAXPNAMELEN As Short = 32
      Private Const MIXER_LONG_NAME_CHARS As Short = 64
      Private Const MIXER_SHORT_NAME_CHARS As Short = 16
      Private Const MIXER_GETLINEINFOF_COMPONENTTYPE As Integer = &H3
      Private Const MIXER_GETLINEINFOF_SOURCE As Integer = &H1
      Private Const MIXER_GETCONTROLDETAILSF_VALUE As Integer = &H0
      Private Const MIXER_GETLINECONTROLSF_ONEBYTYPE As Integer = &H2
      Private Const MIXERLINE_COMPONENTTYPE_DST_FIRST As Integer = &H0
      Private Const MIXERLINE_COMPONENTTYPE_SRC_FIRST As Integer = &H1000
      Private Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS As Decimal = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4)
      Private Const MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE As Decimal = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 3)
      Private Const MIXERLINE_COMPONENTTYPE_SRC_LINE As Decimal = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 2)
      Private Const MIXERCONTROL_CT_CLASS_FADER As Integer = &H50000000
      Private Const MIXERCONTROL_CT_UNITS_UNSIGNED As Integer = &H30000
      Private Const MIXERCONTROL_CONTROLTYPE_FADER As Boolean = (MIXERCONTROL_CT_CLASS_FADER Or MIXERCONTROL_CT_UNITS_UNSIGNED)
      Private Const MIXERCONTROL_CONTROLTYPE_VOLUME As Boolean = (CShort(MIXERCONTROL_CONTROLTYPE_FADER) + 1)
      Private Const MIXERLINE_COMPONENTTYPE_DST_WAVEIN As Decimal = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 7)
      Private Const MIXER_SETCONTROLDETAILSF_VALUE As Integer = &H0
      
      Private Structure MIXERCAPS
            Dim wMid As Short '  manufacturer id
            Dim wPid As Short '  product id
            Dim vDriverVersion As Integer '  version of the driver
            <VBFixedString(MAXPNAMELEN),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr,SizeConst:=MAXPNAMELEN)> Public szPname As String '  product name
            Dim fdwSupport As Integer '  misc. support bits
            Dim cDestinations As Integer '  count of destinations
      End Structure
      
      Private Structure MIXERCONTROL
            Dim cbStruct As Integer '  size in Byte of MIXERCONTROL
            Dim dwControlID As Integer '  unique control id for mixer device
            Dim dwControlType As Integer '  MIXERCONTROL_CONTROLTYPE_xxx
            Dim fdwControl As Integer '  MIXERCONTROL_CONTROLF_xxx
            Dim cMultipleItems As Integer '  if MIXERCONTROL_CONTROLF_MULTIPLE set
            <VBFixedString(MIXER_SHORT_NAME_CHARS),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr,SizeConst:=MIXER_SHORT_NAME_CHARS)> Public szShortName As String ' short name of control
            <VBFixedString(MIXER_LONG_NAME_CHARS),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr,SizeConst:=MIXER_LONG_NAME_CHARS)> Public szName As String ' long name of control
            Dim lMinimum As Integer '  Minimum value
            Dim lMaximum As Integer '  Maximum value
            <VBFixedArray(10)> Dim reserved() As Integer '  reserved structure space
            
            'UPGRADE_TODO: "Initialize" must be called to initialize instances of this structure. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1026"'
            Public Sub Initialize()
                  ReDim reserved(10)
            End Sub
      End Structure
      
      Private Structure MIXERCONTROLDETAILS
            Dim cbStruct As Integer '  size in Byte of MIXERCONTROLDETAILS
            Dim dwControlID As Integer '  control id to get/set details on
            Dim cChannels As Integer '  number of channels in paDetails array
            Dim item As Integer '  hwndOwner or cMultipleItems
            Dim cbDetails As Integer '  size of _one_ details_XX struct
            Dim paDetails As Integer '  pointer to array of details_XX structs
      End Structure
      
      Private Structure MIXERCONTROLDETAILS_UNSIGNED
            Dim dwValue As Integer '  value of the control
      End Structure
      
      Private Structure MIXERLINE
            Dim cbStruct As Integer '  size of MIXERLINE structure
            Dim dwDestination As Integer '  zero based destination index
            Dim dwSource As Integer '  zero based source index (if source)
            Dim dwLineID As Integer '  unique line id for mixer device
            Dim fdwLine As Integer '  state/information about line
            Dim dwUser As Integer '  driver specific information
            Dim dwComponentType As Integer '  component type line connects to
            Dim cChannels As Integer '  number of channels line supports
            Dim cConnections As Integer '  number of connections (possible)
            Dim cControls As Integer '  number of controls at this line
            <VBFixedString(MIXER_SHORT_NAME_CHARS),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr,SizeConst:=MIXER_SHORT_NAME_CHARS)> Public szShortName As String
            <VBFixedString(MIXER_LONG_NAME_CHARS),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr,SizeConst:=MIXER_LONG_NAME_CHARS)> Public szName As String
            Dim dwType As Integer
            Dim dwDeviceID As Integer
            Dim wMid As Short
            Dim wPid As Short
            Dim vDriverVersion As Integer
            <VBFixedString(MAXPNAMELEN),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr,SizeConst:=MAXPNAMELEN)> Public szPname As String
      End Structure
      
      Private Structure MIXERLINECONTROLS
            Dim cbStruct As Integer '  size in Byte of MIXERLINECONTROLS
            Dim dwLineID As Integer '  line id (from MIXERLINE.dwLineID)
            '  MIXER_GETLINECONTROLSF_ONEBYID or
            Dim dwControl As Integer '  MIXER_GETLINECONTROLSF_ONEBYTYPE
            Dim cControls As Integer '  count of controls pmxctrl points to
            Dim cbmxctrl As Integer '  size in Byte of _one_ MIXERCONTROL
            Dim pamxctrl As Integer '  pointer to first MIXERCONTROL array
      End Structure
      
      Private Declare Function mixerClose Lib "winmm.dll" (ByVal hmx As Integer) As Integer
      'UPGRADE_WARNING: Structure MIXERCONTROLDETAILS may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"'
      Private Declare Function mixerGetControlDetails Lib "winmm.dll"  Alias "mixerGetControlDetailsA"(ByVal hmxobj As Integer, ByRef pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Integer) As Integer
      'UPGRADE_WARNING: Structure MIXERCAPS may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"'
      Private Declare Function mixerGetDevCaps Lib "winmm.dll"  Alias "mixerGetDevCapsA"(ByVal uMxId As Integer, ByVal pmxcaps As MIXERCAPS, ByVal cbmxcaps As Integer) As Integer
      Private Declare Function mixerGetID Lib "winmm.dll" (ByVal hmxobj As Integer, ByRef pumxID As Integer, ByVal fdwId As Integer) As Integer
      'UPGRADE_WARNING: Structure MIXERLINECONTROLS may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"'
      Private Declare Function mixerGetLineControls Lib "winmm.dll"  Alias "mixerGetLineControlsA"(ByVal hmxobj As Integer, ByRef pmxlc As MIXERLINECONTROLS, ByVal fdwControls As Integer) As Integer
      'UPGRADE_WARNING: Structure MIXERLINE may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"'
      Private Declare Function mixerGetLineInfo Lib "winmm.dll"  Alias "mixerGetLineInfoA"(ByVal hmxobj As Integer, ByRef pmxl As MIXERLINE, ByVal fdwInfo As Integer) As Integer
      Private Declare Function mixerGetNumDevs Lib "winmm.dll" () As Integer
      Private Declare Function mixerMessage Lib "winmm.dll" (ByVal hmx As Integer, ByVal uMsg As Integer, ByVal dwParam1 As Integer, ByVal dwParam2 As Integer) As Integer
      Private Declare Function mixerOpen Lib "winmm.dll" (ByRef phmx As Integer, ByVal uMxId As Integer, ByVal dwCallback As Integer, ByVal dwInstance As Integer, ByVal fdwOpen As Integer) As Integer
      'UPGRADE_WARNING: Structure MIXERCONTROLDETAILS may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"'
      Private Declare Function mixerSetControlDetails Lib "winmm.dll" (ByVal hmxobj As Integer, ByRef pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Integer) As Integer
      'UPGRADE_ISSUE: Declaring a parameter 'As Any' is not supported. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1016"'
      Private Declare Sub CopyStructFromPtr Lib "kernel32"  Alias "RtlMoveMemory"(ByRef struct As Any, ByVal ptr As Integer, ByVal cb As Integer)
      'UPGRADE_ISSUE: Declaring a parameter 'As Any' is not supported. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1016"'
      Private Declare Sub CopyPtrFromStruct Lib "kernel32"  Alias "RtlMoveMemory"(ByVal ptr As Integer, ByRef struct As Any, ByVal cb As Integer)
      Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Integer, ByVal dwBytes As Integer) As Integer
      Private Declare Function GlobalLock Lib "kernel32" (ByVal hmem As Integer) As Integer
      Private Declare Function GlobalFree Lib "kernel32" (ByVal hmem As Integer) As Integer
      
      Private lMixerHnd As Integer
      'UPGRADE_WARNING: Arrays in structure tMIC may need to be initialized before they can be used. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1063"'
      Private tMIC As MIXERCONTROL
      Private bHasMic As Boolean
      
      Private Function GetMixer() As Boolean
            Dim lReturn As Object
            ' Get a Handle to the Mixer
            ' If we've already got one, return
            If lMixerHnd Then
                  GetMixer = True
                  Exit Function
            End If
            ' Get a new handle to the Mizer
            'UPGRADE_WARNING: Couldn't resolve default property of object lReturn. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
            lReturn = mixerOpen(lMixerHnd, 0, 0, 0, 0)
            'UPGRADE_WARNING: Couldn't resolve default property of object lReturn. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
            If lReturn = MMSYSERR_NOERROR Then
                  GetMixer = True
            Else
                  ' Problems opening the Mixer
                  MsgBox("Unable to open mixer.")
            End If
      End Function
      
      Public Function GetMicrophoneRecordVolume() As Integer
            ' Retreives the current volume of the Microphone control (Recording)
            Dim lResult, lMemHnd As Integer
            Dim tMIXERCONTROLDETAILS As MIXERCONTROLDETAILS
            Dim tVOLUME As MIXERCONTROLDETAILS_UNSIGNED
            
            ' If we haven't gotten the Microphone Control yet, do so.
            If Not bHasMic Then bHasMic = GetMicControl()
            If Not bHasMic Then
                  ' Unable to get the Microphone
                  MsgBox("Unable to open Microphone Control")
                  Exit Function
            End If
            
            ' Prep a MICERCONTROLDETAILS structure for retreiving info. about a specific control
            tMIXERCONTROLDETAILS.item = 0
            tMIXERCONTROLDETAILS.dwControlID = tMIC.dwControlID
            tMIXERCONTROLDETAILS.cbStruct = Len(tMIXERCONTROLDETAILS)
            tMIXERCONTROLDETAILS.cbDetails = Len(tVOLUME)
            
            ' Allocate a buffer for the control's value
            lMemHnd = GlobalAlloc(&H40s, Len(tVOLUME))
            tMIXERCONTROLDETAILS.paDetails = GlobalLock(lMemHnd)
            tMIXERCONTROLDETAILS.cChannels = 1
            
            ' Get the controls details
            Call mixerGetControlDetails(lMixerHnd, tMIXERCONTROLDETAILS, MIXER_GETCONTROLDETAILSF_VALUE)
            
            ' Copy the data into the control's VOLUME struct
            'UPGRADE_WARNING: Couldn't resolve default property of object tVOLUME. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
            CopyStructFromPtr(tVOLUME, tMIXERCONTROLDETAILS.paDetails, Len(tVOLUME))
            
            ' Release the memory buffer
            Call GlobalFree(lMemHnd)
            
            ' Return the current value
            GetMicrophoneRecordVolume = tVOLUME.dwValue
      End Function
      
      Public Sub SetMicrophoneRecordVolume(ByVal lVolume As Integer)
            ' Set the Microphone volume used for recording
            Dim lResult, lMemHnd As Integer
            Dim tMIXERCONTROLDETAILS As MIXERCONTROLDETAILS
            Dim tVOLUME As MIXERCONTROLDETAILS_UNSIGNED
            
            ' If we haven't got the Microphone yet, do so..
            If Not bHasMic Then bHasMic = GetMicControl()
            If Not bHasMic Then
                  MsgBox("Unable to open Microphone Control")
                  Exit Sub
            End If
            
            ' Prep the MIXERCONTROLDETAILS struct to set info. about this control
            tMIXERCONTROLDETAILS.item = 0
            tMIXERCONTROLDETAILS.dwControlID = tMIC.dwControlID
            tMIXERCONTROLDETAILS.cbStruct = Len(tMIXERCONTROLDETAILS)
            tMIXERCONTROLDETAILS.cbDetails = Len(tVOLUME)
            
            ' Allocate a buffer for the control's volume value
            lMemHnd = GlobalAlloc(&H40s, Len(tVOLUME))
            tMIXERCONTROLDETAILS.paDetails = GlobalLock(lMemHnd)
            tMIXERCONTROLDETAILS.cChannels = 1
            tVOLUME.dwValue = lVolume
            
            ' Copy the data from the VOLUME struct into the memory buffer
            'UPGRADE_WARNING: Couldn't resolve default property of object tVOLUME. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
            CopyPtrFromStruct(tMIXERCONTROLDETAILS.paDetails, tVOLUME, Len(tVOLUME))
            
            ' Set the new volume
            Call mixerSetControlDetails(lMixerHnd, tMIXERCONTROLDETAILS, MIXER_SETCONTROLDETAILSF_VALUE)
            
            ' Release the memory buffer
            Call GlobalFree(lMemHnd)
      End Sub
      
      Private Function GetMicControl() As Boolean
            ' Get the Microphone Control (from the Recording Line)
            Dim tMIXERLINECONTROLS As MIXERLINECONTROLS
            Dim tMIXERLINE As MIXERLINE
            Dim lMemHnd As Integer
            Dim lReturn As Integer
            Dim lConnections As Integer
            Dim lIndex As Integer
            
            ' Get a handle to the Mixer
            If Not GetMixer() Then Exit Function
            
            ' First find the WAVEIN Line
            tMIXERLINE.cbStruct = Len(tMIXERLINE)
            tMIXERLINE.dwComponentType = MIXERLINE_COMPONENTTYPE_DST_WAVEIN
            
            lReturn = mixerGetLineInfo(lMixerHnd, tMIXERLINE, MIXER_GETLINEINFOF_COMPONENTTYPE)
            
            If lReturn <> MMSYSERR_NOERROR Then Exit Function
            
            ' Next enumerate the connections for this line, checking for the Microphone
            lConnections = tMIXERLINE.cConnections - 1
            
            For lIndex = 0 To lConnections
                  tMIXERLINE.dwSource = lIndex
                  Call mixerGetLineInfo(lMixerHnd, tMIXERLINE, MIXER_GETLINEINFOF_SOURCE)
                  If tMIXERLINE.dwComponentType = MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE Then
                        Exit For
                  End If
            Next
            
            ' If no microphone was found, exit
            If lIndex > lConnections Then Exit Function
            
            ' Extract the control for the Microphone from the line
            tMIXERLINECONTROLS.cbStruct = Len(tMIXERLINECONTROLS)
            tMIXERLINECONTROLS.dwLineID = tMIXERLINE.dwLineID
            tMIXERLINECONTROLS.dwControl = MIXERCONTROL_CONTROLTYPE_VOLUME
            tMIXERLINECONTROLS.cControls = 1
            tMIXERLINECONTROLS.cbmxctrl = Len(tMIC)
            
            ' Create a buffer for the Microphone
            lMemHnd = GlobalAlloc(&H40s, Len(tMIC))
            tMIXERLINECONTROLS.pamxctrl = GlobalLock(lMemHnd)
            tMIC.cbStruct = Len(tMIC)
            
            ' Get the Microphone
            lReturn = mixerGetLineControls(lMixerHnd, tMIXERLINECONTROLS, MIXER_GETLINECONTROLSF_ONEBYTYPE)
            
            If (MMSYSERR_NOERROR = lReturn) Then
                  GetMicControl = True
                  ' Copy the Microphone control into the tMIC structure
                  'UPGRADE_WARNING: Couldn't resolve default property of object tMIC. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
                  CopyStructFromPtr(tMIC, tMIXERLINECONTROLS.pamxctrl, Len(tMIC))
            End If
            
            ' Release the buffer
            Call GlobalFree(lMemHnd)
      End Function
End Module
Hope this is useful
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

771 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now