By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
443,640 Members | 1,363 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 443,640 IT Pros & Developers. It's quick & easy.

Bitmap to Icon

P: n/a
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.FromFile("C:\myfolder\file.bmp"),
Bitmap)
2: Dim ico As Icon = Icon.FromHandle(bmp.GetHicon())
3: Dim file As FileStream = New
FileStream("C:\myfolder\file.ico",FileMode.OpenOrC reate)
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.
Nov 20 '05 #1
Share this Question
Share on Google+
6 Replies


P: n/a
* "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.com/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/>
Nov 20 '05 #2

P: n/a
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****************@TK2MSFTNGP09.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.com/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/>

Nov 20 '05 #3

P: n/a
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...including 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...give me a fender any day.
;^)
"Lespaul36" <le*******@none.net> wrote in message
news:OP*************@TK2MSFTNGP11.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****************@TK2MSFTNGP09.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.com/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/>
|
|
Nov 20 '05 #4

P: n/a
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" <a@b.com> wrote in message
news:10*************@corp.supernews.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...including 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...give me a fender any day.
;^)
"Lespaul36" <le*******@none.net> wrote in message
news:OP*************@TK2MSFTNGP11.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****************@TK2MSFTNGP09.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.com/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/>
|
|

Nov 21 '05 #5

P: n/a
| 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_ALLOWMULTISELECT As Long = &H200
Public Const OFN_CREATEPROMPT As Long = &H2000
Public Const OFN_ENABLEHOOK As Long = &H20
Public Const OFN_ENABLETEMPLATE As Long = &H40
Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Public Const OFN_EXPLORER As Long = &H80000
Public Const OFN_EXTENSIONDIFFERENT As Long = &H400
Public Const OFN_FILEMUSTEXIST As Long = &H1000
Public Const OFN_HIDEREADONLY As Long = &H4
Public Const OFN_LONGNAMES As Long = &H200000
Public Const OFN_NOCHANGEDIR As Long = &H8
Public Const OFN_NODEREFERENCELINKS As Long = &H100000
Public Const OFN_NOLONGNAMES As Long = &H40000
Public Const OFN_NONETWORKBUTTON As Long = &H20000
Public Const OFN_NOREADONLYRETURN As Long = &H8000
Public Const OFN_NOTESTFILECREATE As Long = &H10000
Public Const OFN_NOVALIDATE As Long = &H100
Public Const OFN_OVERWRITEPROMPT As Long = &H2
Public Const OFN_PATHMUSTEXIST As Long = &H800
Public Const OFN_READONLY As Long = &H1
Public Const OFN_SHAREAWARE As Long = &H4000
Public Const OFN_SHAREFALLTHROUGH 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_ENHMETAFILE As Long = 4
Public Const PICTYPE_ICON As Long = 3
Public Const PICTYPE_METAFILE As Long = 2
Public Const PICTYPE_NONE As Long = 0
Public Const PICTYPE_UNINITIALIZED As Long = -1

Public Const DEFAULT_OPEN_FLAGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_CREATEPROMPT _
Or OFN_NODEREFERENCELINKS

Public Const DEFAULT_SAVE_FLAGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_OVERWRITEPROMPT _
Or OFN_HIDEREADONLY

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 CreateCompatibleBitmap Lib "gdi32.dll" (ByVal HDC As
Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal HDC As
Long) As Long
Public Declare Function CreateIconIndirect 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.dll" Alias
"GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long
Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias
"GetSaveFileNameA" (pOpenfilename As OpenFileName) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll"
(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(ByVal 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.bmWidth
udtPoint.y = udtBitmap.bmHeight
hSourceDC = CreateCompatibleDC(hSourceDC)
SelectObject hSourceDC, hBitmap
DPtoLP hSourceDC, udtPoint, 1
' ====== create device contexts for blitting
hInverseDC = CreateCompatibleDC(hSourceDC)
hDestDC = CreateCompatibleDC(hSourceDC)
hMaskDC = CreateCompatibleDC(hSourceDC)
hOriginalDC = CreateCompatibleDC(hSourceDC)
' ====== create monochrome bitmaps for image masks
hInverse = CreateBitmap(udtPoint.x, udtPoint.y, 1, 1, 0)
hMask = CreateBitmap(udtPoint.x, udtPoint.y, 1, 1, 0)
' ====== create color bitmaps for masking
hDest = CreateCompatibleBitmap(hSourceDC, udtPoint.x, udtPoint.y)
hOriginal = CreateCompatibleBitmap(hSourceDC, udtPoint.x, udtPoint.y)
' ====== select images into respective device contexts so we can blit
hPrevInverse = SelectObject(hInverseDC, hInverse)
hPrevMask = SelectObject(hMaskDC, hMask)
hPrevDest = SelectObject(hDestDC, hDest)
hPrevOriginal = SelectObject(hOriginalDC, hOriginal)
' ====== store original bitmap
BitBlt hOriginalDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0,
vbSrcCopy
' ====== set transparent color on source image
lngColor = SetBkColor(hSourceDC, 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.bmWidth * 0.5
.yHotspot = udtBitmap.bmHeight * 0.5
End With
With udtPictureInfo
.cbSizeofStruct = Len(udtPictureInfo)
.picType = PICTYPE_ICON
.hImage = CreateIconIndirect(udtIconInfo)
End With
' ====== transform bitmap to icon object
OleCreatePictureIndirect udtPictureInfo, udtGuid, 1, objPicture
' ====== release resources
' DestroyIcon udtPictureInfo.hImage
DeleteObject SelectObject(hDestDC, hPrevDest)
DeleteObject SelectObject(hInverseDC, hPrevInverse)
DeleteObject SelectObject(hMaskDC, hPrevMask)
DeleteObject SelectObject(hOriginalDC, 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$(Command))
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.properties.make.commandline 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\my.bmp" "\\pcname\sharename\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(strCommandLine) Then
frmMain.Show
Exit Sub
End If
For Each objMatch In .Execute(strCommandLine)
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$(objMatch.Value, 5), "color", vbTextCompare) = 0
Then lngTransparency = CLng(Replace(Replace(strMatch, "color",
vbNullString), "=", vbNullString))
Next
End With
If Not strSourcePath = vbNullString And Not strIconPath = vbNullString
Then
frmMain.picBitmap = LoadPicture(strSourcePath)
' 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.picBitmap.HDC,
frmMain.picBitmap.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(hBitmap, lngTransparency)
SavePicture objPicture, strPath
frmMain.Icon = objPicture
Set frmMain.picBitmap = objPicture
' TransparentBlt frmMain.picBitmap.HDC, 0, 0, 32, 32,
frmMain.picBitmap.HDC, 0, 0, 32, 32, vbWhite
Set objPicture = Nothing
End Sub

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

frmMain.frm

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

Option Explicit

Private mlngTransparent As Long

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

Private Sub picBitmap_MouseUp(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",
"InitialBitmapDir", "C:\") & vbNullChar & vbNullChar
.nMaxFile = Len(.sFile)
.nMaxTitle = Len(udtFileIO.sFileTitle)
.flags = DEFAULT_OPEN_FLAGS
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.sFileTitle)
.flags = DEFAULT_SAVE_FLAGS
If GetSaveFileName(udtFileIO) = 0 Then Exit Sub
End If
End With
strFile = Trim$(Replace(udtFileIO.sFileTitle, vbNullChar, vbNullString))
strPath = Trim$(Replace(udtFileIO.sFile, vbNullChar, vbNullString))
If Index = 0 Then
picBitmap.Picture = LoadPicture(strPath)
SaveSetting App.EXEName, "FileIO", "InitialBitmapDir",
Left$(strPath, Len(strPath) - Len(strFile) - 1)
Else
SaveIcon strPath, picBitmap.HDC, picBitmap.Picture, mlngTransparent
SaveSetting App.EXEName, "FileIO", "InitialIconDir", Left$(strPath,
Len(strPath) - Len(strFile) - 1)
End If
End Sub
Nov 21 '05 #6

P: n/a
" 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" <a@b.com> wrote in message
news:10*************@corp.supernews.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_ALLOWMULTISELECT As Long = &H200
Public Const OFN_CREATEPROMPT As Long = &H2000
Public Const OFN_ENABLEHOOK As Long = &H20
Public Const OFN_ENABLETEMPLATE As Long = &H40
Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Public Const OFN_EXPLORER As Long = &H80000
Public Const OFN_EXTENSIONDIFFERENT As Long = &H400
Public Const OFN_FILEMUSTEXIST As Long = &H1000
Public Const OFN_HIDEREADONLY As Long = &H4
Public Const OFN_LONGNAMES As Long = &H200000
Public Const OFN_NOCHANGEDIR As Long = &H8
Public Const OFN_NODEREFERENCELINKS As Long = &H100000
Public Const OFN_NOLONGNAMES As Long = &H40000
Public Const OFN_NONETWORKBUTTON As Long = &H20000
Public Const OFN_NOREADONLYRETURN As Long = &H8000
Public Const OFN_NOTESTFILECREATE As Long = &H10000
Public Const OFN_NOVALIDATE As Long = &H100
Public Const OFN_OVERWRITEPROMPT As Long = &H2
Public Const OFN_PATHMUSTEXIST As Long = &H800
Public Const OFN_READONLY As Long = &H1
Public Const OFN_SHAREAWARE As Long = &H4000
Public Const OFN_SHAREFALLTHROUGH 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_ENHMETAFILE As Long = 4
Public Const PICTYPE_ICON As Long = 3
Public Const PICTYPE_METAFILE As Long = 2
Public Const PICTYPE_NONE As Long = 0
Public Const PICTYPE_UNINITIALIZED As Long = -1

Public Const DEFAULT_OPEN_FLAGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_CREATEPROMPT _
Or OFN_NODEREFERENCELINKS

Public Const DEFAULT_SAVE_FLAGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_OVERWRITEPROMPT _
Or OFN_HIDEREADONLY

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 CreateCompatibleBitmap Lib "gdi32.dll" (ByVal HDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal HDC As
Long) As Long
Public Declare Function CreateIconIndirect 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.dll" Alias
"GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long
Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias
"GetSaveFileNameA" (pOpenfilename As OpenFileName) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll"
(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(ByVal 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.bmWidth
udtPoint.y = udtBitmap.bmHeight
hSourceDC = CreateCompatibleDC(hSourceDC)
SelectObject hSourceDC, hBitmap
DPtoLP hSourceDC, udtPoint, 1
' ====== create device contexts for blitting
hInverseDC = CreateCompatibleDC(hSourceDC)
hDestDC = CreateCompatibleDC(hSourceDC)
hMaskDC = CreateCompatibleDC(hSourceDC)
hOriginalDC = CreateCompatibleDC(hSourceDC)
' ====== create monochrome bitmaps for image masks
hInverse = CreateBitmap(udtPoint.x, udtPoint.y, 1, 1, 0)
hMask = CreateBitmap(udtPoint.x, udtPoint.y, 1, 1, 0)
' ====== create color bitmaps for masking
hDest = CreateCompatibleBitmap(hSourceDC, udtPoint.x, udtPoint.y)
hOriginal = CreateCompatibleBitmap(hSourceDC, udtPoint.x, udtPoint.y)
' ====== select images into respective device contexts so we can blit
hPrevInverse = SelectObject(hInverseDC, hInverse)
hPrevMask = SelectObject(hMaskDC, hMask)
hPrevDest = SelectObject(hDestDC, hDest)
hPrevOriginal = SelectObject(hOriginalDC, hOriginal)
' ====== store original bitmap
BitBlt hOriginalDC, 0, 0, udtPoint.x, udtPoint.y, hSourceDC, 0, 0,
vbSrcCopy
' ====== set transparent color on source image
lngColor = SetBkColor(hSourceDC, 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.bmWidth * 0.5
.yHotspot = udtBitmap.bmHeight * 0.5
End With
With udtPictureInfo
.cbSizeofStruct = Len(udtPictureInfo)
.picType = PICTYPE_ICON
.hImage = CreateIconIndirect(udtIconInfo)
End With
' ====== transform bitmap to icon object
OleCreatePictureIndirect udtPictureInfo, udtGuid, 1, objPicture
' ====== release resources
' DestroyIcon udtPictureInfo.hImage
DeleteObject SelectObject(hDestDC, hPrevDest)
DeleteObject SelectObject(hInverseDC, hPrevInverse)
DeleteObject SelectObject(hMaskDC, hPrevMask)
DeleteObject SelectObject(hOriginalDC, 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$(Command))
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.properties.make.commandline 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\my.bmp" "\\pcname\sharename\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(strCommandLine) Then
frmMain.Show
Exit Sub
End If
For Each objMatch In .Execute(strCommandLine)
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$(objMatch.Value, 5), "color", vbTextCompare) = 0 Then lngTransparency = CLng(Replace(Replace(strMatch, "color",
vbNullString), "=", vbNullString))
Next
End With
If Not strSourcePath = vbNullString And Not strIconPath = vbNullString
Then
frmMain.picBitmap = LoadPicture(strSourcePath)
' 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.picBitmap.HDC,
frmMain.picBitmap.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(hBitmap, lngTransparency)
SavePicture objPicture, strPath
frmMain.Icon = objPicture
Set frmMain.picBitmap = objPicture
' TransparentBlt frmMain.picBitmap.HDC, 0, 0, 32, 32,
frmMain.picBitmap.HDC, 0, 0, 32, 32, vbWhite
Set objPicture = Nothing
End Sub

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

frmMain.frm

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

Option Explicit

Private mlngTransparent As Long

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

Private Sub picBitmap_MouseUp(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",
"InitialBitmapDir", "C:\") & vbNullChar & vbNullChar
.nMaxFile = Len(.sFile)
.nMaxTitle = Len(udtFileIO.sFileTitle)
.flags = DEFAULT_OPEN_FLAGS
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.sFileTitle)
.flags = DEFAULT_SAVE_FLAGS
If GetSaveFileName(udtFileIO) = 0 Then Exit Sub
End If
End With
strFile = Trim$(Replace(udtFileIO.sFileTitle, vbNullChar, vbNullString)) strPath = Trim$(Replace(udtFileIO.sFile, vbNullChar, vbNullString))
If Index = 0 Then
picBitmap.Picture = LoadPicture(strPath)
SaveSetting App.EXEName, "FileIO", "InitialBitmapDir",
Left$(strPath, Len(strPath) - Len(strFile) - 1)
Else
SaveIcon strPath, picBitmap.HDC, picBitmap.Picture, mlngTransparent SaveSetting App.EXEName, "FileIO", "InitialIconDir", Left$(strPath, Len(strPath) - Len(strFile) - 1)
End If
End Sub

Nov 21 '05 #7

This discussion thread is closed

Replies have been disabled for this discussion.