Справочник функций

Ваш аккаунт

Войти через: 
Забыли пароль?
Регистрация
Информацию о новых материалах можно получать и без регистрации:

Последние темы форума

Показать новые сообщения »

Почтовая рассылка

Подписчиков: 11642
Последний выпуск: 19.06.2015

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

Пономаренко Владимир
www.vbstreets.ru

Например Вам понравилась верхняя иконка программы, рисунка, любых файлов.

Буду Краток. Нам Понадобятся:

  • 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

Вот и Всё, И Быстро и удобно.

Можно Конечно Чтобы Рисунок Прозрачный Был, Но Тяги НЕТ Всё Описывать.

Оставить комментарий

Комментарий:
можно использовать BB-коды
Максимальная длина комментария - 4000 символов.
 
Реклама на сайте | Обмен ссылками | Ссылки | Экспорт (RSS) | Контакты
Добавить статью | Добавить исходник | Добавить хостинг-провайдера | Добавить сайт в каталог