Option Explicit
Private Enum VOL_ACTION
ºSetVol
ºGetVol
ºMute
ºUnMute
ºIsMuteState
End Enum
#If Win64 Then
Private Const NULL_PTR = 0^
Private Const PTR_SIZE = 8&
#Else
Private Const NULL_PTR = 0&
Private Const PTR_SIZE = 4&
#End If
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0& To 7&) As Byte
End Type
#If VBA7 Then
Private Declare PtrSafe Sub SetLastError Lib "Kernel32.dll" (ByVal dwErrCode As Long)
Private Declare PtrSafe Function DispCallFunc Lib "OleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef lpiid As Any) As Long
Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Sub SetLastError Lib "Kernel32.dll" (ByVal dwErrCode As Long)
Private Declare Function DispCallFunc Lib "OleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef lpiid As Any) As Long
Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
#End If
' _________________________________________PUBLIC CLASS METHODS _____________________________________
Public Sub Mute(Optional ByVal bMute As Boolean = True)
If bMute Then
Audio ºMute
Else
Audio ºUnMute
End If
End Sub
Public Sub SeVol(ByVal VolLevel As Single)
Audio ºSetVol, VolLevel
End Sub
Public Function GetVol() As Single
GetVol = Audio(ºGetVol)
End Function
Public Function IsMuteState() As Boolean
IsMuteState = Audio(ºIsMuteState)
End Function
' _________________________________________PRIVATE HELPER ROUTINES _____________________________________
Private Function Audio(eAction As VOL_ACTION, Optional VolLevel As Single = -1&) As Single
Const CLSID_MMDeviceEnumerator = "{BCDE0395-E52F-467C-8E3D-C4579291692E}"
Const IID_IMMDeviceEnumerator = "{A95664D2-9614-4F35-A746-DE8DB63617E6}"
Const IID_IAudioEndpointVolume = "{5CDF2C82-841E-4546-9722-0CF74078229A}"
Const IID_NULL = "{00000000-0000-0000-0000-000000000000}"
Const CLSCTX_INPROC_SERVER = 1&
Const CC_STDCALL = 4&
Dim tClsID As GUID, tIID As GUID
Dim pDeviceEnumerator As LongPtr, pdefaultDevice As LongPtr, pIAudioEndpointVolume As LongPtr
Dim eRender As Long, eMultimedia As Long
Dim lRet As Long
If VolLevel <> -1& Then
If VolLevel < 0& Or VolLevel > 1& Then
MsgBox "Audio-tapered value must be in the range from 0.0 to 1.0"
Exit Function
End If
End If
lRet = CLSIDFromString(StrPtr(CLSID_MMDeviceEnumerator), tClsID)
lRet = IIDFromString(StrPtr(IID_IMMDeviceEnumerator), tIID)
'Create an enumerator for the audio endpoint devices
lRet = CoCreateInstance(tClsID, NULL_PTR, CLSCTX_INPROC_SERVER, tIID, pDeviceEnumerator)
If lRet Then MsgBox "Failed to get IMMDeviceEnumerator.": Exit Function
eRender = 0&: eMultimedia = 1&
'IMMDeviceEnumerator::GetDefaultAudioEndpoint Method.
lRet = vtblCall(pDeviceEnumerator, 4& * PTR_SIZE, vbLong, CC_STDCALL, eRender, eMultimedia, VarPtr(pdefaultDevice))
If lRet Then MsgBox "Failed to get IMMDevice.": Exit Function
lRet = IIDFromString(StrPtr(IID_IAudioEndpointVolume), tIID)
'IMMDevice::Activate Method.
lRet = vtblCall(pdefaultDevice, 3& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(tIID), CLSCTX_INPROC_SERVER, 0&, VarPtr(pIAudioEndpointVolume))
If lRet Then MsgBox "Failed to get IAudioEndpointVolume.": Exit Function
lRet = IIDFromString(StrPtr(IID_NULL), tIID)
Select Case eAction
Case ºMute
'IAudioEndpointVolume::SetMute Method.(True)
lRet = vtblCall(pIAudioEndpointVolume, 14& * PTR_SIZE, vbLong, CC_STDCALL, 1&, VarPtr(tIID))
Case ºUnMute
'IAudioEndpointVolume::SetMute Method. (False)
lRet = vtblCall(pIAudioEndpointVolume, 14& * PTR_SIZE, vbLong, CC_STDCALL, 0&, VarPtr(tIID))
Case ºSetVol
'IAudioEndpointVolume::SetMasterVolumeLevelScalar Method.
lRet = vtblCall(pIAudioEndpointVolume, 7& * PTR_SIZE, vbLong, CC_STDCALL, CSng(VolLevel), VarPtr(tIID))
Case ºGetVol
'IAudioEndpointVolume::GetMasterVolumeLevelScalar Method.
lRet = vtblCall(pIAudioEndpointVolume, 9& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(Audio))
Case ºIsMuteState
'IAudioEndpointVolume::GetMute Method.
lRet = vtblCall(pIAudioEndpointVolume, 15& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(Audio))
End Select
'Release Interfaces.
lRet = vtblCall(pIAudioEndpointVolume, 2& * PTR_SIZE, vbLong, CC_STDCALL)
lRet = vtblCall(pdefaultDevice, 2& * PTR_SIZE, vbLong, CC_STDCALL)
lRet = vtblCall(pDeviceEnumerator, 2& * PTR_SIZE, vbLong, CC_STDCALL)
End Function
Private Function vtblCall(ByVal InterfacePointer As LongPtr, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
Dim vParamPtr() As LongPtr
If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function
Dim pIndex As Long, pCount As Long
Dim vParamType() As Integer
Dim vRtn As Variant, vParams() As Variant
vParams() = FunctionParameters()
pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
If pCount = 0& Then
ReDim vParamPtr(0& To 0&)
ReDim vParamType(0& To 0&)
Else
ReDim vParamPtr(0& To pCount - 1&)
ReDim vParamType(0& To pCount - 1&)
For pIndex = 0& To pCount - 1&
vParamPtr(pIndex) = VarPtr(vParams(pIndex))
vParamType(pIndex) = VarType(vParams(pIndex))
Next
End If
pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
vParamType(0&), vParamPtr(0&), vRtn)
If pIndex = 0& Then
vtblCall = vRtn
Else
SetLastError pIndex
End If
End Function
