GDI/图象编程

开发平台：

Visual Basic

c32bppDIB.cls：源码内容

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "c32bppDIB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' Credits/Acknowledgements - Thanx goes to:
' Paul Caton for his class on calling non VB-Friendly DLLs that use _cdecl calling convention
' Used when calling non VB-friendly zLIB dll versions
' Alfred Koppold for his PNG, VB-only, decompression routines.
' Used when zLib & GDI+ not available
' Carles P.V for his pvResize logic
' Used when manually scaling images with NearestNeighbor or BiLinear interpolation
' www.zlib.net for their free zLIB.dll, the standard DLL for compressing/decompressing PNGs
' Without it, we'd be limited to GDI+ for creating PNGs
' coders like you that provide constructive criticism to make this class better & more all-inclusive
' Without your comments, this project probably would have died several versions/updates ago
' For most current updates/enhancements visit the following:
' Visit http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=67466&lngWId=1
' NOTE: ALL CLASSES AND MODULES WITHIN THIS CONTROL MAY HAVE BEEN MODIFIED AND SOME
' ROUTINES REMOVED. THEREFORE COMMENTS MAY APPEAR REFERENCING ROUTINES THAT DO NOT EXIST
' FOR THE COMPLETE UP TO DATE VERSIONS OF THESE CLASSES VISIT:
' http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=67466&lngWId=1
' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
' O V E R V I E W
' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
' About 32bpp pre-multiplied RGB (pARGB) bitmaps, if you are not aware.
' - These are used specifically for the AlphaBlend API & are GDI+ compatible
' Advantages:
' - Images can be per-pixel alpha blended
' - Opacity can be simultaneously adjusted during rendering
' - AlphaBlend does both BitBlt & StretchBlt for pARGB images.
' - Speed: AlphaBlend & GDI+ are pretty quick APIs vs manual blending
' Disadvantages:
' - The original RGB values are permanently destroyed during pre-multiplying
' -- Premultiplied formula: preMultipliedRed=(OriginalRed * Alpha) 255
' -- There is no way to convert pARGB back to non-premultiplied RGB values
' The formula would be: reconstructedRed=(preMultipliedRed * 255) Alpha.
' but because of integer division when pre-multiplying, the result is only
' close and if this should be premultiplied again & converted again, the
' alphas can get more transparent with every iteration.
' Fully opaque pixels & fully transparent pixels are not affected.
' ** Note: When images are converted to PNG formats, removal of
' premultiplication is performed to meet PNG specs.
' - Displaying a pre-multiplied bitmap without AlphaBlend will not result in
' the image being displayed as expected.
' - Not ideal for saving due to its size: SizeOf= W x H x 4
' -- better to save source image instead or compress the DIB bytes using favorite compression utility
' -- with GDI+ or zLib, image can be converted to PNG for storage
' - AlphaBlend (msimg32.dll) is not included/compatible with Win95, NT4 and lower
' - AlphaBlend on Win9x systems can be buggy, especially when rendering to DIBs vs DDBs
' Note that GDI+ is standard on WinXP+, and can be used on Win98,ME,2K, & on NT4 if SP6 is installed
' Download GDI+ from:
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdicpp/GDIPlus/GDIPlus.asp
' ----------------------------------------------
' About Win95, Win98, NT3.5, NT4 & WinME support
' ----------------------------------------------
' The routines will not honor AlphaBlend if it exists on those systems. Win98's version,
' for example, has several bugs that can crash the application when AlphaBlending to DIBs.
' NT4, NT3.5 & Win95 do not come with AlphaBlend and I do not have WinME to test with.
' Therefore, to support these systems, the Render routine will alphablend manually
' regardless if the AlhpaBlend API (msimg32.dll) exists on the system or not.
' However, this can be overridden by you. See isAlphaBlendFriendly routine
' Class Purpose:
' ----------------------------------------------
' This class holds the 32bpp image. It also marshals any new image thru
' the battery of parsers to determine best method for converting the image
' to a 32bpp alpha-compatible image. It handles rendering, rotating, scaling,
' mirroring of DIBs using manual processes, AlphaBlend, and/or GDI+.
' The parser order is very important for fastest/best results...
' cPNGparser :: will convert PNG, all bit depths; aborts quickly if not PNG
' cGIFparser :: will convert non-transparent/transparent GIFs; aborts quickly
' cICOpraser :: will convert XP-Alpha, paletted, true color, & Vista PNG icons
' -- can also convert most non-animated cursors
' cBMPparser :: will convert bitmaps, wmf/emf & jpgs
' The parsers are efficient. Most image formats have a magic number that give
' a hint to what type of image the file/stream is. However, checks need to
' be employed because non-image files could feasibly have those same magic
' numbers. If the image is determined not to be one the parser is designed
' to handle, the parser rejects it and the next parser takes over. The
' icon parser is slightly different because PNG files can be included into
' a Vista ico file. When this occurs, the icon parser will pass off the
' PNG format to the PNG parser automatically.
' And last but not least, the parsers have no advanced knowledge of the image
' format; as far as they are concerned, anything passed is just a byte array
' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
' CHANGE HISTORY
' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
' Accompanying FAQ.rtf is updated with every change
' Last changed: 11 Apr 07. See change history within the FAQ file
' 26 Dec 06: First version
' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
' No APIs are declared public. This is to prevent possibly, differently
' declared APIs, or different versions of the same API, from conflciting
' with any APIs you declared in your project. Same rule for UDTs.
' Note: I did take liberties, changing parameter types, in several APIs throughout
' Used to determine operating system
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As Any) As Long
Private Type OSVERSIONINFOEX
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' up to here is OSVERSIONINFO vs EX
wServicePackMajor As Integer ' 8 bytes larger than OSVERSIONINFO
wServicePackMinor As Integer
wSuiteMask As Integer
wProductType As Byte
wReserved As Byte
End Type
' APIs used to manage the 32bpp DIB
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (ByRef Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hDC As Long, ByRef pBitmapInfo As Any, ByVal un As Long, ByRef Pointer As Long, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal lBlendFunction As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32.dll" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function GetObjectType Lib "gdi32.dll" (ByVal hgdiobj As Long) As Long
Private Declare Function GetCurrentObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal uObjectType As Long) As Long
Private Declare Function GetIconInfo Lib "user32.dll" (ByVal hIcon As Long, ByRef piconinfo As ICONINFO) As Long
Private 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
Private Declare Function SetDIBitsToDevice Lib "gdi32.dll" (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, ByRef Bits As Any, ByRef BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetDIBits Lib "gdi32.dll" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function OffsetRgn Lib "gdi32.dll" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Const STRETCH_HALFTONE As Long = &H4&
Private Const OBJ_BITMAP As Long = &H7&
Private Const OBJ_METAFILE As Long = &H9&
Private Const OBJ_ENHMETAFILE As Long = &HD&
' APIs used to create files
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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByRef lpOverlapped As Any) As Long
Private Declare Function SetFilePointer Lib "kernel32.dll" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByRef lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Const INVALID_HANDLE_VALUE = -1&
' ////////////////////////////////////////////////////////////////
' Unicode-capable Drag and Drop of file names with wide characters
' ////////////////////////////////////////////////////////////////
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, _
ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As VbVarType, _
ByVal paCNT As Long, ByRef paTypes As Integer, _
ByRef paValues As Long, ByRef retVAR As Variant) As Long
Private Declare Function lstrlenW Lib "kernel32.dll" (lpString As Any) As Long
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
' ////////////////////////////////////////////////////////////////
' Unicode-capable Pasting of file names with wide characters
' ////////////////////////////////////////////////////////////////
Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
' ////////////////////////////////////////////////////////////////
Private Type FORMATETC
cfFormat As Long
pDVTARGETDEVICE As Long
dwAspect As Long
lIndex As Long
TYMED As Long
End Type
Private Type DROPFILES
pFiles As Long
ptX As Long
ptY As Long
fNC As Long
fWide As Long
End Type
Private Type STGMEDIUM
TYMED As Long
Data As Long
pUnkForRelease As IUnknown
End Type
' used to create the checkerboard pattern on demand
Private Declare Function FillRect Lib "user32.dll" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function OffsetRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' used when saving an image or part of the image
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Type SafeArrayBound
cElements As Long
lLbound As Long
End Type
Private Type SafeArray
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
rgSABound(0 To 1) As SafeArrayBound ' reusable UDT for 1 & 2 dim arrays
End Type
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type
Private Type BITMAPINFOHEADER
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 BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiPalette As Long
End Type
Private Const AC_SRC_OVER = &H0&
Private Const AC_SRC_ALPHA = &H1&
Public Enum eImageFormat ' source image format
imgError = -1 ' no DIB has been initialized
imgNone = 0 ' no image loaded
imgBitmap = 1 ' standard bitmap or jpg
imgIcon = 3 ' standard icon
imgWMF = 2 ' windows meta file
imgEMF = 4 ' enhanced WMF
imgCursor = 5 ' standard cursor
imgBmpARGB = 6 ' 32bpp bitmap where RGB is not pre-multiplied
imgBmpPARGB = 7 ' 32bpp bitmap where RGB is pre-multiplied
imgIconARGB = 8 ' XP-type icon; 32bpp ARGB
imgGIF = 9 ' gif; if class.Alpha=True, then transparent GIF
imgPNG = 10 ' PNG image
imgPNGicon = 11 ' PNG in icon file (Vista)
imgCursorARGB = 12 ' alpha blended cursors? do they exist yet?
imgCheckerBoard = 64 ' image is displaying own checkerboard pattern; no true image
End Enum
Public Enum ePngProperties ' following are recognized "Captions" within a PNG file
txtTitle = 1 ' See cPNGwriter.SetPngProperty for more information
txtAuthor = 2
txtDescription = 4
txtCopyright = 8
txtCreationTime = 16
txtSoftware = 32
txtDisclaimer = 64
txtWarning = 128
txtSource = 256
txtComment = 512
' special properties
txtLargeBlockText = 1024 ' this is free-form text can be of any length & contain most any characters
dateTimeModified = 2048 ' date/time of the last image modification (not the time of initial image creation)
colorDefaultBkg = 4096 ' default background color to use if PNG viewer does not do transparency
filterType = 8192 ' one of the eFilterMethods values
ClearAllProperties = -1 ' resets all PNG properties
End Enum
Public Enum eTrimOptions ' see TrimImage method
trimAll = 0 ' can be combined using OR
trimLeft = 1
trimTop = 2
trimRight = 4
trimBottom = 8
End Enum
Public Enum eGrayScaleFormulas
gsclNTSCPAL = 0 ' R=R*.299, G=G*.587, B=B*.114 - Default
gsclCCIR709 = 1 ' R=R*.213, G=G*.715, B=B*.072
gsclSimpleAvg = 2 ' R,G, and B = (R+G+B)/3
gsclRedMask = 3 ' uses only the Red sample value: RGB = Red / 3
gsclGreenMask = 4 ' uses only the Green sample value: RGB = Green / 3
gsclBlueMask = 5 ' uses only the Blue sample value: RGB = Blue / 3
gsclRedGreenMask = 6 ' uses Red & Green sample value: RGB = (Red+Green) / 2
gsclBlueGreenMask = 7 ' uses Blue & Green sample value: RGB = (Blue+Green) / 2
gsclNone = -1
End Enum
Public Enum eFilterMethods
filterDefault = 0 ' paletted PNGs will use filterNone while others will use filterPaeth
filterNone = 1 ' no byte preparation used; else preps bytes using one of the following
filterAdjLeft = 2 ' see cPNGwriter.EncodeFilter_Sub
filterAdjTop = 3 ' see cPNGwriter.EncodeFilter_Up
filterAdjAvg = 4 ' see cPNGwriter.EncodeFilter_Avg
filterPaeth = 5 ' see cPNGwriter.EncodeFilter_Paeth
filterAdaptive = 6 ' this is a best guess of the above 4 (can be different for each DIB scanline)
End Enum
Public Enum eRegionStyles ' See CreateRegion
regionBounds = 0
regionEnclosed = 1
regionShaped = 2
End Enum
Public Enum eConstants ' See SourceIconSizes
TRUE_COLOR = &HFF000000
HIGH_COLOR = &HFFFF00
TRUE_COLOR_ALPHA = &HFFFFFFFF
End Enum
Private m_PNGprops As cPNGwriter ' used for more advanced PNG creation options
Private m_StretchQuality As Boolean ' if true will use BiLinear or better interpolation
Private m_Handle As Long ' handle to 32bpp DIB
Private m_Pointer As Long ' pointer to DIB bits
Private m_Height As Long ' height of DIB
Private m_Width As Long ' width of DIB
Private m_hDC As Long ' DC if self-managing one
Private m_prevObj As Long ' object deselected from DC when needed
Private m_osCAP As Long ' See Class_Initialize
Private m_Format As eImageFormat ' type of source image
Private m_ManageDC As Boolean ' does class manage its own DC
Private m_AlphaImage As Boolean ' does the DIB contain alpha/transparency
Private m_GDItoken As Long
Private m_ImageByteCache() As Byte ' should you want the DIB class to cache original bytes
' ^^ N/A if image is loaded by handle, stdPicture, or resource
Public Function LoadPicture_File(ByVal FileName As String, _
Optional ByVal iconCx As Long, _
Optional ByVal iconCy As Long, _
Optional ByVal SaveFormat As Boolean, _
Optional ByVal iconBitDepth As Long = 32) As Boolean
' PURPOSE: Convert passed image file into a 32bpp image
' Parameters.
' FileName :: full path of file. Validation occurs before we continue
' iconCx :: desired width of icon if file is an icon file. Default is 32x32
' iconCy :: desired height of icon if file is an icon file. Default is 32x32
' SaveFormat :: if true, then the image will be cached as a byte array only
' if the image was successfully loaded. Call GetOrginalFormat to retrieve them.
' iconBitDepth :: the desired bit depth of an icon if the resource is an icon file
' Why would you want to save the bytes? If this is being used in a usercontrol,
' saving the bytes will almost always be less size than saving the 32bit DIB.
' Additionally, these classes have the ability to get different sizes from
' the original source (i.e., WMF, icon, cursors) if available, but if the
' 32bit DIB is saved, it is a constant size. The potential of different sizes
' could allow better resizing of the image vs stretching the DIB.
On Error Resume Next
Dim hFile As Long
hFile = iparseGetFileHandle(FileName, True, ((m_osCAP And 24) = 8))
If hFile = INVALID_HANDLE_VALUE Then Exit Function
If GetFileSize(hFile, 0&) > 56 Then
' no image file/stream can be less than 57 bytes and still be an image
Dim aDIB() As Byte ' dummy array
LoadPicture_File = LoadPictureEx(hFile, FileName, aDIB(), iconCx, iconCy, 0&, 0&, SaveFormat, iconBitDepth)
End If
CloseHandle hFile
End Function
Public Function LoadPicture_Stream(inStream() As Byte, _
Optional ByVal iconCx As Long, _
Optional ByVal iconCy As Long, _
Optional ByVal streamStart As Long = 0&, _
Optional ByVal streamLength As Long = 0&, _
Optional ByVal SaveFormat As Boolean, _
Optional ByVal iconBitDepth As Long = 32) As Boolean
' PURPOSE: Convert passed array into a 32bpp image
' Parameters.
' inStream:: byte stream containing the image. Validation occurs below
' iconCx :: desired width of icon if file is an icon file. Default is 32x32
' iconCy :: desired height of icon if file is an icon file. Default is 32x32
' streamStart :: array position of 1st byte of the image file. Validated.
' streamLength :: total length of the image file. Validated.
' SaveFormat :: if true, then the image will be cached as a byte array only
' if the image was successfully loaded. Call GetOrginalFormat to retrieve them.
' iconBitDepth :: the desired bit depth of an icon if the resource is an icon stream
' Why would you want to save the bytes? If this is being used in a usercontrol,
' saving the bytes will almost always be less size than saving the 32bit DIB.
' Additionally, these classes have the ability to get different sizes from
' the original source (i.e., WMF, icon, cursors) if available, but if the
' 32bit DIB is saved, it is a constant size. The potential of different sizes
' could allow better resizing of the image vs stretching the DIB.
If iparseIsArrayEmpty(VarPtrArray(inStream)) = 0& Then Exit Function
If streamStart < LBound(inStream) Then streamStart = LBound(inStream)
If streamLength = 0& Then streamLength = UBound(inStream) - streamStart + 1&
If streamLength < 57 Then Exit Function
' no image file/stream can be less than 57 bytes and still be an image
LoadPicture_Stream = LoadPictureEx(0&, vbNullString, inStream, iconCx, iconCy, streamStart, streamLength, SaveFormat, iconBitDepth)
End Function
Public Function LoadPicture_Resource(ByVal ResIndex As Variant, ByVal ResSection As Variant, _
Optional VBglobal As IUnknown, _
Optional ByVal iconCx As Long, _
Optional ByVal iconCy As Long, _
Optional ByVal streamStart As Long = 0&, _
Optional ByVal streamLength As Long = 0&, _
Optional ByVal iconBitDepth As Long) As Boolean
' PURPOSE: Convert passed resource into a 32bpp image
' Parameters.
' ResIndex :: the resource file index (i.e., 101)
' ResSection :: one of the VB LoadResConstants or String value of
' your resource section, i.e., vbResBitmap, vbResIcon, "Custom", etc
' VbGlobal :: pass as VB.GLOBAL of the project containing the resource file
' - Allows class to be mobile; can exist in DLL or OCX
' - if not provided, class will use resource from existing workspace
' - For example, if this class was in a compiled OCX, then the only way
' to use the host's resource file is passing the host's VB.Global reference
' iconCx :: desired width of icon if file is an icon file. Default is 32x32
' iconCy :: desired height of icon if file is an icon file. Default is 32x32
' streamStart :: array position of 1st byte of the image file. Validated.
' streamLength :: total length of the image file. Validated.
' -- See LoadPicture_Stream for the validation
' iconBitDepth :: the desired bit depth of an icon if the resource is an icon
' Tips:
' 1) Store 32bpp bitmaps in the "Custom" resource always. Storing in the
' Bitmap resource can change color depth of the image created by VB
' depending on your screen settings
' 2) Icons, normal bitmaps, & cursors are generally stored in their own sections
' However, with icons containing multiple formats, VB will extract the
' closest format to 32x32. May want to consider storing these in "Custom"
' 3) All other types of images are normally stored in the "Custom" section
On Error GoTo ExitRoutine
Dim oWorkSpace As VB.Global, tPic As StdPicture
If VBglobal Is Nothing Then
Set oWorkSpace = VB.Global
ElseIf TypeOf VBglobal Is VB.Global Then
Set oWorkSpace = VBglobal
Else
Set oWorkSpace = VB.Global
End If
If VarType(ResSection) = vbString Then
Dim inStream() As Byte
' could be anything, PNG,icon,gif,32bpp bitmap,wmf, etc
inStream = oWorkSpace.LoadResData(ResIndex, ResSection)
LoadPicture_Resource = LoadPicture_Stream(inStream, iconCx, iconCy, streamStart, streamLength, , iconBitDepth)
Else
' can only be single icon, bitmap or cursor
Set tPic = oWorkSpace.LoadResPicture(ResIndex, ResSection)
LoadPicture_StdPicture tPic
End If
LoadPicture_Resource = Not (m_Handle = 0&)
ExitRoutine:
If Err Then Err.Clear
End Function
Public Function LoadPicture_StdPicture(Picture As StdPicture) As Boolean
' PURPOSE: Convert passed stdPicture into a 32bpp image
' Revised to allow 32bpp stdPicture objects which can be loaded
Me.DestroyDIB
If Not Picture Is Nothing Then
' simply pass off to other parsers
If Picture.Type = vbPicTypeIcon Then
' pass to icon/cursor parser
Dim cICO As New cICOparser
Call cICO.ConvertstdPicTo32bpp(Picture.Handle, Me)
Set cICO = Nothing
ElseIf Not Picture.Type = vbPicTypeNone Then
' pass to bmp,jpg,wmf parser
' Note: transparent GIFs should not be passed as stdPictures
' Pass transparent GIFs by Stream or FileName
Dim cBMP As New cBMPparser
If Picture.Type = vbPicTypeBitmap Then
' pass by handle to ensure 32bpp stdPicture objects are processed correctly
Call cBMP.ConvertstdPicTo32bpp(Nothing, Picture.Handle, Me, 0&)
Else ' probably wmf/emf, pass by stdPicture
Call cBMP.ConvertstdPicTo32bpp(Picture, 0&, Me, 0&)
End If
Set cBMP = Nothing
End If
LoadPicture_StdPicture = Not (m_Handle = 0&)
End If
End Function
Public Function LoadPicture_ByHandle(Handle As Long) As Boolean
' PURPOSE: Convert passed image handle into a 32bpp image
' Revised. Previously, I cheated by creating a stdPicture from the handle
' then used existing LoadPicture_stdPicture to process. This had
' the nasty side effect of not processing 32bpp images correctly
' if they were loaded from LoadImage API
Dim icoInfo As ICONINFO, tPic As StdPicture
DestroyDIB
If Not Handle = 0& Then
Select Case GetObjectType(Handle)
Case OBJ_BITMAP
' process bitmaps by handle
Dim cBMP As New cBMPparser
LoadPicture_ByHandle = cBMP.ConvertstdPicTo32bpp(Nothing, Handle, Me, 0&)
Case OBJ_METAFILE, OBJ_ENHMETAFILE
' we should be able to convert this to a stdPicture...
' Really don't want to mess with metafile DCs if I don't have to
Set tPic = iparseHandleToStdPicture(Handle, vbPicTypeBitmap)
If Not tPic Is Nothing Then
' send to this routine to process
LoadPicture_ByHandle = LoadPicture_StdPicture(tPic)
End If
Case Else
' Test for icons & cursors
If Not GetIconInfo(Handle, icoInfo) = 0 Then
' got it; clean up the bitmap(s) created by GetIconInfo API
If Not icoInfo.hbmColor = 0& Then DeleteObject icoInfo.hbmColor
If Not icoInfo.hbmMask = 0& Then DeleteObject icoInfo.hbmMask
Dim cICO As New cICOparser
' process icons by handle
LoadPicture_ByHandle = cICO.ConvertstdPicTo32bpp(Handle, Me)
End If
End Select
End If
End Function
Public Function LoadPicture_ClipBoard() As Boolean
' PURPOSE: Convert clipboard object into a 32bpp image
On Error Resume Next
With Clipboard
If (.GetFormat(vbCFBitmap) Or .GetFormat(vbCFDIB) Or .GetFormat(vbCFEMetafile) Or .GetFormat(vbCFMetafile)) Then
If Not Err Then LoadPicture_ClipBoard = LoadPicture_StdPicture(.GetData())
End If
End With
If Err Then Err.Clear
End Function
Public Function LoadPicture_FromOrignalFormat(Optional ByVal iconCx As Long, _
Optional ByVal iconCy As Long, _
Optional ByVal iconBitDepth As Long) As Boolean
' PURPOSE: Reload the current image from the cached bytes (if any)
' If the original bytes were not cached when the image was loaded, then no action
' will be taken. See LoadPicture_File & LoadPicture_Stream
' iconCx :: desired width of icon if file is an icon file. Default is 32x32
' iconCy :: desired height of icon if file is an icon file. Default is 32x32
' iconBitDepth :: the desired bit depth of an icon if the resource is an icon
Dim tBytes() As Byte
tBytes() = m_ImageByteCache() ' copy bytes; original are destroyed when DIB is recreated
LoadPicture_FromOrignalFormat = Me.LoadPicture_Stream(tBytes, iconCx, iconCy, , , True, iconBitDepth)
End Function
Public Function GetPixel(ByVal X As Long, ByVal Y As Long, Optional ByRef AlphaValue As Long, _
Optional ByRef asPreMultiplied As Boolean) As Long
' Function will return the pixel color value and alpha value from the DIB
' Note that the DIB is always referenced top down within this function
' X is the left coordinate of the pixel to be returned, image always starts at 0,0
' Y is the top coordinate of the pixel to be returned, image always starts at 0,0
' AlphaValue will contain the alpha value of the pixel.
' asPreMultiplied. If false, then premultiplication is removed else it isn't
' Return value is the RGB color value of the pixel.
' If return value is -1 then the X,Y coordinates passed are invalid
' It is far more efficient to use GetDIBits or overlaying your own array when more than
' one pixel is required to be returned; in other words, recommend not using this
' function within a loop
AlphaValue = 0&
If X < 0& Or X > m_Width - 1& Then
GetPixel = -1&
ElseIf Y < 0& Or Y > m_Height - 1& Then
GetPixel = -1&
Else
Dim pOffset As Long, pColor As Long
' calculate the location of the X,Y coordinate in relation to a bottom-up DIB
pOffset = iparseSafeOffset(m_Pointer, X * 4& + ((m_Height - Y - 1&) * m_Width * 4&))
' get the alpha value
CopyMemory AlphaValue, ByVal iparseSafeOffset(pOffset, 3&), 1&
' get the pixel color & convert it to RGB
CopyMemory pColor, ByVal pOffset, 3&
If asPreMultiplied = True Or (AlphaValue Mod 255) = 0 Then
GetPixel = ((pColor And &HFF) * &H10000) Or ((pColor &H100) And &HFF) * &H100 Or ((pColor &H10000) And &HFF)
Else ' remove premultiplication
pOffset = ((255& * (pColor And &HFF)) AlphaValue) * &H10000
pOffset = pOffset Or ((255& * ((pColor &H100) And &HFF)) AlphaValue) * &H100
GetPixel = pOffset Or ((255& * ((pColor &H10000) And &HFF)) AlphaValue)
End If
End If
End Function
Public Function GetDIBbits(outStream() As Byte, _
Optional ByVal as2dArray As Boolean = True, _
Optional ByVal asBGRformat As Boolean = True, _
Optional ByVal as32bpp As Boolean = True, _
Optional ByVal asWordAligned As Boolean = True, _
Optional ByVal asBottomUp As Boolean = True, _
Optional ByVal X As Long, Optional ByVal Y As Long, _
Optional ByVal Width As Long, Optional ByVal Height As Long, _
Optional ByVal asPreMultiplied As Boolean = True) As Boolean
' Function replicates the GetDIBits API with more flexibility.
' Note: Unless you need a copy of the bytes for other purposes than just
' referencing them, it is much more efficient to overlay your own
' SafeArray on the Me.BitsPointer property vs copying the bytes into an array
' Function returns True if an image exists and the array was filled.
' Parameters
' outStream(). An array to hold the returned bytes. Array is always zero-bound
' as2dArray. If True, array is returned as (0 to Columns*4-1, 0 to Rows-1) else (0 to Columns*Rows*4-1)
' asBGRformat. If True, pixels are in BGRalpha format else RGBalpha format
' The alpha byte may be excluded depending on as32bpp parameter
' as32bpp. If true, pixels use 4 bytes else pixels use 3 bytes (24bpp)
' asWordAligned. If true, scanlines/columns are word aligned else scanlines are byte aligned
' asBottomUp. If true, 1st row of array is bottom of picture else is top of picture
' X,Y. The left,top position of the image to return
' Width,Height. The number of columns,rows to return. Defaults are entire image
' asPreMultiplied. If true, returned pixels are in their default state, premultiplied
' If false, premultiplication is removed.
' Tip: How to determine the scanwidth of the returned rows?
' 1. If as32bpp=True, then it is always Width parameter x 4
' 2. Otherwise, regardless of asWordAligned parameter
' a. If as2dArray=True, UBound(outStream,1)+1
' b. If as2dArray=False, (UBound(outStream)+1)Height parameter
If m_Handle = 0& Then Exit Function
If X < 0& Or Y < 0& Then Exit Function
Dim dstX As Long, dstY As Long
Dim dstYincr As Long, bytesPP As Long
Dim dstScanWidth As Long, srcScanWidth As Long
Dim dstBytes() As Byte, srcBytes() As Byte
Dim dstSA As SafeArray, srcSA As SafeArray
Dim Rows As Long, Cols As Long, pAlpha As Byte
' validate parameters
If Width = 0 Then Width = m_Width
If Height = 0 Then Height = m_Height
If Width + X > m_Width Then Width = m_Width - X
If Height + Y > m_Height Then Height = m_Height - Y
' now we will set up the scanwidth and dimensioning the return array
If as32bpp = True Then
bytesPP = 4&
dstScanWidth = Width * bytesPP
Else
bytesPP = 3&
If asWordAligned = True Then
dstScanWidth = iparseByteAlignOnWord(24, Width)
Else
dstScanWidth = Width * bytesPP
End If
End If
' size the destination array
If as2dArray = True Then
ReDim outStream(0 To dstScanWidth - 1&, 0 To Height - 1&)
dstSA.pvData = VarPtr(outStream(0, 0)) ' track pointer of 1st element
Else
ReDim outStream(0 To dstScanWidth * Height - 1&)
dstSA.pvData = VarPtr(outStream(0)) ' track pointer of 1st element
End If
' quick check for copying. This is probably going to be most used
If as32bpp = True And asBGRformat = True And asBottomUp = True Then
If Width = m_Width And Height = m_Height And asPreMultiplied = True Then
If as2dArray = True Then
CopyMemory outStream(0, 0), ByVal m_Pointer, scanWidth * Height
Else
CopyMemory outStream(0), ByVal m_Pointer, scanWidth * Height
End If
GetDIBbits = True
Exit Function
End If
End If
' set up overlays using identical 2D arrays
With dstSA
.cbElements = 1
.cDims = 2
.rgSABound(0).cElements = Height
.rgSABound(1).cElements = dstScanWidth
End With
With srcSA
.cbElements = 1
.cDims = 2
.pvData = m_Pointer
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width * 4&
End With
CopyMemory ByVal VarPtrArray(dstBytes), VarPtr(dstSA), 4&
CopyMemory ByVal VarPtrArray(srcBytes), VarPtr(srcSA), 4&
' calculate destination starting row
If asBottomUp = True Then
dstY = Height - 1&
dstYincr = -1&
Else
dstYincr = 1&
End If
srcScanWidth = (Width + X) * 4& - 1& ' position of 1st byte in DIB
If asPreMultiplied = True Then
For Rows = m_Height - Y - 1& To m_Height - Height - Y Step -1&
dstX = 0& ' destination column
For Cols = X * 4 To srcScanWidth Step 4&
If asBGRformat = True Then
CopyMemory dstBytes(dstX, dstY), srcBytes(Cols, Rows), bytesPP
Else
dstBytes(dstX, dstY) = srcBytes(Cols + 2&, Rows)
dstBytes(dstX + 1&, dstY) = srcBytes(Cols + 1&, Rows)
dstBytes(dstX + 2&, dstY) = srcBytes(Cols, Rows)
If bytesPP = 4& Then ' want the alpha array too
dstBytes(dstX + 3&, dstY) = srcBytes(Cols + 3&, Rows)
End If
End If
dstX = dstX + bytesPP ' move to next destination column
Next
dstY = dstY + dstYincr ' next destination row
Next
Else ' remove premultiplication
For Rows = m_Height - Y - 1& To m_Height - Height - Y Step -1&
dstX = 0& ' destination column
For Cols = X * 4 To srcScanWidth Step 4&
pAlpha = srcBytes(Cols + 3&, Rows)
If asBGRformat = True Then
If pAlpha = 255 Then
CopyMemory dstBytes(dstX, dstY), srcBytes(Cols, Rows), 3&
ElseIf Not pAlpha = 0 Then
dstBytes(dstX, dstY) = (255& * srcBytes(Cols, Rows) pAlpha)
dstBytes(dstX + 1&, dstY) = (255& * srcBytes(Cols + 1&, Rows) pAlpha)
dstBytes(dstX + 2&, dstY) = (255& * srcBytes(Cols + 2&, Rows) pAlpha)
End If
Else ' convert to RGB
If pAlpha = 255 Then
dstBytes(dstX, dstY) = srcBytes(Cols + 2&, Rows)
dstBytes(dstX + 1&, dstY) = srcBytes(Cols + 1&, Rows)
dstBytes(dstX + 2&, dstY) = srcBytes(Cols, Rows)
ElseIf Not pAlpha = 0 Then
dstBytes(dstX, dstY) = (255& * srcBytes(Cols + 2&, Rows) pAlpha)
dstBytes(dstX + 1&, dstY) = (255& * srcBytes(Cols + 1&, Rows) pAlpha)
dstBytes(dstX + 2&, dstY) = (255& * srcBytes(Cols, Rows) pAlpha)
End If
End If
If bytesPP = 4& Then dstBytes(dstX + 3&, dstY) = pAlpha ' want the alpha array too
dstX = dstX + bytesPP ' move to next destination column
Next
dstY = dstY + dstYincr ' next destination row
Next
End If
' release arrays
CopyMemory ByVal VarPtrArray(dstBytes), 0&, 4&
CopyMemory ByVal VarPtrArray(srcBytes), 0&, 4&
GetDIBbits = True
eh:
If Err Then
Err.Clear
'Stop ' troubleshooting only
'Resume
End If
End Function
Public Function SetDIBbits(inStream() As Byte, _
Optional ByVal isBGRformat As Boolean = True, _
Optional ByVal is32bpp As Boolean = True, _
Optional ByVal isWordAligned As Boolean = True, _
Optional ByVal isBottomUp As Boolean = True, _
Optional ByVal dstX As Long, Optional ByVal dstY As Long, _
Optional ByVal dstWidth As Long, Optional ByVal dstHeight As Long) As Boolean
' Function replicates the SetDIBits API with more flexibility.
' Note: It is much more efficient to overlay your own SafeArray on
' the Me.BitsPointer property and updating directly
' Function returns True if an image exists and updated.
' Parameters
' inStream(). An array containing new DIB bytes. Can be any dimension
' isBGRformat. If True, pixels are in BGRalpha format else RGBalpha format
' The alpha byte may be excluded depending on is32bpp parameter
' is32bpp. If true, pixels use 4 bytes else pixels use 3 bytes (24bpp)
' isWordAligned. If true, scanlines are word aligned else scanlines are byte aligned
' isBottomUp. If true, 1st row of array is bottom of picture else is top of picture
' dstX,Y. The left,top position of the image to update
' dstWidth,Height. The number of columns,rows to update. Defaults are entire image
If m_Handle = 0& Then Exit Function
If dstX < 0& Or dstY < 0& Then Exit Function
Dim SrcX As Long, SrcY As Long
Dim srcYincr As Long, bytesPP As Long
Dim dstScanWidth As Long, srcScanWidth As Long
Dim dstBytes() As Byte, srcBytes() As Byte
Dim dstSA As SafeArray, srcSA As SafeArray
Dim srcBounds() As Long
Dim Rows As Long, Cols As Long
' test and cache the passed inStream's pointer
srcYincr = iparseIsArrayEmpty(VarPtrArray(inStream))
If srcYincr = 0& Then Exit Function
' validate parameters
If dstWidth = 0 Then dstWidth = m_Width
If dstHeight = 0 Then dstHeight = m_Height
If dstWidth + dstX > m_Width Then dstWidth = m_Width - dstX
If dstHeight + dstY > m_Height Then dstHeight = m_Height - dstY
' now we will set up the scanwidth of the source array
If is32bpp = True Then
bytesPP = 4&
srcScanWidth = dstWidth * bytesPP
Else
bytesPP = 3&
If isWordAligned = True Then
srcScanWidth = iparseByteAlignOnWord(24, dstWidth)
Else
srcScanWidth = dstWidth * bytesPP
End If
End If
' Get 1st 16 bytes of source SafeArray
CopyMemory srcSA, ByVal srcYincr, 16&
' copy the array dimension's bounds to tempoary array
ReDim srcBounds(1 To 2 * srcSA.cDims)
CopyMemory srcBounds(1), ByVal srcYincr + 16&, 8& * srcSA.cDims
' tally up the amount of bytes contained in the array
dstScanWidth = srcBounds(1)
For srcSA.cDims = 3 To 2 * srcSA.cDims Step 2
dstScanWidth = (srcBounds(srcSA.cDims) * dstScanWidth)
Next
' does passed array have enough bytes?
If dstScanWidth * srcSA.cbElements < srcScanWidth * Height Then Exit Function
Erase srcBounds()
' set up overlay on source array
With srcSA
.cbElements = 1
.cDims = 2
.cLocks = 0 ' remove may have been set when copied
.fFeatures = 0 ' remove may have been set when copied
'.pvData was set when we copied the structure
.rgSABound(0).cElements = dstHeight
.rgSABound(1).cElements = srcScanWidth
End With
CopyMemory ByVal VarPtrArray(srcBytes), VarPtr(srcSA), 4&
' set up overlay on our DIB
With dstSA
.cbElements = 1
.cDims = 2
.pvData = m_Pointer
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width * 4&
End With
CopyMemory ByVal VarPtrArray(dstBytes), VarPtr(dstSA), 4&
' set source starting row
If isBottomUp = True Then
SrcY = dstHeight - 1
srcYincr = -1
Else
srcYincr = 1
End If
dstScanWidth = (dstWidth + dstX) * 4& - 1& ' position for 1st byte in our DIB
For Rows = m_Height - dstY - 1& To m_Height - dstHeight - dstY Step -1&
SrcX = 0&
For Cols = dstX * 4 To dstScanWidth Step 4&
If isBGRformat = True Then
CopyMemory dstBytes(Cols, Rows), srcBytes(SrcX, SrcY), bytesPP
Else
dstBytes(Cols, Rows) = srcBytes(SrcX + 2&, SrcY)
dstBytes(Cols + 1&, Rows) = srcBytes(SrcX + 1&, SrcY)
dstBytes(Cols + 2&, Rows) = srcBytes(SrcX, SrcY)
If bytesPP = 4& Then ' want the alpha byte too
dstBytes(Cols + 3&, Rows) = srcBytes(SrcX + 3&, SrcY)
End If
End If
SrcX = SrcX + bytesPP ' position of next source byte
Next
SrcY = SrcY + srcYincr ' next source row
Next
' release overlays
CopyMemory ByVal VarPtrArray(srcBytes), 0&, 4&
' our image must remain pre-multiplied, ensure it now
iparseValidateAlphaChannel dstBytes(), True, m_AlphaImage, 0&
CopyMemory ByVal VarPtrArray(dstBytes), 0&, 4&
SetDIBbits = True
End Function
Public Function CreateRegion(Optional ByVal Style As eRegionStyles = regionBounds, Optional ByVal xOffset As Long, Optional ByVal yOffset As Long) As Long
' Creates a region that can be used for clipping, filling, hit testing
' You ARE responsible for destroying the region with a call to DeleteObject
' Note: This region is created from this DIB, not the rendered DIB, therefore
' should the rendered DIB be of different size, mirrored, rotated or otherwise modified
' you should render this to a new/blank DIB and create the region from that one
' Style must be one of the following. Default is regionBounds
' - regionShaped: region consists of only non-transparent pixels
' :: example: region for the letter O would only contain the outline
' - regionEnclosed: transparent pixels between furthest left and furtherst right
' non-transparent pixels in each scan line are included in the region
' :: example: region for the letter O would be like filling the center then creating the region
' - regionBounds: all pixels within the rectangular bounds of the image are included
' :: example: region for the letter O would be like drawing a tight rectangle around it then creating a solid rectangular region
' xOffset is used to shift the region n pixels left or right
' yOffset is used to shift the region n pixels up or down
Dim hRgn As Long
If Not m_Handle = 0& Then
If Style >= regionBounds And Style <= regionShaped Then
hRgn = iparseCreateShapedRegion(Me, Style)
If Not ((xOffset Or yOffset) = 0&) Then OffsetRgn hRgn, xOffset, yOffset
End If
End If
CreateRegion = hRgn
End Function
Public Sub CopyImageTo(cDIBclass As c32bppDIB, Optional ByVal newWidth As Long, _
Optional ByVal newHeight As Long, Optional ByVal CopyOriginalFormat As Boolean = False)
' Function replicates the the current image to another DIB class and optionally resizes it
' NewWidth is optional. if zero, will use the source DIB width. If negative will mirror & resize if needed
' NewHeight is optional. if zero, will use the source DIB height. If negative will mirror & resize if needed
' If CopyOriginalFormat = True then, and only, if class loaded its image
' with the optional SaveFormat=True, then the original image bytes
' were cached and will be copied to the target cDIBclass also
' See LoadPicture_File & LoadPicture_Stream for more info
Dim dDC As Long, aResized() As Byte
Dim bUnselect As Boolean, bResetAlphaCap As Boolean
If Not m_Handle = 0& Then ' do we have an image to copy?
If newWidth = 0& Then newWidth = m_Width
If newHeight = 0& Then newHeight = m_Height
If cDIBclass Is Nothing Then
Set cDIBclass = New c32bppDIB ' was a valid ref passed?
cDIBclass.gdiToken = m_GDItoken
cDIBclass.isGDIplusEnabled = Me.isGDIplusEnabled
cDIBclass.HighQualityInterpolation = Me.HighQualityInterpolation
cDIBclass.InitializeDIB Abs(newWidth), Abs(newHeight) ' Create new one
Else
cDIBclass.gdiToken = m_GDItoken
If Not (Abs(newWidth) = cDIBclass.Width And Abs(newHeight) = cDIBclass.Height) Then
cDIBclass.InitializeDIB Abs(newWidth), Abs(newHeight) ' Create new one
End If
End If
cDIBclass.Alpha = m_AlphaImage ' carry over the alpha flag
cDIBclass.ImageType = m_Format ' and image type flag
If newWidth = m_Width And newHeight = m_Height Then
' can copy using CopyMemory vs AlphaBlend
CopyMemory ByVal cDIBclass.BitsPointer, ByVal m_Pointer, newWidth * 4& * newHeight
Else
If (m_osCAP And 17) = 17 Then ' system is Win98/ME with AlphaBlend capability overridden
' but we will be resizing DIB to DIB so disallow it for now
m_osCAP = (m_osCAP And Not 1)
bResetAlphaCap = True
End If
bUnselect = (m_prevObj = 0&)
If Me.isGDIplusEnabled And (m_StretchQuality = True Or Me.isAlphaBlendFriendly = False) Then ' use GDI+ to resize
Dim cGDIp As New cGDIPlus
dDC = cDIBclass.LoadDIBinDC(True)
If bUnselect Then Me.LoadDIBinDC True
cGDIp.RenderGDIplus Me, dDC, 0&, 100&, 0&, 0&, newWidth, newHeight, 0&, 0&, m_Width, m_Height, True, gsclNone, m_GDItoken
cDIBclass.LoadDIBinDC False
Set cGDIp = Nothing
If bUnselect Then Me.LoadDIBinDC False
ElseIf newWidth < 0& Or newHeight < 0& Then ' handle mirroring, AlphaBlend cannot do mirroring
MirrorDIB 0&, 0&, 0&, 0&, newWidth, newHeight, aResized(), cDIBclass ' routine mirrors directly to DIB bytes
ElseIf Me.isAlphaBlendFriendly And m_StretchQuality = False Then ' O/S has no alphablending shortfalls that are known
dDC = cDIBclass.LoadDIBinDC(True) ' load target into a DC
If bUnselect Then Me.LoadDIBinDC True
Me.Render dDC, 0&, 0&, newWidth, newHeight, 0&, 0&, m_Width, m_Height, , , False, cDIBclass
cDIBclass.LoadDIBinDC False ' remove DIB from DC
If bUnselect Then Me.LoadDIBinDC False
Else
' stretching is involved, resize
Call pvResize(0&, aResized(), aResized(), cDIBclass) ' routine resizes directly to DIB bytes
End If
If bResetAlphaCap Then m_osCAP = m_osCAP Or 1
End If
' if the original image bytes are to be copied, do them too
If CopyOriginalFormat = True Then Call cDIBclass.SetOriginalFormat(m_ImageByteCache)
End If
End Sub
Public Function GetOrginalFormat(outStream() As Byte) As Boolean
' If SaveFormat is true when LoadPicture_Stream or LoadPicture_File was
' called, the original bytes were cached when the image was successfully
' loaded. Call this to return those original bytes
' If there are no original bytes, the function returns False & outStream is uninitialized
outStream() = m_ImageByteCache()
GetOrginalFormat = Not (iparseIsArrayEmpty(VarPtrArray(m_ImageByteCache)) = 0&)
End Function
Friend Property Let Alpha(isAlpha As Boolean)
m_AlphaImage = isAlpha ' determines the flags used for AlphaBlend API
' this flag is set by the various image parsers; setting it yourself
' can produce less than desirable effects.
' Used in Me.Render & Me.TrimImage, cPNGwriter.OptimizeTrueColor & cPNGwriter.PalettizeImage
End Property
Public Property Get Alpha() As Boolean
Alpha = m_AlphaImage
End Property
Public Property Let HighQualityInterpolation(Value As Boolean)
' When possible GDI+ will be used for stretching & rotation.
' If GDI+ is used,then high quality equates to BiCubic interpolation
' If not used, then BiLinear (manual processing) will be used.
' If High Quality is false, then Nearest Neighbor (very fast) interpolation used
m_StretchQuality = Value
End Property
Public Property Get HighQualityInterpolation() As Boolean
HighQualityInterpolation = m_StretchQuality
End Property
Public Property Get ImageType() As eImageFormat
ImageType = m_Format ' returns image format of the source image
End Property
Friend Property Let ImageType(iType As eImageFormat)
m_Format = iType ' set by the various image parsers. This is not used
' anywhere in these classes, you can do with it what you want -- for now.
End Property
Public Property Get Width() As Long
Width = m_Width ' width of image in pixels
End Property
Public Property Get Height() As Long
Height = m_Height ' height of image in pixels
End Property
Public Property Get BitsPointer() As Long
BitsPointer = m_Pointer ' pointer to the bits of the image
End Property
Public Property Get scanWidth() As Long
scanWidth = m_Width * 4& ' number of bytes per scan line
End Property
Public Property Get Handle() As Long
Handle = m_Handle ' the picture handle of the image
End Property
Public Function LoadDIBinDC(ByVal bLoad As Boolean) As Long
' Purpose: Select/Unselect the DIB into a DC.
' Returns the DC handle when image is loaded
' Called by image parser if it needs to paint the image into the DIB
If bLoad = True Then
Dim tDC As Long
If Not m_Handle = 0& Then ' do we have an image?
If m_hDC = 0& Then ' do we have a DC?
tDC = GetDC(0&) ' if not create one
m_hDC = CreateCompatibleDC(tDC)
ReleaseDC 0&, tDC
End If
If m_prevObj = 0& Then
m_prevObj = SelectObject(m_hDC, m_Handle)
End If
LoadDIBinDC = m_hDC
End If
Else
If Not m_prevObj = 0& Then
SelectObject m_hDC, m_prevObj
If m_ManageDC = False Then
DeleteObject m_hDC
m_hDC = 0&
End If
m_prevObj = 0&
End If
End If
End Function
Public Property Let ManageOwnDC(bManage As Boolean)
' Determines whether or not this class will manage its own DC
' If false, then a DC is created each time the image needs to be Rendered
Dim tDC As Long
If bManage = False Then ' removing management of DC
If Not m_hDC = 0& Then ' DC does exist, destroy it
' first remove the dib, if one exists
If Not m_Handle = 0& Then SelectObject m_hDC, m_prevObj
m_prevObj = 0&
End If
DeleteDC m_hDC
m_hDC = 0&
Else ' allowing creation of dc
If m_hDC = 0& Then ' create DC only if we have a dib to put in it
If Not m_Handle = 0& Then
tDC = GetDC(0&)
m_hDC = CreateCompatibleDC(tDC)
ReleaseDC 0&, tDC
End If
End If
End If
m_ManageDC = bManage
End Property
Public Property Get ManageOwnDC() As Boolean
ManageOwnDC = m_ManageDC
End Property
Public Property Get isAlphaBlendFriendly() As Boolean
isAlphaBlendFriendly = ((m_osCAP And 1) = 1)
' WinNT4 & below and Win95 are not shipped with msimg32.dll (AlphaBlend API)
' Win98 has bugs & would believe that WinME is buggy too but don't know for sure
' Therefore, the Rendering in this class will not use AlphaBlend on these
' operating systems even if the DLL exists, but will use GDI+ if available
' Can be overridden by setting this property to True
End Property
Public Property Let isAlphaBlendFriendly(Enabled As Boolean)
' This has been provided to override safety of using AlphaBlend on Win9x systems.
' Caution. Only set this when rendering to a known device dependent bitmap (DDB)
' Alphablend can crash when rendering DIB to DIB vs DIB to DDB. Be warned.
If Enabled = True Then
' Overriding in play: allow AlphaBlend if system is Win98 or better
' By default this is already set for Win2K or better
If ((m_osCAP And 8) = 8) Then m_osCAP = m_osCAP Or 1
Else
m_osCAP = m_osCAP And Not 1 ' disallow AlphaBlend
End If
End Property
Public Property Get isGDIplusEnabled() As Boolean
' identifies if GDI+ is usable on the system.
' Before this property is set, GDI+ is tested to ensure it is usable
isGDIplusEnabled = ((m_osCAP And 2) = 2)
End Property
Public Property Let isGDIplusEnabled(Enabled As Boolean)
' Sets the property. If set to False by you, GDI+ will not be used
' for any rendering, but still may be used to create PNG files if needed
If Not Enabled = Me.isGDIplusEnabled Then
m_osCAP = (m_osCAP And Not 2)
If Enabled Then
If (m_osCAP And 32) = 0 Then ' else Win95, NT4 SP5 or lower
Dim cGDIp As New cGDIPlus
If cGDIp.isGDIplusOk() = True Then m_osCAP = m_osCAP Or 2
End If
End If
End If
End Property
Public Property Get isZlibEnabled() As Boolean
' Read Only
' To create PNG files, GDI+ or zLib is required. This property informs
' you if zLIB exists in the system's DLL path
isZlibEnabled = iparseValidateZLIB(vbNullString, 0, False, False, True)
End Property
Public Function InitializeDIB(ByVal Width As Long, ByVal Height As Long) As Boolean
' Creates a blank (all black, all transparent) DIB of requested height & width
Dim tBMPI As BITMAPINFO, tDC As Long
DestroyDIB ' clear any pre-existing dib
If Width < 0& Then Exit Function
If Height = 0& Then
Exit Function
ElseIf Height < 0& Then
Height = Abs(Height) ' no top-down dibs
End If
On Error Resume Next
With tBMPI.bmiHeader
.biBitCount = 32
.biHeight = Height
.biWidth = Width
.biPlanes = 1
.biSize = 40&
.biSizeImage = .biHeight * .biWidth * 4&
End With
If Err Then
Err.Clear
' only possible error would be that Width*Height*4& is absolutely huge
Exit Function
End If
tDC = GetDC(0&) ' get screen DC
m_Handle = CreateDIBSection(tDC, tBMPI, 0&, m_Pointer, 0&, 0&)
If m_ManageDC = True Then
' create a DC if class is managing its own & one isn't created yet
If m_hDC = 0& Then m_hDC = CreateCompatibleDC(tDC)
End If
' release the screen DC if we captured it
ReleaseDC 0&, tDC
If Not m_Handle = 0& Then ' let's hope system resources allowed DIB creation
m_Width = Width
m_Height = Height
m_AlphaImage = True
m_Format = imgNone
InitializeDIB = True
End If
End Function
Public Sub DestroyDIB()
' PURPOSE: Destroy any existing image
If Not m_hDC = 0& Then ' do we have a DC?
' do we have an image; if so get it out of the DC
If Not m_prevObj = 0& Then SelectObject m_hDC, m_prevObj
' destroy our DC, no point in keeping it w/o image
DeleteObject m_hDC
m_hDC = 0&
End If
' if we do have an image, destroy it now
If Not m_Handle = 0& Then
DeleteObject m_Handle
Erase m_ImageByteCache
End If
' reset other image attributes
m_Width = 0&
m_Height = 0&
m_Handle = 0&
m_Pointer = 0&
m_prevObj = 0&
m_AlphaImage = False
m_Format = imgError
End Sub
Public Sub EraseDIB()
' Function clears out an existing DIB, making it 100% transparent/black
If Not m_Handle = 0& Then
FillMemory ByVal m_Pointer, m_Width * m_Height * 4&, 0
m_Format = imgNone
m_AlphaImage = True
End If
End Sub
Public Function Render(ByVal destinationDC As Long, _
Optional ByVal destX As Long, Optional ByVal destY As Long, _
Optional ByVal destWidth As Long, Optional ByVal destHeight As Long, _
Optional ByVal SrcX As Long, Optional ByVal SrcY As Long, _
Optional ByVal srcWidth As Long, Optional ByVal srcHeight As Long, _
Optional ByVal Opacity As Long = 100&, _
Optional ByVal Blend As Boolean = True, _
Optional ByVal SetHalfTone As Boolean = True, _
Optional ByRef destHostDIB As c32bppDIB = Nothing, _
Optional ByVal grayScale As eGrayScaleFormulas = gsclNone, _
Optional ByVal LightAdjustment As Single = 0!, _
Optional ByVal Angle As Single = 0!, _
Optional ByVal CenterOnDestXY As Boolean = False) As Boolean
' PURPOSE: Render an existing 32bpp DIB to a target DC
' Angle & CenterOnDestXY added to allow this routine to replace the RotateAtCenterPoint & RotateAtTopLeft calls
' Mirroring: When destWidth & srcWidth are compared, if one is negative and the other positive, mirroring horizontally occurs
' When destHeight & srcHeight are compared, if one is negative and the other positive, mirroring vertically occurs
' All four of those parameters are optional & any that are not passed will default to the image's width/height as needed
' before the mirroring check is applied
' Parameters. Only destinationDC is required
' destinationDC :: target DC to draw to. Ignored if destHostDIB is passed
' destX, destY :: the top/left coordinates to draw to, default is 0,0
' destWidth, destHeight :: the width and height to draw to, default is the image's width & height
' srcX, srcY :: the left & top offset within the DIB
' srcWidth, srcHeight :: the amount of DIB to be rendered
' Opacity :: how opaque to draw the image, default is 100% opaque
' Blend :: no longer used, reserved & left in for backward compatibility
' SetHalfTone :: if True, then the destination DC's stretch mode will be modified to
' produce better quality results. This option is not available on Win9x systems.
' Tip: When AlphaBlending to another DIB set to False
' When AlphaBlending to CompatibleBitmap (DDB) or visible DC set to True
' destHostDIB :: When rendering from DIB class to DIB class, pass the destination
' DIB class to ensure alpha blending occurs correctly on systems that do not
' support GDI+ or AlphaBlend APIs. When passed, destinationDC is ignored
' grayscale :: one of several formulas to grayscale while rendering (optional)
' LightAdjustment :: values between -100 and 100 percent of added pixel darkeness/lightness
' -100% will display a black image & 100 percent will display a white image
' Angle :: between -360 and 360. Rotation is clockwise
' CenterOnDestXY :: If true then rendering is centered on the destX,destY coordinates
Dim lBlendFunc As Long, tDC As Long, hOldImage As Long
Dim lStretchMode As Long
Dim aResizedBytes() As Byte, aMirrorBytes() As Byte
Dim bStretching As Boolean
Dim bMirroring As Boolean
Dim bRotating As Boolean
Dim bCanUseAlphaBlend As Boolean
' validate a few things
If Opacity < 1& Then ' nothing to render if image is 100% transparent
Render = Not (m_Handle = 0)
Exit Function
ElseIf m_Handle = 0& Then
Exit Function
ElseIf destinationDC = 0& Then
If destHostDIB Is Nothing Then Exit Function
End If
' validate optional destination parameters
If destWidth = 0& Then destWidth = m_Width
If destHeight = 0& Then destHeight = m_Height
' validate optional parameters for source image
If SrcX < 0& Then SrcX = 0& ' source X,Y cannot be negative
If SrcY < 0& Then SrcY = 0& ' but the dest X,Y can be
If srcWidth = 0& Then
srcWidth = m_Width
ElseIf srcWidth < 0& Then ' locally, only the destWidth can be negative for mirroring, not srcHeight
destWidth = -destWidth
srcWidth = -srcWidth
End If
If srcHeight = 0& Then
srcHeight = m_Height
ElseIf srcHeight < 0& Then ' locally, only the destHeight can be negative for mirroring, not srcHeight
destHeight = -destHeight
srcHeight = -srcHeight
End If
If SrcX + srcWidth > m_Width Then srcWidth = m_Width - SrcX
If SrcY + srcHeight > m_Height Then srcHeight = m_Height - SrcY
' angle is Single. See if passed angle is evenly divisible by 360
If Int(Angle) = Angle Then
bRotating = Not ((Angle Mod 360) = 0)
Else ' angle has fractional component; therefore can't be Mod 360
bRotating = True
End If
' validate opacity is within range
Opacity = Abs(Opacity) Mod 100
If Opacity = 0& Then Opacity = 100&
' validate light adjustment is within range. Disqualify LigthAdjustmnet if out of range
If Not LightAdjustment = 0! Then
If LightAdjustment > 100! Then
LightAdjustment = 0!
ElseIf LightAdjustment < -100! Then
LightAdjustment = 0!
End If
End If
If CenterOnDestXY = True Then
If bRotating Then
destX = destX - destWidth 2 ' use negative destWidth,destHeight if mirroring - rotation routines expect it
destY = destY - destHeight 2
If Not destHostDIB Is Nothing Then destinationDC = destHostDIB.LoadDIBinDC(True)
Render = RotateImage(destinationDC, Angle, destX, destY, destWidth, destHeight, SrcX, SrcY, srcWidth, srcHeight, Opacity, destHostDIB, grayScale, LightAdjustment)
If Not destHostDIB Is Nothing Then destHostDIB.LoadDIBinDC False
Exit Function
Else
destX = destX - Abs(destWidth 2) ' not rotating, don't allow negative destWidth,destHeight for calculations
destY = destY - Abs(destHeight 2)
End If
ElseIf bRotating Then
If Not destHostDIB Is Nothing Then destinationDC = destHostDIB.LoadDIBinDC(True)
Render = RotateImage(destinationDC, Angle, destX, destY, destWidth, destHeight, SrcX, SrcY, srcWidth, srcHeight, Opacity, destHostDIB, grayScale, LightAdjustment)
If Not destHostDIB Is Nothing Then destHostDIB.LoadDIBinDC False
Exit Function
End If
' are we mirroring? rules out AlphaBlend usage if we are
If destWidth > 0& Then
bMirroring = (destHeight < 0&)
Else
bMirroring = True
End If
' are we resizing? may rule out AlphaBlend usage (stretching DIB to DIB can crash on Win9x)
If (Abs(destWidth) = srcWidth) Then
bStretching = Not (Abs(destHeight) = srcHeight)
Else
bStretching = True
End If
' The following IF tree and above boolean assignments are to determine:
' 1. Do we use AlphaBlend
' 2. Do we use GDI+
' 3. Do we do it manually.
' The answer depends on user settings, O/S, graphics manipulation & DLL abilities
' if user provided token, allow GDI+ to override AlphaBlend
If Me.isGDIplusEnabled = False Or Me.gdiToken = 0& Then
' see if alphablend will support the various rendering options
If Me.isAlphaBlendFriendly Then ' Win98 or better with AlphaBlend enabled & GDI+ disabled
If Not bMirroring Then ' can't use alphaBlend if mirroring
If grayScale = gsclNone Then ' can't use alphaBlend if gray scaling
If LightAdjustment = 0! Then ' can't use alphaBlend if modifying pixel brightness
If bStretching Then
bCanUseAlphaBlend = Not m_StretchQuality ' can't use alphaBlend if using Bilinear interpolation
Else
bCanUseAlphaBlend = True
End If
End If
End If
End If
End If
End If
If Me.isGDIplusEnabled = True And bCanUseAlphaBlend = False Then
' we will use GDI+ to render when higher quality interpolation is desired, system is not AlphaBlend friendly or user supplied gdi+ token
Dim cGDIp As New cGDIPlus
If Not destHostDIB Is Nothing Then destinationDC = destHostDIB.LoadDIBinDC(True)
Render = cGDIp.RenderGDIplus(Me, destinationDC, 0&, Opacity, destX, destY, destWidth, destHeight, SrcX, SrcY, srcWidth, srcHeight, m_StretchQuality, grayScale, m_GDItoken, LightAdjustment)
If Not destHostDIB Is Nothing Then destHostDIB.LoadDIBinDC False
Set cGDIp = Nothing
Else
If m_hDC = 0& Then ' do we have a DC to select our image into?
tDC = GetDC(0&) ' if not create one, if ManageOwnDC=True, we will have one
m_hDC = CreateCompatibleDC(tDC)
ReleaseDC 0&, tDC
hOldImage = SelectObject(m_hDC, m_Handle)
Else
' we have a DC, but is the image selected into it?
If m_prevObj = 0& Then hOldImage = SelectObject(m_hDC, m_Handle)
End If
If bCanUseAlphaBlend = False Then
' Ruled out use of AlphaBlend (preferred when GDI+ isn't available)
' Win95/NT4 - not shipped with AlphaBlend
' Mirroring or high quality interpolation stretching - can't use AlphaBlend
' Grayscaling/light adjustments on the fly - can't use AlphaBlend
' Stretching from DIB to destination - can crash with Win9x
' AlphaBlend can't do high quality interpolation
' doing it completely manually
' 1. Mirror and change light intensity as needed
If bMirroring Then MirrorDIB SrcX, SrcY, srcWidth, srcHeight, destWidth, destHeight, aMirrorBytes(), , LightAdjustment
' 2. Resize using Nearest Neighbor or Bi-Linear algorithms & change light intensity as needed, then Render
If bStretching Then
If pvResize(destinationDC, aResizedBytes(), aMirrorBytes(), Nothing, SrcX, SrcY, srcWidth, srcHeight, destX, destY, destWidth, destHeight, LightAdjustment) = False Then Exit Function
' use custom blending routine, passing aResizedBytes array
Render = Win9xBlend(destinationDC, aResizedBytes(), SrcX, SrcY, destX, destY, destWidth, destHeight, (255& * Opacity) 100&, destHostDIB, grayScale, LightAdjustment)
Else
' use custom blending routine, passing aMirrorBytes array. If LigthAdjustment not applied above, it will be applied in spt_Win9xBlend
Render = Win9xBlend(destinationDC, aMirrorBytes(), SrcX, SrcY, destX, destY, destWidth, destHeight, (255& * Opacity) 100&, destHostDIB, grayScale, LightAdjustment)
End If
Else ' we can use AlphaBlend
If Not destHostDIB Is Nothing Then destinationDC = destHostDIB.LoadDIBinDC(True)
If SetHalfTone Then ' Stretch_Halftone not compatible with win9x
If ((m_osCAP And 16&) = 0&) Then lStretchMode = SetStretchBltMode(destinationDC, STRETCH_HALFTONE)
End If
' calculate the opacity required & add it to the BlendFunction variable
lBlendFunc = AC_SRC_OVER Or (((255& * Opacity) 100&) * &H10000)
' if the image has transparency, then we add the AC_SRC_ALPHA flag too
If Me.Alpha = True Then lBlendFunc = lBlendFunc Or (AC_SRC_ALPHA * &H1000000)
Render = Not (AlphaBlend(destinationDC, destX, destY, destWidth, destHeight, m_hDC, SrcX, SrcY, srcWidth, srcHeight, lBlendFunc) = 0&)
If SetHalfTone Then ' Stretch_Halftone not compatible with win9x
If ((m_osCAP And 16&) = 0&) Then SetStretchBltMode destinationDC, lStretchMode
End If
If Not destHostDIB Is Nothing Then destHostDIB.LoadDIBinDC False
End If
' remove the image from the DC if necessary
If Not hOldImage = 0& Then SelectObject m_hDC, hOldImage
If Not tDC = 0& Then ' if we created a DC, let's destroy it now
DeleteDC m_hDC
m_hDC = 0&
End If
End If
End Function
Public Function SaveToStream(outStream() As Byte) As Boolean
' Should you want to serialize the 32bpp DIB.
' Stream is formatted as a complete bitmap; therefore,
' one could simply write the bytes to file and a true bitmap is created
' Use GetDibBits function to return just the pixel data
On Error GoTo ExitRoutine ' should out of memory occur?
If m_Handle = 0& Then Exit Function
Dim tBMPI As BITMAPINFO
Dim b24bpp() As Byte
With tBMPI.bmiHeader
.biHeight = m_Height
.biWidth = m_Width
.biPlanes = 1
.biSize = 40
.biBitCount = 24 + m_AlphaImage * -8
.biSizeImage = iparseByteAlignOnWord(.biBitCount, .biWidth) * .biHeight
End With
ReDim outStream(0 To 53 + tBMPI.bmiHeader.biSizeImage)
CopyMemory outStream(0), &H4D42, 2& ' bmp magic number
CopyMemory outStream(2), CLng(54 + tBMPI.bmiHeader.biSizeImage), 4& ' overall size of image
' ^^ 54 = 14 byte bmp header + 40 for the tBMPI structure
CopyMemory outStream(10), 54&, 4& ' image offset from beginning of file
CopyMemory outStream(14), tBMPI, 40&
If tBMPI.bmiHeader.biBitCount = 32 Then
CopyMemory outStream(54), ByVal m_Pointer, tBMPI.bmiHeader.biSizeImage
Else
GetDIBbits b24bpp(), , , False
CopyMemory outStream(54), b24bpp(0, 0), tBMPI.bmiHeader.biSizeImage
End If
SaveToStream = True
ExitRoutine:
If Err Then
Err.Clear
Erase outStream()
End If
End Function
Public Function SaveToStream_PNG(outStream() As Byte) As Boolean
' Requires GDI+ and/or zLib installed on the system, otherwise function fails.
' Tesst isGDIplusEnabled or isZlibEnabled
' To use the optional PNG properties, isZlibEnabled must be True
' See PngPropertySet and PngPropertyGet
' Function saves the current 32bpp DIB to an array containing the DIB in PNG format
' Per PNG recommendations, the PNG is created with non-premultiplied pixels
If m_Handle = 0& Then Exit Function
Dim cGDIp As cGDIPlus, cZlib As cPNGwriter
Dim bSuccess As Boolean
If m_PNGprops Is Nothing Then ' no special PNG properties set, use GDI+
Set cGDIp = New cGDIPlus
If cGDIp.SaveToPNG(vbNullString, outStream(), Me, m_GDItoken) = False Then
Set cZlib = New cPNGwriter ' failed, attempt to use zLIB
bSuccess = cZlib.SavePNGex(Me, vbNullString, outStream())
Else
bSuccess = True ' GDI+ created the PNG
End If
Else
' user set some optional PNG properties (See PngPropertySet), use zLib
If m_PNGprops.SavePNGex(Me, vbNullString, outStream()) = False Then
Set cGDIp = New cGDIPlus ' failed, attempt to use GDI+
bSuccess = cGDIp.SaveToPNG(vbNullString, outStream(), Me, m_GDItoken)
Else
bSuccess = True ' zLIB created the PNG
End If
End If
SaveToStream_PNG = bSuccess
End Function
Public Function SourceIconSizes(sizeArray() As Long) As Long
' Function will return a 2D array that contains the icon width, height,
' bit depth and color count for each icon in the source image/file
' The 2D array is always zero bound and the return value of the function
' indicates how many icons exist in the source
' 1st dimension of the array
' 0 element: icon width
' 1 element: icon height
' 2 element: icon bit depth: 1,2,4,8,16,24,32
' 3 element: icon colors: 2,4,16,256,HIGH_COLOR,TRUE_COLOR, TRUE_COLOR_ALPHA
' HIGH_COLOR, TRUE_COLOR,& TRUE_COLOR_ALPHA are public variables
' 2nd dimension of the array is 0 to number of icons - 1
If m_Handle = 0& Then Exit Function
Select Case m_Format
Case imgIcon, imgIconARGB, imgPNGicon, imgCursor, imgCursorARGB
If iparseIsArrayEmpty(VarPtrArray(m_ImageByteCache)) = 0& Then
' original bytes were not kept, therefore, we only have one image
ReDim sizeArray(0 To 3, 0 To 0)
sizeArray(0, 0) = m_Width
sizeArray(1, 0) = m_Height
sizeArray(2, 0) = 32
sizeArray(3, 0) = TRUE_COLOR_ALPHA
SourceIconSizes = 1
Else
Dim cICO As cICOparser, i As Long
Set cICO = New cICOparser
If cICO.LoadStream(m_ImageByteCache, 32, 32, Nothing, 0, UBound(m_ImageByteCache) + 1, 32) = True Then
ReDim sizeArray(0 To 3, 0 To cICO.IconCount - 1)
With cICO
For i = 1 To .IconCount
sizeArray(0, i - 1) = .Width(i)
sizeArray(1, i - 1) = .Height(i)
sizeArray(2, i - 1) = .bitDepth(i)
Select Case .bitDepth(i)
Case 1: sizeArray(3, i - 1) = 2
Case 2: sizeArray(3, i - 1) = 4
Case 4: sizeArray(3, i - 1) = 16
Case 8: sizeArray(3, i - 1) = 256
Case Is < 24: sizeArray(3, i - 1) = HIGH_COLOR
Case 24: sizeArray(3, i - 1) = TRUE_COLOR
Case Else: sizeArray(3, i - 1) = TRUE_COLOR_ALPHA
End Select
Next
End With
SourceIconSizes = cICO.IconCount
End If
End If
Case Else
' not an icon/cursor source
End Select
End Function
Public Function CreateCheckerBoard(Optional ByVal CheckerSize As Long = 12&, _
Optional ByVal FirstColor As Long = vbWhite, Optional ByVal SecondColor As Long = 12632256) As Boolean
' Function simply creates a checkerboard pattern. This can be desirable when the DIB currently has no
' image but something should be displayed. When this is set, you can test whether or not this class
' created the Checkerboard by testing class.ImageType = imgCheckerBoard
' The checker size is used for both the width and height of each square. Default value is 12.
' FirstColor is the colored checker at the top left corner of the pattern. Default is white
' SecondColor is the alternating checker color. Default is gray RGB: 192,192,192
If m_Handle = 0& Then Exit Function
Dim hBrush As Long, hBr1 As Long, hBr2 As Long
Dim cRect As RECT, tSA As SafeArray
Dim X As Long, Y As Long, tDC As Long
Dim bUnselect As Boolean, bEven As Boolean
Dim dibBytes() As Byte
bUnselect = (m_prevObj = 0&)
tDC = LoadDIBinDC(True)
hBr1 = CreateSolidBrush(FirstColor)
hBr2 = CreateSolidBrush(SecondColor)
cRect.Right = CheckerSize
cRect.Bottom = CheckerSize
For Y = 0& To m_Height - 1& Step CheckerSize
If bEven Then hBrush = hBr2 Else hBrush = hBr1
For X = 0& To m_Width - 1& Step CheckerSize
FillRect tDC, cRect, hBrush
If hBrush = hBr1 Then hBrush = hBr2 Else hBrush = hBr1
OffsetRect cRect, CheckerSize, 0&
Next
bEven = Not bEven
OffsetRect cRect, -cRect.Left, CheckerSize
Next
DeleteObject hBr1
DeleteObject hBr2
If bUnselect Then LoadDIBinDC False
' here we will force every alpha byte to be fully opaque
With tSA
.cbElements = 1
.cDims = 2
.pvData = m_Pointer
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width * 4&
End With