Creating Icons on the fly in VB6
William Leader
code I draw to a picture box. I do draw to it transparently so some parts of
the picturebox contain the default grey background. Now, using the
CreateIconIndirect API call I have been able to make a valid Icon in memmory
and get a handle for it. I am also able to set the dragicon property of the
picture to that icon in memory using OleCreatePictureIndirect API call. I am
able to sucessfully set the icon, but what is displayed on the screen has
the grey background part of the picture box. So I have a feeling that when
using the CreateIconIndirect I need to fix or supply the transparency
information. Now before I start giving you code to pour over,
The code I am using to create the icon in memmory the code in this message
nearly verbatim.
http://groups.google.com/groups?hl=en&lr=&ie=UTF-8&oe=UTF-8&selm=up%24tU%245TDHA.1724%40TK2MSFTNGP10.phx.gbl
Now if I understand this code correctly It does create a mask and pass that
mask to the CreateIconIndirect through the ICON info structure, but it
doesn't seem to create the mask as I would expect it should. anyway the code
in that message gives me an Icon handle.
I also use the code as shown in this message:
http://groups.google.com/groups?hl=en&lr=&ie=UTF-8&oe=UTF-8&selm=eCELjoCF%23GA.233%40uppssnewspub05.moswest.msn.net
I feel that code works just fine.
here is what I am using in my app (simplified).
Dim hICon As Long
hICon = ImageToIcon(Picture1)
Picture1.DragIcon = GetPicture(hICon, vbPicTypeIcon, False)
Any suggesstions on getting transparancy working? Like I said this does get
me a dragicon that is the contents of the picture box, I just don't want the
dragicon to have the grey background.
If anyone wants I'll send them a zip file with the test code.
-Will
mayayana
for a drag icon why not just save it in a resource file?
Picture1.DragIcon = LoadResPicture("DRAGICO1", 1)
--
--
William Leader <lea...@k2wrpg.no.spam.org> wrote in message
news:orqdnZIj8sR...@usadatanet.net...
William Leader
Thats why I have to create an icon from the contents of a picture or
bitmap in memory.
-Will
William Leader
I still don't know how to do it.
In the ImageToIcon function described here:
http://groups.google.com/groups?hl=en&lr=&ie=UTF-8&oe=UTF-8&selm=up%24tU%245TDHA.1724%40TK2MSFTNGP10.phx.gbl
There is a variable hmask that points to a monochrome bitmap in memory.
Right now this bitmap is a solid square, I need to change it to match the
transparent area of the source image. I guess this would be done through
some bitblting. Anyhelp in creating a mask would be appreciated.
-Will
Larry Serflaten
"William Leader" <lea...@k2wrpg.no.spam.org> wrote
I played with this a bit, but I could not get it to work so I did not reply.
I was successful at creating a monochrome bitmap, but I was unsuccessful
at making the image on it of the desired shape. What I had planned to do
was to alter that function you linked to, so that is accepted 2 pictureboxes
one for the mask and another for the color image. Like you, when I used
the original function I saw the color image with no transparency, and when
I tried to create the mask, I gat tranparency, but not at all like the mask
image it was made from. I am aware that Windows stores images with
the scan lines in reversed order, but I was trying to make a circle which
should be pretty close, right side up, or up side down. What I got did
not resemble a circle at all.
I'll post it so you can see where I was heading, but again, I did not get
it to work, and it may not be cleaning up after itself as it should....
I got the idea from:
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/winui/windowsuserinterface/resources/icons/usingicons.asp
On a new form, add 2 picture boxes, and set their BorderStyle properties
to 0 and AutoRedraw properties to True. Then paste in the code below,
run it, and try to drag the color image to see the result as its DragIcon.
HTH
LFS
Option Explicit
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" ( _
piconinfo As IconInfo) As Long
Private Declare Function DestroyIcon Lib "user32" ( _
ByVal hIcon As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" ( _
ByVal nWidth As Long, ByVal nWidth As Long, _
ByVal nPlanes As Long, ByVal nBitCount As Long, _
lpBits As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObj As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PICTDESC
cbSize As Long
picType As Long ' one of VB's PictureTypeConstants
hImage As Long ' HBITMAP, HMETAFILE, HICON, HENHMETAFILE
Data1 As Long ' HBITMAP HPALETTE, HMETAFILE xExt
Data2 As Long ' HMETAFILE yExt
End Type
' Note that StdPicture is a interface implemented by the OLE
' Automation type library Stdole2.tlb. You will need to add
' a project reference to the typelib in order to use this function.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(pPictDesc As PICTDESC, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ppvObj As StdPicture) As Long
Private Const S_OK = 0 ' indicates successful HRESULT
' Creates a picture object from an image handle
' hImage - either an HBITMAP, HMETAFILE, HICON or HENHMETAFILE
' dwPicType - one of VB's PictureTypeConstants describing the hImage param.
' fDestroyHandle - flag specifying whether the new picture destroys hImage when
' the picture itself is destroyed. Don't destroy it twice!!! ...or else
' Returns a VB Picture object on success, or the object value "Nothing" on error.
Public Function GetPicture(hImage As Long, _
dwPicType As PictureTypeConstants, _
fDestroyHandle As Boolean) As StdPicture
Dim pd As PICTDESC
Dim IID_IDispatch As GUID
If hImage = 0 Then Exit Function
' Fill picture description
With pd
.cbSize = LenB(pd)
.picType = dwPicType 'vbPicTypeIcon
.hImage = hImage
End With
' Fill IDispatch Interface ID, {00020400-0000-0000-C000-000000046}
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Create the Picture object
Call OleCreatePictureIndirect(pd, IID_IDispatch, fDestroyHandle, GetPicture)
End Function
Public Function ImageToIcon( _
ByVal Color As PictureBox, _
ByVal mask As PictureBox, _
Optional ByVal HotX As Long = 0, _
Optional ByVal HotY As Long = 0) As Long
Dim Info As IconInfo
Dim mono(0 To 128) As Byte
Dim X As Long, Y As Long, byt As Long, msk As Long
' Create mono data from mask image
byt = 128
For Y = 0 To 31
For X = 0 To 31
msk = (Y * 4 + X \ 8)
mono(msk) = mono(msk) Or (byt And mask.Point(X, Y))
' Checking for correct data
'Debug.Print X, Y, msk, mono(msk)
'PSet (X, Y), (byt And mono(msk)) > 0
byt = byt \ 2
If byt = 0 Then byt = 128
Next X
Next Y
' Get mask image from data
msk = CreateBitmap(32, 32, 1, 1, mono(0))
'msk = CreateBitmap(32, 32, 1, 1, ByVal 0&)
If msk Then
' Fill ICONINFO struct
Info.fIcon = True
Info.hbmColor = Color.Picture.Handle
Info.hbmMask = msk
Info.xHotspot = HotX
Info.yHotspot = HotY
' Create the icon
ImageToIcon = CreateIconIndirect(Info)
End If
End Function
Private Sub Form_Load()
Dim Handle As Long
Dim msk As StdPicture
Show
Picture1.Move 30, 30, 32, 32
Picture2.Move 30, 80, 32, 32
Picture1.DrawWidth = 8
Picture2.DrawWidth = 8
Picture1.Circle (16, 16), 12, vbRed
Picture2.BackColor = vbWhite
Picture2.Circle (16, 16), 12, vbBlack
Set msk = Picture1.Image
'Set Picture2.Picture = Nothing
Handle = ImageToIcon(Picture1, Picture2, 16, 16)
If Handle Then
Picture1.DragIcon = GetPicture(Handle, vbPicTypeIcon, False)
Else
Stop
End If
End Sub
-----= Posted via Newsfeeds.Com, Uncensored Usenet News =-----
http://www.newsfeeds.com - The #1 Newsgroup Service in the World!
-----== Over 100,000 Newsgroups - 19 Different Servers! =-----
William Leader
inverted the mask (like a photo negative?) I'll try it out when i get home,
but could you describe what you did see?
-Will
"Larry Serflaten" <Ab...@SpamBusters.com> wrote in message
news:40637...@corp.newsgroups.com...
Larry Serflaten
"William Leader" <lea...@k2wrpg.no.spam.org> wrote
> I'm not at home right now so I can't test, but I wonder if perhaps you
> inverted the mask (like a photo negative?) I'll try it out when i get home,
> but could you describe what you did see?
> -Will
It would be hard to explain. It was a black and white image, but it
was no where near a circle as it should have been. There were some
transparent parts, and a few inverted parts....
As I said, it did not work right! ;-)
But it might be closer than what you've got so far and you may see
something I overlooked...
Good luck!
LFS
William Leader
11111111111111111111111111111111
11111111111100000000011111111111
11111111100000000000000011111111
11111110000000000000000000111111
11111100000000000000000000011111
11111000000000000000000000001111
11110000000000000000000000000111
11100000000000000000000000000011
11100000000000000000000000000011
11000000000001111111000000000001
11000000000011111111100000000001
11000000000111111111110000000001
10000000001111111111111000000000
10000000011111111111111100000000
10000000011111111111111100000000
10000000011111111111111100000000
00000000111111111111111100000000
10000000011111111111111100000000
10000000011111111111111100000000
10000000011111111111111100000000
10000000001111111111111000000000
11000000000111111111110000000001
11000000000011111111100000000001
11000000000001111111000000000001
11100000000000000000000000000011
11100000000000000000000000000011
11110000000000000000000000000111
11111000000000000000000000001111
11111100000000000000000000011111
11111110000000000000000000111111
11111111100000000000000011111111
11111111111100000000011111111111
So I am prety sure that your logic for creating the mask bits is good,
but I picked up on this. In the line
msk = CreateBitmap(32, 32, 1, 1, mono(0))
What is happening here is the create bitmap function is getting passed
the value of mono(0), in this case 255. So I don't think the function
is getting the whole array. I'm going to play with this little bit.
and see what happens.
-Will
Larry Serflaten
"William Leader" <lea...@no.k2wrpg.spam.org> wrote
> but I picked up on this. In the line
>
> msk = CreateBitmap(32, 32, 1, 1, mono(0))
>
> What is happening here is the create bitmap function is getting passed
> the value of mono(0), in this case 255. So I don't think the function
> is getting the whole array. I'm going to play with this little bit.
> and see what happens.
I tried that code, and noticed I forgot to mention several settings, like
set everything to Pixels, and set Picture1.DragMode to automatic.
Sorry about that!
Sending mono(0) to the function actually passes the pointer to
to that value, which is the beginning of the data. So passing that
first value is like passing a pointer to the array. That should be
OK.
A few changes I made showed significant improvement. Try these
modifications and see if you get a white circle as the drag icon:
' Double the size of the array:
Dim mono(0 To 256) As Byte
' Fill that section with the AND mask
(inside the X Y loops)
msk = (Y * 4 + X \ 8)
mono(msk) = mono(msk) Or (byt And mask.Point(X, Y))
mono(msk + 128) = mono(msk) Xor &HFF ' <----- ADD THIS
byt = byt \ 2
If byt = 0 Then byt = 128
' Then tell the API the bitmap is larger:
msk = CreateBitmap(32, 64, 1, 1, mono(0))
I don't know why the color is not showing, but since this is
much farther along, I thought I would post it.... I also did not
know when you'd get back to the group which is why I CC'd
you a copy. If you'd rather not get them direct, then just mention
it, and I'll stop, no problem....
Larry Serflaten
the color to show. Here is what I have, but I am
not certain who is responsible for clean up of
the monochrome handle. That could be a source
of a memory leak if the code is supposed to
destroy it, but does not. Just a heads up to do
a bit more research....
Here is what I have that works on my W2K system.
To try it out, just add 2 pictureboxes to a form
and paste in the code....
HTH
LFS
Option Explicit
End Function
Dim mono(0 To 127) As Byte
Dim X As Long, Y As Long, byt As Long, msk As Long
' Create mono data from mask image
byt = 128
For Y = 0 To 31
For X = 0 To 31
msk = (Y * 4 + X \ 8)
mono(msk) = mono(msk) Or (byt And mask.Point(X, Y))
byt = byt \ 2
If byt = 0 Then byt = 128
Next X
Next Y
' Get mask image from data
msk = CreateBitmap(32, 32, 1, 1, mono(0))
Color.Picture = Color.Image
If msk Then
' Fill ICONINFO struct
Info.fIcon = 1
Info.hbmColor = Color.Picture.handle
Info.hbmMask = msk
Info.xHotspot = HotX
Info.yHotspot = HotY
' Create the icon
ImageToIcon = CreateIconIndirect(Info)
End If
End Function
Private Sub Form_Load()
Dim handle As Long
Show
ScaleMode = vbPixels
AutoRedraw = True
Picture1.Move 30, 30, 32, 32
Picture2.Move 30, 80, 32, 32
Picture1.ScaleMode = vbPixels
Picture2.ScaleMode = vbPixels
Picture1.BorderStyle = 0
Picture2.BorderStyle = 0
Picture1.AutoRedraw = True
Picture2.AutoRedraw = True
Picture1.DragMode = 1
Picture1.DrawWidth = 7
Picture1.BackColor = vbBlack
Picture1.Circle (16, 16), 11, vbRed
Picture1.DrawWidth = 5
Picture1.Line (10, 10)-(22, 22), vbYellow
Picture2.DrawWidth = 9
Picture2.BackColor = vbWhite
Picture2.Circle (16, 16), 11, vbBlack
Picture2.DrawWidth = 7
Picture2.Line (10, 10)-(22, 22), vbBlack
handle = ImageToIcon(Picture1, Picture2, 16, 16)
If handle Then
Picture1.DragIcon = GetPicture(handle, vbPicTypeIcon, False)
Else
Stop
End If
End Sub
-----= Posted via Newsfeeds.Com, Uncensored Usenet News =-----
Larry Serflaten
It urns out, this is all that was needed:
Public Function ImageToIcon( _
ByVal Color As PictureBox, _
ByVal Mask As PictureBox, _
Optional ByVal HotX As Long = 0, _
Optional ByVal HotY As Long = 0) As Long
Dim Info As IconInfo
Color.Picture = Color.Image
Mask.Picture = Mask.Image
' Fill ICONINFO struct
Info.fIcon = True
Info.hbmColor = Color.Picture.Handle
Info.hbmMask = Mask.Picture.Handle
Info.xHotspot = HotX
Info.yHotspot = HotY
' Create the icon
ImageToIcon = CreateIconIndirect(Info)
End Function
Oh well!
LFS
William Leader
be in the picture box. (which is really what I need..) However the
nested loops slow things down. this takes about .17 seconds on my
Duron 1.8 Ghz. (which I feel is too long) I suspect it could be done
much faster using bitblt, but I really don't understand the bitblt
well enough to do that for myself.
-Will
Public Function ImageToIcon( _
ByVal Color As PictureBox, _
ByVal Mask As PictureBox, _
Optional ByVal HotX As Long = 0, _
Optional ByVal HotY As Long = 0, _
Optional ByVal TransColor As Long = 0) As Long
Dim Info As IconInfo
Dim X As Integer
Dim Y As Integer
Color.Picture = Color.Image
'create the mask
'there is probably a faster way to do this with bitblts
Mask.BackColor = vbWhite
Mask.Cls
For X = 0 To 31
For Y = 0 To 31
If Color.Point(X, Y) <> TransColor Then
Mask.PSet (X, Y), vbBlack
End If
Next Y
Next X
Mask.Picture = Mask.Image
' Fill ICONINFO struct
Info.fIcon = True
Info.hbmColor = Color.Picture.handle
Info.hbmMask = Mask.Picture.handle
Larry Serflaten
"William Leader" <lea...@no.k2wrpg.spam.org> wrote in message
> This Variation allows the mask to be created from any image that might
> be in the picture box. (which is really what I need..) However the
> nested loops slow things down. this takes about .17 seconds on my
> Duron 1.8 Ghz. (which I feel is too long) I suspect it could be done
> much faster using bitblt, but I really don't understand the bitblt
> well enough to do that for myself.
http://www.mvps.org/vb/hardcore/html/thewindowswayofpainting.htm
There is a bit of reading material for ya. Hit the >> button in the upper
right to advance a few pages to see what its about....
Specifically, here is how to create masks....
http://www.mvps.org/vb/hardcore/html/creatingmasks.htm
HTH
Murphy McCauley
"William Leader" <lea...@no.k2wrpg.spam.org> wrote in message
news:2gjb60p43uv8007dr...@4ax.com...
...
> ' Fill ICONINFO struct
> Info.fIcon = True
> Info.hbmColor = Color.Picture.handle
> Info.hbmMask = Mask.Picture.handle
> Info.xHotspot = HotX
> Info.yHotspot = HotY
...
The hotspot is ignored when fIcon is set to True. It only matters for
cursors. So you should either extend your function to make cursors as well,
or just remove the hotspot stuff.
Secondly, according to MSDN:
"Because the system may temporarily select the bitmaps in a device context,
the hbmMask and hbmColor members of the ICONINFO structure should not
already be selected into a device context."
The .Picture.handle bitmaps are already selected into the PictureBox, I must
imagine... so you should make copies of them and hand THOSE to
CreateIconIndirect(). And then delete them, obviously.
Murphy
www.ConstantThought.com