如何使用宏设置音量？ [英] How to set volume using macro?

问题描述

以下宏在PC上的XP下工作，但不在笔记本电脑上的Win 7 Home下工作。



有没有人对错误提出任何建议？

提前感谢任何建议

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

明确选项



Dim hmixer As Long          '混音器手柄

Dim volCtrl As MIXERC​​ONTROL'波形音量控制器

Dim micCtrl作为MIXERC​​ONTROL'麦克风音量控制器

Dim rc As Long               '返回代码

Dim ok As Boolean           '布尔返回代码

Dim vol As Long             'volume

Dim cnt As Long

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

 

'打开带有deviceID 0的调音台。

    rc = mixerOpen（hmixer，0,0,0,0）

   如果（（MMSYSERR_NOERROR<> rc））那么

       MsgBox"无法打开调音台。"&
      退出子

   结束如果



    '获取waveout音量控制权
    OK = GetVolumeControl（hmixer，_

&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP ;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP; MIXERLINE_COMPONENTTYPE_DST_SPEAKERS，_

&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP; &NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP; MIXERC​​ONTROL_CONTROLTYPE_VOLUME，_

&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP ;             volCtrl）

   如果确定则为
        SetVolumeControl hmixer，volCtrl，
10000

   结束如果



结束子

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

推荐答案

你好，

似乎您的问题与Excel开发无关，它与VBA和Windows API有关。 SetVolumeControl在Windows XP和Windows7之间是不同的。我认为

VBA论坛是一个更适合你的地方。

Seems that your question is not related to Excel Development, it's all about VBA and Windows API. SetVolumeControl is different between Windows XP and Windows7. I think VBA forum is a more suitable place for you.

无论如何，我做了一些搜索，找到了这段代码，你可以尝试一下，它适用于Win7 X64：

Any way, I did some search, and found this code, you can try it, it's for Win7 X64:

Option Explicit

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:
' SetVolume 25000

这篇关于如何使用宏设置音量？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！