Хорошо, я очистил код. Метод ExtractAssociatedIcon возвращает значок 64x64, поэтому для примера я только что жестко запрограммировал этот размер. Picturebox был удален, и изображение было присвоено свойству изображения формы, чтобы избежать путаницы.
Пример: скопировать код в новую форму и запустить
Option Explicit
Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (ByRef PicDesc As PICTDESC_BMP, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PICTDESC_BMP
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Const DI_MASK = &H1
Const DI_IMAGE = &H2
Const DI_NORMAL = DI_MASK Or DI_IMAGE
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub Form_Load()
Call GetIcon("C:\Program Files\Internet Explorer\iexplore.exe")
End Sub
Private Sub GetIcon(ByVal sFileName As String)
Dim hIcon As Long
Dim hAssocIcon As Long
Dim sAssocFile As String * 260
Dim sCommand As String
Dim lDC As Long
Dim lBmp As Long
Dim R As RECT
Dim OldBMP As Long
Me.AutoRedraw = True
hIcon = ExtractAssociatedIcon(App.hInstance, sFileName, hAssocIcon)
If hIcon <> 0 Then 'no icons found - use icon generic icon resource
'Create a device context, compatible with the screen
lDC = CreateCompatibleDC(GetDC(0&))
'Create a bitmap, compatible with the screen
lBmp = CreateCompatibleBitmap(GetDC(0&), 64, 64)
'Select the bitmap into the device context
OldBMP = SelectObject(lDC, lBmp)
' Set the rectangles' values
R.Left = 0
R.Top = 0
R.Right = 64
R.Bottom = 64
' Fill the rect with white
FillRect lDC, R, 0
' Draw the icon
Call DrawIconEx(lDC, 0, 0, hIcon, 64, 64, 0, 0, DI_NORMAL)
Me.Picture = PictureFromBitmap(lBmp, 0&)
DestroyIcon (hIcon)
End If
Call SelectObject(lDC, OldBMP)
Call DeleteObject(lDC)
End Sub
Private Function PictureFromBitmap(ByVal hBmp As Long, ByVal hPal As Long) As StdPicture
Dim IPictureIID As GUID
Dim IPic As IPicture
Dim tagPic As PICTDESC_BMP
Dim lpGUID As Long
' Fill in the IPicture GUID
' {7BF80980-BF32-101A-8BBB-00AA00300CAB}
With IPictureIID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Set the properties on the picture object
With tagPic
.Size = Len(tagPic)
.Type = vbPicTypeBitmap
.hBmp = hBmp
.hPal = hPal
End With
' Create a picture that will delete it's bitmap when it is finished with it
Call OleCreatePictureIndirect(tagPic, IPictureIID, 1, IPic)
' Return the picture to the caller
Set PictureFromBitmap = IPic
End Function