Bitmap to Icon

[Lespaul36]

From what I have read, there isn't really a converter to icon format..it
becomes a png file. I tried:

1: Dim bmp As Bitmap = CType(Bitmap.Fr omFile("C:\myfo lder\file.bmp") ,
Bitmap)
2: Dim ico As Icon = Icon.FromHandle (bmp.GetHicon() )
3: Dim file As FileStream = New
FileStream("C:\ myfolder\file.i co",FileMode.Op enOrCreate)
4: ico.Save(file)
5: file.Close()
6: ico.Dispose()

but it still isn't right. How can I do this. I found some code in C# that
I am trying to work out, but it is real flakey.
Any help would be great. I need 16 x16 and 32x32.

[Herfried K. Wagner [MVP]]

* "Lespaul36" <le*******@none .net> scripsit:

From what I have read, there isn't really a converter to icon format..it
becomes a png file.
[...]
I need 16 x16 and 32x32.

Maybe you can base your implementation on this sample:

<URL:http://vbaccelerator.c om/article.asp?id= 4567>

--
M S Herfried K. Wagner
M V P <URL:http://dotnet.mvps.org/>
V B <URL:http://dotnet.mvps.org/dotnet/faqs/>

[Lespaul36]

Unfortunately that example doesn't save the icons. It was usefull for some
future information. I have figured out a bit more on the format of Icons.

What I am stuck at right now is making the XOR mask and the AND mask. I
figured out how to draw them, but I need to scan each row into a byte array.

I have some more research to do, but I am getting closer (I think).
"Herfried K. Wagner [MVP]" <hi************ ***@gmx.at> wrote in message
news:%2******** ********@TK2MSF TNGP09.phx.gbl. ..

* "Lespaul36" <le*******@none .net> scripsit:

From what I have read, there isn't really a converter to icon format..it
becomes a png file.
[...]
I need 16 x16 and 32x32.

Maybe you can base your implementation on this sample:

<URL:http://vbaccelerator.c om/article.asp?id= 4567>

--
M S Herfried K. Wagner
M V P <URL:http://dotnet.mvps.org/>
V B <URL:http://dotnet.mvps.org/dotnet/faqs/>

[steve]

one of the things i like most about .net is that a lot of the tough ground i
used to tread in vb 6 is gone...includin g having to create bitmaps.

just load an image into a bitmap object and use the bitmap.toicon()
method...there' s also a method to save that resulting image to file.

vioa-la

hth,

steve

btw...les paul's are overpriced and overrated...giv e me a fender any day.
;^)
"Lespaul36" <le*******@none .net> wrote in message
news:OP******** *****@TK2MSFTNG P11.phx.gbl...
| Unfortunately that example doesn't save the icons. It was usefull for
some
| future information. I have figured out a bit more on the format of Icons.
|
| What I am stuck at right now is making the XOR mask and the AND mask. I
| figured out how to draw them, but I need to scan each row into a byte
array.
|
| I have some more research to do, but I am getting closer (I think).
| "Herfried K. Wagner [MVP]" <hi************ ***@gmx.at> wrote in message
| news:%2******** ********@TK2MSF TNGP09.phx.gbl. ..
| > * "Lespaul36" <le*******@none .net> scripsit:
| > > From what I have read, there isn't really a converter to icon
format..it
| > > becomes a png file.
| > > [...]
| > > I need 16 x16 and 32x32.
| >
| > Maybe you can base your implementation on this sample:
| >
| > <URL:http://vbaccelerator.c om/article.asp?id= 4567>
| >
| > --
| > M S Herfried K. Wagner
| > M V P <URL:http://dotnet.mvps.org/>
| > V B <URL:http://dotnet.mvps.org/dotnet/faqs/>
|
|

[Lespaul36]

I don't see a toicon method for the bitmap. I agree that I like alot of the
features of .Net better, but it just seems that if they offer the ability to
save .ico files..they should really be icon files not png files.
if you don't get what I am talking about check out this link
http://support.microsoft.com/default...;en-us;q316563

I am on a search to find out how to get the info that I need. am even
trying to find old vb6 code and updte it to work. So far I am screwed. I
just had the thought that maybe there is a way to adapt the png file to
become a real icon file, more research i guess.

Also, Steve...to each thier oen, but I wouldn't trade my Lespaul in for
anything. It has been a great companion for 15 years.

"steve" <[e-mail]> wrote in message
news:10******** *****@corp.supe rnews.com...

one of the things i like most about .net is that a lot of the tough ground i used to tread in vb 6 is gone...includin g having to create bitmaps.

just load an image into a bitmap object and use the bitmap.toicon()
method...there' s also a method to save that resulting image to file.

vioa-la

hth,

steve

btw...les paul's are overpriced and overrated...giv e me a fender any day.
;^)
"Lespaul36" <le*******@none .net> wrote in message
news:OP******** *****@TK2MSFTNG P11.phx.gbl...
| Unfortunately that example doesn't save the icons. It was usefull for
some
| future information. I have figured out a bit more on the format of Icons. |
| What I am stuck at right now is making the XOR mask and the AND mask. I
| figured out how to draw them, but I need to scan each row into a byte
array.
|
| I have some more research to do, but I am getting closer (I think).
| "Herfried K. Wagner [MVP]" <hi************ ***@gmx.at> wrote in message
| news:%2******** ********@TK2MSF TNGP09.phx.gbl. ..
| > * "Lespaul36" <le*******@none .net> scripsit:
| > > From what I have read, there isn't really a converter to icon
format..it
| > > becomes a png file.
| > > [...]
| > > I need 16 x16 and 32x32.
| >
| > Maybe you can base your implementation on this sample:
| >
| > <URL:http://vbaccelerator.c om/article.asp?id= 4567>
| >
| > --
| > M S Herfried K. Wagner
| > M V P <URL:http://dotnet.mvps.org/>
| > V B <URL:http://dotnet.mvps.org/dotnet/faqs/>
|
|

[steve]

| I am on a search to find out how to get the info that I need. am even
| trying to find old vb6 code and updte it to work.

here's my old vb 6 code i was working on for creating icons/cursors prior to
..net. for the most part, it works.

| Also, Steve...to each thier oen, but I wouldn't trade my Lespaul in for
| anything. It has been a great companion for 15 years.

i was just giving you a hard time. ;^) gives a great quality sound don't
they.

anyway...(need reference to ms vbscript lib)

basMain.bas

---------------------

Option Explicit

Public Const COLOR_INVALID As Long = -1
Public Const MAX_PATH As Long = 260
Public Const OFN_ALLOWMULTIS ELECT As Long = &H200
Public Const OFN_CREATEPROMP T As Long = &H2000
Public Const OFN_ENABLEHOOK As Long = &H20
Public Const OFN_ENABLETEMPL ATE As Long = &H40
Public Const OFN_ENABLETEMPL ATEHANDLE As Long = &H80
Public Const OFN_EXPLORER As Long = &H80000
Public Const OFN_EXTENSIONDI FFERENT As Long = &H400
Public Const OFN_FILEMUSTEXI ST As Long = &H1000
Public Const OFN_HIDEREADONL Y As Long = &H4
Public Const OFN_LONGNAMES As Long = &H200000
Public Const OFN_NOCHANGEDIR As Long = &H8
Public Const OFN_NODEREFEREN CELINKS As Long = &H100000
Public Const OFN_NOLONGNAMES As Long = &H40000
Public Const OFN_NONETWORKBU TTON As Long = &H20000
Public Const OFN_NOREADONLYR ETURN As Long = &H8000
Public Const OFN_NOTESTFILEC REATE As Long = &H10000
Public Const OFN_NOVALIDATE As Long = &H100
Public Const OFN_OVERWRITEPR OMPT As Long = &H2
Public Const OFN_PATHMUSTEXI ST As Long = &H800
Public Const OFN_READONLY As Long = &H1
Public Const OFN_SHAREAWARE As Long = &H4000
Public Const OFN_SHAREFALLTH ROUGH As Long = 2
Public Const OFN_SHAREWARN As Long = 0
Public Const OFN_SHARENOWARN As Long = 1
Public Const OFN_SHOWHELP As Long = &H10
Public Const OFS_MAXPATHNAME As Long = 260
Public Const PICTYPE_BITMAP As Long = 1
Public Const PICTYPE_ENHMETA FILE As Long = 4
Public Const PICTYPE_ICON As Long = 3
Public Const PICTYPE_METAFIL E As Long = 2
Public Const PICTYPE_NONE As Long = 0
Public Const PICTYPE_UNINITI ALIZED As Long = -1

Public Const DEFAULT_OPEN_FL AGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_CREATEPROMP T _
Or OFN_NODEREFEREN CELINKS

Public Const DEFAULT_SAVE_FL AGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_OVERWRITEPR OMPT _
Or OFN_HIDEREADONL Y

Public 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

Public Type IconInfo
fIcon As Long
xHotspot As Long
yHotspot As Long
hBMMask As Long
hBMColor As Long
End Type

Public Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Public Type PictureInfo
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type

Public Type PointApi
x As Long
y As Long
End Type

Public Type OpenFileName
nStructSize As Long
hWndOwner As Long
hInstance As Long
sFilter As String
sCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
sFile As String
nMaxFile As Long
sFileTitle As String
nMaxTitle As Long
sInitialDir As String
sDialogTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
sDefFileExt As String
nCustData As Long
fnHook As Long
sTemplateName As String
End Type

Public Declare Function TransparentBlt Lib "gdi32.dll" (ByVal hdcDest As
Long, ByVal nXOriginDest As Integer, ByVal nYOriginDest As Integer, ByVal
nWidthDest As Integer, ByVal hHeightDest As Integer, ByVal hdcSrc As Long,
ByVal nXOriginSrc As Integer, ByVal nYOriginSrc As Integer, ByVal nWidthSrc
As Integer, ByVal nHeightSrc As Integer, ByVal crTransparent As Long)

Public Declare Function BitBlt Lib "gdi32.dll" (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
Public 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
Public Declare Function CreateCompatibl eBitmap Lib "gdi32.dll" (ByVal HDC As
Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibl eDC Lib "gdi32.dll" (ByVal HDC As
Long) As Long
Public Declare Function CreateIconIndir ect Lib "user32.dll " (icoinfo As
IconInfo) As Long
Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal HDC As Long) As Long
Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long)
As Long
Public Declare Function DestroyIcon Lib "user32.dll " (ByVal hIcon As Long)
As Long
Public Declare Function DPtoLP Lib "gdi32" (ByVal HDC As Long, lpPoint As
PointApi, ByVal nCount As Long) As Long
Public Declare Function GetMapMode Lib "gdi32" (ByVal HDC As Long) As Long
Public Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA " (ByVal
hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetOpenFileName Lib "comdlg32.d ll" Alias
"GetOpenFileNam eA" (pOpenfilename As OpenFileName) As Long
Public Declare Function GetSaveFileName Lib "comdlg32.d ll" Alias
"GetSaveFileNam eA" (pOpenfilename As OpenFileName) As Long
Public Declare Function OleCreatePictur eIndirect Lib "olepro32.d ll"
(lpPictureInfo As PictureInfo, riid As Guid, ByVal fown As Long, ipic As
IPicture) As Long
Public Declare Function SelectObject Lib "gdi32.dll" (ByVal HDC As Long,
ByVal hObject As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal HDC As Long, ByVal
crColor As Long) As Long
Public Declare Function SetMapMode Lib "gdi32" (ByVal HDC As Long, ByVal
nMapMode As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal HDC As Long, ByVal
crColor As Long) As Long

Public Function ConvertBitmap(B yVal hBitmap As Long, ByVal lngTransparency
As Long) As IPicture
On Error Resume Next
Dim udtBitmap As Bitmap
Dim lngColor As Long
Dim udtGuid As Guid
Dim udtIconInfo As IconInfo
Dim hInverse As Long
Dim hInverseDC As Long
Dim hMask As Long
Dim hMaskDC As Long
Dim hDest As Long
Dim hDestDC As Long
Dim hOriginal As Long
Dim hOriginalDC As Long
Dim objPicture As IPicture
Dim udtPictureInfo As PictureInfo
Dim udtPoint As PointApi
Dim hPrevDest As Long
Dim hPrevInverse As Long
Dim hPrevMask As Long
Dim hPrevOriginal As Long
Dim hSource As Long
Dim hSourceDC As Long
' ====== get image information
GetObject hBitmap, Len(udtBitmap), udtBitmap
udtPoint.x = udtBitmap.bmWid th
udtPoint.y = udtBitmap.bmHei ght
hSourceDC = CreateCompatibl eDC(hSourceDC)
SelectObject hSourceDC, hBitmap
DPtoLP hSourceDC, udtPoint, 1
' ====== create device contexts for blitting
hInverseDC = CreateCompatibl eDC(hSourceDC)
hDestDC = CreateCompatibl eDC(hSourceDC)
hMaskDC = CreateCompatibl eDC(hSourceDC)
hOriginalDC = CreateCompatibl eDC(hSourceDC)
' ====== create monochrome bitmaps for image masks
hInverse = CreateBitmap(ud tPoint.x, udtPoint.y, 1, 1, 0)
hMask = CreateBitmap(ud tPoint.x, udtPoint.y, 1, 1, 0)
' ====== create color bitmaps for masking
hDest = CreateCompatibl eBitmap(hSource DC, udtPoint.x, udtPoint.y)
hOriginal = CreateCompatibl eBitmap(hSource DC, udtPoint.x, udtPoint.y)
' ====== select images into respective device contexts so we can blit
hPrevInverse = SelectObject(hI nverseDC, hInverse)
hPrevMask = SelectObject(hM askDC, hMask)
hPrevDest = SelectObject(hD estDC, hDest)
hPrevOriginal = SelectObject(hO riginalDC, hOriginal)
' ====== store original bitmap
BitBlt hOriginalDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0,
vbSrcCopy
' ====== set transparent color on source image
lngColor = SetBkColor(hSou rceDC, lngTransparency )
' ====== create b/w version of the source bitmap (minus transparent color)
BitBlt hMaskDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0, vbSrcCopy
' ====== restore the original color to source
SetBkColor hSourceDC, lngColor
' ====== create inverse composite of masked image
BitBlt hInverseDC, 0, 0, udtPoint.x, udtPoint.y, hMaskDC, 0, 0,
vbNotSrcCopy
' ====== copy original image to destination
BitBlt hDestDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0, vbSrcCopy
' ====== mask places where image is to be placed
BitBlt hDestDC, 0, 0, udtPoint.x, udtPoint.y, hMaskDC, 0, 0, vbSrcAnd
' ====== mask transparent places of image
BitBlt hSourceDC, 0, 0, udtPoint.x, udtPoint.y, hInverseDC, 0, 0,
vbSrcAnd
' ====== merge source image with destination's background
BitBlt hDestDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0,
vbSrcPaint
' ====== restore original image
BitBlt hSourceDC, 0, 0, udtPoint.x, udtPoint.y, hOriginalDC, 0, 0,
vbSrcCopy
' ====== prepare bitmap data for transformation
With udtGuid
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With udtIconInfo
.fIcon = 1
.hBMColor = hDest
.hBMMask = hMask
.xHotspot = udtBitmap.bmWid th * 0.5
.yHotspot = udtBitmap.bmHei ght * 0.5
End With
With udtPictureInfo
.cbSizeofStruct = Len(udtPictureI nfo)
.picType = PICTYPE_ICON
.hImage = CreateIconIndir ect(udtIconInfo )
End With
' ====== transform bitmap to icon object
OleCreatePictur eIndirect udtPictureInfo, udtGuid, 1, objPicture
' ====== release resources
' DestroyIcon udtPictureInfo. hImage
DeleteObject SelectObject(hD estDC, hPrevDest)
DeleteObject SelectObject(hI nverseDC, hPrevInverse)
DeleteObject SelectObject(hM askDC, hPrevMask)
DeleteObject SelectObject(hO riginalDC, hPrevOriginal)
DeleteDC hDestDC
DeleteDC hInverseDC
DeleteDC hMaskDC
DeleteDC hOriginalDC
DeleteDC hSourceDC
' ====== return results
Set ConvertBitmap = objPicture
Set objPicture = Nothing
End Function

Public Sub Main()
On Error Resume Next
Dim strColor As String
Dim strCommandLine As String: strCommandLine =
LCase(Trim$(Com mand))
Dim strIconPath As String
Dim objMatch As Match
Dim strPattern As String: strPattern =
"(([a-z]\:\\|\\{2})(((\ w|\s)+\\{1})*)? (\w|\s)+(\.bmp| \.ico))|(color\ s*\=\s*\
d+)"
Dim objRegExp As RegExp
Dim strSourcePath As String
Dim lngTransparency As Long: lngTransparency = vbWhite
Dim strMatch As String
App.TaskVisible = False
' only display the user interface if no command line args present
' PLEASE NOTE: for sake of example, i've put in
project.propert ies.make.comman dline arguments
' already...if you want a ui experience, just un-comment the next line
'
strCommandLine = vbNullString
'
' command line format is:
' app.exename pathtofile.bmp pathtofile.ico [color=16777215]
' example: icp.exe "c:\directory\m y.bmp" "\\pcname\share name\my.ico"
' either hard-drive or unc path support...at least that's what the
' regular expression is trying to define ;^) the order in which
' any of the arguments appears doesn't matter, but there must be,
' at a minimum, a file that ends with .bmp and another that ends with
..ico
' the bitmap is the input file...the icon is the output file.
Set objRegExp = New RegExp
With objRegExp
.IgnoreCase = True
.Global = True
.Pattern = strPattern
If Not .Test(strComman dLine) Then
frmMain.Show
Exit Sub
End If
For Each objMatch In .Execute(strCom mandLine)
strMatch = Trim$(objMatch. Value)
If StrComp(Right$( strMatch, 4), ".bmp", vbTextCompare) = 0 Then
strSourcePath = strMatch
If StrComp(Right$( strMatch, 4), ".ico", vbTextCompare) = 0 Then
strIconPath = strMatch
If StrComp(Left$(o bjMatch.Value, 5), "color", vbTextCompare) = 0
Then lngTransparency = CLng(Replace(Re place(strMatch, "color",
vbNullString), "=", vbNullString))
Next
End With
If Not strSourcePath = vbNullString And Not strIconPath = vbNullString
Then
frmMain.picBitm ap = LoadPicture(str SourcePath)
' if we had command line args then we need to quit this app
' after we save the icon to disk...
' since we have implicitly loaded frmmain, we need to unload
' the form or the app will live in memory even though it may
' not be visible.
SaveIcon strIconPath, frmMain.picBitm ap.HDC,
frmMain.picBitm ap.Picture, lngTransparency
Unload frmMain
Else
frmMain.Show
End If
End Sub

Public Sub SaveIcon(ByVal strPath As String, ByRef hBitmapDC As Long, ByRef
hBitmap As Long, ByVal lngTransparency As Long)
Dim objPicture As IPicture
Set objPicture = ConvertBitmap(h Bitmap, lngTransparency )
SavePicture objPicture, strPath
frmMain.Icon = objPicture
Set frmMain.picBitm ap = objPicture
' TransparentBlt frmMain.picBitm ap.HDC, 0, 0, 32, 32,
frmMain.picBitm ap.HDC, 0, 0, 32, 32, vbWhite
Set objPicture = Nothing
End Sub

--------------------

frmMain.frm

--------------------

Option Explicit

Private mlngTransparent As Long

Private Sub picBitmap_Mouse Move(Button As Integer, Shift As Integer, x As
Single, y As Single)
lblTransparency .BackColor = picBitmap.Point (x, y)
End Sub

Private Sub picBitmap_Mouse Up(Button As Integer, Shift As Integer, x As
Single, y As Single)
mlngTransparent = picBitmap.Point (x, y)
End Sub

Private Sub cmdDiskIO_Click (Index As Integer)
On Error Resume Next
Dim strFile As String
Dim udtFileIO As OpenFileName
Dim strPath As String
Static sstrFileName As String
With udtFileIO
.nStructSize = Len(udtFileIO)
.hWndOwner = hWnd
.sDialogTitle = cmdDiskIO(Index ).Caption
.nFilterIndex = 1
If Index = 0 Then
.sFilter = "Bitmaps (*.bmp)" & vbNullChar & "*.bmp" & vbNullChar
& vbNullChar
.sDefFileExt = "bmp" & vbNullChar & vbNullChar
.sFileTitle = "*.bmp" & vbNullChar & Space$(512) & vbNullChar &
vbNullChar
.sFile = "*.bmp" & Space$(1024) & vbNullChar & vbNullChar
.sInitialDir = GetSetting(App. EXEName, "FileIO",
"InitialBitmapD ir", "C:\") & vbNullChar & vbNullChar
.nMaxFile = Len(.sFile)
.nMaxTitle = Len(udtFileIO.s FileTitle)
.flags = DEFAULT_OPEN_FL AGS
If GetOpenFileName (udtFileIO) = 0 Then Exit Sub
Else
.sFilter = "Icon (*.ico)" & vbNullChar & "*.ico" & vbNullChar &
vbNullChar
.sDefFileExt = "ico" & vbNullChar & vbNullChar
.sFileTitle = "*.ico" & vbNullChar & Space$(512) & vbNullChar &
vbNullChar
.sFile = "*.ico" & Space$(1024) & vbNullChar & vbNullChar
.sInitialDir = GetSetting(App. EXEName, "FileIO",
"InitialIconDir ", "C:\") & vbNullChar & vbNullChar
.nMaxFile = Len(.sFile)
.nMaxTitle = Len(udtFileIO.s FileTitle)
.flags = DEFAULT_SAVE_FL AGS
If GetSaveFileName (udtFileIO) = 0 Then Exit Sub
End If
End With
strFile = Trim$(Replace(u dtFileIO.sFileT itle, vbNullChar, vbNullString))
strPath = Trim$(Replace(u dtFileIO.sFile, vbNullChar, vbNullString))
If Index = 0 Then
picBitmap.Pictu re = LoadPicture(str Path)
SaveSetting App.EXEName, "FileIO", "InitialBitmapD ir",
Left$(strPath, Len(strPath) - Len(strFile) - 1)
Else
SaveIcon strPath, picBitmap.HDC, picBitmap.Pictu re, mlngTransparent
SaveSetting App.EXEName, "FileIO", "InitialIconDir ", Left$(strPath,
Len(strPath) - Len(strFile) - 1)
End If
End Sub

[Lespaul36]

" i was just giving you a hard time. ;^) gives a great quality sound don't

they."
yeah..I know you were, but I had to say something ya know :).

Thanks for the code I will check it out . I am just getting deperate.
It is almost all written in .Net. I would hate to have to rewrite it in
vb6.

Thanks.
"steve" <[e-mail]> wrote in message
news:10******** *****@corp.supe rnews.com... | I am on a search to find out how to get the info that I need. am even
| trying to find old vb6 code and updte it to work.

here's my old vb 6 code i was working on for creating icons/cursors prior to .net. for the most part, it works.

| Also, Steve...to each thier oen, but I wouldn't trade my Lespaul in for
| anything. It has been a great companion for 15 years.

i was just giving you a hard time. ;^) gives a great quality sound don't
they.

anyway...(need reference to ms vbscript lib)

basMain.bas

---------------------

Option Explicit

Public Const COLOR_INVALID As Long = -1
Public Const MAX_PATH As Long = 260
Public Const OFN_ALLOWMULTIS ELECT As Long = &H200
Public Const OFN_CREATEPROMP T As Long = &H2000
Public Const OFN_ENABLEHOOK As Long = &H20
Public Const OFN_ENABLETEMPL ATE As Long = &H40
Public Const OFN_ENABLETEMPL ATEHANDLE As Long = &H80
Public Const OFN_EXPLORER As Long = &H80000
Public Const OFN_EXTENSIONDI FFERENT As Long = &H400
Public Const OFN_FILEMUSTEXI ST As Long = &H1000
Public Const OFN_HIDEREADONL Y As Long = &H4
Public Const OFN_LONGNAMES As Long = &H200000
Public Const OFN_NOCHANGEDIR As Long = &H8
Public Const OFN_NODEREFEREN CELINKS As Long = &H100000
Public Const OFN_NOLONGNAMES As Long = &H40000
Public Const OFN_NONETWORKBU TTON As Long = &H20000
Public Const OFN_NOREADONLYR ETURN As Long = &H8000
Public Const OFN_NOTESTFILEC REATE As Long = &H10000
Public Const OFN_NOVALIDATE As Long = &H100
Public Const OFN_OVERWRITEPR OMPT As Long = &H2
Public Const OFN_PATHMUSTEXI ST As Long = &H800
Public Const OFN_READONLY As Long = &H1
Public Const OFN_SHAREAWARE As Long = &H4000
Public Const OFN_SHAREFALLTH ROUGH As Long = 2
Public Const OFN_SHAREWARN As Long = 0
Public Const OFN_SHARENOWARN As Long = 1
Public Const OFN_SHOWHELP As Long = &H10
Public Const OFS_MAXPATHNAME As Long = 260
Public Const PICTYPE_BITMAP As Long = 1
Public Const PICTYPE_ENHMETA FILE As Long = 4
Public Const PICTYPE_ICON As Long = 3
Public Const PICTYPE_METAFIL E As Long = 2
Public Const PICTYPE_NONE As Long = 0
Public Const PICTYPE_UNINITI ALIZED As Long = -1

Public Const DEFAULT_OPEN_FL AGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_CREATEPROMP T _
Or OFN_NODEREFEREN CELINKS

Public Const DEFAULT_SAVE_FL AGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_OVERWRITEPR OMPT _
Or OFN_HIDEREADONL Y

Public 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

Public Type IconInfo
fIcon As Long
xHotspot As Long
yHotspot As Long
hBMMask As Long
hBMColor As Long
End Type

Public Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Public Type PictureInfo
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type

Public Type PointApi
x As Long
y As Long
End Type

Public Type OpenFileName
nStructSize As Long
hWndOwner As Long
hInstance As Long
sFilter As String
sCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
sFile As String
nMaxFile As Long
sFileTitle As String
nMaxTitle As Long
sInitialDir As String
sDialogTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
sDefFileExt As String
nCustData As Long
fnHook As Long
sTemplateName As String
End Type

Public Declare Function TransparentBlt Lib "gdi32.dll" (ByVal hdcDest As
Long, ByVal nXOriginDest As Integer, ByVal nYOriginDest As Integer, ByVal
nWidthDest As Integer, ByVal hHeightDest As Integer, ByVal hdcSrc As Long,
ByVal nXOriginSrc As Integer, ByVal nYOriginSrc As Integer, ByVal nWidthSrc As Integer, ByVal nHeightSrc As Integer, ByVal crTransparent As Long)

Public Declare Function BitBlt Lib "gdi32.dll" (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
Public 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
Public Declare Function CreateCompatibl eBitmap Lib "gdi32.dll" (ByVal HDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibl eDC Lib "gdi32.dll" (ByVal HDC As
Long) As Long
Public Declare Function CreateIconIndir ect Lib "user32.dll " (icoinfo As
IconInfo) As Long
Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal HDC As Long) As Long Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Public Declare Function DestroyIcon Lib "user32.dll " (ByVal hIcon As Long)
As Long
Public Declare Function DPtoLP Lib "gdi32" (ByVal HDC As Long, lpPoint As
PointApi, ByVal nCount As Long) As Long
Public Declare Function GetMapMode Lib "gdi32" (ByVal HDC As Long) As Long
Public Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA " (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetOpenFileName Lib "comdlg32.d ll" Alias
"GetOpenFileNam eA" (pOpenfilename As OpenFileName) As Long
Public Declare Function GetSaveFileName Lib "comdlg32.d ll" Alias
"GetSaveFileNam eA" (pOpenfilename As OpenFileName) As Long
Public Declare Function OleCreatePictur eIndirect Lib "olepro32.d ll"
(lpPictureInfo As PictureInfo, riid As Guid, ByVal fown As Long, ipic As
IPicture) As Long
Public Declare Function SelectObject Lib "gdi32.dll" (ByVal HDC As Long,
ByVal hObject As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal HDC As Long, ByVal
crColor As Long) As Long
Public Declare Function SetMapMode Lib "gdi32" (ByVal HDC As Long, ByVal
nMapMode As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal HDC As Long, ByVal
crColor As Long) As Long

Public Function ConvertBitmap(B yVal hBitmap As Long, ByVal lngTransparency
As Long) As IPicture
On Error Resume Next
Dim udtBitmap As Bitmap
Dim lngColor As Long
Dim udtGuid As Guid
Dim udtIconInfo As IconInfo
Dim hInverse As Long
Dim hInverseDC As Long
Dim hMask As Long
Dim hMaskDC As Long
Dim hDest As Long
Dim hDestDC As Long
Dim hOriginal As Long
Dim hOriginalDC As Long
Dim objPicture As IPicture
Dim udtPictureInfo As PictureInfo
Dim udtPoint As PointApi
Dim hPrevDest As Long
Dim hPrevInverse As Long
Dim hPrevMask As Long
Dim hPrevOriginal As Long
Dim hSource As Long
Dim hSourceDC As Long
' ====== get image information
GetObject hBitmap, Len(udtBitmap), udtBitmap
udtPoint.x = udtBitmap.bmWid th
udtPoint.y = udtBitmap.bmHei ght
hSourceDC = CreateCompatibl eDC(hSourceDC)
SelectObject hSourceDC, hBitmap
DPtoLP hSourceDC, udtPoint, 1
' ====== create device contexts for blitting
hInverseDC = CreateCompatibl eDC(hSourceDC)
hDestDC = CreateCompatibl eDC(hSourceDC)
hMaskDC = CreateCompatibl eDC(hSourceDC)
hOriginalDC = CreateCompatibl eDC(hSourceDC)
' ====== create monochrome bitmaps for image masks
hInverse = CreateBitmap(ud tPoint.x, udtPoint.y, 1, 1, 0)
hMask = CreateBitmap(ud tPoint.x, udtPoint.y, 1, 1, 0)
' ====== create color bitmaps for masking
hDest = CreateCompatibl eBitmap(hSource DC, udtPoint.x, udtPoint.y)
hOriginal = CreateCompatibl eBitmap(hSource DC, udtPoint.x, udtPoint.y)
' ====== select images into respective device contexts so we can blit
hPrevInverse = SelectObject(hI nverseDC, hInverse)
hPrevMask = SelectObject(hM askDC, hMask)
hPrevDest = SelectObject(hD estDC, hDest)
hPrevOriginal = SelectObject(hO riginalDC, hOriginal)
' ====== store original bitmap
BitBlt hOriginalDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0,
vbSrcCopy
' ====== set transparent color on source image
lngColor = SetBkColor(hSou rceDC, lngTransparency )
' ====== create b/w version of the source bitmap (minus transparent color)
BitBlt hMaskDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0, vbSrcCopy ' ====== restore the original color to source
SetBkColor hSourceDC, lngColor
' ====== create inverse composite of masked image
BitBlt hInverseDC, 0, 0, udtPoint.x, udtPoint.y, hMaskDC, 0, 0,
vbNotSrcCopy
' ====== copy original image to destination
BitBlt hDestDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0, vbSrcCopy ' ====== mask places where image is to be placed
BitBlt hDestDC, 0, 0, udtPoint.x, udtPoint.y, hMaskDC, 0, 0, vbSrcAnd
' ====== mask transparent places of image
BitBlt hSourceDC, 0, 0, udtPoint.x, udtPoint.y, hInverseDC, 0, 0,
vbSrcAnd
' ====== merge source image with destination's background
BitBlt hDestDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0,
vbSrcPaint
' ====== restore original image
BitBlt hSourceDC, 0, 0, udtPoint.x, udtPoint.y, hOriginalDC, 0, 0,
vbSrcCopy
' ====== prepare bitmap data for transformation
With udtGuid
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With udtIconInfo
.fIcon = 1
.hBMColor = hDest
.hBMMask = hMask
.xHotspot = udtBitmap.bmWid th * 0.5
.yHotspot = udtBitmap.bmHei ght * 0.5
End With
With udtPictureInfo
.cbSizeofStruct = Len(udtPictureI nfo)
.picType = PICTYPE_ICON
.hImage = CreateIconIndir ect(udtIconInfo )
End With
' ====== transform bitmap to icon object
OleCreatePictur eIndirect udtPictureInfo, udtGuid, 1, objPicture
' ====== release resources
' DestroyIcon udtPictureInfo. hImage
DeleteObject SelectObject(hD estDC, hPrevDest)
DeleteObject SelectObject(hI nverseDC, hPrevInverse)
DeleteObject SelectObject(hM askDC, hPrevMask)
DeleteObject SelectObject(hO riginalDC, hPrevOriginal)
DeleteDC hDestDC
DeleteDC hInverseDC
DeleteDC hMaskDC
DeleteDC hOriginalDC
DeleteDC hSourceDC
' ====== return results
Set ConvertBitmap = objPicture
Set objPicture = Nothing
End Function

Public Sub Main()
On Error Resume Next
Dim strColor As String
Dim strCommandLine As String: strCommandLine =
LCase(Trim$(Com mand))
Dim strIconPath As String
Dim objMatch As Match
Dim strPattern As String: strPattern =
"(([a-z]\:\\|\\{2})(((\ w|\s)+\\{1})*)? (\w|\s)+(\.bmp| \.ico))|(color\ s*\=\s*\ d+)"
Dim objRegExp As RegExp
Dim strSourcePath As String
Dim lngTransparency As Long: lngTransparency = vbWhite
Dim strMatch As String
App.TaskVisible = False
' only display the user interface if no command line args present
' PLEASE NOTE: for sake of example, i've put in
project.propert ies.make.comman dline arguments
' already...if you want a ui experience, just un-comment the next line
'
strCommandLine = vbNullString
'
' command line format is:
' app.exename pathtofile.bmp pathtofile.ico [color=16777215]
' example: icp.exe "c:\directory\m y.bmp" "\\pcname\share name\my.ico"
' either hard-drive or unc path support...at least that's what the
' regular expression is trying to define ;^) the order in which
' any of the arguments appears doesn't matter, but there must be,
' at a minimum, a file that ends with .bmp and another that ends with
.ico
' the bitmap is the input file...the icon is the output file.
Set objRegExp = New RegExp
With objRegExp
.IgnoreCase = True
.Global = True
.Pattern = strPattern
If Not .Test(strComman dLine) Then
frmMain.Show
Exit Sub
End If
For Each objMatch In .Execute(strCom mandLine)
strMatch = Trim$(objMatch. Value)
If StrComp(Right$( strMatch, 4), ".bmp", vbTextCompare) = 0 Then strSourcePath = strMatch
If StrComp(Right$( strMatch, 4), ".ico", vbTextCompare) = 0 Then strIconPath = strMatch
If StrComp(Left$(o bjMatch.Value, 5), "color", vbTextCompare) = 0 Then lngTransparency = CLng(Replace(Re place(strMatch, "color",
vbNullString), "=", vbNullString))
Next
End With
If Not strSourcePath = vbNullString And Not strIconPath = vbNullString
Then
frmMain.picBitm ap = LoadPicture(str SourcePath)
' if we had command line args then we need to quit this app
' after we save the icon to disk...
' since we have implicitly loaded frmmain, we need to unload
' the form or the app will live in memory even though it may
' not be visible.
SaveIcon strIconPath, frmMain.picBitm ap.HDC,
frmMain.picBitm ap.Picture, lngTransparency
Unload frmMain
Else
frmMain.Show
End If
End Sub

Public Sub SaveIcon(ByVal strPath As String, ByRef hBitmapDC As Long, ByRef hBitmap As Long, ByVal lngTransparency As Long)
Dim objPicture As IPicture
Set objPicture = ConvertBitmap(h Bitmap, lngTransparency )
SavePicture objPicture, strPath
frmMain.Icon = objPicture
Set frmMain.picBitm ap = objPicture
' TransparentBlt frmMain.picBitm ap.HDC, 0, 0, 32, 32,
frmMain.picBitm ap.HDC, 0, 0, 32, 32, vbWhite
Set objPicture = Nothing
End Sub

--------------------

frmMain.frm

--------------------

Option Explicit

Private mlngTransparent As Long

Private Sub picBitmap_Mouse Move(Button As Integer, Shift As Integer, x As
Single, y As Single)
lblTransparency .BackColor = picBitmap.Point (x, y)
End Sub

Private Sub picBitmap_Mouse Up(Button As Integer, Shift As Integer, x As
Single, y As Single)
mlngTransparent = picBitmap.Point (x, y)
End Sub

Private Sub cmdDiskIO_Click (Index As Integer)
On Error Resume Next
Dim strFile As String
Dim udtFileIO As OpenFileName
Dim strPath As String
Static sstrFileName As String
With udtFileIO
.nStructSize = Len(udtFileIO)
.hWndOwner = hWnd
.sDialogTitle = cmdDiskIO(Index ).Caption
.nFilterIndex = 1
If Index = 0 Then
.sFilter = "Bitmaps (*.bmp)" & vbNullChar & "*.bmp" & vbNullChar & vbNullChar
.sDefFileExt = "bmp" & vbNullChar & vbNullChar
.sFileTitle = "*.bmp" & vbNullChar & Space$(512) & vbNullChar & vbNullChar
.sFile = "*.bmp" & Space$(1024) & vbNullChar & vbNullChar
.sInitialDir = GetSetting(App. EXEName, "FileIO",
"InitialBitmapD ir", "C:\") & vbNullChar & vbNullChar
.nMaxFile = Len(.sFile)
.nMaxTitle = Len(udtFileIO.s FileTitle)
.flags = DEFAULT_OPEN_FL AGS
If GetOpenFileName (udtFileIO) = 0 Then Exit Sub
Else
.sFilter = "Icon (*.ico)" & vbNullChar & "*.ico" & vbNullChar & vbNullChar
.sDefFileExt = "ico" & vbNullChar & vbNullChar
.sFileTitle = "*.ico" & vbNullChar & Space$(512) & vbNullChar & vbNullChar
.sFile = "*.ico" & Space$(1024) & vbNullChar & vbNullChar
.sInitialDir = GetSetting(App. EXEName, "FileIO",
"InitialIconDir ", "C:\") & vbNullChar & vbNullChar
.nMaxFile = Len(.sFile)
.nMaxTitle = Len(udtFileIO.s FileTitle)
.flags = DEFAULT_SAVE_FL AGS
If GetSaveFileName (udtFileIO) = 0 Then Exit Sub
End If
End With
strFile = Trim$(Replace(u dtFileIO.sFileT itle, vbNullChar, vbNullString)) strPath = Trim$(Replace(u dtFileIO.sFile, vbNullChar, vbNullString))
If Index = 0 Then
picBitmap.Pictu re = LoadPicture(str Path)
SaveSetting App.EXEName, "FileIO", "InitialBitmapD ir",
Left$(strPath, Len(strPath) - Len(strFile) - 1)
Else
SaveIcon strPath, picBitmap.HDC, picBitmap.Pictu re, mlngTransparent SaveSetting App.EXEName, "FileIO", "InitialIconDir ", Left$(strPath, Len(strPath) - Len(strFile) - 1)
End If
End Sub