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