Public Declare Function AssocQueryKey Lib "shlwapi.dll" Alias "AssocQueryKeyA" _
 (ByVal Flags As ASSOCF, ByVal key As ASSOCKEY, _
 ByVal pszAssoc As String, ByVal pszExtra As String, _
 ByRef phkeyOut As Long) As Long

Public Function AssocQKey(ByVal Flags As ASSOCF, ByVal GetKey As ASSOCKEY, _
 ByVal m_Ext As String, Optional ByVal m_Verb As String = "") As Long
  Dim Verb As String
  Dim n As Long
   
  ' Always ignore "Unknown" progids
  Flags = Flags Or ASSOCF_IGNOREUNKNOWN
   
  ' Different strings need different verbs.
  Select Case GetKey
    Case ASSOCSTR_SHELLNEWVALUE, ASSOCSTR_INFOTIP, _
     ASSOCSTR_QUICKTIP, ASSOCSTR_CONTENTTYPE, _
     ASSOCSTR_DEFAULTICON, ASSOCSTR_SHELLEXTENSION
      Verb = vbNullString
    Case Else
      Verb = m_Verb
  End Select
   
  ' Use the AssocQueryKey API to find application
  ' associated with passed document extension.
  n = AssocQueryKey(Flags, GetKey, m_Ext, Verb, AssocQKey)
  If n = S_OK Then
    'для проверки читаем какую-нибудь value, напр. default
    MsgBox GetRegValue(AssocQKey, "", "", "", False)
    RegCloseKey AssocQKey
  End If
End Function

Private Sub CommandProgID_Click()
  MsgBox AssocQKey(0&, ASSOCKEY_CLASS, ".jpg")
End Sub

Public Enum KEY_INFORMATION_CLASS
  KeyBasicInformation = 0
  KeyNodeInformation = 1
  KeyFullInformation = 2
  KeyNameInformation = 3
  KeyCachedInformation = 4
  KeyFlagsInformation = 5
  KeyVirtualizationInformation = 6
  KeyHandleTagsInformation = 7
  MaxKeyInfoClass = 8
End Enum

Public Type KEY_NAME_INFORMATION
  NameLength As Long
  Name As String
End Type

Private Const STATUS_BUFFER_TOO_SMALL = &HC0000023
Private Const STATUS_SUCCESS = 0
 
Public Declare Function NtQueryKey Lib "ntdll.dll" (ByVal KeyHandle As Long, _
 ByVal KeyInformationClass As KEY_INFORMATION_CLASS, KeyInformation As Any, _
 ByVal length As Long, ByRef ResultLength As Long) As Long
Public Function GetRegKeyName(ByVal hKey As Long) As String

  Dim Buffer As String
  Dim m_size As Long

  'запрашиваем сначала длину буфера
  If NtQueryKey(hKey, _
   KeyNameInformation, ByVal 0&, 0, m_size) = STATUS_BUFFER_TOO_SMALL Then
    m_size = m_size + 2
    Buffer = StrConv(String$(m_size / 2, 0), vbUnicode) 'size is in bytes
    If NtQueryKey(hKey, KeyNameInformation, ByVal Buffer, m_size, m_size) _
     = STATUS_SUCCESS Then
     'первые 4 байта NameLength -длина Name
     GetRegKeyName = _
      StrConv(Left(Right(Buffer, Len(Buffer) - 4), AscW(Left(Buffer, 2))), vbFromUnicode)
    End If
  End If
End Function

Public Enum KEY_INFORMATION_CLASS
  KeyBasicInformation = 0
  KeyNodeInformation = 1
  KeyFullInformation = 2
  KeyNameInformation = 3
  KeyCachedInformation = 4
  KeyFlagsInformation = 5
  KeyVirtualizationInformation = 6
  KeyHandleTagsInformation = 7
  MaxKeyInfoClass = 8
End Enum

Public Type KEY_NAME_INFORMATION
  NameLength As Long
  UName() As Byte
End Type

Private Const STATUS_BUFFER_TOO_SMALL = &HC0000023
Private Const STATUS_SUCCESS = 0
 
Public Declare Function NtQueryKey Lib "ntdll.dll" (ByVal KeyHandle As Long, _
 ByVal KeyInformationClass As KEY_INFORMATION_CLASS, KeyInformation As Any, _
 ByVal length As Long, ByRef ResultLength As Long) As Long

Public Const CP_ACP = 0 'ANSI CodePage

Public Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, _
                                                    ByVal dwFlags As Long, _
                                                    ByVal lpWideCharStr As Long, _
                                                    ByVal cchWideChar As Long, _
                                                    ByVal lpMultiByteStr As Long, _
                                                    ByVal cbMultiByte As Long, _
                                                    ByVal lpDefaultChar As Long, _
                                                    ByVal lpUsedDefaultChar As Long) As Long


Public Function GetRegKeyName(ByVal hKey As Long) As String
  Dim m_size As Long
  Dim i As Long

  'запрашиваем сначала длину буфера (в байтах)
  If NtQueryKey(hKey, _
   KeyNameInformation, ByVal 0&, 0, m_size) = STATUS_BUFFER_TOO_SMALL Then

    Dim ByteStrUnicode() As Byte
    ReDim ByteStrUnicode(0 To m_size - 1) 'резервируем буфер
    If NtQueryKey(hKey, KeyNameInformation, ByVal VarPtr(ByteStrUnicode(0)), m_size, m_size) _
     = STATUS_SUCCESS Then
      'первые 4 байта - это NameLength (длина Name в байтах)
      CopyMemory m_size, ByVal VarPtr(ByteStrUnicode(0)), 4
      m_size = m_size / 2 'длина строки в символах = длине ANSI-байт массива
      Dim ByteStrANSI() As Byte
      ReDim ByteStrANSI(0 To m_size - 1) 'резервируем буфер для приема ANSI-строки
      If WideCharToMultiByte(CP_ACP, 0&, ByVal VarPtr(ByteStrUnicode(4)), m_size, _
       ByVal VarPtr(ByteStrANSI(0)), m_size, 0&, 0&) <> 0 Then
        For i = 0 To m_size - 1
          If ByteStrANSI(i) = 0 Then Exit For 'страховка
          GetRegKeyName = GetRegKeyName & Chr(ByteStrANSI(i))
        Next i
      End If
    End If
  End If
End Function