Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

 

Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long

 

Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

 

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long

 

Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long

 

Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

 

Private Const HKEY_CLASSES_ROOT = &H80000000

 

Private aIcons() As String

 

Private Sub Form_Load()

 

Dim sType As String

 

Dim sName As String

 

Dim sFile As String

 

Dim iIndex As Integer

 

Dim lRegKey As Long

 

Dim iFoundCount As Integer

 

iIndex = 1

 

iFoundCount = 1

 

sType = Space(255)

 

'Ïåðå÷èñëåíèå âñåõ ðàñøèðåíèé

 

Do While RegEnumKey(HKEY_CLASSES_ROOT, iIndex, ByVal sType, 255) = 0

 

If Left(sType, 1) <> "." Then

 

Else

 

'Ñîõðàíåíèå èíôîðìàöèè îá èêîíêå

 

ReDim Preserve aIcons(iIndex - 1)

 

sType = Left(sType, InStr(sType, Chr(0)) - 1)

 

'Ïîëó÷èòü èìÿ ðàñøèðåíèÿ, (ê ïðèìåðó - .zip = WinZip)

 

If RegOpenKey(HKEY_CLASSES_ROOT, ByVal sType, lRegKey) = 0 Then

 

sName = Space(255)

 

Call RegQueryValueEx(lRegKey, ByVal "", 0&, 1, ByVal sName, 255)

 

If InStr(sName, Chr(0)) Then sName = Left(sName, InStr(sName, Chr(0)) - 1)

 

Call RegCloseKey(lRegKey)

 

If Len(Trim(sName)) Then

 

'Ïîèñê èêîíêè ïî óìîë÷àíèþ äëÿ ðàñøèðåíèÿ

 

If RegOpenKey(HKEY_CLASSES_ROOT, sName & "\DefaultIcon\", lRegKey) = 0 Then

 

sFile = Space(255)

 

Call RegQueryValueEx(lRegKey, ByVal "", 0&, 1, ByVal sFile, 255)

 

If InStr(sFile, Chr(0)) Then sFile = Left(sFile, InStr(sFile, Chr(0)) - 1)

 

Call RegCloseKey(lRegKey)

 

aIcons(iFoundCount - 1) = sFile

 

End If

 

End If

 

End If

 

List1.AddItem Left(sType & Space(10), 10) & " - " & sName

 

iFoundCount = iFoundCount + 1

 

End If

 

sType = Space(255)

 

iIndex = iIndex + 1

 

Loop

 

End Sub

 

Private Sub List1_Click()

 

Dim sFile As String

 

Dim iIndex As Integer

 

Dim lIcon As Long

 

Picture1.Cls

 

On Error GoTo IconErr

 

 

sFile = Left$(aIcons(List1.ListIndex), InStr(aIcons(List1.ListIndex), ",") - 1)

 

iIndex = Val(Mid$(aIcons(List1.ListIndex), InStr(aIcons(List1.ListIndex), ",") + 1))

 

lIcon = ExtractIcon(App.hInstance, sFile, iIndex)

 

Call DrawIconEx(Picture1.hdc, 0, 0, lIcon, 32, 32, 0, 0, 3)

 

IconErr:

 

End Sub