Извлечение иконок

Command Button - Command1 TextBox - Text1 PictureBox - Picture1 А также для удобства брауза файлов CommonDialog - CD1 Ну А Теперь Самое Интересное, Конечно Же VB Код: 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 DrawIcon Lib "user32" (ByVal hDC As Long, _ ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long Private Declare Function DestroyIcon Lib "user32" _ (ByVal hIcon As Long) As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type 'Разные Функции Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Const SRCCOPY = &HCC0020 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 SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Const CF_BITMAP = 2 Private Sub Command1_Click() CD1.ShowOpen 'Открываем Брауз Text1.Text = CD1.FileName 'Присваеваем Тексту Путь и Имя Файла Picture1.Cls 'Очищаем Картинку От Старой Иконки Dim sPath As String, hIcon As Long, nIcon As Long 'Присваеваем Переменные sPath = Text1.Text 'Берем путь из Текста 'Забираем Верхнюю Иконку hIcon = ExtractAssociatedIcon(App.hInstance, sPath, nIcon) DrawIcon Picture1.hDC, 0&, 0&, hIcon 'Вставляем иконку в PictureBox DestroyIcon hIcon 'Берём Иконку CopyEntirePicture Picture1 'Вставляем иконку в буфер обмена. 'Теперь Можно Вставлять Иконку Хоть Куда End Sub 'Функция Тута (Копирование Рисунка) Public Function CopyEntirePicture(ByRef objFrom As Object) As Boolean Dim lhDC As Long Dim lhBMP As Long Dim lhBMPOld As Long Dim lWidthPixels As Long Dim lHeightPixels As Long lhDC = CreateCompatibleDC(objFrom.hDC) If (lhDC <> 0) Then lWidthPixels = objFrom.ScaleX(objFrom.ScaleWidth, objFrom.ScaleMode, vbPixels) lHeightPixels = objFrom.ScaleY(objFrom.ScaleHeight, objFrom.ScaleMode, vbPixels) lhBMP = CreateCompatibleBitmap(objFrom.hDC, lWidthPixels, lHeightPixels) If (lhBMP <> 0) Then lhBMPOld = SelectObject(lhDC, lhBMP) BitBlt lhDC, 0, 0, lWidthPixels, lHeightPixels, objFrom.hDC, 0, 0, SRCCOPY SelectObject lhDC, lhBMPOld OpenClipboard 0 EmptyClipboard SetClipboardData CF_BITMAP, lhBMP CloseClipboard End If DeleteObject lhDC End If End Function