Create Icons on the fly

Folks, I've written a function that creates icons and cursors on the fly, returning the handle of the created object. Is there some way to set a control's MouseIcon to this Icon/Cursor?



'Place in general section
Option Explicit
'Graphics
Private Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hDC 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)
Private Declare Function SetBkColor& Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long)
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)
Private Declare Function CreateCompatibleBitmap& Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) 'Icons
Private Declare Function CreateIconIndirect& Lib "user32" (piconinfo As ICONINFO)
Private Declare Function DestroyIcon& Lib "user32" (ByVal hIcon As Long)
Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function GetIconInfo& Lib "user32" (ByVal hIcon As Long, udpIconInfo As ICONINFO)
Private Declare Function SetTextColor& Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long)
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetPixel& Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long)
'System
Private Declare Function SelectObject& Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long)
Private Type ICONINFO
fIcon As Boolean
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type

Public Function PZNoteIconCreate(ByVal lopHPicture As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
ByVal MaskColor As Long, _
ByVal fIcon As Boolean, _
ByVal xHotspot As Long, _
ByVal yHotspot As Long)

'Where
'lopHPicture Handle for source picture
'x Left starting point on picture
'y Top starting point on picture
'Width Width of Icon
'Height Height of Icon
'MaskColor Mask Color
'fIcon As True if Icon/false if cursor
'xHotspot Cursor hotspot X
'yHotspot Cursor hotspot Y


Dim udpIF As ICONINFO
Dim lopIcon As Long
Dim lopLastBackColor As Long
Dim lopLastForeColor As Long

Dim lopSourcehDc As Long
Dim lopLastSourcehDc As Long

Dim lopIconBitmapDc As Long
Dim lopIconBitmap As Long
Dim lopLastIconBitmatDc As Long

Dim lopMonoMaskDc As Long
Dim lopMonoMaskBitmap As Long
Dim lopLastMonoMaskDc As Long


'Create Source hDc
lopSourcehDc = CreateCompatibleDC(0)
lopLastSourcehDc = SelectObject(lopSourcehDc, lopHPicture)
'Create Mask Bitmap
lopMonoMaskBitmap = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
lopMonoMaskDc = CreateCompatibleDC(0) 'Screen compatible device context
lopLastMonoMaskDc = SelectObject(lopMonoMaskDc, lopMonoMaskBitmap)
'Save dest backColor and textcolor
lopLastBackColor = SetBkColor(lopSourcehDc, MaskColor)
BitBlt lopMonoMaskDc, 0, 0, Width, Height, lopSourcehDc, x, y, vbSrcCopy
SetBkColor lopSourcehDc, lopLastBackColor

'Create Icon bitmap
lopIconBitmap = CreateCompatibleBitmap(lopSourcehDc, Width, Height)
lopIconBitmapDc = CreateCompatibleDC(0)
lopLastIconBitmatDc = SelectObject(lopIconBitmapDc, lopIconBitmap)
'Save dest backColor and textcolor
lopLastForeColor = SetTextColor(lopIconBitmapDc, &H0)
lopLastBackColor = SetBkColor(lopIconBitmapDc, &HFFFFFF)
'Copy mono into bitmap
BitBlt lopIconBitmapDc, 0, 0, Width, Height, lopMonoMaskDc, 0, 0, vbSrcCopy
'Copy source into bitmap
BitBlt lopIconBitmapDc, 0, 0, Width, Height, lopSourcehDc, x, y, vbSrcPaint
BitBlt lopIconBitmapDc, 0, 0, Width, Height, lopMonoMaskDc, 0, 0, vbSrcInvert
SetTextColor lopIconBitmapDc, lopLastForeColor
SetBkColor lopIconBitmapDc, lopLastBackColor

udpIF.fIcon = fIcon
udpIF.xHotspot = xHotspot
udpIF.yHotspot = yHotspot
udpIF.hbmMask = lopMonoMaskBitmap
udpIF.hbmColor = lopIconBitmap

PZNoteIconCreate = CreateIconIndirect(udpIF)

SelectObject lopLastSourcehDc, lopHPicture
SelectObject lopLastIconBitmatDc, lopIconBitmap
SelectObject lopLastMonoMaskDc, lopMonoMaskBitmap

DeleteDC lopSourcehDc
DeleteDC lopIconBitmapDc
DeleteDC lopMonoMaskDc

DeleteObject lopMonoMaskBitmap
DeleteObject lopIconBitmap


End Function

[Dim]

Umm you can try
Text1.MouseIcon(StringValue)
where StringValue equals whatever the created icon is named. I think i'm missing something here...but hope that helps.

Laterz,
D!m