Controlling the System Sounds (Warnings, Notifications etc) via CoreAudio Interfaces.

[Jaafar Tribak]

Hi excel/vba enthusiasts,

In this recent thread, the topic of muting the system sounds came up ... With the advent of Windows Vista, the mixer\sounds are per process and Winmm.lib legacy audio apis don't seem to be working for selectively controlling individual sound sessions.

After some exploring, I have succeeded in pulling this through using interfaces in the coreaudio api ... It is all achieved without the need for 3rd party libraries or any references. Just plain vba api calls.

Basically, the aim of the code is simple. It just enables the user to set\get the system sounds volume without altering any other currently active sound session like in browsers, other running processes & media apps etc. I guess, this same approach could be tweaked\extended in a nice class wrapper to control all sound sessions in the mixer, not just the System sounds.

File Demo:
SystemSounds_Control.xlsm



1- In a Standard Module :

Option Explicit

Private Enum VOL_ACTION
    ºSetVol
    ºGetVol
End Enum

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 Sub SetSystemSoundsVol(ByVal VolLevel As Single)
    Audio ºSetVol, VolLevel '0.00 to 1
End Sub

Public Function GetSystemSoundsVol() As Single
    GetSystemSoundsVol = Audio(ºGetVol) '0.00 to 1
End Function



' _________________________________________PRIVATE 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_IAudioSessionManager2 = "{77AA99A0-1BD6-484F-8BC7-2C654C9A9B6F}"
    Const IID_IAudioSessionControl2 = "{bfb7ff88-7239-4fc9-8fa2-07c950be9c6d}"
    Const IID_ISimpleAudioVolume = "{87CE5498-68D6-44E5-9215-6DA47EF883D8}"
    Const IID_NULL = "{00000000-0000-0000-0000-000000000000}"
    Const CLSCTX_INPROC_SERVER = 1&
    Const CC_STDCALL = 4&, S_OK = 0&
    
    #If Win64 Then
        Const PTR_SIZE = 8&, NULL_PTR = 0^
    #Else
        Const PTR_SIZE = 4&, NULL_PTR = 0&
    #End If

    Dim tClsID As GUID, tIID As GUID
    Dim pDeviceEnumerator As LongPtr, pdefaultDevice As LongPtr
    Dim pSessionEnum As LongPtr, pSessionManager2 As LongPtr
    Dim pSessionCtl2 As LongPtr, pAudiSessionCtl As LongPtr, pSimpl As LongPtr
    Dim i As Long, lCnt As Long
    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.": GoTo CleanUp
  
    'IMMDeviceEnumerator::GetDefaultAudioEndpoint Method.
     eRender = 0&: eMultimedia = 1&
    lRet = vtblCall(pDeviceEnumerator, 4& * PTR_SIZE, vbLong, CC_STDCALL, eRender, eMultimedia, VarPtr(pdefaultDevice))
    If lRet Then MsgBox "Failed to get IMMDevice.": GoTo CleanUp
    
    'IMMDevice::Activate Method. 'Get audio SessionManager2 interface.
    lRet = IIDFromString(StrPtr(IID_IAudioSessionManager2), tIID)
    lRet = vtblCall(pdefaultDevice, 3& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(tIID), CLSCTX_INPROC_SERVER, 0&, VarPtr(pSessionManager2))
    If lRet Then MsgBox "Failed to get IAudioEndpointVolume.": GoTo CleanUp

    'IID_IID_IAudioSessionManager2::GetSessionEnumerator.
    lRet = vtblCall(pSessionManager2, 5& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(pSessionEnum))
    If lRet Then MsgBox "Failed to get SessionEnumerator.": GoTo CleanUp

    'Get the sessions count.
    lRet = vtblCall(pSessionEnum, 3& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(lCnt))
    If lRet Then MsgBox "Failed to get SessionEnumerator count.": GoTo CleanUp
    
    For i = 0& To (lCnt - 1&)
        'IID_IAudioSessionEnumerator::GetSession.
        lRet = vtblCall(pSessionEnum, 4& * PTR_SIZE, vbLong, CC_STDCALL, i, VarPtr(pAudiSessionCtl))
        If lRet Then MsgBox "Failed to get SessionEnumerator count.": GoTo CleanUp
    
        'Cast IAudioSessionControl to IAudioSessionControl2.
        lRet = IIDFromString(StrPtr(IID_IAudioSessionControl2), tIID)
        lRet = vtblCall(pAudiSessionCtl, 0& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(tIID), VarPtr(pSessionCtl2))
        If lRet Then MsgBox "Failed to cast IAudioSessionControl to IAudioSessionControl2": GoTo CleanUp
    
        'Check if we are dealing with the system sounds ssystem.
        'IAudioSessionControl2::IsSystemSoundsSession.
        If vtblCall(pSessionCtl2, 15& * PTR_SIZE, vbLong, CC_STDCALL) = S_OK Then
    
            'Cast IAudioSessionControl2 to ISimpleAudioVolume.
            lRet = IIDFromString(StrPtr(IID_ISimpleAudioVolume), tIID)
            lRet = vtblCall(pSessionCtl2, 0& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(tIID), VarPtr(pSimpl))
            If lRet Then MsgBox "Failed to cast IAudioSessionControl2 to ISimpleAudioVolume": GoTo CleanUp
    
            If eAction = ºSetVol Then
                'ISimpleAudioVolume::SetMasterVolume
                lRet = IIDFromString(StrPtr(IID_NULL), tIID)
                lRet = vtblCall(pSimpl, 3& * PTR_SIZE, vbLong, CC_STDCALL, CSng(VolLevel), VarPtr(tIID))
            ElseIf eAction = ºGetVol Then
                'ISimpleAudioVolume::GetMasterVolume
                lRet = IIDFromString(StrPtr(IID_NULL), tIID)
                lRet = vtblCall(pSimpl, 4& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(Audio))
            End If
            
        End If
    
        lRet = vtblCall(pSimpl, 2& * PTR_SIZE, vbLong, CC_STDCALL)
        lRet = vtblCall(pSessionCtl2, 2& * PTR_SIZE, vbLong, CC_STDCALL)
        lRet = vtblCall(pAudiSessionCtl, 2& * PTR_SIZE, vbLong, CC_STDCALL)
   Next i

CleanUp:
  
    'Release Interfaces.
    lRet = vtblCall(pSimpl, 2& * PTR_SIZE, vbLong, CC_STDCALL)
    lRet = vtblCall(pSessionCtl2, 2& * PTR_SIZE, vbLong, CC_STDCALL)
    lRet = vtblCall(pAudiSessionCtl, 2& * PTR_SIZE, vbLong, CC_STDCALL)
    lRet = vtblCall(pSessionEnum, 2& * PTR_SIZE, vbLong, CC_STDCALL)
    lRet = vtblCall(pSessionManager2, 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

2- Usage Examples:

Option Explicit

Sub Test1()

    Const sPrompt = "The System sounds "

    SetSystemSoundsVol VolLevel:=0 'Mute
    'The following MsgBox Critical sound is now muted.
    MsgBox "SystemSounds Volume =  [ " & FormatPercent(GetSystemSoundsVol, 1&, True) & " ]" _
    & vbLf & vbLf & sPrompt & "have been muted.", vbExclamation
    
    SetSystemSoundsVol VolLevel:=1 'UnMute
    'The following MsgBox Critical sound is now active.
    MsgBox "SystemSounds Volume =  [ " & FormatPercent(GetSystemSoundsVol, 1&, True) & " ]" _
    & vbLf & vbLf & sPrompt & "are now back to active.", vbExclamation

End Sub

Sub Test2()
    SetSystemSoundsVol VolLevel:=0.5 'Half volume
    MsgBox FormatPercent(GetSystemSoundsVol, 1&, True), vbInformation
End Sub

 

[Jaafar Tribak]