[VB6, Vista+] Core Audio - Change the system default audio device

[fafalone]

Changing the system-wide default input and output audio devices

WARNING: This feature is not designed to be accessible to programs and uses a COM interface that is undocumented and unsupported by Microsoft. As such, it may not function in future versions of Windows.

Several times I've come across people asking how to change the default input/output devices through code, and usually the reply is that it isn't possible. Changing the device per-app is well documented, but many people want to be able to set the system-wide default like the Sound control panel applet does. Tonight I was looking into that a little deeper, and the applet does it through an undocumented private COM interface called IPolicyConfig. So naturally I immediately found the definition and added it to oleexp.

There's two versions of the interface included, one for Windows Vista (IPolicyConfigVista / CPolicyConfigVistaClient) and one for Windows 7 and higher (IPolicyConfig / PolicyConfigClient).
Using this interface to set the defaults is very easy:

Private pPolicyCfg As PolicyConfigClient

If (pPolicyCfg Is Nothing) Then
    Set pPolicyCfg = New PolicyConfigClient
End If
pPolicyCfg.SetDefaultEndpoint StrPtr(sDeviceID), eMultimedia
pPolicyCfg.SetDefaultEndpoint StrPtr(sDeviceID), eCommunications

It's actually far more complicated to figure out the device ID string that you need, as it's not name, it's a string like {0.0.1.00000000}.{b12f40bc-c3ec-4a74-afcc-4b6d0eb6914a}. The good news is enumerating all the devices and their IDs (as well as enabling them if you need to, as they need to be active to be set as default) was covered in my Core Audio Basics demo. The enumeration code is copied right out of that project.

Requirements
-Windows Vista or higher
-oleexp.tlb v4.11 or higher (new release for this demo)
-oleexp addon mIID.bas (included in oleexp download)
-oleexp addon mCoreAudio.bas (included in oleexp download)
-oleexp addon mPKEY.bas (included in oleexp download)

[neotechni]

Option Explicit

Private pPolicyCfg As PolicyConfigClient

Public Sub var_dump(Text() As String)
    Dim temp As Long
    Debug.Print "var_dump"
    For temp = 0 To UBound(Text)
        Debug.Print temp, Text(temp)
    Next
End Sub

Public Function EnumAudioDevices(Optional InputDevices As Boolean = True) As String()
    Dim sOut As String
    Dim i As Long
    Dim lp As Long
    Dim s1 As String
    Dim RET() As String
    Dim pDvEnum As MMDeviceEnumerator
    Set pDvEnum = New MMDeviceEnumerator
    Dim pDvCol As IMMDeviceCollection
    If InputDevices Then
        pDvEnum.EnumAudioEndpoints eCapture, DEVICE_STATE_ACTIVE, pDvCol
    Else
        pDvEnum.EnumAudioEndpoints eRender, DEVICE_STATE_ACTIVE, pDvCol
    End If
    If (pDvCol Is Nothing) = False Then
        Dim nCount As Long
        If pDvCol.GetCount(nCount) = S_OK Then
            ReDim RET(nCount - 1)
            For i = 0 To (nCount - 1)
                RET(i) = GetDeviceName(pDvCol, i)
            Next
        End If
    End If
    EnumAudioDevices = RET
End Function

Private Function GetDeviceName(pCol As IMMDeviceCollection, nIdx As Long) As String
    Dim pDevice As IMMDevice
    Dim sID As String
    Dim pStore As IPropertyStore
    Dim pDesc As IPropertyDescription
    Dim lp As Long
    Dim lpID As Long
    Dim vrProp As Variant
    Dim vProp As Variant
    Dim j As Long
    If (pCol.Item(nIdx, pDevice)) = S_OK Then
        pDevice.GetId lpID
        sID = LPWSTRtoStr(lpID)
        'Debug.Print "Got device(" & nIdx & ") id=" & sID
        If (sID = "") Or (sID = vbNullChar) Then
            GetDeviceName = "<Invalid DeviceID>"
            Exit Function
        End If
        pDevice.OpenPropertyStore STGM_READ, pStore
        If (pStore Is Nothing) = False Then
            'these property stores aren't as full-featured as other ones
            'such as those associated with IShellItem's of files.. for
            'example we can't use the superior PSFormatPropertyValue b/c
            'we can't get an IPropertyDescription, or a property name
            'So we're stuck using PropVariants, a nightmare in VB
            Dim pcnt As Long
            pStore.GetCount pcnt
            'Debug.Print "prop cnt=" & pcnt & " outputting propvariant..."
            Dim pk As PROPERTYKEY
            pStore.GetValue PKEY_Device_FriendlyName, vProp
            PropVariantToVariant vProp, vrProp
            Dim vte As VbVarType
            vte = VarType(vrProp)
            If (vte And vbArray) = vbArray Then 'this always seems to be vbString and vbArray, haven't encountered other types
                For j = LBound(vrProp) To UBound(vrProp)
                    Debug.Print "Array Value(" & j & ")=" & CStr(vrProp(j))
                Next j
            Else
                Select Case vte
                    Case vbDataObject, vbObject, vbUserDefinedType
                        GetDeviceName = "<cannot display this type>"
                    Case vbEmpty, vbNull
                        GetDeviceName = "<empty or null>"
                    Case vbError
                        GetDeviceName = "<vbError>"
                    Case Else
                        GetDeviceName = CStr(vrProp) & "|" & sID
                End Select
            End If
        Else
            GetDeviceName = "<Failed to get IPropertyStore>"
        End If
    Else
        GetDeviceName = "<Failed to get device with pCol.Item, nIdx=" & nIdx & ">"
    End If
End Function
Private Function GetDeviceNameDirect(pDevice As IMMDevice) As String
    Dim sID As String
    Dim pStore As IPropertyStore
    Dim pDesc As IPropertyDescription
    Dim lp As Long
    Dim lpID As Long
    Dim vrProp As Variant
    Dim vProp As Variant
    Dim j As Long
    pDevice.GetId lpID
    sID = LPWSTRtoStr(lpID)
    Debug.Print "GetDeviceNameDirect------------"
    Debug.Print "Got device id=" & sID
    If (sID = "") Or (sID = vbNullChar) Then
        GetDeviceNameDirect = "<Invalid DeviceID>"
        Exit Function
    End If
    pDevice.OpenPropertyStore STGM_READ, pStore
    If (pStore Is Nothing) = False Then
        'these property stores aren't as full-featured as other ones
        'such as those associated with IShellItem's of files.. for
        'example we can't use the superior PSFormatPropertyValue b/c
        'we can't get an IPropertyDescription, or a property name
        'So we're stuck using PropVariants, a nightmare in VB
        Dim pcnt As Long
        pStore.GetCount pcnt
        Debug.Print "prop cnt=" & pcnt & " outputting propvariant..."
        Dim pk As PROPERTYKEY
        pStore.GetValue PKEY_Device_FriendlyName, vProp
        PropVariantToVariant vProp, vrProp
        Dim vte As VbVarType
        vte = VarType(vrProp)
        If (vte And vbArray) = vbArray Then 'this always seems to be vbString and vbArray, haven't encountered other types
            For j = LBound(vrProp) To UBound(vrProp)
                Debug.Print "Array Value(" & j & ")=" & CStr(vrProp(j))
            Next j
        Else
            Select Case vte
                Case vbDataObject, vbObject, vbUserDefinedType
                    GetDeviceNameDirect = "<cannot display this type>"
                Case vbEmpty, vbNull
                    GetDeviceNameDirect = "<empty or null>"
                Case vbError
                    GetDeviceNameDirect = "<vbError>"
                Case Else
                    GetDeviceNameDirect = CStr(vrProp) & "|" & sID
            End Select
        End If
    Else
        GetDeviceNameDirect = "<Failed to get IPropertyStore>"
    End If
End Function

Public Function getSID(sID As String, Optional UseAsDefault As Boolean = False) As String
    Dim temp As Long
    If Left(sID, 1) <> "<" And Right(sID, 1) <> ">" Then
        temp = InStr(sID, "|")
        If temp > 0 Then sID = Mid$(sID, temp + 1)
        If UseAsDefault Then
            If (pPolicyCfg Is Nothing) Then Set pPolicyCfg = New PolicyConfigClient
            pPolicyCfg.SetDefaultEndpoint StrPtr(sID), eMultimedia
            pPolicyCfg.SetDefaultEndpoint StrPtr(sID), eCommunications
        End If
    Else
        sID = ""
    End If
    getSID = sID
End Function

Public Function FindDevice(Name As String, Optional InputDevices As Boolean = True, Optional UseAsDefault As Boolean = False) As String
    Dim AudioDevices() As String, temp As Long, sID As String, temp2 As Long
    AudioDevices = EnumAudioDevices(InputDevices)
    For temp = 0 To UBound(AudioDevices)
        sID = AudioDevices(temp)
        temp2 = InStr(sID, "|")
        If Left(sID, 1) <> "<" And Right(sID, 1) <> ">" And temp2 > 0 Then
            sID = Trim(Left(sID, temp2 - 1))
            If StrComp(Name, sID, vbTextCompare) = 0 Then
                FindDevice = getSID(AudioDevices(temp), UseAsDefault)
                Exit Function
            End If
        End If
    Next
End Function

I redid the code so it wasn't hardcoded to usercontrols, so I could re-use it in a command line interface.

EnumRenderDevices and EnumCaptureDevices were combined into EnumAudioDevices since there was only 1 word different between the 2.
It returns the list as a string array instead of putting it in a usercontrol

GetDeviceName and GetDeviceNameDirect had the debug.prints switched to returning a text in the form of "<error>" like the other errors.

Command1_Click and Command2_Click were combined into getSID which takes the ID text (example: BBY LCD TV-4 (NVIDIA High Definition Audio)|{0.0.0.00000000}.{a3654c19-7934-4b6b-8102-b0bb9f1921bf}) and spits out the ID code after the |
If UseAsDefault is true, it sets the input/output device to that ID code

FindDevice looks for the first device name (before the | ) and calls getSID

I don't want to sound rude, but I wish more developers would make code this way. That way the code is reusable from the start

[fafalone]

If you want to pay me to make it how you want instead of a 10 minute proof-of-concept job using whatever method strikes my mood, I'd be happy to oblige