Получение длинных имен аудиоустройств на Vista/Win7 - VB

Private Function CallPointer(ByVal fnc As Long, ParamArray params()) As Long

Private Function Invoke_(unk As IUnknown, ByVal VtblIndex As Long, _
                         ParamArray Args() As Variant) As Variant
  Dim pArgs() As Long, vt() As Integer, c As Long, i As Long, hr As Long

  c = UBound(Args) + 1
  ReDim pArgs(0 To c + (c > 0)): ReDim vt(0 To UBound(pArgs))
  For i = 0 To c - 1
    vt(i) = VarType(Args(i)): pArgs(i) = VarPtr(Args(i))
  Next i
  hr = DispCallFunc(ObjPtr(unk), VtblIndex * 4, CC_STDCALL, _
                    vbLong, c, vt(0), pArgs(0), Invoke_)
  If hr < 0 Then Err.Raise hr
End Function

'Private Type IPropertyStoreVtbl 'http://msdn.microsoft.com/en-us/library/bb761474%28VS.85%29.aspx
'' IUnknown                                Interface
'  QueryInterface                          As Long '[0]
'  AddRef                                  As Long '[1]
'  Release                                 As Long '[2]
'' IPropertyStore                          Interface
'  GetCount                                As Long '[3]
'  GetAt                                   As Long '[4]
'  GetValue                                As Long '[5]
'  SetValue                                As Long '[6]??
'  Commit                                  As Long'End Type

Public Function PrintEndpointNames(the_listbox As ListBox) As Boolean
  If IsVistaSimple = False Then
    PrintEndpointNames = False
    Exit Function
  Else
    PrintEndpointNames = True
  End If
  
  the_listbox.Clear

  Dim tGuidMMDeviceEnumerator As GUID
  IIDFromString StrPtr(CLSID_MMDeviceEnumerator), tGuidMMDeviceEnumerator
  
  Dim tGuidIMMDeviceEnumerator As GUID
  IIDFromString StrPtr(IID_IMMDeviceEnumerator), tGuidIMMDeviceEnumerator

  Dim hr As Long
  hr = 0
  
  Dim PKEY_Device_FriendlyName As PROPERTYKEY
  With PKEY_Device_FriendlyName
    IIDFromString StrPtr(GUID_PKEY_Device_FriendlyName), .the_GUID 'CLSIDFromString
    .the_PID = PID_PKEY_Device_FriendlyName
  End With
  
  Dim hlMMDeviceEnumerator          As IUnknown
  Set hlMMDeviceEnumerator = Nothing
  
  Dim hlMMDeviceCollection          As IUnknown
  Set hlMMDeviceCollection = Nothing
  
  Dim hlMMDevice                    As IUnknown
  Set hlMMDevice = Nothing
  
  Dim hlPropertyStore               As IUnknown
  Set hlPropertyStore = Nothing
    
  Dim hlPointerID As Long
  hlPointerID = 0

' get the device enumerator
  hr = CoCreateInstance(tGuidMMDeviceEnumerator, 0, _
                        CLSCTX_ALL, tGuidIMMDeviceEnumerator, _
                        hlMMDeviceEnumerator)
  If hr = S_OK Then
    'get the endpoint collection
    hr = Invoke_(hlMMDeviceEnumerator, 3, eRender, DEVICE_STATE_ACTIVE Or DEVICE_STATE_UNPLUGGED, _
      VarPtr(hlMMDeviceCollection)) '[3]=IMMDeviceEnumerator::EnumAudioEndpoints
    If hr = S_OK Then
      'get the size of the collection
      Dim lCount As Long
      lCount = 0
      hr = Invoke_(hlMMDeviceCollection, 3, VarPtr(lCount)) '[3]=IMMDeviceCollection::GetCount
      If hr = S_OK Then
        Dim i As Long
        Dim bExitLoop As Boolean
        bExitLoop = False
        For i = 0 To lCount - 1
          'Get pointer to endpoint number i.
          hr = Invoke_(hlMMDeviceCollection, 4, Abs(i), VarPtr(hlMMDevice)) '[4]=IMMDeviceCollection::Item
                   'Abs(i), т.к.[in]UINT nDevice, ни Long ни Integer понимать не хочет
          If Not (hr = S_OK) Then
            bExitLoop = True
          Else
            'Get the endpoint ID string.
            hr = Invoke_(hlMMDevice, 5, VarPtr(hlPointerID)) '[5]=IMMDevice::GetId
            If Not (hr = S_OK) Then
              bExitLoop = True
            Else
              'get the human readable name
              hr = Invoke_(hlMMDevice, 4, STGM_READ, VarPtr(hlPropertyStore)) '[4]=IMMDevice::OpenPropertyStore
              If Not (hr = S_OK) Then
                bExitLoop = True
              Else
                Dim varName As PROPVARIANT
                hr = Invoke_(hlPropertyStore, 5, VarPtr(PKEY_Device_FriendlyName), VarPtr(varName))
                '[5]=IPropertyStore::GetValue
                If Not (hr = S_OK) Then
                  bExitLoop = True
                Else
                  the_listbox.AddItem PointerToString(varName.pwszVal)
                  CoTaskMemFree hlPointerID
                  hlPointerID = 0
                  PropVariantClear varName
                  SAFE_RELEASE hlPropertyStore
                  SAFE_RELEASE hlMMDevice
                End If
              End If
            End If
          End If
          If bExitLoop Then Exit For
        Next i
      End If
    End If
  End If
  SAFE_RELEASE hlMMDeviceEnumerator
  SAFE_RELEASE hlMMDeviceCollection
End Function

Private Function SAFE_RELEASE(objecta As IUnknown) As Long
  SAFE_RELEASE = 0
  If Not (objecta Is Nothing) Then
    'SAFE_RELEASE = Invoke_(objecta, 2) '[2]=IUnknown::Release 'может привести к краш-да ну его
    Set objecta = Nothing
  End If
End Function

Private Type PROPVARIANT 'http://msdn.microsoft.com/en-us/library/aa380072(v=vs.85).aspx
  vt                                      As Integer 'VT_LPWSTR
  wReserved1                              As Integer
  wReserved2                              As Integer
  wReserved3                              As Integer
  pwszVal                                 As Long   ' union LPWSTR pwszVal;
                                                    'A pointer to a null-terminated Unicode string
                                                    'in the user default locale.
  Padding As Long ' 16 Bytes
End Type