locked
How to set volume using macro? RRS feed

  • Question

  • The following macro work under XP on PC, but not under Win 7 Home on Notebook.

    Does anyone have any suggestions on what wrong it is?
    Thanks in advance for any suggestions

    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
    Dim vol As Long             ' volume
    Dim cnt As Long

    Sub Set_Volumn()

    Dim dblTime As Double
    Dim dblTime2 As Double
     
    ' 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 Then
            SetVolumeControl hmixer, volCtrl, 10000
        End If

    End Sub

     

    Given modules : basGeneral and basVolume


    Thanks in advance for any suggestions

    Monday, December 1, 2014 10:11 AM

All replies

  • The following macro work under XP on PC, but not under Win 7 Home on Notebook.

    Does anyone have any suggestions on what wrong it is?
    Thanks in advance for any suggestions

    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
    Dim vol As Long             ' volume
    Dim cnt As Long

    Sub Set_Volumn()

    Dim dblTime As Double
    Dim dblTime2 As Double
     
    ' 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 Then
            SetVolumeControl hmixer, volCtrl, 10000
        End If

    End Sub

     

    Given modules : basGeneral and basVolume


    Thanks in advance for any suggestions

    Can you give more info which version of Windows 7? 32 or 64 bit?

    I suspect you are using 64-bit, if that's the case you do need to declare the API calls differently.

    You need to re-write the API in order to get them to work in 64-bit windows version.

    Btw. I am assuming you are using similar code in below KB article:

    Volume API

    In case you are using 64-bit, see below article how to deal with conversion from 32-bit to 64-bit:

    Declaring API functions in 64 bit Office

    Hope this helps,


    Daniel van den Berg | Washington, USA | "Anticipate the difficult by managing the easy"

    Please vote an answer helpful if they helped. Please mark an answer(s) as an answer when your question is being answered.


    • Edited by danishani Monday, December 1, 2014 10:27 PM fixed link
    Monday, December 1, 2014 4:38 PM
  • Can you give more info which version of Windows 7? 32 or 64 bit?

    I suspect you are using 64-bit, if that's the case you do need to declare the API calls differently.

    You need to re-write the API in order to get them to work in 64-bit windows version.


    I am using Window 7 Home 64 bit.

    Do you have any suggestions on what API coding looks like to set volume?
    Thank you very much for any suggestions :>


    Thanks in advance for any suggestions

    Monday, December 1, 2014 9:47 PM
  • Can you give more info which version of Windows 7? 32 or 64 bit?

    I suspect you are using 64-bit, if that's the case you do need to declare the API calls differently.

    You need to re-write the API in order to get them to work in 64-bit windows version.


    I am using Window 7 Home 64 bit.

    Do you have any suggestions on what API coding looks like to set volume?
    Thank you very much for any suggestions :>


    Thanks in advance for any suggestions

    Yes, I think most of the API function you are using only need to have PtrSafe in front of the Function.

    For example:

    ' Note: PtrSafe in front of Function 
    Declare PtrSafe Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long

    Btw. Below link will help you how to declare the API, download the API reference and search the API you are looking for on how to declare in 64 -bit.

    Win32API_PtrSafe with 64-bit Support

    Btw. If your application needs to support both, use something like this:

    #If VBA7 Then
      Declare PtrSafe Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long
     #Else
      Declare Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long
    #End If

    Hope this helps,


    Daniel van den Berg | Washington, USA | "Anticipate the difficult by managing the easy"

    Please vote an answer helpful if they helped. Please mark an answer(s) as an answer when your question is being answered.


    • Edited by danishani Monday, December 1, 2014 10:42 PM additional info
    Monday, December 1, 2014 10:40 PM
  • Yes, I think most of the API function you are using only need to have PtrSafe in front of the Function.

    For example:

    ' Note: PtrSafe in front of Function 
    Declare PtrSafe Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long

    Btw. Below link will help you how to declare the API, download the API reference and search the API you are looking for on how to declare in 64 -bit.

    Win32API_PtrSafe with 64-bit Support

    Btw. If your application needs to support both, use something like this:

    #If VBA7 Then
      Declare PtrSafe Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long
     #Else
      Declare Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long
    #End If

    Declare PtrSafe Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long

    When I paste above code in macro, text turns red, and highlight the word "PtrSafe" and show interpretation error (which must be Sub or Function)

    Do you have any suggestions on what wrong it is?
    Thank you very much for any suggestions :>


    Thanks in advance for any suggestions


    Tuesday, December 2, 2014 12:38 AM
  • Yes, I think most of the API function you are using only need to have PtrSafe in front of the Function.

    For example:

    ' Note: PtrSafe in front of Function 
    Declare PtrSafe Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long

    Btw. Below link will help you how to declare the API, download the API reference and search the API you are looking for on how to declare in 64 -bit.

    Win32API_PtrSafe with 64-bit Support

    Btw. If your application needs to support both, use something like this:

    #If VBA7 Then
      Declare PtrSafe Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long
     #Else
      Declare Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long
    #End If

    Declare PtrSafe Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long

    When I paste above code in macro, text turns red, and highlight the word "PtrSafe" and show interpretation error (which must be Sub or Function)

    Do you have any suggestions on what wrong it is?
    Thank you very much for any suggestions :>


    Thanks in advance for any suggestions


    Sorry that's my bad, this should be the correct code:

    #If VBA7 Then
      Declare PtrSafe Function mixerClose Lib "winmm.dll" Alias "mixerClose" (ByVal hmx As LongPtr) As Long
     #Else
      Declare Function mixerClose Lib "winmm.dll" _
                         (ByVal hmx As Long) As Long
    #End If

    Hope this helps,


    Daniel van den Berg | Washington, USA | "Anticipate the difficult by managing the easy"

    Please vote an answer helpful if they helped. Please mark an answer(s) as an answer when your question is being answered.

    Tuesday, December 2, 2014 5:03 AM
  • #If VBA7 Then Declare PtrSafe Function mixerClose Lib "winmm.dll" Alias "mixerClose" (ByVal hmx As LongPtr) As Long #Else Declare Function mixerClose Lib "winmm.dll" _ (ByVal hmx As Long) As Long #End If

    Private Declare Function mixerClose Lib "winmm.dll" (ByVal hmx As Long) As Long

    compile error
    non-confirm name : mixerClose

    I get compile error and would like to know on whether I need to load any library before function or not.

    Do you have any suggestions?
    Thank you very much for any suggestions :>



    Thanks in advance for any suggestions

    Tuesday, December 2, 2014 5:38 AM
  • There is all the coding, when I run it.

    It shows red color for PtrSafe code, and shows compile error for mixerClose code.

    Do you have any suggestions on what wrong it is?
    Thank you very much for any suggestions :>

    Option Explicit
    #If VBA7 Then
    Declare PtrSafe Function mixerClose Lib "winmm.dll" Alias "mixerClose" (ByVal hmx As LongPtr) As Long
    #Else
        Declare Function mixerClose Lib "winmm.dll" (ByVal hmx As Long) As Long
    #End If

    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_SETCONTROLDETAILSF_VALUE = &H0&

    Private Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2&
    Private Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0&

    Private Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = _
      (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4)

    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 hmixer As Long          ' mixer handle
    Private volCtrl As MIXERCONTROL ' waveout volume control

    Private 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

    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 rc As Long              ' return code
      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
    End Function

    Public Sub SetVolume(ByVal vol As Long)
      Dim ok As Boolean           ' boolean return code
      Dim rc As Long              ' return code
      ' 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 Then
        ' If the function successfully gets the volume control,
        ' the maximum and minimum values are specified by
        ' lMaximum and lMinimum
        If vol < volCtrl.lMinimum Then
          vol = volCtrl.lMinimum
        End If
        If vol > volCtrl.lMaximum Then
          vol = volCtrl.lMaximum
        End If
        SetVolumeControl hmixer, volCtrl, vol
      End If
    End Sub

    ' Example of use:
    Sub Test()
    SetVolume 25000


    End Sub
    '

       

    Thanks in advance for any suggestions

    Tuesday, December 2, 2014 11:18 PM
  • Does anyone have any suggestions?
    Thanks, to everyone very much for any suggestions :>

    Thanks in advance for any suggestions

    Friday, December 5, 2014 1:28 AM
  • Does anyone have any suggestions on what wrong it is on setting volume within win7 (64 bit)?
    Thanks, to everyone very much for any suggestions :>

    Thanks in advance for any suggestions

    Tuesday, December 9, 2014 8:26 AM