Как добиться корректного отображения альфа-канала

[Space]

в ф-и IconToPicture?

Код: Выделить всё

Private Type PictDesc
    cbSizeofStruct As Long
    PicType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type
Private Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As _
PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long

Public Function IconToPicture(ByVal hIcon As Long) As StdPicture
    If hIcon = 0 Then Exit Function
    Dim oNewPic As Picture
    Dim tPicConv As PictDesc
    Dim IGuid As Guid
    With tPicConv
    .cbSizeofStruct = Len(tPicConv)
    .PicType = vbPicTypeIcon
    .hImage = hIcon
    End With
    With IGuid
    .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
    OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
    Set IconToPicture = oNewPic
End Function

[arthur2]

Видимо, никак Объект stdpicture в бейсике просто не умеет его понимать... точнее, не знаю, как сам объект, но контролы - точно не понимают. Не веришь - попробуй загрузить иконку с альфой в пикчебокс через дизайнер.

Просто рисуй иконку на пикчебоксе с помощью DrawIconEx - и будет тебе альфа-канал

[Space]

просто рисовать мне не подходит, просто рисование выливается в размер картинки 32х32, а мне надо 16х16. Также надо использовать SavePicture.
А что за метод использован в рисовании таких иконок в ListView, вот кусок кода:

Код: Выделить всё

' Set the item index (is zero-based)
  lvi.iItem = li.Index - 1

  ' Get the item's icon index within the system's small imagelist.
  ' (indices of images in the small and large imagelists are the same)
  lvi.iImage = GetFileIconIndexPIDL(pidlfqChild, SHGFI_SMALLICON)
   
  ' Add any overlay image...
  ' Overlay images reside in bits 8-11 of the system's normal imagelist
  ' (as opposed to a state imagelist). The share overlay is the 1st image,
  ' shortcut is 2nd, 3rd, and 4th images vary. The SFGAO_SHARE
  ' (folders) and SFGAO_LINK (files) attributes are mutually exclusive.
  If (ulAttr And (SFGAO_SHARE Or SFGAO_LINK)) Then
    lvi.mask = LVIF_IMAGE Or LVIF_STATE
    lvi.stateMask = LVIS_OVERLAYMASK
    If (ulAttr And SFGAO_SHARE) Then
      lvi.state = INDEXTOOVERLAYMASK(1)
    Else   ' (ulAttr And SFGAO_LINK)
      lvi.state = INDEXTOOVERLAYMASK(2)
    End If
  Else
    lvi.mask = LVIF_IMAGE   ' no overlay...
  End If

  ' And set the item's icon, with any overlay
  Call ListView_SetItem(objLV.hWnd, lvi)

что тут за маски и оверлей, что они дают? Как переводится коммент "Overlay images reside ..."?

[arthur2]

просто рисовать мне не подходит, просто рисование выливается в размер картинки 32х32, а мне надо 16х16

Одно с другим никак не связано.

[JohnK]

А так подойдет?

Код: Выделить всё

Private Type TypeIcon
cbSize As Long
picType As PictureTypeConstants
hIcon As Long
End Type

Private Type CLSID
id(16) As Byte
End Type

Private Const MAX_PATH = 260

Private Type SHFILEINFO
hIcon As Long ' out: icon
iIcon As Long ' out: icon index
dwAttributes As Long ' out: SFGAO_ flags
szDisplayName As String * MAX_PATH ' out: display name (or path)
szTypeName As String * 80 ' out: type name
End Type

Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, ByRef lpiIcon As Long) As Long
Private Declare Function DrawIcon Lib "user32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long

Private Const SHGFI_ICON = &H100
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_SMALLICON = &H1

Private Function IconToPicture(hIcon As Long) As IPictureDisp
Dim cls_id As CLSID
Dim hRes As Long
Dim new_icon As TypeIcon
Dim lpUnk As IUnknown

With new_icon
.cbSize = Len(new_icon)
.picType = vbPicTypeIcon
.hIcon = hIcon
End With
With cls_id
.id(8) = &HC0
.id(15) = &H46
End With
hRes = OleCreatePictureIndirect(new_icon, cls_id, 1, lpUnk)
If hRes = 0 Then Set IconToPicture = lpUnk
End Function

Private Function GetIcon(filename As String, icon_size As Long) As IPictureDisp
Dim index As Integer
Dim hIcon As Long
Dim item_num As Long
Dim icon_pic As IPictureDisp
Dim sh_info As SHFILEINFO

SHGetFileInfo filename, 0, sh_info, Len(sh_info), SHGFI_ICON + icon_size
hIcon = sh_info.hIcon

Set icon_pic = IconToPicture(hIcon)
Set GetIcon = icon_pic
End Function

Private Sub Command1_Click()
On Error GoTo LoadPictureError

Picture1.Picture = GetIcon(Text1.Text, SHGFI_SMALLICON)
Exit Sub

LoadPictureError:
End Sub

Private Sub Form_Load()
Text1.Text = "Путь к экзешнику"
End Sub



[arthur2]

http://vsokovikov.narod.ru/New_MSDN_API ... n_icon.htm

[Space]

А так подойдет?

Альфа-канала нет, заменил код на прорисовку, прорисовки нет...

Код: Выделить всё

Dim hIcon As Long

Private Type TypeIcon
cbSize As Long
picType As PictureTypeConstants
hIcon As Long
End Type

Private Type CLSID
id(16) As Byte
End Type

Private Const MAX_PATH = 260

Private Type SHFILEINFO
hIcon As Long ' out: icon
iIcon As Long ' out: icon index
dwAttributes As Long ' out: SFGAO_ flags
szDisplayName As String * MAX_PATH ' out: display name (or path)
szTypeName As String * 80 ' out: type name
End Type

Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, ByRef lpiIcon As Long) As Long
Private Declare Function DrawIcon Lib "user32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long

Private Const SHGFI_ICON = &H100
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_SMALLICON = &H1

Private Function IconToPicture(hIcon As Long) As IPictureDisp
Dim cls_id As CLSID
Dim hRes As Long
Dim new_icon As TypeIcon
Dim lpUnk As IUnknown

With new_icon
.cbSize = Len(new_icon)
.picType = vbPicTypeIcon
.hIcon = hIcon
End With
With cls_id
.id(8) = &HC0
.id(15) = &H46
End With
hRes = OleCreatePictureIndirect(new_icon, cls_id, 1, lpUnk)
If hRes = 0 Then Set IconToPicture = lpUnk
End Function

Private Function GetIcon(filename As String, icon_size As Long) As IPictureDisp
Dim index As Integer
Dim item_num As Long
Dim icon_pic As IPictureDisp
Dim sh_info As SHFILEINFO

SHGetFileInfo filename, 0, sh_info, Len(sh_info), SHGFI_ICON + icon_size
hIcon = sh_info.hIcon

Set icon_pic = IconToPicture(hIcon)
Set GetIcon = icon_pic
End Function

Private Sub Command1_Click()
On Error GoTo LoadPictureError

'Picture1.Picture = GetIcon(Text1.Text, SHGFI_SMALLICON)
GetIcon Text1.Text, SHGFI_SMALLICON
DrawIcon Picture1.hdc, 0, 0, hIcon
Exit Sub

LoadPictureError:
End Sub

Private Sub Form_Load()
Text1.Text = "c:\WINDOWS\System32\shell32.dll"
End Sub

[Space]

Одно с другим никак не связано.

Не понял, что с чем не связано?

[arthur2]

просто рисование никак не связано с тем, что ты вместо хендла значка 16х16 получил хендл значка 32х32. Ты путаешь файл иконки и значки из этого файла. Хендл относится не к файлу, а к значку - что извлёк, то и нарисуешь.

[Space]

ладно. Ну вот, например, тут viewtopic.php?p=6726082#p6726082 почему не отрисовывает?

[Space]

artur2, вот код, показывающий, как DrawIcon рисует иконки 16х16

[arthur2]

Замени на DrawIconEx

[Space]

DrawIconEx не работает

[arthur2]

С чего бы это? Всё как надо работает
viewtopic.php?p=6726076#p6726076

[Space]

ну где ж работает?

[arthur2]

DI_NORMAL

[Space]

у меня не работает Picture1.Cls! Остаётся Picture, загруженное в дизайнере. Что такое?

[arthur2]

cls очищает то, что нарисовано на контроле. То, что загружено в свойство picture, очищается загрузкой другой картинки (ну или loadpictre() без параметров)

[Space]

LoadPicture очищает и то, что нарисовано. Прикольно. Зачем нужны 2 метода очистки?

[arthur2]

затем, что это не метод очистки

[Space]

однако, очищает лучше его Как мне теперь показать эту иконку в ListView, ReportIcon?

[Space]

люди, ау!