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.OpenOrCreate)
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.

* "Lespaul36" <(E-Mail Removed)> 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/>

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]" <hirf-spam-me-(E-Mail Removed)> wrote in message
news:%(E-Mail Removed)...
> * "Lespaul36" <(E-Mail Removed)> 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/>

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" <(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
| 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]" <hirf-spam-me-(E-Mail Removed)> wrote in message
| news:%(E-Mail Removed)...
| > * "Lespaul36" <(E-Mail Removed)> 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/>
|
|

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 Removed)> wrote in message
news:(E-Mail Removed)...
> 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" <(E-Mail Removed)> wrote in message
> news:(E-Mail Removed)...
> | 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]" <hirf-spam-me-(E-Mail Removed)> wrote in message
> | news:%(E-Mail Removed)...
> | > * "Lespaul36" <(E-Mail Removed)> 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/>
> |
> |
>
>

| 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

" 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 Removed)> wrote in message
news:(E-Mail Removed)...
> | 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*\[color=blue]
> 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
> ' 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
>
>