' which could cause crash when compiled. Fixed & double checked everywhere else too
' 1 Jan 07:
' - Added SaveToFile & SaveToStream methods
' - cBMPparser could possibly try to query unauthorized memory; fixed
' - Methodology changed a bit when parsers return results. If image is definitely one
' that the parser is responsible for & the image is invalid, the parser will return
' True to prevent other parsers from handling the image. The c32bppDIB.Handle is used
' to determine true success or failure.
' -- cGIFparser when recognizing improperly formatted GIF would allow image to continue to
' other parsers which then may cause those parsers to lock up.
' 26 Dec 06: First version
' Used to determine operating system
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As Any) As Long
Private Const VER_PLATFORM_WIN32_WINDOWS As Long = &H1
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 ' 14 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 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 StretchBlt Lib "gdi32.dll" (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 SetStretchBltMode Lib "gdi32.dll" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function GetObjectType Lib "gdi32.dll" (ByVal hgdiobj As Long) As Long
Private Declare Function GetIconInfo Lib "user32.dll" (ByVal hIcon As Long, ByRef piconinfo As ICONINFO) As Long
Private Const STRETCH_HALFTONE As Long = 4
Private Const OBJ_BITMAP As Long = 7
Private Const OBJ_METAFILE As Long = 9
Private Const OBJ_ENHMETAFILE As Long = 13
' 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 PictDesc
Size As Long
Type As Long
hHandle As Long
hPal As Long
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
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?
End Enum
Public Enum eScaleOptions
scaleToSize = 0 ' [Default] will always scale
scaleDownAsNeeded = 1 ' will only scale down if image won't fit
scaleStretch = 2 ' wll always stretch/distort
End Enum
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_os9x As Long ' 1=win9x, 3=win95
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
Public Function LoadPicture_File(ByVal FileName As String, _
Optional ByVal iconCx As Long, _
Optional ByVal iconCy As Long) 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
On Error Resume Next
If Len(Dir$(FileName, vbArchive Or vbReadOnly Or vbSystem Or vbHidden)) = 0 Then Exit Function
If FileLen(FileName) < 57 Then Exit Function
' no image file/stream can be less than 57 bytes and still be an image
Public Sub ScaleImage(ByVal destWidth As Long, ByVal destHeight As Long, NewWidth As Long, NewHeight As Long, Optional ByVal ScaleMode As eScaleOptions = scaleDownAsNeeded)
' Purpose: Returns the width and height needed to draw the image to the requested dimensions.
' Function should be called before .Render should you want to scale the image. Additionally,
' scaling can assist in positioning image too, i.e., centering.
' destWidth [in]:: the width of the target canvas (drawing area)
' destHeight [in]:: the height the target canvas
' NewWidth [out]:: returns the width to use for the supplied ScaleMode
' NewHeight [out]:: returns the height to use for the supplied ScaleMode
' ScaleMode [in]::
' scaleToSize [Default] - will always proportionally stretch the image to the target canvas size
' scaleDownAsNeeded - will only shrink the image if needed; otherwise the original image size is passed
' scaleStretch - the return value is always the canvas width and height; image distortion occurs
If m_Handle = 0& Then Exit Sub
Dim RatioX As Single, RatioY As Single
' calculate scale and offsets
Select Case ScaleMode
Case scaleDownAsNeeded, scaleToSize: ' scaled
RatioX = destWidth / m_Width
RatioY = destHeight / m_Height
If ScaleMode = scaleDownAsNeeded Then
If RatioX > 1! And RatioY > 1! Then
RatioX = 1!: RatioY = RatioX
End If
End If
If RatioX > RatioY Then RatioX = RatioY
NewWidth = Int(RatioX * m_Width)
NewHeight = Int(RatioX * m_Height)
' to center your image in the target canvas. Use the passed & returned parameters like so:
' canvasX = (destWidth - NewWidth) \ 2 + any Left offset you may be using
' canvasY = (destHeight - NewHeight) \ 2 + any Top offset you may be using
' canvasX and canvasY would then be passed to .Render as .Render's X,Y parameters
Case scaleStretch: ' stretch
NewWidth = m_Width
NewHeight = m_Height
End Select
End Sub
Public Sub CopyImageTo(cDIBclass As c32bppDIB)
' Function replicates the the current image to another DIB class
If Not m_Handle = 0 Then ' do we have an image to copy?
If Not cDIBclass Is Nothing Then ' was a valid ref passed?
With cDIBclass
.DestroyDIB ' kill ref's old DIB if any
.InitializeDIB m_Width, m_Height ' create new one & copy data
