VB5 Alpha Icon Creator (186K)
VB6 Alpha Icon Creator (179K)
15 Apr 2004
Fixed error with setting transparent colour: it was comparing the Red colour value with the Blue value and hence only worked with shades of grey.
Added ShowInTaskbar code to the project.
Added more options for generated icon sizes.
Fixed crash when attempting to create an icon which was larger than the resampled image (for example, if tried to resampled a 640x480 image to 48x48 then the resampled version would be 48x36, which would crash the program when attempting to copy). The code now centres images which are smaller to fit.
Reading and Saving .ICO files and resources in VB
vbAccelerator - Contents of code file: cFileIcon.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "cFileIcon"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' ===========================================================================
' Filename: cFileIcon.cls
' Author: Steve McMahon (steve@vbaccelerator.com)
' Date: 2 January 1999
'
' Requires: None
'
' Description:
' A class which reads and writes icons from files using the Win32 ICO
' file format. It can also read icons from Executables (EXE, DLL, OCX
' etc).
' This gives full control over the size and colour depth to be loaded,
' something which cannot be achieved by any other method.
'
' Todo:
' This class can be used as the basis for a full icon editor; you just
' need to be able to set the AND and XOR bits from a bitmap...
'
'
' Based on C code provided in the MSDN article "Icons in Win32" by
' John Hornick.
'
' ---------------------------------------------------------------------------
' Visit vbAccelerator - free, advanced source code for VB programmers.
' http://vbaccelerator.com
' ===========================================================================
' ===========================================================================
' Declares and Types
' ===========================================================================
' Non Win32 Declares:
' -------------------
'// These next two structs represent how the icon information is stored
'// in an ICO file.
Private Type ICONDIRENTRY
bWidth As Byte '// Width of the image
bHeight As Byte '// Height of the image (times 2)
bColorCount As Byte '// Number of colors in image (0 if >=8bpp)
bReserved As Byte '// Reserved
wPlanes As Integer '// Color Planes
wBitCount As Integer '// Bits per pixel
dwBytesInRes As Long '// how many bytes in this resource?
dwImageOffset As Long '// where in the file is this image
End Type
Private Type ICONDIR
idReserved As Integer '// Reserved
idType As Integer '// resource type (1 for icons)
idCount As Integer '// how many images?
' idEntries() as ICONDIRENTRY array follows.
End Type
'// When Icon is bound into a EXE or DLL file then structure members are WORD
'// aligned and the last member of the ICONDIRENTRY structure is the ID instead
of
'// the imageoffset.
' Just to make things difficult in VB....
Private Type MEMICONDIRENTRY
bWidth As Byte '// Width of the image
bHeight As Byte '// Height of the image (times 2)
bColorCount As Byte '// Number of colors in image (0 if >=8bpp)
bReserved As Byte '// Reserved
wPlanes As Integer '// Color Planes
wBitCount As Integer '// Bits per pixel
dwBytesInRes As Long '// how many bytes in this resource?
nID As Integer '// the ID
End Type
' A VB type to store the DIB bits of the icon.
Private Type tBits
bBits() As Byte
End Type
' Win32 Declares:
' ---------------
' Resource idTypes:
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
' File read/write through Win32. Declares are modified from the VB versions to
allow null to be passed to lpSecurityAttributes and lpOverlapped:
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal
lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As
Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal
dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const CREATE_ALWAYS = 2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const INVALID_HANDLE_VALUE = -1
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As
Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer
As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long,
lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long,
lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten
As Long, lpOverlapped As Any) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long,
ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal
dwMoveMethod As Long) As Long
Private Const FILE_BEGIN = 0
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long,
lpFileSizeHigh As Any) As Long
' Resource functions:
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA"
(ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As
Long
' Missing from VB API declarations:
Private Const LOAD_LIBRARY_AS_DATAFILE = &H2&
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long)
As Long
Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long,
ByVal hResInfo As Long) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long)
As Long
' The FindResource and FindResourceEx functions are a bit annoying in VB
because the lpName and lpType
' parameters can take both strings and longs. Declare lpName and lpType as Any
and remember to use ByVal
' when placing a parameter into them
Private Declare Function FindResource Lib "kernel32" Alias "FindResourceA"
(ByVal hInstance As Long, lpName As Any, lpType As Any) As Long
Private Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As
Long, ByVal hResInfo As Long) As Long
Private Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long)
As Long
Private Const RT_CURSOR = 1
Private Const RT_BITMAP = 2
Private Const RT_ICON = 3
' Missing from VB API declarations:
Private Const DIFFERENCE = 11
Private Const RT_GROUP_CURSOR = RT_CURSOR + DIFFERENCE
Private Const RT_GROUP_ICON = RT_ICON + DIFFERENCE
' DIB bitmap types:
Private Type CIEXYZ
ciexyzX As Long 'FXPT2DOT30
ciexyzY As Long 'FXPT2DOT30
ciexyzZ As Long 'FXPT2DOT30
End Type
Private Type CIEXYZTRIPLE
ciexyzRed As CIEXYZ
ciexyzGreen As CIEXYZ
ciexyzBlue As CIEXYZ
End Type
Private Type BITMAPV4HEADER
bV4Size As Long
bV4Width As Long
bV4Height As Long
bV4Planes As Integer
bV4BitCount As Integer
bV4Compression As Long
bV4SizeImage As Long
bV4XPelsPerMeter As Long
bV4YPelsPerMeter As Long
bV4ClrUsed As Long
bV4ClrImportant As Long
bV4RedMask As Long
bV4GreenMask As Long
bV4BlueMask As Long
bV4AlphaMask As Long
bV4CSType As Long
bV4Endpoints As CIEXYZTRIPLE
bV4GammaRed As Long
bV4GammaGreen As Long
bV4GammaBlue As Long
End Type
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
' The size of the BITMAPINFO structure depends on whether there is a colour
' table in the DIB or not and its size. For mono (1bpp) DIBs, the colour
' table has two entries, for 16 colour (4bpp) DIBs, there are 16 entries,
' for 256 colour (8bpp) DIBs there are 256 entries, otherwise the DIB is
' 24 bits per pixel and has no colour table.
Private Type BITMAPINFO_1BPP
bmiHeader As BITMAPINFOHEADER
bmiColors(0 To 1) As RGBQUAD
End Type
Private Type BITMAPINFO_4BPP
bmiHeader As BITMAPINFOHEADER
bmiColors(0 To 15) As RGBQUAD
End Type
Private Type BITMAPINFO_8BPP
bmiHeader As BITMAPINFOHEADER
bmiColors(0 To 255) As RGBQUAD
End Type
' Colour table information:
Private Const DIB_PAL_COLORS = 1 ' color table in palette indices
Private Const DIB_PAL_INDICES = 2 ' No color table indices into surf palette
Private Const DIB_PAL_LOGINDICES = 4 ' No color table indices into DC palette
Private Const DIB_PAL_PHYSINDICES = 2 ' No color table indices into surf
palette
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
' Bitmap compression types:
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
' Getting and setting DIB Bits:
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal
hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As
Any, lpBI As Any, ByVal wUsage As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal
hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As
Any, lpBI As Any, ByVal wUsage As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long,
ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal
SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long,
Bits As Any, BitsInfo As Any, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBitmap Lib "gdi32" (ByVal hdc As Long,
lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any,
lpInitInfo As Any, ByVal wUsage As Long) As Long
' Byref so we get the pointer back:
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, _
pBitmapInfo As Any, _
ByVal un As Long, _
lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw As Long) As Long
' Device dependent Bitmap structure:
Private 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
' General GDI calls for bitmaps and DC:
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal
hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal
lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As
Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As BITMAP)
As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As
Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long,
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As
Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As
Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As
Long, ByVal y As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal
crColor As Long) As Long
Private Declare Function GdiFlush Lib "gdi32" () As Long
' Creating an icon from the mask and colour bitmaps and vice-versa:
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hBmMask As Long
hbmColor As Long
End Type
Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As
ICONINFO) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long,
piconinfo As ICONINFO) As Long
' Declares to allow a hIcon handle to be converted to a VB StdPicture object:
Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL"
(lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic
As IPicture) As Long
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr()
As Any) As Long
' Very much required here:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
' -----------
' ===========================================================================
' Implementation
' ===========================================================================
Public Enum ECFIImageConstants
ecfiImage
ecfiMask
End Enum
Private m_sFile As String
Private m_vID As Variant
' Icon Directory - indicates type of resource and number of images:
Private m_tID As ICONDIR
' Icon Directory information - contains information about where the icon
information
' can be found, colour depth, size.
Private m_tIDE() As ICONDIRENTRY
' Bits in each icon in the directory
' tBits is arranged as a :
' 1) A BITMAPINFOHEADER structure
' 2) An array of RGBQUAD structures (missing if the colour depth of the bitmap
is > 8bpp)
' 3) A colour DIB containing the AND bitmap bits
' 4) A mono DIB containing the XOR bitmap bits
Private m_tBits() As tBits
Public Property Get IsAnIconFile(ByVal sFile As String)
Dim tID As ICONDIR
Dim tIDE() As ICONDIRENTRY
Dim hFile As Long
Dim iEntry As Long
Dim bFail As Boolean
Dim sFail As String
Dim dwBytesRead As Long
Dim lLOf As Long
' Check the signature:
sFail = "Not an Icon File"
hFile = CreateFile(sFile, GENERIC_READ, 0, ByVal 0&, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0)
If (hFile <> 0) Then
lLOf = GetFileSize(hFile, ByVal 0&)
ReadFile hFile, tID, Len(tID), dwBytesRead, ByVal 0&
If dwBytesRead = Len(tID) Then
If (tID.idReserved = 0) Then ' No data in idReserved flag
If (tID.idType = IMAGE_ICON) Then ' Is icon
If tID.idCount > 0 And tID.idCount <= 256 Then ' sensible number
of images?
ReDim tIDE(0 To tID.idCount - 1) As ICONDIRENTRY
For iEntry = 1 To tID.idCount
ReadFile hFile, tIDE(iEntry - 1), Len(tIDE(iEntry - 1)),
dwBytesRead, ByVal 0&
If (dwBytesRead <> Len(tIDE(iEntry - 1))) Then
sFail = "Icon Directory Array is Corrupt."
bFail = True
Exit For
Else
' Check for vital signs:
If tIDE(iEntry - 1).bHeight > 0 And tIDE(iEntry -
1).bWidth > 0 Then
If tIDE(iEntry - 1).bHeight <= 256 And tIDE(iEntry -
1).bWidth <= 256 Then
If tIDE(iEntry - 1).dwBytesInRes <= 16 Or
tIDE(iEntry - 1).dwImageOffset <= 16 Or
tIDE(iEntry - 1).dwBytesInRes < lLOf Or
tIDE(iEntry - 1).dwImageOffset < lLOf Then
' ok
Else
sFail = "Icon Directory contains images with
invalid byte sizes"
bFail = True
Exit For
End If
Else
sFail = "Icon Directory contains oversized images"
End If
Else
sFail = "Icon Directory contains 0 sized images"
End If
End If
Next iEntry
Else
bFail = True
End If
Else
bFail = True
End If
Else
bFail = True
End If
Else
bFail = True
End If
CloseHandle hFile
Else
sFail = "Could not read from file"
End If
IsAnIconFile = Not (bFail)
End Property
Public Sub CloneTo(ByRef cThis As cFileIcon)
cThis.CloneFrom m_sFile, m_vID, m_tID, m_tIDE(), m_tBits()
End Sub
Friend Sub CloneFrom( _
ByRef sFile As String, _
ByRef vId As Variant, _
ByRef tID As ICONDIR, _
ByRef tIDE() As ICONDIRENTRY, _
ByRef tBits() As tBits _
)
Dim i As Long
m_sFile = sFile
m_vID = vId
LSet m_tID = tID
ReDim m_tIDE(0 To m_tID.idCount - 1) As ICONDIRENTRY
ReDim m_tBits(0 To m_tID.idCount - 1) As tBits
For i = 0 To m_tID.idCount - 1
LSet m_tIDE(i) = tIDE(i)
ReDim Preserve m_tBits(i).bBits(0 To tIDE(i).dwBytesInRes - 1) As Byte
CopyMemory m_tBits(i).bBits(0), tBits(i).bBits(0), tIDE(i).dwBytesInRes
Next i
End Sub
Public Property Get Filename() As String
Filename = m_sFile
End Property
Public Property Get ResourceID() As Variant
ResourceID = m_vID
End Property
Private Function IconToPicture(ByVal hIcon As Long) As IPicture
' Returns a VB picture object containing the specified icon.
If hIcon = 0 Then Exit Function
' This is all magic if you ask me:
Dim NewPic As Picture, PicConv As PictDesc, IGuid As Guid
PicConv.cbSizeofStruct = Len(PicConv)
PicConv.picType = vbPicTypeIcon
PicConv.hImage = hIcon
' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
With IGuid
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
OleCreatePictureIndirect PicConv, IGuid, True, NewPic
Set IconToPicture = NewPic
End Function
Public Property Get IconPicture(ByVal lHDC As Long, ByVal nIndex As Long) As
StdPicture
Dim hIcon As Long
hIcon = IconHandle(lHDC, nIndex)
' Change the Icon into a VB StdPicture object:
If (hIcon <> 0) Then
Set IconPicture = IconToPicture(hIcon)
End If
End Property
Public Property Get IconHandle(ByVal lHDC As Long, ByVal nIndex As Long) As Long
Dim hBmpAND As Long
Dim hBmpXOR As Long
Dim tII As ICONINFO
' Creates an icon indirectly from the bits:
tII.fIcon = IMAGE_ICON
tII.hbmColor = GetIconBitmap(lHDC, nIndex, ecfiImage, False,
bReturnBmp:=True)
tII.hBmMask = GetIconBitmap(lHDC, nIndex, ecfiMask, False, bReturnBmp:=True)
IconHandle = CreateIconIndirect(tII)
' Clear up the temporary bitmaps (if any):
DeleteObject tII.hbmColor
DeleteObject tII.hBmMask
End Property
Public Property Get ImageCount() As Long
' Number of icons in the currently loaded file or resource.
ImageCount = m_tID.idCount
End Property
Public Property Get ImageWidth(ByVal nIndex As Long) As Long
' Width of Icon at nIndex
ImageWidth = m_tIDE(nIndex - 1).bWidth
End Property
Public Property Get ImageHeight(ByVal nIndex As Long) As Long
' Height of Icon at nIndex
ImageHeight = m_tIDE(nIndex - 1).bHeight
End Property
Public Property Get ImageBitCount(ByVal nIndex As Long) As Long
' Ensure we read the correct colours (some header entries lie!)
Dim tBMIH As BITMAPINFOHEADER
CopyMemory tBMIH, m_tBits(nIndex - 1).bBits(0), Len(tBMIH)
ImageBitCount = tBMIH.biBitCount
End Property
Public Property Get ImageSize(ByVal nIndex As Long) As Long
ImageSize = m_tIDE(nIndex - 1).dwBytesInRes
End Property
Public Sub SetImageBits(ByVal lIndex As Long, ByVal lPtr As Long)
'
Dim tBMIH As BITMAPINFOHEADER
Dim lXor As Long
' First, get a copy of the BitmapInfoHeader structure:
' Icons have 2 x correct height, so temporarily correct the
' BitmapInfoHeader structure whilst we create the bitmap:
CopyMemory tBMIH, m_tBits(lIndex - 1).bBits(0), Len(tBMIH)
tBMIH.biHeight = tBMIH.biHeight \ 2
lXor = FindDIBits(tBMIH)
CopyMemory m_tBits(lIndex - 1).bBits(lXor), ByVal lPtr, tBMIH.biHeight *
WidthBytes(tBMIH.biWidth * tBMIH.biPlanes * tBMIH.biBitCount)
'
End Sub
Public Sub SetMaskBits(ByVal lIndex As Long, ByVal lPtr As Long)
Dim tBMIH As BITMAPINFOHEADER
Dim lXor As Long
Dim lAnd As Long
' First, get a copy of the BitmapInfoHeader structure:
' Icons have 2 x correct height, so temporarily correct the
' BitmapInfoHeader structure whilst we create the bitmap:
CopyMemory tBMIH, m_tBits(lIndex - 1).bBits(0), Len(tBMIH)
tBMIH.biHeight = tBMIH.biHeight \ 2
lXor = FindDIBits(tBMIH)
lAnd = lXor + m_tIDE(lIndex - 1).bHeight * 1# * WidthBytes(tBMIH.biWidth *
tBMIH.biPlanes * tBMIH.biBitCount)
CopyMemory m_tBits(lIndex - 1).bBits(lAnd), ByVal lPtr,
WidthBytes(tBMIH.biWidth) * tBMIH.biHeight
End Sub
Public Function RemoveImage(ByVal nIndex As Long) As Long
Dim i As Long
Dim tIDE As ICONDIRENTRY
Dim lShift As Long
Dim bFound As Boolean
' Removes icon at nIndex:
If (m_tID.idCount > 1) Then
' Remove the image, then shift up the remaining items
' in the array and fix up the image offsets:
For i = 0 To m_tID.idCount - 1
If (nIndex = i + 1) Then
bFound = True
lShift = m_tIDE(i).dwBytesInRes
ElseIf (i + 1 >= nIndex) Then
LSet tIDE = m_tIDE(i)
LSet m_tIDE(i - 1) = tIDE
ReDim Preserve m_tBits(i - 1).bBits(0 To tIDE.dwBytesInRes - 1) As
Byte
CopyMemory m_tBits(i - 1).bBits(0), m_tBits(i).bBits(0),
tIDE.dwBytesInRes
m_tIDE(i - 1).dwImageOffset = m_tIDE(i).dwImageOffset - lShift
End If
Next i
m_tID.idCount = m_tID.idCount - 1
ReDim Preserve m_tIDE(0 To m_tID.idCount - 1) As ICONDIRENTRY
ReDim Preserve m_tBits(0 To m_tID.idCount - 1) As tBits
For i = 0 To m_tID.idCount - 1
m_tIDE(i).dwImageOffset = m_tIDE(i).dwImageOffset + bFound * Len(tIDE)
Next i
Else
' no icons left:
Erase m_tIDE
Erase m_tBits
m_tID.idCount = 0
End If
End Function
Public Property Get IconIndex(ByVal nWidth As Long, ByVal nHeight As Long,
ByVal nBitCount As Long) As Long
If (m_tID.idCount > 0) Then
Dim i As Long
For i = 0 To m_tID.idCount - 1
With m_tIDE(i)
If (.bHeight = nHeight) And (.bWidth = nWidth) And (.wBitCount =
nBitCount) Then
' we already have it
IconIndex = i + 1
Exit For
End If
End With
Next i
End If
End Property
Public Function AddImage(ByVal nWidth As Long, ByVal nHeight As Long, ByVal
nBitCount As Long) As Long
Dim i As Long
Dim iItem As Long
Dim lNewImageOffset As Long
Dim tBMI As BITMAPINFOHEADER
Dim tRGBQ As RGBQUAD
Dim lPosition As Long
' Ensure the icon type is set correctly:
m_tID.idType = IMAGE_ICON
' Adds a new icon to the image:
If (m_tID.idCount > 0) Then
' Check we don't already have it:
For i = 0 To m_tID.idCount - 1
With m_tIDE(i)
If (.bHeight = nHeight) And (.bWidth = nWidth) And (.wBitCount =
nBitCount) Then
' we already have it
Err.Raise vbObjectError + 1048 + 1, App.EXEName & ".cFileIcon",
"Icon already exists."
Exit Function
End If
End With
Next i
' Increment all the image offsets to account for the new icon
' directory entry:
For i = 0 To m_tID.idCount - 1
m_tIDE(i).dwImageOffset = m_tIDE(i).dwImageOffset + Len(m_tIDE(i))
Next i
i = m_tID.idCount - 1
lNewImageOffset = m_tIDE(i).dwImageOffset + m_tIDE(i).dwBytesInRes
End If
' If we don't, then add it:
m_tID.idCount = m_tID.idCount + 1
iItem = m_tID.idCount - 1
' Add the ICONDIRENTRY header:
ReDim Preserve m_tIDE(0 To iItem) As ICONDIRENTRY
With m_tIDE(iItem)
.wBitCount = nBitCount
If (.wBitCount = 1) Then
.bColorCount = 2
ElseIf (.wBitCount = 4) Then
.bColorCount = 16
Else
.bColorCount = 0
End If
.wPlanes = 1
.bWidth = nWidth
.bHeight = nHeight
If (iItem = 0) Then
.dwImageOffset = Len(m_tID) + Len(m_tIDE(iItem))
Else
.dwImageOffset = lNewImageOffset
End If
' Add Bitmap Info Header size + Palette Size:
If (.wBitCount <= 8) Then
.dwBytesInRes = Len(tBMI) + (2 ^ .wBitCount) * Len(tRGBQ)
Else
' > 256 colours, true colour icon.
.dwBytesInRes = Len(tBMI)
End If
' Add XOR (colour) image size:
.dwBytesInRes = .dwBytesInRes + nHeight * WidthBytes(nWidth * .wBitCount
* .wPlanes)
' Add AND (mask) image size:
.dwBytesInRes = .dwBytesInRes + nHeight * WidthBytes(nWidth)
End With
' Add the Bitmap bits:
ReDim Preserve m_tBits(0 To iItem) As tBits
ReDim Preserve m_tBits(iItem).bBits(0 To m_tIDE(iItem).dwBytesInRes - 1) As
Byte
' Generate the Bitmap Info Header:
tBMI.biSize = Len(tBMI)
tBMI.biWidth = nWidth
' Note that icons have a height of x2
tBMI.biHeight = nHeight * 2
tBMI.biPlanes = 1
tBMI.biBitCount = m_tIDE(iItem).wBitCount
tBMI.biCompression = BI_RGB
tBMI.biClrUsed = 0
' Put it into the bits.
CopyMemory m_tBits(iItem).bBits(0), tBMI, Len(tBMI)
' Now you have an all black mask (no transparent pixels)
' and an all black image.
lPosition = tBMI.biSize
' Lets generate a palette as required:
If (tBMI.biBitCount = 1) Then
' 1 bit, 2 colours, set the second colour to white
tRGBQ.rgbBlue = 255
tRGBQ.rgbRed = 255
tRGBQ.rgbGreen = 255
lPosition = Len(tBMI) + Len(tRGBQ)
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
ElseIf (tBMI.biBitCount = 4) Then
' 4 bits, 16 colours, set 16 colour palette:
set16ColorPalette iItem, lPosition
ElseIf (tBMI.biBitCount = 8) Then
' 8 bits, 256 colours, set websafe palette:
set16ColorPalette iItem, lPosition
addWebSafePalette iItem, lPosition
End If
AddImage = iItem + 1
End Function
Private Sub addWebSafePalette(ByVal iItem As Long, ByRef lPosition As Long)
Dim iR As Long
Dim iB As Long
Dim iG As Long
Dim tRGBQ As RGBQUAD
For iR = 0 To &HCC Step &H33
tRGBQ.rgbRed = iR
For iG = 0 To &HCC Step &H33
tRGBQ.rgbGreen = iG
For iB = 0 To &HCC Step &H33
tRGBQ.rgbBlue = iB
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
Next iB
Next iG
Next iR
End Sub
Private Sub set16ColorPalette(ByVal iItem As Long, ByRef lPosition As Long)
Dim tRGBQ As RGBQUAD
' Black
tRGBQ.rgbRed = 0: tRGBQ.rgbGreen = 0: tRGBQ.rgbBlue = 0
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Dark Green:
tRGBQ.rgbRed = 0: tRGBQ.rgbGreen = 128: tRGBQ.rgbBlue = 0
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Dark Cyan
tRGBQ.rgbRed = 0: tRGBQ.rgbGreen = 128: tRGBQ.rgbBlue = 128
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Dark Red
tRGBQ.rgbRed = 128: tRGBQ.rgbGreen = 0: tRGBQ.rgbBlue = 0
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Dark Purple
tRGBQ.rgbRed = 128: tRGBQ.rgbGreen = 0: tRGBQ.rgbBlue = 128
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Olive
tRGBQ.rgbRed = 128: tRGBQ.rgbGreen = 128: tRGBQ.rgbBlue = 0
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Dark Blue
tRGBQ.rgbRed = 0: tRGBQ.rgbGreen = 0: tRGBQ.rgbBlue = 128
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Light Gray
tRGBQ.rgbRed = 192: tRGBQ.rgbGreen = 192: tRGBQ.rgbBlue = 192
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Dark Gray:
tRGBQ.rgbRed = 128: tRGBQ.rgbGreen = 128: tRGBQ.rgbBlue = 128
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Bright Blue:
tRGBQ.rgbRed = 0: tRGBQ.rgbGreen = 0: tRGBQ.rgbBlue = 255
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Bright Green:
tRGBQ.rgbRed = 0: tRGBQ.rgbGreen = 255: tRGBQ.rgbBlue = 0
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Cyan
tRGBQ.rgbRed = 0: tRGBQ.rgbGreen = 255: tRGBQ.rgbBlue = 255
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Red
tRGBQ.rgbRed = 255: tRGBQ.rgbGreen = 0: tRGBQ.rgbBlue = 0
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Magenta:
tRGBQ.rgbRed = 255: tRGBQ.rgbGreen = 0: tRGBQ.rgbBlue = 255
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' Yellow;
tRGBQ.rgbRed = 255: tRGBQ.rgbGreen = 255: tRGBQ.rgbBlue = 0
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
' White:
tRGBQ.rgbRed = 255: tRGBQ.rgbGreen = 255: tRGBQ.rgbBlue = 255
CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ)
lPosition = lPosition + Len(tRGBQ)
End Sub
Public Function LoadIconFromEXE( _
ByVal sFile As String, _
Optional ByVal lpID As Long = 0, _
Optional ByVal lpName As String = "" _
) As Boolean
Dim hLibrary As Long
Dim hRsrc As Long
Dim hGlobal As Long
Dim lPtr As Long
Dim iEntry As Long
Dim tMIDE As MEMICONDIRENTRY
Dim nID() As Integer
Dim iBaseOffset As Long
Dim lSize As Long
Dim bFail As Boolean
' Loads an Icon from an Executable (EXE, DLL etc). Use the EnumResources
module
' to determine the available resource IDs.
m_sFile = sFile
m_vID = Empty
Erase m_tIDE
Erase m_tBits
With m_tID
.idCount = 0
.idReserved = 0
.idType = 0
End With
hLibrary = LoadLibraryEx(sFile, ByVal 0&, LOAD_LIBRARY_AS_DATAFILE)
If (hLibrary = 0) Then
' Failed to load the executable. Probably not a Win32 EXE.
Err.Raise vbObjectError + 1048 + 6, App.EXEName & ".cFileIcon", "Can't
load library."
LoadIconFromEXE = False
Else
' Find the resource:
If (lpID <> 0) Then
lpName = "#" & CStr(lpID)
hRsrc = FindResource(hLibrary, ByVal lpName, ByVal RT_GROUP_ICON)
m_vID = lpID
Else
hRsrc = FindResource(hLibrary, ByVal lpName, ByVal RT_GROUP_ICON)
m_vID = lpName
End If
If (hRsrc = 0) Then
' Resource not found in this library:
Err.Raise vbObjectError + 1048 + 7, App.EXEName & ".cFileIcon", "Can't
find resource."
LoadIconFromEXE = False
Else
' Load the resource (returns a handle which can be used to access the
data):
hGlobal = LoadResource(hLibrary, hRsrc)
If (hGlobal = 0) Then
Err.Raise vbObjectError + 1048 + 8, App.EXEName & ".cFileIcon",
"Can't load resource."
LoadIconFromEXE = False
Else
' Lock the resource for reading (returns a pointer to the resource
data):
lPtr = LockResource(hGlobal)
If (lPtr = 0) Then
Err.Raise vbObjectError + 1048 + 8, App.EXEName & ".cFileIcon",
"Can't lock resource."
LoadIconFromEXE = False
Else
' Get the icon header:
CopyMemory m_tID, ByVal lPtr, Len(m_tID)
Debug.Print m_tID.idCount, m_tID.idReserved, m_tID.idType
' Do we have icons in this resource?
If (m_tID.idCount > 0) Then
' For each of the entries, get the icon directory information:
ReDim m_tIDE(0 To m_tID.idCount - 1) As ICONDIRENTRY
ReDim nID(0 To m_tID.idCount - 1) As Integer
' Get all the directory information into a byte array (to
avoid
' problems with WORD alignment of structures):
ReDim b(0 To Len(m_tID) + Len(tMIDE) * m_tID.idCount - 1) As
Byte
CopyMemory b(0), ByVal lPtr, Len(m_tID) + Len(tMIDE) *
m_tID.idCount
' Loop through the entries, getting the IDs and creating a
standard
' ICONDIRENTRY structure:
For iEntry = 0 To m_tID.idCount - 1
' Get the MEMICONDIRENTRY structure:
CopyMemory tMIDE, b(Len(m_tID) + iEntry * Len(tMIDE)),
Len(tMIDE)
' Store the icon's resource id:
nID(iEntry) = tMIDE.nID
' Copy data into standard ICONDIRENTRY structure. Note
the .dwImageOffset
' member will be wrong at this stage:
CopyMemory m_tIDE(iEntry), tMIDE, Len(tMIDE)
Next iEntry
' Now correct the ICONDIRENTRY byte offsets:
iBaseOffset = Len(m_tID) + Len(m_tIDE(0)) * m_tID.idCount
m_tIDE(0).dwImageOffset = iBaseOffset
For iEntry = 1 To m_tID.idCount - 1
m_tIDE(iEntry).dwImageOffset = m_tIDE(iEntry -
1).dwImageOffset + m_tIDE(iEntry - 1).dwBytesInRes
Next iEntry
' Now we have the ICONDIRENTRY structures, get the actual
bits of the icons:
ReDim m_tBits(0 To m_tID.idCount - 1) As tBits
For iEntry = 0 To m_tID.idCount - 1
' Load the icon with the specified resource ID:
lpName = "#" & nID(iEntry)
hRsrc = FindResource(hLibrary, ByVal lpName, ByVal RT_ICON)
If (hRsrc = 0) Then
bFail = True
Exit For
Else
' Load the resource:
hGlobal = LoadResource(hLibrary, hRsrc)
If (hGlobal = 0) Then
bFail = True
Exit For
Else
' Determine the size of the resource:
lSize = SizeofResource(hLibrary, hRsrc)
' If the size is valid:
If (lSize > 0) And (lSize =
m_tIDE(iEntry).dwBytesInRes) Then
' Lock the resource and get a pointer to the
memory:
lPtr = LockResource(hGlobal)
If (lPtr = 0) Then
bFail = True
Exit For
Else
' Store this memory in the bitmap bits array:
ReDim Preserve m_tBits(iEntry).bBits(0 To
lSize - 1) As Byte
CopyMemory m_tBits(iEntry).bBits(0), ByVal
lPtr, lSize
End If
Else
bFail = True
End If
End If
End If
Next iEntry
' Did we succeed?
If (bFail) Then
Err.Raise vbObjectError + 1048 + 9, App.EXEName &
".cFileIcon", "Failed to read bitmap bits from resource."
' ensure clear:
sFile = ""
Erase m_tIDE
Erase m_tBits
m_tID.idCount = 0
m_vID = Empty
End If
LoadIconFromEXE = Not (bFail)
End If
End If
End If
End If
' Free library:
FreeLibrary hLibrary
End If
End Function
Public Function LoadIcon(ByVal sFile As String) As Boolean
Dim hFile As Long
Dim iValue As Long
Dim iType As Long
Dim iEntry As Long
Dim i As Long
Dim dwBytesRead As Long
Dim bFail As Boolean
Dim sFail As String
Dim tBMI As BITMAPINFOHEADER
m_sFile = sFile
m_vID = Empty
Erase m_tIDE
Erase m_tBits
With m_tID
.idCount = 0
.idReserved = 0
.idType = 0
End With
' Here we use API methods to access the file. We don't need to, but there
' is more flexibility this way to ensure we get the correct bits.
hFile = CreateFile(sFile, GENERIC_READ, 0, ByVal 0&, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0)
If (hFile <> 0) Then
ReadFile hFile, m_tID, Len(m_tID), dwBytesRead, ByVal 0&
If (m_tID.idReserved = 0) Then ' No data in idReserved flag
If (m_tID.idType = IMAGE_ICON) Then ' Is icon
Debug.Print "Icon contains " & m_tID.idCount & " images."
If (m_tID.idCount > 0) Then
' loop through reading the directory information:
ReDim m_tIDE(0 To m_tID.idCount - 1) As ICONDIRENTRY
For iEntry = 1 To m_tID.idCount
ReadFile hFile, m_tIDE(iEntry - 1), Len(m_tIDE(iEntry - 1)),
dwBytesRead, ByVal 0&
If (dwBytesRead <> Len(m_tIDE(iEntry - 1))) Then
sFail = "Icon Directory Array is Corrupt."
bFail = True
Exit For
End If
'With m_tIDE(iEntry - 1)
' Debug.Print .bWidth, .bHeight, .bColorCount, .wPlanes,
.wBitCount, .dwBytesInRes, .dwImageOffset
'End With
Next iEntry
' we have the directories, now read the icon images:
If Not (bFail) Then
ReDim m_tBits(0 To m_tID.idCount - 1) As tBits
For iEntry = 1 To m_tID.idCount
' Move to the image position:
SetFilePointer hFile, m_tIDE(iEntry - 1).dwImageOffset,
ByVal 0&, FILE_BEGIN
' Prepare the correct number of bits for the image:
ReDim m_tBits(iEntry - 1).bBits(0 To m_tIDE(iEntry -
1).dwBytesInRes) As Byte
' Get them from the file:
ReadFile hFile, m_tBits(iEntry - 1).bBits(0),
m_tIDE(iEntry - 1).dwBytesInRes, dwBytesRead, ByVal 0&
' Check if we got the right number:
If (dwBytesRead <> m_tIDE(iEntry - 1).dwBytesInRes) Then
sFail = "Icon Images Array is Corrupt."
bFail = True
Exit For
End If
Next iEntry
LoadIcon = Not (bFail)
End If
Else
sFail = "Icon contains no images."
End If
Else
sFail = "File is not icon type (idType <> IMAGE_ICON)"
End If
Else
sFail = "File is not icon type (reserved member is 0)"
End If
' Close file handle:
CloseHandle hFile
' Did we succeed?
If (bFail) Then
Err.Raise vbObjectError + 1048 + 2, App.EXEName & ".cFileIcon",
"Failed to load icon: " & sFail
' ensure clear:
sFile = ""
Erase m_tIDE
Erase m_tBits
m_tID.idCount = 0
End If
End If
End Function
Public Sub GetPalette(ByVal nIndex As Long, ByVal lPtrMem As Long)
Dim lOffset As Long
Dim tBMIH As BITMAPINFOHEADER
Dim lColorCount As Long
Dim tRGB As RGBQUAD
If m_tIDE(nIndex - 1).wBitCount <= 8 Then
lOffset = Len(tBMIH)
lColorCount = 2 ^ m_tIDE(nIndex - 1).wBitCount
CopyMemory ByVal lPtrMem, m_tBits(nIndex - 1).bBits(lOffset), lColorCount
* Len(tRGB)
End If
End Sub
Public Sub SetPalette(ByVal nIndex As Long, ByVal lPtrMem As Long)
Dim lOffset As Long
Dim tBMIH As BITMAPINFOHEADER
Dim lColorCount As Long
Dim tRGB As RGBQUAD
If m_tIDE(nIndex - 1).wBitCount <= 8 Then
lOffset = Len(tBMIH)
lColorCount = 2 ^ m_tIDE(nIndex - 1).wBitCount
CopyMemory m_tBits(nIndex - 1).bBits(lOffset), ByVal lPtrMem, lColorCount
* Len(tRGB)
End If
End Sub
Public Function SaveIcon( _
Optional ByVal sFileName As String = "" _
) As Boolean
Dim hFile As Long
Dim dwBytesWritten As Long
Dim iEntry As Long
Dim bFail As Boolean
' General error checking:
If (m_sFile = "") Then
If (sFileName = "") Then
Err.Raise vbObjectError + 1048 + 3, App.EXEName & ".cFileIcon", "No
filename specified."
Exit Function
End If
End If
If (m_tID.idCount = 0) Then
Err.Raise vbObjectError + 1048 + 4, App.EXEName & ".cFileIcon", "Icon
contains no images."
Exit Function
End If
' Now start writing:
If (sFileName <> "") Then
m_sFile = sFileName
End If
' Open the file for write:
hFile = CreateFile(m_sFile, GENERIC_WRITE, 0, ByVal 0&, CREATE_ALWAYS,
FILE_ATTRIBUTE_NORMAL, ByVal 0&)
If (hFile = INVALID_HANDLE_VALUE) Then
Err.Raise vbObjectError + 1048 + 4, App.EXEName & ".cFileIcon", "Couldn't
open file for writing."
Else
' Write the header:
WriteFile hFile, m_tID, Len(m_tID), dwBytesWritten, ByVal 0&
If (dwBytesWritten = Len(m_tID)) Then
' Write the ICONDIRENTRY structures:
For iEntry = 0 To m_tID.idCount - 1
WriteFile hFile, m_tIDE(iEntry), Len(m_tIDE(iEntry)),
dwBytesWritten, ByVal 0&
If (dwBytesWritten <> Len(m_tIDE(iEntry))) Then
bFail = True
Exit For
End If
Next iEntry
' Write the icon bits:
If Not (bFail) Then
For iEntry = 0 To m_tID.idCount - 1
WriteFile hFile, m_tBits(iEntry).bBits(0),
m_tIDE(iEntry).dwBytesInRes, dwBytesWritten, ByVal 0&
If (m_tIDE(iEntry).dwBytesInRes <> dwBytesWritten) Then
bFail = True
Exit For
End If
Next iEntry
End If
Else
bFail = True
End If
' Close the file:
CloseHandle hFile
' Did we succeed?
If (bFail) Then
Err.Raise vbObjectError + 1048 + 5, App.EXEName & ".cFileIcon",
"General failure writing icon."
End If
SaveIcon = Not (bFail)
End If
End Function
Public Sub DrawIconImage( _
ByVal lHDC As Long, _
ByVal nIndex As Long, _
Optional ByVal eType As ECFIImageConstants = ecfiImage, _
Optional ByVal x As Long = 0, Optional ByVal y As Long = 0, _
Optional ByVal lWidth As Long = 0, Optional ByVal lHeight As Long = 0, _
Optional ByVal eRasterOp As RasterOpConstants = vbSrcCopy _
)
' Draws either the Image (XOR) or Mask (AND) parts of the icon to an HDC:
GetIconBitmap lHDC, nIndex, eType, True, x, y, lWidth, lHeight, eRasterOp
End Sub
Public Function SetIconFromBitmap( _
ByVal lHDC As Long, _
ByVal nIndex As Long, _
Optional ByVal x As Long = 0, Optional ByVal y As Long = 0, _
Optional ByVal bSetMaskUsingTransparentColour As Boolean, _
Optional ByVal lTransparentColour As OLE_COLOR = -1, _
Optional ByVal lMaskHDC As Long _
)
Dim tBMIH As BITMAPINFOHEADER
Dim tBMIMono As BITMAPINFO_1BPP
Dim lXor As Long
Dim lAnd As Long
Dim lhDCMaskCopy As Long
Dim lhBMPMask As Long
Dim lhBMPMaskOld As Long
Dim lhDCImage As Long
Dim lhBmpImage As Long
Dim lhBmpImageOld As Long
Dim lPtrMask As Long
Dim lhDCDibImage As Long
Dim hDibImage As Long
Dim lhDibImageOld As Long
Dim lPtr As Long
' First, get a copy of the BitmapInfoHeader structure:
' Icons have 2 x correct height, so temporarily correct the
' BitmapInfoHeader structure whilst we create the bitmap:
CopyMemory tBMIH, m_tBits(nIndex - 1).bBits(0), Len(tBMIH)
tBMIH.biHeight = tBMIH.biHeight \ 2
CopyMemory m_tBits(nIndex - 1).bBits(0), tBMIH, Len(tBMIH)
' find the XOR (image) bits within the icon:
lXor = FindDIBits(tBMIH)
' Find the AND (mask) bits within the icon:
lAnd = lXor + m_tIDE(nIndex - 1).bHeight * 1# * WidthBytes(tBMIH.biWidth *
tBMIH.biPlanes * tBMIH.biBitCount)
' Get the transparent colour:
If lTransparentColour = -1 Then
lTransparentColour = GetPixel(lHDC, x, y)
End If
' Get a copy of the mask at the right position:
lhDCMaskCopy = CreateCompatibleDC(0)
If lhDCMaskCopy <> 0 Then
'lhBMPMask = CreateCompatibleBitmap(lhDCMaskCopy, tBMIH.biWidth,
tBMIH.biHeight)
With tBMIMono
With .bmiHeader
.biSize = Len(tBMIMono.bmiHeader)
.biPlanes = 1
.biHeight = tBMIH.biHeight
.biWidth = tBMIH.biWidth
.biBitCount = 1
.biCompression = BI_RGB
End With
With .bmiColors(0)
.rgbBlue = 0: .rgbGreen = 0: .rgbRed = 0
End With
With .bmiColors(1)
.rgbBlue = 255: .rgbGreen = 255: .rgbRed = 255
End With
End With
lhBMPMask = CreateCompatibleBitmap(lhDCMaskCopy, tBMIH.biWidth,
tBMIH.biHeight)
If lhBMPMask <> 0 Then
lhBMPMaskOld = SelectObject(lhDCMaskCopy, lhBMPMask)
If lMaskHDC = 0 Then
' Create a mask from the transparent colour:
SetBkColor lMaskHDC, lTransparentColour
SetBkColor lHDC, lTransparentColour
' Copy from source DC, inverting the destination:
BitBlt lhDCMaskCopy, 0, 0, tBMIH.biWidth, tBMIH.biHeight, lHDC, x,
y, vbNotSrcCopy
Else
' Make a copy of the mask:
BitBlt lhDCMaskCopy, 0, 0, tBMIH.biWidth, tBMIH.biHeight, lMaskHDC,
x, y, vbSrcCopy
End If
' We have the mask bitmap. Now we can transfer the
' image:
lhDCImage = CreateCompatibleDC(lHDC)
If lhDCImage <> 0 Then
lhBmpImage = CreateCompatibleBitmap(lHDC, tBMIH.biWidth,
tBMIH.biHeight)
If lhBmpImage <> 0 Then
lhBmpImageOld = SelectObject(lhDCImage, lhBmpImage)
' Copy the image;
BitBlt lhDCImage, 0, 0, tBMIH.biWidth, tBMIH.biHeight, lHDC, x,
y, vbSrcCopy
' Set to black where mask is black:
BitBlt lhDCImage, 0, 0, tBMIH.biWidth, tBMIH.biHeight,
lhDCMaskCopy, 0, 0, &H8800C6
' Now we have a suitable image and mask for the icon, we want to
convert
' them into DIB sections so we can load the data directly into
the
' icon resource:
hDibImage = CreateDIBSection(lHDC, m_tBits(nIndex - 1).bBits(0),
DIB_RGB_COLORS, lPtr, 0, 0)
If hDibImage <> 0 Then
lhDCDibImage = CreateCompatibleDC(lHDC)
If lhDCDibImage <> 0 Then
lhDibImageOld = SelectObject(lhDCDibImage, hDibImage)
BitBlt lhDCDibImage, 0, 0, tBMIH.biWidth, tBMIH.biHeight,
lhDCImage, 0, 0, vbSrcCopy
SelectObject lhDCDibImage, lhDibImageOld
DeleteDC lhDCDibImage
GdiFlush
CopyMemory m_tBits(nIndex - 1).bBits(lXor), ByVal lPtr,
WidthBytes(tBMIH.biWidth * tBMIH.biHeight *
tBMIH.biPlanes * tBMIH.biBitCount)
End If
DeleteObject hDibImage
End If
hDibImage = 0: lhDCDibImage = 0: lhDibImageOld = 0
hDibImage = CreateDIBSection(lHDC, tBMIMono, DIB_RGB_COLORS,
lPtr, 0, 0)
If hDibImage <> 0 Then
lhDCDibImage = CreateCompatibleDC(lHDC)
If lhDCDibImage <> 0 Then
lhDibImageOld = SelectObject(lhDCDibImage, hDibImage)
BitBlt lhDCDibImage, 0, 0, tBMIH.biWidth, tBMIH.biHeight,
lhDCMaskCopy, 0, 0, vbNotSrcCopy
SelectObject lhDCDibImage, lhDibImageOld
DeleteDC lhDCDibImage
GdiFlush
CopyMemory m_tBits(nIndex - 1).bBits(lAnd), ByVal lPtr,
WidthBytes(tBMIH.biWidth) * tBMIH.biHeight
End If
DeleteObject hDibImage
End If
SelectObject lhDCImage, lhBmpImage
DeleteObject lhBmpImage
End If
DeleteDC lhDCImage
End If
SelectObject lhDCMaskCopy, lhBMPMaskOld
DeleteObject lhBMPMask
End If
DeleteDC lhDCMaskCopy
End If
' Put the x2 icon height back again:
CopyMemory tBMIH, m_tBits(nIndex - 1).bBits(0), Len(tBMIH)
tBMIH.biHeight = tBMIH.biHeight * 2
CopyMemory m_tBits(nIndex - 1).bBits(0), tBMIH, Len(tBMIH)
End Function
Private Function GetIconBitmap( _
ByVal lHDC As Long, _
ByVal nIndex As Long, _
ByVal eType As ECFIImageConstants, _
Optional ByVal bDrawToDC As Boolean = True, _
Optional ByVal x As Long, Optional ByVal y As Long, _
Optional ByVal lWidth As Long, Optional ByVal lHeight As Long, _
Optional ByVal eOp As RasterOpConstants, _
Optional ByVal bReturnBmp As Boolean = False _
) As Long
Dim hdc As Long
Dim lR As Long
Dim lAnd As Long, lXor As Long
Dim tBMIH As BITMAPINFOHEADER
Dim tBMIMono As BITMAPINFO_1BPP
Dim hBmp As Long
Dim hBmpOld As Long
' Returns or draws a device dependent bitmap containing the Image (XOR)
' or Mask (AND) image from an icon
If (eType = ecfiImage) Then
' Extract the XOR (colour) part of the icon image:
' First create a compatible DC:
hdc = CreateCompatibleDC(lHDC) ' we can replace this with desktop DC
If (hdc <> 0) Then
' Create a Bitmap compatible with the device:
hBmp = CreateCompatibleBitmap(lHDC, m_tIDE(nIndex - 1).bWidth,
m_tIDE(nIndex - 1).bHeight)
If (hBmp <> 0) Then
' Select the object into the DC:
hBmpOld = SelectObject(hdc, hBmp)
If (hBmpOld <> 0) Then
' Icons have 2 x correct height, so temporarily correct the
' BitmapInfoHeader structure whilst we create the bitmap:
CopyMemory tBMIH, m_tBits(nIndex - 1).bBits(0), Len(tBMIH)
tBMIH.biHeight = tBMIH.biHeight \ 2
CopyMemory m_tBits(nIndex - 1).bBits(0), tBMIH, Len(tBMIH)
' find the XOR (image) bits within the icon:
lXor = FindDIBits(tBMIH)
' Set the Compatible Bitmap to the colour bits in the DIB within
the icon:
lR = SetDIBitsToDevice(hdc, 0, 0, m_tIDE(nIndex - 1).bWidth,
m_tIDE(nIndex - 1).bHeight, 0, 0, 0, m_tIDE(nIndex -
1).bHeight, m_tBits(nIndex - 1).bBits(lXor), m_tBits(nIndex -
1).bBits(0), DIB_RGB_COLORS)
' Draw it if required:
If (bDrawToDC) Then
If (lWidth = 0) And (lHeight = 0) Then
BitBlt lHDC, x, y, m_tIDE(nIndex - 1).bWidth,
m_tIDE(nIndex - 1).bHeight, hdc, 0, 0, eOp
Else
' NB only allowing a larger version to be drawn here.
If (lWidth = 0) Then
lWidth = m_tIDE(nIndex - 1).bWidth
End If
If (lHeight = 0) Then
lHeight = m_tIDE(nIndex - 1).bHeight
End If
StretchBlt lHDC, x, y, lWidth, lHeight, hdc, 0, 0,
m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight, eOp
End If
End If
' Put the x2 icon height back again:
CopyMemory tBMIH, m_tBits(nIndex - 1).bBits(0), Len(tBMIH)
tBMIH.biHeight = tBMIH.biHeight * 2
CopyMemory m_tBits(nIndex - 1).bBits(0), tBMIH, Len(tBMIH)
' Remove the bitmap from the DC
SelectObject hdc, hBmpOld
End If
' Delete created bitmap if required:
If (bReturnBmp) Then
GetIconBitmap = hBmp
Else
DeleteObject hBmp
End If
End If
' Clear up memory DC:
DeleteDC hdc
End If
Else
' Extract the AND (mask) part of the icon image:
' Create a monochrome DC:
hdc = CreateCompatibleDC(0&)
If (hdc <> 0) Then
' Create a monochrome bitmap:
hBmp = CreateCompatibleBitmap(hdc, m_tIDE(nIndex - 1).bWidth,
m_tIDE(nIndex - 1).bHeight)
If (hBmp <> 0) Then
' Select the mono-bitmap into the DC:
hBmpOld = SelectObject(hdc, hBmp)
If (hBmpOld <> 0) Then
' We need to create a BitmapInfo structure is a monochrome
' version of the one provided in the Icon.
' First, get a copy of the BitmapInfoHeader structure:
CopyMemory tBMIMono.bmiHeader, m_tBits(nIndex - 1).bBits(0),
Len(tBMIH)
' Find the Mask bits within the icon. These directly follow the
XOR bits
' so we find the XOR bits and then add the size of the AND DIB:
lXor = FindDIBits(tBMIMono.bmiHeader)
lAnd = lXor + m_tIDE(nIndex - 1).bHeight * 1# *
WidthBytes(tBMIMono.bmiHeader.biWidth *
tBMIMono.bmiHeader.biPlanes * tBMIMono.bmiHeader.biBitCount)
' Fix up the BitmapInfo structure to represent a monochrome
' DIB:
With tBMIMono
With .bmiHeader
' In icons the height = 2x the actual height:
.biHeight = .biHeight \ 2
.biPlanes = 1
.biBitCount = 1
.biCompression = BI_RGB
.biSizeImage = 0
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
.biClrUsed = 0
.biClrImportant = 0
End With
' Set up monochrome colour palette:
With .bmiColors(0)
.rgbRed = 0
.rgbGreen = 0
.rgbBlue = 0
.rgbReserved = 0
End With
With .bmiColors(1)
.rgbRed = 255
.rgbGreen = 255
.rgbBlue = 255
.rgbReserved = 0
End With
End With
' Set the Compatible Bitmap to the mask bits in the DIB within
the icon:
lR = SetDIBitsToDevice(hdc, 0, 0, m_tIDE(nIndex - 1).bWidth,
m_tIDE(nIndex - 1).bHeight, 0, 0, 0, m_tIDE(nIndex -
1).bHeight, m_tBits(nIndex - 1).bBits(lAnd), tBMIMono,
DIB_RGB_COLORS)
' Draw it if required:
If (bDrawToDC) Then
If (lWidth = 0) And (lHeight = 0) Then
BitBlt lHDC, x, y, m_tIDE(nIndex - 1).bWidth,
m_tIDE(nIndex - 1).bHeight, hdc, 0, 0, eOp
Else
' NB only allowing a larger version to be drawn here.
If (lWidth = 0) Then
lWidth = m_tIDE(nIndex - 1).bWidth
End If
If (lHeight = 0) Then
lHeight = m_tIDE(nIndex - 1).bHeight
End If
StretchBlt lHDC, x, y, lWidth, lHeight, hdc, 0, 0,
m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight, eOp
End If
End If
' Remove bitmap from DC:
SelectObject hdc, hBmpOld
End If
' Clear up bitmap if required:
If (bReturnBmp) Then
GetIconBitmap = hBmp
Else
DeleteObject hBmp
End If
End If
' Clear up memory DC.
DeleteObject hdc
End If
End If
End Function
Private Function FindDIBits(ByRef tBMI As BITMAPINFOHEADER) As Long
Dim tRGBQ As RGBQUAD
' Returns the position of the DIB bitmap bits within a
' DIB bitmap array:
FindDIBits = Len(tBMI) + DIBNumColors(tBMI) * Len(tRGBQ)
End Function
Private Function DIBNumColors(ByRef tBMI As BITMAPINFOHEADER) As Long
'{
Dim wBitCount As Long
Dim dwClrUsed As Long
' Returns the number of colour entries in a DIB:
dwClrUsed = tBMI.biClrUsed
If (dwClrUsed <> 0) Then
DIBNumColors = dwClrUsed
Else
wBitCount = tBMI.biBitCount
Select Case wBitCount
Case 1
DIBNumColors = 2
Case 4
DIBNumColors = 16
Case 8
DIBNumColors = 256
Case Else
DIBNumColors = 0
End Select
End If
' }
'/* End DIBNumColors() ******************************************************/
End Function
Private Function WidthBytes(ByVal lWidth As Long) As Long
'#define WIDTHBYTES(bits) ((((bits) + 31)>>5)<<2)
' Returns the width of a row in a DIB Bitmap given the
' number of bits. DIB Bitmap rows always align on a DWORD boundary.
WidthBytes = ((lWidth + 31) \ 32) * 4
End Function
