Use WIA 2.0 and an ImageList to load a PNG file as a StdPicture. Then draw using DrawIconEx(), which seems to hold the alchemy here.
Code:
Option Explicit
Private Const WIN32_NULL As Long = 0
Private Enum DI_FLAGS
DI_MASK = &H1&
DI_IMAGE = &H2&
DI_NORMAL = &H3&
DI_COMPAT = &H4&
DI_DEFAULTSIZE = &H8&
DI_NOMIRROR = &H10&
End Enum
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 DI_FLAGS) As Long
Private PngAsIcon As StdPicture
Private WidthPx As Long
Private HeightPx As Long
Private Coords As Collection
Private Sub Backdrop()
Dim I As Single
For I = 0 To ScaleWidth Step ScaleX(15, vbPixels)
Line (I, 0)-(I, ScaleHeight), &HC0E0C0
Next
For I = 0 To ScaleHeight Step ScaleX(15, vbPixels)
Line (0, I)-(ScaleWidth, I), &HFFC0C0
Next
End Sub
Private Sub DrawCenteredAt(ByVal X As Single, ByVal Y As Single)
DrawIconEx hDC, _
ScaleX(X, ScaleMode, vbPixels) - WidthPx \ 2, _
ScaleY(Y, ScaleMode, vbPixels) - HeightPx \ 2, _
PngAsIcon.Handle, _
WidthPx, _
HeightPx, _
0, _
WIN32_NULL, _
DI_NORMAL
End Sub
Private Sub Form_Load()
With New WIA.ImageFile
.LoadFile "GlassBall.png"
WidthPx = .Width
HeightPx = .Height
ImageList1.ImageWidth = WidthPx
ImageList1.ImageHeight = HeightPx
ImageList1.ListImages.Add , , .FileData.Picture()
End With
Set PngAsIcon = ImageList1.ListImages.Item(1).ExtractIcon()
ImageList1.ListImages.Clear
Set Coords = New Collection
BackColor = &HF0F0FF
DrawWidth = 2
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
DrawCenteredAt X, Y
Coords.Add Array(X, Y)
End Sub
Private Sub Form_Resize()
Dim Coord As Variant
If WindowState <> vbMinimized Then
Cls
Backdrop
For Each Coord In Coords
DrawCenteredAt Coord(0), Coord(1)
Next
End If
End Sub
Private Sub Form_Load()
With New WIA.ImageFile
.LoadFile "GlassBall.png"
WidthPx = .Width
HeightPx = .Height
ImageList1.ListImages.Add , , .FileData.Picture()
End With
With ImageList1.ListImages
Set PngAsIcon = .Item(1).ExtractIcon()
.Clear
End With
Set Coords = New Collection
BackColor = &HF0F0FF
DrawWidth = 2
End Sub
Another rewrite showing loading from a Byte array instead of a file:
Code:
Private Sub Form_Load()
With New WIA.Vector
.BinaryData = LoadResData("GLASSBALL", "PNG")
With .ImageFile
WidthPx = .Width
HeightPx = .Height
End With
ImageList1.ListImages.Add , , .Picture()
End With
With ImageList1.ListImages
Set PngAsIcon = .Item(1).ExtractIcon()
.Clear
End With
Set Coords = New Collection
BackColor = &HF0F0FF
DrawWidth = 2
End Sub
It helps to have the CHM Help from the WIA 2.0 SDK, but if you failed to download it before Microsoft removed it you might have to search it out from less reputable sources.
With this CopyDibToIcon function it might be possible to emulate ExtractIcon method
Code:
Option Explicit
Private Declare Function APIGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateIconIndirect Lib "user32" (pIconInfo As ICONINFO) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, pUnk As IUnknown) As Long
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type
Private Type PICTDESC
lSize As Long
lType As Long
hBmp As Long
hPal As Long
End Type
Public Function CopyDibToIcon(ByVal hDib As Long) As StdPicture
Dim uBmp As BITMAP
Dim uInfo As ICONINFO
Dim hIcon As Long
Dim uDesc As PICTDESC
Dim IID_IUnknown(0 To 1) As Currency
If APIGetObject(hDib, Len(uBmp), uBmp) = 0 Then
GoTo QH
End If
With uInfo
.fIcon = 1
.hbmColor = hDib
.hbmMask = CreateBitmap(uBmp.bmWidth, uBmp.bmHeight, 1, 1, ByVal 0)
End With
hIcon = CreateIconIndirect(uInfo)
With uDesc
.lSize = Len(uDesc)
.lType = vbPicTypeIcon
.hBmp = hIcon
End With
IID_IUnknown(1) = 504403158265495.5712@
If OleCreatePictureIndirect(uDesc, IID_IUnknown(0), 1, CopyDibToIcon) <> 0 Then
GoTo QH
End If
hIcon = 0
QH:
If hIcon <> 0 Then
Call DestroyIcon(hIcon)
End If
If uInfo.hbmMask <> 0 Then
Call DeleteObject(uInfo.hbmMask)
End If
End Function
Can be used with something like this
Code:
With New WIA.ImageFile
.LoadFile "GlassBall.png"
Set PngAsIcon = CopyDibToIcon(.FileData.Picture.Handle)
End With
cheers,
</wqw>
Last edited by wqweto; Nov 11th, 2020 at 02:39 AM.
Option Explicit
Private Const BM_SETIMAGE As Long = &HF7&
Private Const IMAGE_ICON As Long = 1&
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const GWL_STYLE As Long = -16&
Private Enum BS_TEXTPOS_STYLES
[_BS_TEXTPOSMASK] = &HF00&
BS_LEFT = &H100&
BS_RIGHT = &H200&
BS_CENTER = &H300&
BS_TOP = &H400&
BS_BOTTOM = &H800&
BS_VCENTER = &HC00&
End Enum
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Sub IconizeButton( _
ByVal CommandButton As CommandButton, _
Optional ByVal Position As BS_TEXTPOS_STYLES = BS_CENTER)
'Assumes the CommandButton has an icon as its Picture property.
Dim NewStyle As Long
With CommandButton
NewStyle = GetWindowLong(.hWnd, GWL_STYLE) And Not [_BS_TEXTPOSMASK] Or Position
SetWindowLong .hWnd, GWL_STYLE, NewStyle
SendMessage .hWnd, BM_SETIMAGE, IMAGE_ICON, .Picture.Handle
End With
End Sub
Private Sub Backdrop()
Dim I As Single
For I = 0 To ScaleWidth Step ScaleX(15, vbPixels)
Line (I, 0)-(I, ScaleHeight), &HC0E0C0
Next
For I = 0 To ScaleHeight Step ScaleX(15, vbPixels)
Line (0, I)-(ScaleWidth, I), &HFFC0C0
Next
End Sub
Private Sub Form_Load()
Dim PngIcon As StdPicture
With New WIA.Vector
'Use a 32x32 image, the largest size for a normal MouseIcon (cursor):
.BinaryData = LoadResData("TRIANGLE", "PNG")
ImageList1.ListImages.Add , , .Picture()
End With
With ImageList1.ListImages
Set PngIcon = .Item(1).ExtractIcon()
.Clear
End With
'Because we are using an icon rather than a cursor we can't specify the hotspot
'so it will be at the center:
Set MouseIcon = PngIcon
MousePointer = vbCustom
'Now we'll just reuse the image for some CommandButton controls. These could
'be other sizes. A CC6 manifest is required or you won't see the icons:
Set Command1.Picture = PngIcon
IconizeButton Command1, BS_LEFT
Set Command2.Picture = PngIcon
IconizeButton Command2, BS_RIGHT
Set Command3.Picture = PngIcon
IconizeButton Command3, BS_CENTER Or BS_TOP
BackColor = &HF0F0FF
DrawWidth = 2
End Sub
Private Sub Form_Resize()
If WindowState <> vbMinimized Then
Cls
Backdrop
End If
End Sub
Option Explicit
'
'VB_PredeclaredId = True so we have a global instance
'
Private Const WIN32_FALSE As Long = 0
Private Const WIN32_TRUE As Long = Not WIN32_FALSE
Private Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function CLSIDFromString Lib "ole32" ( _
ByVal lpsz As Long, _
ByRef clsid As IID) As Long
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type
Private Declare Function CreateIconIndirect Lib "user32" (ByRef piconinfo As ICONINFO) As Long
Private Type PICTDESC_ICO
cbSizeofStruct As Long
picType As Long
hIcon As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32" ( _
ByRef PICTDESC_ICO As PICTDESC_ICO, _
ByRef riid As IID, _
ByVal fOwn As Long, _
ByRef IPic As IPicture) As Long
Private IID_IPicture As IID
Public Property Get Solid(ByVal BitmapPicture As StdPicture) As IPicture
Dim ICONINFO As ICONINFO
Dim hIcon As Long
Dim PICTDESC As PICTDESC_ICO
With ICONINFO
.fIcon = WIN32_TRUE
.hbmMask = BitmapPicture.Handle
.hbmColor = BitmapPicture.Handle
End With
hIcon = CreateIconIndirect(ICONINFO)
If hIcon <> 0 Then
With PICTDESC
.cbSizeofStruct = Len(PICTDESC)
.picType = vbPicTypeIcon
.hIcon = hIcon
End With
OleCreatePictureIndirect PICTDESC, _
IID_IPicture, _
WIN32_TRUE, _
Solid
End If
End Property
Private Sub Class_Initialize()
CLSIDFromString StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture
End Sub
I have no idea why I had named the property "Solid" here though, or why it wasn't a method instead. Function "FromBitmap" would make more sense.
Last edited by dilettante; Nov 10th, 2020 at 08:58 PM.
No ImageList, no WIA, and no (explicit) GDI+ though some of the GDI icon entrypoints used here may well employ GDI+ under the covers much as WIA 2.0 does.
If you only need to load-then-paint a PNG you can even skip the conversion to an icon-type StdPicture. Just be sure you manually DestroyIcon() then.
I know LaVolpe had explored PNG support via icons earlier. For all I know I've merely parroted him in a slow and bumbling manner here. Perhaps he will see this and weigh in. I wasn't trying to reinvent any wheels or take credit for being particularly clever about this.
Yes, this works on Vista but does *not* work on XP (tested on both). Loading PNGs with GDI+, converting to 32-bit premultiplied alpha DIBs and painting these with AlphaBlend does work on XP though.
For anything before XP there is no GDI+ available though AlphaBlend API *is* available since Win2000 and of course all hope is lost on NT4 where both are missing.
(I recently found out that even SetStretchBltMode to HALFTONE does *not* interpolate bitmaps upon downsizing on NT4, so no cheap SSAA (supersampling anti-aliasing) is available there too. HALFTONE stretching needs Win2000 video drivers at least.)
Experiment and you can find lots of ways to use PNG images instead of jaggier alternatives or hand-tooled antialiasing.
Code:
Option Explicit
Private Sub Form_Load()
Dim Parent As Integer
Dim ParentNode As ComctlLib.Node
Dim Child As Integer
With ImageList1.ListImages
.Add , , GetIcon.FromPngFile("button.png")
.Add , , GetIcon.FromPngFile("brush.png")
End With
With TreeView1
Set .ImageList = ImageList1
With .Nodes
For Parent = 1 To 4
Set ParentNode = .Add(, , , MonthName(Parent), 1)
For Child = 1 To 4
.Add ParentNode, tvwChild, , WeekdayName(Child), 2
Next
ParentNode.Expanded = True
Next
.Item(1).EnsureVisible 'Scroll to top.
End With
End With
End Sub
Private Sub Form_Resize()
If WindowState <> vbMinimized Then
TreeView1.Move 0, 0, ScaleWidth, ScaleHeight
End If
End Sub
These images are imperfect, being scaled down from larger originals. If you craft your own PNGs at the actual desired size appearance can improve a little more. I don't have a good tool for creating alpha anti-aliased images myself.
If you want to use any of the code above please note that in several cases there are bugs. The glaring one is where "UBound(Bytes) - 1" was used when it should be "+ 1" instead.
Sorry about that. I guess the code worked by luck not by design.
if png in the resources. can't set this icon handle to systray icon. but if load png in file "x:\xx.png". can set to systray icon. why. I test win10
I used PngThing.zip res can work ok。but i usde reshack to add new png to the res,can not show the systray ico。the question is how to add png images to res correctly
Last edited by xxdoc123; Mar 7th, 2021 at 06:12 PM.
if png in the resources. can't set this icon handle to systray icon. but if load png in file "x:\xx.png". can set to systray icon. why. I test win10
I used PngThing.zip res can work ok。but i usde reshack to add new png to the res,can not show the systray ico。the question is how to add png images to res correctly
o my god
i test
Code:
Public Function GetIconFromRes(mResPngName As String) As StdPicture
Dim Bytes() As Byte
Dim shIcon As Long
Bytes = LoadResData(mResPngName, "PNGT")
shIcon = CreateIconFromResourceEx(Bytes(0), UBound(Bytes) + 1&, WIN32_TRUE, &H30000, 0, 0, LR_DEFAULTCOLOR)
'hIcon = CopyImage(hIcon, IMAGE_ICON, 48, 48, 0)
Set GetIconFromRes = HandleToStdPicture(shIcon,vbPicTypeIcon)
'DestroyIcon hIcon
End Function
Private Function HandleToStdPicture(ByVal hImage As Long, ByVal imgType As PictureTypeConstants) As IPicture
' function creates a stdPicture object from an image handle (bitmap or icon)
Dim lpPictDesc(0 To 3) As Long, aGUID(0 To 3) As Long
lpPictDesc(0) = 16& ' faux PictDesc structure
lpPictDesc(1) = imgType
lpPictDesc(2) = hImage
' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
aGUID(0) = &H7BF80980
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
' create stdPicture
Call OleCreatePictureIndirect(lpPictDesc(0), aGUID(0), True, HandleToStdPicture)
End Function
in my form load to used
icoHandle = GetIconFromRes("CLOCK").Handle
m_oSysTray.IconHandle = icoHandle ' have no error,but can not show picture
now changed code to
Code:
Dim mp As StdPicture
Set mp = GetIconFromRes("CLOCK")
icoHandle = mp.Handle ' now work ok ......why ....That's weird
m_oSysTray.IconHandle = icoHandle