GDI/图象编程

开发平台：

Visual Basic

c32bppDIB.cls：源码内容

CopyMemory ByVal VarPtrArray(dibBytes), VarPtr(tSA), 4&
For Y = 0& To m_Height - 1&
For X = 3& To m_Width * 4& - 1& Step 4&
dibBytes(X, Y) = 255
Next
Next
CopyMemory ByVal VarPtrArray(dibBytes), 0&, 4&
m_AlphaImage = False ' we are not using transparency
m_Format = imgCheckerBoard ' special flag for user
CreateCheckerBoard = True
End Function
Private Function RotateImage(ByVal hDC As Long, ByVal Angle As Single, _
ByVal TopX As Long, ByVal TopY As Long, _
ByVal destWidth As Long, ByVal destHeight As Long, _
ByVal SrcX As Long, ByVal SrcY As Long, _
ByVal srcWidth As Long, ByVal srcHeight As Long, _
ByVal Opacity As Long, _
ByRef destHostDIB As c32bppDIB, _
ByVal grayScale As eGrayScaleFormulas, _
ByVal LightAdjustment As Single) As Boolean
' Internal function will rotate an image by passed Angle and render to the passed hDC.
' This function simultaneously rotates, scales and then blends.
' Note: Me.HighQualityInterpolation property setting is used to determine quality of rotation/scaling
' Called only by the Render method
' first see if we can do this via GDI+
If Me.isGDIplusEnabled Then
Dim cGDIp As New cGDIPlus
If cGDIp.RenderGDIplus(Me, hDC, Angle, Opacity, TopX, TopY, destWidth, destHeight, SrcX, SrcY, srcWidth, srcHeight, m_StretchQuality, grayScale, m_GDItoken, LightAdjustment) = True Then
RotateImage = True
Exit Function
End If
Set cGDIp = Nothing
End If
Dim cosTx As Double, sinTx As Double
Dim cosTy As Double, sinTy As Double
Dim scalerX As Double, scalerY As Double
Dim maxX As Long, maxY As Long, maxSize As Long
Dim ctrX As Long, ctrY As Long
Dim xOffset As Double, yOffset As Double
Dim targetX As Double, targetY As Double
Dim dSA As SafeArray, sSA As SafeArray
Dim dBytes() As Byte, sBytes() As Byte
Dim rHost As New c32bppDIB
Dim lRow As Long, lCol As Long
' following variables are used for the BiLinear interpolation only
Dim tgtY As Long, tgtX As Long
Dim srcPixel As Long, dstPixel As Long, srcRow As Long
Dim edgeOffsetX As Long, edgeOffsetY As Long
Dim fY As Double, fX As Double, iX As Long, iY As Long
Dim R As Double, G As Double, B As Double, A As Double
' handle mirroring as needed. Fix negative values as needed
If destWidth < 0& Then TopX = TopX + destWidth
If destHeight < 0& Then TopY = TopY + destHeight
If MirrorDIB(SrcX, SrcY, srcWidth, srcHeight, destWidth, destHeight, sBytes(), , LightAdjustment) = False Then
' if light adjustments, preprocess bytes
If Not LightAdjustment = 0! Then Call LightenDarken(Me, LightAdjustment, sBytes)
End If
' determine the scale to use based off the passed
' source and destination widths,heights
scalerX = destWidth / srcWidth ' scale x coordinates
scalerY = destHeight / srcHeight ' scale y coordinates
' convert angle to radians & calculate scaled COS/SIN of the angle
' Multiplying by Negative so we rotate clockwise
sinTx = -((Angle Mod 360) * (4& * Atn(1))) / 180 ' convert Degree to Radian
cosTy = Cos(sinTx) / scalerY ' get cosine of angle (Y coordinates)
sinTy = Sin(sinTx) / scalerY ' get sine of angle (Y coordinates)
cosTx = Cos(sinTx) / scalerX ' get cosine of angle (X coordinates)
sinTx = Sin(sinTx) / scalerX ' get sine of angle (X coordinates)
' determine maximum size image we will need to cover any angle
maxSize = Sqr(destWidth * destWidth + destHeight * destHeight)
' create a temporary DIB to hold the rotated image
rHost.InitializeDIB maxSize, maxSize
rHost.isGDIplusEnabled = Me.isGDIplusEnabled
rHost.HighQualityInterpolation = Me.HighQualityInterpolation
On Error GoTo eh
' overlay the temp DIB and our host DIB
With dSA
.cbElements = 1
.cDims = 2
.pvData = rHost.BitsPointer
.rgSABound(0).cElements = maxSize
.rgSABound(1).cElements = maxSize * 4&
End With
CopyMemory ByVal VarPtrArray(dBytes), VarPtr(dSA), 4&
If iparseIsArrayEmpty(VarPtrArray(sBytes)) = 0& Then
With sSA
.cbElements = 1
.cDims = 2
.pvData = m_Pointer
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width * 4&
End With
CopyMemory ByVal VarPtrArray(sBytes), VarPtr(sSA), 4&
End If
' bottom up dib, vertical offset is from bottom, not top
SrcY = UBound(sBytes, 2) - srcHeight - SrcY + 1&
' set up offsets for calculating rotated/scaled points
maxX = srcWidth + SrcX ' the right edge of the source image
maxY = srcHeight + SrcY ' the bottom edge of the source image
' determine where the center of the source selected bounds falls within the maxSize bounds
ctrX = srcWidth 2 + SrcX ' the center of the source image
ctrY = srcHeight 2 + SrcY
' calculate offsets to "center" destination image in its maxSize window
xOffset = ((maxSize - srcWidth) 2)
yOffset = ((maxSize - srcHeight) 2)
' here's where we apply all of the above offsets
' This is a bit complicated because we allow any angle rotation,
' and also allowing portions of the image or entire image to be rotated
' and also allows scaling up or down
If m_StretchQuality = False Then
For lRow = -yOffset To maxSize - yOffset - 1&
' Calculate the point in the source image needed for the rotated point in destination image
' This only needs to be done once per image scan line & contains many math executions
targetX = (-xOffset - ctrX) * cosTx + (lRow - ctrY) * sinTx + ctrX
targetY = (lRow - ctrY) * cosTy - (-xOffset - ctrX) * sinTy + ctrY
For lCol = -xOffset To maxSize - xOffset - 1&
' validate rotated point is within bounds of the image/portion
If targetY >= SrcY Then ' is Y within area of source?
If targetY < maxY Then
If targetX >= SrcX Then ' is X within area of source?
If targetX < maxX Then
' validation complete, copy pixel to destination
CopyMemory dBytes((xOffset + lCol) * 4&, yOffset + lRow), sBytes(Int(targetX) * 4&, Int(targetY)), 4&
End If
End If
End If
End If
' Excellent optimization I found (wish I remember where so I can give credit)
' But the logic is simple: once the initial X,Y coordinates for the
' current source row is found, the next point is always a constant value from
' the last point. In this case, increments of cosT & sinT.
' Therefore we don't need to recalculate targetX,targetY for every point
' since we did it once for current row. Thus we have 2 simple additions per pixel
' vs 4 multiplications & 12 additions per pixel
targetX = targetX + cosTx
targetY = targetY - sinTy
Next
Next
Else
' BiLinear interpolation with rotation. This can produce better quality
' results but takes significantly (x4) longer. Recommend using this option
' when you need a static rotated image, but when rotating via a scrollbar
' or some other method where scrolling is expected to be repeated often,
' then use the non-BiLinear method. COMPILED IS MUCH FASTER !!!
' Up to 4 source pixels (16 bytes) are blended for each destination pixel (4 bytes)
srcWidth = maxX - 1& ' reuse variable & subtract now vs subtraction for every pixel in the image
For lRow = -yOffset To maxSize - yOffset - 1&
' Calculate the rotated point in relation to host image
' These calcs only needs to be done once per image scan line
targetX = (-xOffset - ctrX) * cosTx + (lRow - ctrY) * sinTx + ctrX
targetY = (lRow - ctrY) * cosTy - (-xOffset - ctrX) * sinTy + ctrY
For lCol = -xOffset To maxSize - xOffset - 1&
If targetY >= SrcY Then ' is Y within area of source?
If targetY < maxY Then
If targetX >= SrcX Then ' is X within area of source?
If targetX < maxX Then
tgtY = Int(targetY) ' whole number of the double
If tgtY = 0& Then ' for top down images check for last row vs 0
' last row of source image, will use only this row
edgeOffsetY = 0&
fY = 0#
Else
' will use this row & next row for blending
edgeOffsetY = 1&
fY = 1# - (targetY - tgtY) ' for top down images, use: fY = targetY-tgtY
' ^ Y coordinate fraction; pct of next vertical pixel that is used
End If
R = 0#: G = 0#: B = 0#: A = 0#
tgtX = Int(targetX) ' coordinate rounded down to whole number
If tgtX = srcWidth Then
' at far edge of source image, will use only this pixel for blending
edgeOffsetX = 0&
fY = 0#: fX = 0#
Else
' will use this pixel and next pixel for blending
edgeOffsetX = 1&
fX = targetX - tgtX
' ^ X coordinate fraction, pct of next horizontal pixel that is used
End If
For iY = 0& To edgeOffsetY
scalerY = Abs(iY - fY) ' percentage of current row's pixel to blend
If Not scalerY = 1& Then ' else zero
srcRow = tgtY - iY ' for top down images Add iY vs subtracting
For iX = 0& To edgeOffsetX
scalerX = Abs(fX - iX) ' percentage of current column's pixel to blend
If Not scalerX = 1& Then ' else zero
scalerX = (1# - scalerX) * (1# - scalerY) ' combine percentages
srcPixel = (tgtX + iX) * 4&
B = B + sBytes(srcPixel, srcRow) * scalerX
G = G + sBytes(srcPixel + 1&, srcRow) * scalerX
R = R + sBytes(srcPixel + 2&, srcRow) * scalerX
A = A + sBytes(srcPixel + 3&, srcRow) * scalerX
End If
Next
End If
Next
dstPixel = (xOffset + lCol) * 4&
iY = lRow + yOffset
dBytes(dstPixel, iY) = Int(B)
dBytes(dstPixel + 1&, iY) = Int(G)
dBytes(dstPixel + 2&, iY) = Int(R)
dBytes(dstPixel + 3&, iY) = Int(A)
End If
End If
End If
End If
targetX = targetX + cosTx
targetY = targetY - sinTy
Next
Next
End If
CopyMemory ByVal VarPtrArray(dBytes), 0&, 4&
If sSA.pvData = 0& Then ' image was also mirrored
Erase sBytes()
Else ' remove overlay of non-mirrored image
CopyMemory ByVal VarPtrArray(sBytes), 0&, 4&
End If
xOffset = (TopX + destWidth 2) - (maxSize 2)
yOffset = (TopY + destHeight 2) - (maxSize 2)
rHost.gdiToken = m_GDItoken
' now render it. We won't pass some parameters because they have been handled here or don't apply with this temp DIB
RotateImage = rHost.Render(hDC, xOffset, yOffset, , , , , , , Opacity, , (destHostDIB Is Nothing), destHostDIB, grayScale)
eh:
If Err Then
Stop
Err.Clear ' troubleshooting only, should be removed before compiling to final app
Resume
End If
End Function
Public Function MakeImageInverse() As Boolean
' Function will invert the RGB values creating a color negative of the image
' Calling this function again, returns the image to its previous state
If m_Handle = 0& Then Exit Function
Dim tSA As SafeArray, gBytes() As Byte
Dim pAlpha As Byte
Dim X As Long, Y As Long
With tSA
.cbElements = 1
.cDims = 2
.pvData = m_Pointer
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width * 4&
End With
CopyMemory ByVal VarPtrArray(gBytes), VarPtr(tSA), 4&
On Error Resume Next
For Y = 0& To m_Height - 1&
For X = 0& To m_Width * 4& - 1& Step 4&
pAlpha = gBytes(X + 3&, Y)
If Not pAlpha = 0 Then ' otherwise fully transparent pixel
gBytes(X, Y) = -gBytes(X, Y) + pAlpha
gBytes(X + 1&, Y) = -gBytes(X + 1&, Y) + pAlpha
gBytes(X + 2&, Y) = -gBytes(X + 2&, Y) + pAlpha
End If
Next
Next
CopyMemory ByVal VarPtrArray(gBytes), 0&, 4&
MakeImageInverse = True
End Function
Public Function MakeTransparent(ByVal TransparentColor As Long, Optional ByVal Revert As Boolean = False) As Boolean
' if Revert = False
' Function will convert all pixels that are of the TransparentColor to fully transparent.
' Additionally, only if the alpha value of the color is fully opaque will the pixel become transparent.
' if Revert = True
' All fully transparent colors are made fully opaque and changed to the TransparentColor
If m_Handle = 0& Then Exit Function
Dim tSA As SafeArray, dPixels() As Long, bPixels() As Byte
Dim X As Long, Y As Long, bAlpha As Boolean
' convert passed color from RGB to BGRA
TransparentColor = ((TransparentColor And &HFF) * &H10000) Or ((TransparentColor &H100) And &HFF) * &H100 _
Or ((TransparentColor &H10000) And &HFF) Or &HFF000000
With tSA
.cbElements = 4
.cDims = 2
.pvData = m_Pointer
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width
End With
CopyMemory ByVal VarPtrArray(dPixels), VarPtr(tSA), 4&
If Revert Then
' change all fully transparent pixels to passed color
For Y = 0& To m_Height - 1&
For X = 0& To m_Width - 1&
If dPixels(X, Y) = 0& Then
dPixels(X, Y) = TransparentColor
End If
Next
Next
CopyMemory ByVal VarPtrArray(dPixels), 0&, 4&
' image may or may not contain alpha any longer, validate it
' The validation routine expects a 2D byte array, not long, so...
tSA.cbElements = 1
tSA.rgSABound(1).cElements = m_Width * 4&
CopyMemory ByVal VarPtrArray(bPixels), VarPtr(tSA), 4&
iparseValidateAlphaChannel bPixels(), False, bAlpha, 0&
CopyMemory ByVal VarPtrArray(bPixels), 0&, 4&
Me.Alpha = bAlpha
If bAlpha = False Then
If m_Format = imgBmpPARGB Or m_Format = imgBmpARGB Then m_Format = imgBitmap
End If
Else
' change all fully opaque colors matching TransparentColor to fully transparent
For Y = 0& To m_Height - 1&
For X = 0& To m_Width - 1&
If dPixels(X, Y) = TransparentColor Then
dPixels(X, Y) = 0&
bAlpha = True
End If
Next
Next
CopyMemory ByVal VarPtrArray(dPixels), 0&, 4&
If bAlpha Then
m_AlphaImage = True
If m_Format = imgBitmap Then m_Format = imgBmpPARGB
End If
End If
MakeTransparent = True
End Function
Public Function MirrorImage(ByVal MirrorAxisX As Boolean, ByVal MirrorAxisY As Boolean) As Boolean
' Function will mirror an image onto the same DIB.
' This function should be called when any image is mirrored vs mirroring the image
' within the Render function or rotate functions. Faster rendering will then occur.
' Mirroring never destroys original data and can be easily unmirrored.
' MirrorAxisX: If true, then image is mirrored horizontally
' MirrorAxisY: If true, then image is mirrored vertically
If Not m_Handle = 0& Then
If MirrorAxisX Or MirrorAxisY Then
Dim tBytes() As Byte, cX As Long, cY As Long
If MirrorAxisX = True Then cX = -m_Width Else cX = m_Width
If MirrorAxisY = True Then cY = -m_Height Else cY = m_Height
MirrorDIB 0&, 0&, m_Width, m_Height, cX, cY, tBytes()
CopyMemory ByVal m_Pointer, tBytes(0, 0), m_Width * m_Height * 4&
MirrorImage = True
End If
End If
End Function
Friend Sub SetOriginalFormat(inStream() As Byte)
' Purpose: Pass the original image file/bytes to this DIB from another DIB
' This is only called by the CopyImageTo function. Note it is Friend vs Public
m_ImageByteCache() = inStream()
End Sub
Private Function LoadPictureEx(ByVal FileHandle As Long, FileName As String, aStream() As Byte, _
cX As Long, cY As Long, _
streamOffset As Long, streamLength As Long, _
SaveFormat As Boolean, bitDepth As Long) As Boolean
' PURPOSE: Marshal passed file/array to image classes for conversion to 32bpp image
' For parameter information, see LoadPicture_File & LoadPicture_Stream
Me.DestroyDIB
' various image parsers, in order of precedence
' All 4 recognize transparency
Dim cPNG As cPNGparser ' very fast to abort if not a PNG file
Dim cGIF As cGIFparser ' very fast to abort if not a GIF file
Dim cICO As cICOparser ' must parse key parts of a file. handles icons & Vista PNG Icons
Dim cBMP As cBMPparser ' catchall. Handles bitmaps, wmf, emf & jpgs
Dim cGDI As cGDIPlus
Dim bReturn As Boolean ' function return value
Dim rtnRead As Long
' validate passed desired icon sizes
If cX < 0& Then cX = 0&
If cY < 0& Then cY = 0&
If bitDepth < 0& Then
bitDepth = 32
ElseIf bitDepth > 32 Then
bitDepth = 32
End If
Set cPNG = New cPNGparser ' see if image is a PNG; aborts quickly if not
If FileHandle = 0 Then
bReturn = cPNG.LoadStream(aStream(), Me, streamOffset, streamLength, m_GDItoken)
Else ' note: processing from file is slightly faster than via array
bReturn = cPNG.LoadFile(FileHandle, FileName, Me, m_GDItoken)
'If bReturn = True Then Close #fileNum ' close the file
End If
If Err Then MsgBox Err.Description
Set cPNG = Nothing
If Not bReturn Then
If Not FileHandle = 0& Then
streamOffset = 0&
streamLength = GetFileSize(FileHandle, 0&)
'streamLength = LOF(fileNum) ' cache length of file
ReDim aStream(streamOffset To streamLength - 1&)
'Get #fileNum, , aStream() ' populate our stream with the file contents
'Close #fileNum
SetFilePointer FileHandle, 0&, 0&, 0&
ReadFile FileHandle, aStream(streamOffset), streamLength, rtnRead, ByVal 0&
End If
Set cGIF = New cGIFparser ' what about a GIF; aborts quickly if not
bReturn = cGIF.LoadStream(aStream(), Me, streamOffset, streamLength)
Set cGIF = Nothing
If Not bReturn Then
Set cICO = New cICOparser ' will process Vista PNG icon if needed
bReturn = cICO.LoadStream(aStream(), cX, cY, Me, streamOffset, streamLength, bitDepth, m_GDItoken)
Set cICO = Nothing
If Not bReturn Then ' check for bmp, emf, wmf & jpg << last chance
Set cBMP = New cBMPparser
bReturn = cBMP.LoadStream(aStream(), Me, streamOffset, streamLength)
Set cBMP = Nothing
End If
End If
End If
If m_Handle = 0& Then ' hmmm, not an image file processed here, we can try
' one more thing... Send it GDI+ if possible
If Me.isGDIplusEnabled Then
Set cGDI = New cGDIPlus
If cGDI.GDIplusLoadPNG(FileName, aStream(), Me, m_GDItoken) = True Then
' it worked, whatever file type it was. Convert it to PNG
If SaveFormat = True Then
Call cGDI.SaveToPNG(vbNullString, aStream, Me, m_GDItoken)
FileHandle = 0& ' prevent next IF from trying to re-load it from file if applicable
End If
End If
End If
End If
If Not m_Handle = 0 Then
If SaveFormat = True Then ' we will cache the original bytes
If iparseIsArrayEmpty(VarPtrArray(aStream)) = 0& And Not FileHandle = 0& Then
' we loaded the image from the file and not a stream (PNG), need to get stream
'fileNum = FreeFile()
'Open FileName For Binary Access Read As #fileNum
If streamLength = 0& Then streamLength = GetFileSize(FileHandle, 0&)
ReDim m_ImageByteCache(0 To streamLength - 1)
SetFilePointer FileHandle, 0&, 0&, 0&
ReadFile FileHandle, m_ImageByteCache(0), streamLength, rtnRead, ByVal 0&
'Get #fileNum, 1, m_ImageByteCache
'Close #fileNum
Else
m_ImageByteCache() = aStream()
End If
End If
LoadPictureEx = True
End If
End Function
Private Function pvResize(ByVal destDC As Long, _
rSizedBytes() As Byte, rMirror() As Byte, _
Optional tHost As c32bppDIB, _
Optional ByVal SrcX As Long, Optional ByVal scrY As Long, _
Optional ByVal srcWidth As Long, Optional ByVal srcHeight As Long, _
Optional ByVal destX As Long, Optional ByVal destY As Long, _
Optional ByRef destWidth As Long, Optional ByRef destHeight As Long, _
Optional ByRef LightAdjustment As Single = 0!) As Boolean
' Function resizes an alpha image, maintaining premultiplied pixels & alpha values
' Code originally by Carles P.V. but significantly modified for this project.
' Parameters:
' destDC :: DC being rendered to, may be null
' rSizedbytes() : array to hold resized alpha section; not used if tHost is not Nothing
' tHost : when resizing to another DIB class, the destination DIB class
' srcX,Y : the coordinates of the source image to start resizing from
' srcWidth,srcHeight : the width/height of the source image to resize from
' destX,Y : the coordinates of the destination image to resize to
' destWidth,destHeight : the width/height of the destination image to resize to
If srcWidth = 0& Then srcWidth = m_Width
If srcHeight = 0& Then srcHeight = m_Height
Dim aNewBits() As Byte, dSA As SafeArray ' new size, overlay of DIB pointer
Dim aOldBits() As Byte, tSA As SafeArray ' old size, overlay of DIB pointer
Dim xLUdbl() As Double ' look up table (LUT)
Dim xRatio As Double, yRatio As Double ' scaled ratios
Dim srcPixel As Long, dstPixel As Long ' source/destination pixel locations
Dim lCol As Long, lRow As Long ' loop variables
Dim newWidth As Long, newHeight As Long
' following used with BiLinear scaling
Dim fX As Double, fY As Double
Dim tgtX As Long, tgtY As Long
Dim edgeOffsetX As Long, edgeOffsetY As Long
Dim iX As Long, iY As Long
Dim R As Double, G As Double, B As Double, A As Double
Dim scalerX As Double, scalerY As Double
' fill in opitonal parameters
If Not tHost Is Nothing Then
newWidth = tHost.Width
newHeight = tHost.Height
' Scaling ratio (ratio of actual image to scaled image)
xRatio = srcWidth / newWidth
yRatio = srcHeight / newHeight
If newWidth > tHost.Width Then newWidth = tHost.Width
If newHeight > tHost.Height Then newHeight = tHost.Height
Else
newWidth = Abs(destWidth)
newHeight = Abs(destHeight)
' Scaling ratio (ratio of actual image to scaled image)
xRatio = srcWidth / newWidth
yRatio = srcHeight / newHeight
' safety checks, recalculation of bounding destination size
' if not done, we could very easily access unallocated memory.
If destX < 0 Then ' negative DC offset
newWidth = newWidth + destX ' reduce width to process
destX = -destX ' used to offset LUT; adjust so not processing bytes not used
Else
destX = 0& ' fits within destination bitmap; no offsetting needed
End If
' now to check the vertical
If destY < 0& Then ' negative DC offset
newHeight = newHeight + destY
destY = 0&
Else
destY = 0&
End If
End If
If newHeight < 1& Or newWidth < 1& Then Exit Function
With dSA ' overlay destination array onto the passed Byte() array
.cbElements = 1
.cDims = 2
.rgSABound(0).cElements = newHeight
.rgSABound(1).cElements = newWidth * 4&
If tHost Is Nothing Then
ReDim rSizedBytes(0& To .rgSABound(1).cElements - 1&, 0& To newHeight - 1&)
.pvData = VarPtr(rSizedBytes(0&, 0&))
Else
.pvData = tHost.BitsPointer ' called by CopyImageTo & Resize routines
End If
End With
With tSA ' overlay source array onto our DIB
.cbElements = 1
.cDims = 2
If iparseIsArrayEmpty(VarPtrArray(rMirror)) = 0& Then
.pvData = m_Pointer ' source is our DIB
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width * 4&
Else
.pvData = VarPtr(rMirror(0&, 0&)) ' source is the mirrored DIB; clipped as needed
.rgSABound(0).cElements = UBound(rMirror, 2) + 1&
.rgSABound(1).cElements = UBound(rMirror, 1) + 1&
End If
End With
CopyMemory ByVal VarPtrArray(aNewBits), VarPtr(dSA), 4&
CopyMemory ByVal VarPtrArray(aOldBits), VarPtr(tSA), 4&
On Error GoTo eh
scrY = UBound(aOldBits, 2) - srcHeight - scrY + 1& ' adjust Y position in source for bottom up DIBs
If (m_StretchQuality = False) Then
' Scaling LUT, cache actual X position of DIB in relation to scaled X
' Cache one scan line of X coords so we don't have to calculate for every pixel
ReDim xLUdbl(0 To newWidth - 1&)
For lCol = 0 To newWidth - 1&
' offset destX used for negative coordinates, X is location in source to start blending at
xLUdbl(lCol) = Int(((lCol + destX) * xRatio) + SrcX) * 4&
Next
' nearest neighbor algorithm
For lRow = newHeight - 1& To 0& Step -1&
'^ current scanline for the scaled image
' offset destY is used for negative coordinates
srcPixel = Int((lRow + destY) * yRatio) + scrY ' recalcualted once per scanline
' current scanline for the scaled image
dstPixel = 0&
For lCol = 0& To newWidth - 1&
' copy into resized array the nearest raw/actual pixel
CopyMemory aNewBits(dstPixel, lRow), aOldBits(Int(xLUdbl(lCol)), srcPixel), 4&
dstPixel = dstPixel + 4&
Next lCol
Next lRow
Else
' BiLinear interoplation, up to 4 source pixels (16 bytes) are blended for each destination pixel (4 bytes)
ReDim xLUd(0 To newWidth - 1&) ' work with doubles, we need the decimal portions
' Cache one scan line of X coords so we don't have to calculate for every pixel
For lCol = 0& To newWidth - 1&
' offset destX used for negative coordinates, X is location in source to start blending at
xLUd(lCol) = (((lCol + destX) * xRatio) + SrcX)
Next
srcWidth = srcWidth - 1& ' subtract now vs subtracting in loop below
For lRow = newHeight - 1& To 0& Step -1&
fY = (lRow + destY) * yRatio + scrY ' get the scaled source row
tgtY = Int(fY) ' get whole number of double
If tgtY = 0& Then ' for top down images, test for last row vs 0
' last row of source image, will use only this row
edgeOffsetY = 0&
fY = 0#
Else
' will use this row & next row for blending
edgeOffsetY = 1&
fY = Abs(1# - (fY - tgtY)) ' for top down images, use fY = fY-tgtY
' ^ Y coordinate fraction; pct of next vertical pixel that is used
End If
For lCol = 0& To newWidth - 1&
R = 0#: G = 0#: B = 0#: A = 0#
tgtX = Int(xLUd(lCol)) ' coordinate rounded down to whole number
If tgtX = srcWidth Then
' at far edge of source image, will use only this pixel for blending
edgeOffsetX = 0&
fX = 0#
Else
' will use this pixel and next pixel for blending
edgeOffsetX = 1&
fX = xLUd(lCol) - tgtX
' ^ X coordinate fraction, pct of next horizontal pixel that is used
End If
For iY = 0& To edgeOffsetY
scalerY = Abs(iY - fY) ' percentage of current row's pixel to blend
If Not scalerY = 1# Then ' else result will be zero
For iX = 0& To edgeOffsetX
scalerX = Abs(fX - iX) ' percentage of current column's pixel to blend
If Not scalerX = 1# Then ' else result will be zero
scalerX = (1# - scalerX) * (1# - scalerY) ' combine percentages
' Build the blended RGB values, for top down images Add iY vs subtracting
srcPixel = (tgtX + iX) * 4&
B = B + aOldBits(srcPixel, tgtY - iY) * scalerX
G = G + aOldBits(srcPixel + 1&, tgtY - iY) * scalerX
R = R + aOldBits(srcPixel + 2&, tgtY - iY) * scalerX
A = A + aOldBits(srcPixel + 3&, tgtY - iY) * scalerX
End If
Next
End If
Next
iX = lCol * 4&
' update destination with adjusted pixel
aNewBits(iX, lRow) = Int(B)
aNewBits(iX + 1&, lRow) = Int(G)
aNewBits(iX + 2&, lRow) = Int(R)
aNewBits(iX + 3&, lRow) = Int(A)
Next
Next
End If
CopyMemory ByVal VarPtrArray(aOldBits), 0&, 4&
CopyMemory ByVal VarPtrArray(aNewBits), 0&, 4&
' the passed destWidth,destHeight params are used when rendering; we are just sizing now
destWidth = newWidth ' the parameter is ByRef, update it now
destHeight = newHeight ' the parameter is ByRef, update it now
Erase rMirror()
If Not LightAdjustment = 0! Then
Call LightenDarken(Nothing, LightAdjustment, rSizedBytes())
LightAdjustment = 0! ' reset, taken care of now
End If
pvResize = True
eh:
If Err Then
Err.Clear ' troubleshooting only, should be removed before compiling to final app
Stop
Resume
End If
End Function
Private Function Win9xBlend(ByVal destinationDC As Long, aResizedBytes() As Byte, _
ByVal SrcX As Long, ByVal SrcY As Long, _
ByVal destX As Long, ByVal destY As Long, _
ByVal destWidth As Long, ByVal destHeight As Long, _
ByVal GlobalAlpha As Long, tHost As c32bppDIB, _
ByVal grayScale As eGrayScaleFormulas, _
ByVal lightAdj As Single) As Boolean
' Function manually blends an alpha bitmap to a target DC
' Never called when GDI+ is available unless user forced isGDIplusEnabled=False.
' Used when AlphaBlend is not available or when AlphaBlend is available but cannot
' perform the graphic manipulation required
' Parameters identify the destination more than anything else. The source was already pre-processed if needed
' destinationDC :: DC to blend to
' aResizedBytes() :: array of bytes sized to target destination blend area.
' if array is null, then the destination size is same size as our DIB's image
' srcX,Y :: the position on source to begin blending
' destX,Y :: the position on destination where blending starts
' destWidth,Height :: the amount of columns/rows to blend
' globalAlpha :: the AlphaBlend global alpha value: between 0 and 255
' tHost :: blending will occur DIB to DIB vs DIB to DC
' grayScale :: if simultaneously grayscaling then the grayscale formula
' ligthAdj :: light adjustment value adds/subtracts -100 to 100 percent intensity per pixel
' Special note. Having problems rendering 32bpp DIBs to WinME; artifacts are being rendered
' from the alpha channel. Therefore, to completely eliminate this problem (hopefully), the
' destination array will be 24bpp vs 32bpp which will then be updated and rendered onto the
' destination DC. 32bpp would be easier, but oh well.
Dim srcBytes() As Byte, srcSA As SafeArray
Dim dstBytes() As Byte, dstSA As SafeArray
Dim srcCol As Long, srcRow As Long
Dim srcAlpha As Long, dstAlpha As Long
Dim Y As Long, X As Long
Dim sX As Long, sY As Long
Dim dX As Long, dY As Long
Dim dDC As Long, tDC As Long, hOldBmp As Long, hDib As Long
Dim Rg As Single, Gg As Single, Bg As Single
Dim gScaleByte As Long
Dim BMPI As BITMAPINFO
' The following is just a wee bit confusing.
' Our source can be 2 different objects:
' 1) Our host DIB
' 2) The passed aResizedBytes() array if pre-processing was required
' Likewise, the destination can be 2 different objects
' 1) A passed DC handle (DIB to 24bpp bitmap - 32bpp to 24bpp)
' 2) Another DIB class if tHost is passed (32bpp to 32bpp)
' So to use a common base for all possibilities, we use SafeArrays
If iparseIsArrayEmpty(VarPtrArray(aResizedBytes)) = 0& Then
If lightAdj = 0! Then
srcSA.pvData = m_Pointer
' need to tweak for negative offsets
If destX < 0& Then
SrcX = SrcX - destX ' less area that needs to be rendered
destWidth = destWidth + destX ' adjust amount of destination we copy
destX = 0& ' set destination offset to zero
End If
If destY < 0& Then
SrcY = SrcY - destY ' less area that needs to be rendered
destHeight = destHeight + destY ' adjust amount of destination we copy
destY = 0& ' set destination offset to zero
End If
SrcY = m_Height - SrcY ' set DIB offset for 1st row to be blended
Else
' if light adjustments, preprocess bytes
LightenDarken Me, lightAdj, aResizedBytes()
srcSA.pvData = VarPtr(aResizedBytes(0, 0))
SrcX = 0&: SrcY = destHeight
End If
Else ' source is the resized array
srcSA.pvData = VarPtr(aResizedBytes(0, 0))
If destX < 0& Then destX = 0& ' when negative target coords are used, we set to
If destY < 0& Then destY = 0& ' zero to match the resized array (zero-based)
SrcX = 0&: SrcY = destHeight
End If
If Not tHost Is Nothing Then
' need to ensure we won't be copying memory to unallocated memory
If destWidth > tHost.Width Then destWidth = tHost.Width
If destHeight > tHost.Height Then destHeight = tHost.Height
End If
If destWidth < 1& Or destHeight < 1& Then Exit Function ' nothing to Blt, passed bad params
If tHost Is Nothing Then
' we need the contents of the target DC, describe its bitmap
With BMPI.bmiHeader
.biSize = 40
.biHeight = destHeight
.biWidth = destWidth
.biPlanes = 1
.biBitCount = 24 ' see Special note above
End With
dDC = GetDC(0&)
tDC = CreateCompatibleDC(dDC)
If Not tDC = 0& Then
hDib = CreateDIBSection(dDC, BMPI, 0&, dstSA.pvData, 0&, 0&)
End If
ReleaseDC 0&, dDC
If tDC = 0& Or hDib = 0& Then Exit Function
hOldBmp = SelectObject(tDC, hDib)
BitBlt tDC, 0&, 0&, destWidth, destHeight, destinationDC, destX, destY, vbSrcCopy
SelectObject tDC, hOldBmp
DeleteDC tDC
With dstSA
.cbElements = 1
.cDims = 2
.rgSABound(0).cElements = destHeight
.rgSABound(1).cElements = iparseByteAlignOnWord(24, destWidth)
End With
Else
' DIB class to DIB class blending
With dstSA
.cbElements = 1
.cDims = 2
.pvData = tHost.BitsPointer
.rgSABound(0).cElements = tHost.Height
.rgSABound(0).lLbound = -(tHost.Height - destY - destHeight)
.rgSABound(1).cElements = tHost.scanWidth
.rgSABound(1).lLbound = -destX * 4
End With
End If
CopyMemory ByVal VarPtrArray(dstBytes), VarPtr(dstSA), 4&
With srcSA ' overlay onto our DIB
.cbElements = 1
.cDims = 2
If .pvData = m_Pointer Then ' using DIB as source
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width * 4&
Else ' using resized array as source
.rgSABound(0).cElements = UBound(aResizedBytes, 2) + 1
.rgSABound(1).cElements = UBound(aResizedBytes, 1) + 1
End If
End With
CopyMemory ByVal VarPtrArray(srcBytes), VarPtr(srcSA), 4&
On Error Resume Next ' expected errors? using a corrupted pre-multiplied image possibly, but will just draw wrong
' this loop is broken into several different loops to enhance speed when less options are used
' 1. separate loop when rendering DIB to DC or DIB to DIB
' 2. separate loop when using global alpha of 255 or using less than 255
' 3. separate loop when grayscaling and not grayscaling
SrcX = SrcX * 4& ' first pixel to be procesed
For srcRow = 0& To destHeight - 1&
' offset our DIB row as we go
SrcY = SrcY - 1 ' current source row being processed
sX = SrcX ' 1st column of source row
dY = destHeight - srcRow - 1 ' next row for destination image
dX = 0& ' 1st column of destination row
If tHost Is Nothing Then ' DIB to DC rendering (4 pixel source to 3 pixel target)
If grayScale = gsclNone Then
If GlobalAlpha = &HFF& Then
' with full opaqueness, use separate loop, less calculations
For srcCol = 0& To destWidth - 1&
srcAlpha = srcBytes(sX + 3&, SrcY) ' get its alpha value
If (srcAlpha = &HFF&) Then
' copy pixel to destination, adjusting for destination row/column as needed
CopyMemory dstBytes(dX, dY), srcBytes(sX, SrcY), 3&
ElseIf Not srcAlpha = 0& Then
'-- Blend
dstAlpha = &HFF& - srcAlpha ' calculate dest alpha value
dstBytes(dX, dY) = (dstAlpha * dstBytes(dX, dY)) &HFF + srcBytes(sX, SrcY)
dstBytes(dX + 1&, dY) = (dstAlpha * dstBytes(dX + 1&, dY)) &HFF + srcBytes(sX + 1&, SrcY)
dstBytes(dX + 2&, dY) = (dstAlpha * dstBytes(dX + 2&, dY)) &HFF + srcBytes(sX + 2&, SrcY)
End If
dX = dX + 3&
sX = sX + 4&
Next
Else
' global alpha and per-pixel blending
For srcCol = 0& To destWidth - 1&
srcAlpha = srcBytes(sX + 3&, SrcY) ' get its alpha value
If Not srcAlpha = 0& Then
' following formula is for already pre-multiplied bytes
dstAlpha = &HFF& - ((srcAlpha * GlobalAlpha) &HFF&)
dstBytes(dX, dY) = (dstAlpha * (dstBytes(dX, dY)) + (srcBytes(sX, SrcY) * GlobalAlpha)) &HFF
dstBytes(dX + 1&, dY) = (dstAlpha * (dstBytes(dX + 1&, dY)) + (srcBytes(sX + 1&, SrcY) * GlobalAlpha)) &HFF
dstBytes(dX + 2&, dY) = (dstAlpha * (dstBytes(dX + 2&, dY)) + (srcBytes(sX + 2&, SrcY) * GlobalAlpha)) &HFF
End If
dX = dX + 3&
sX = sX + 4&
Next
End If
Else ' gray scaling
Call iparseGrayScaleRatios(grayScale, Rg, Gg, Bg)
If GlobalAlpha = &HFF& Then
' with full opaqueness, use separate loop, less calculations
For srcCol = 0& To destWidth - 1&
srcAlpha = srcBytes(sX + 3&, SrcY) ' get its alpha value
If (srcAlpha = &HFF&) Then
' copy pixel to destination, adjusting for destination row/column as needed
dstBytes(dX, dY) = (srcBytes(sX, SrcY) * Bg) + (srcBytes(sX + 1&, SrcY) * Gg) + (srcBytes(sX + 2&, SrcY) * Rg)
dstBytes(dX + 1&, dY) = dstBytes(dX, dY)
dstBytes(dX + 2&, dY) = dstBytes(dX, dY)
ElseIf Not srcAlpha = 0& Then
'-- Blend
dstAlpha = &HFF& - srcAlpha ' calculate dest alpha value
' calculate green,red channel grayscale value
gScaleByte = ((srcBytes(sX, SrcY) * Bg) + (srcBytes(sX + 1&, SrcY) * Gg) + (srcBytes(sX + 2&, SrcY) * Rg)) And &HFF
' blend grayscale to target
dstBytes(dX + 1&, dY) = (dstAlpha * dstBytes(dX + 1&, dY)) &HFF + gScaleByte
dstBytes(dX + 2&, dY) = (dstAlpha * dstBytes(dX + 2&, dY)) &HFF + gScaleByte
dstBytes(dX, dY) = (dstAlpha * dstBytes(dX, dY)) &HFF + gScaleByte
End If
dX = dX + 3&
sX = sX + 4&
Next
Else
' global alpha and per-pixel blending
For srcCol = 0& To destWidth - 1&
srcAlpha = srcBytes(sX + 3&, SrcY) ' get its alpha value
If Not srcAlpha = 0& Then
' following formula is for already pre-multiplied bytes
dstAlpha = &HFF& - ((srcAlpha * GlobalAlpha) &HFF&)
' calculate green,red channel grayscale value
gScaleByte = (((srcBytes(sX, SrcY) * Bg) + (srcBytes(sX + 1&, SrcY) * Gg) + (srcBytes(sX + 2&, SrcY) * Rg)) And &HFF) * GlobalAlpha
' calculate green,red channels
dstBytes(dX, dY) = (dstAlpha * (dstBytes(dX, dY)) + gScaleByte) &HFF
dstBytes(dX + 1&, dY) = (dstAlpha * (dstBytes(dX + 1&, dY)) + gScaleByte) &HFF
dstBytes(dX + 2&, dY) = (dstAlpha * (dstBytes(dX + 2&, dY)) + gScaleByte) &HFF
End If
dX = dX + 3&
sX = sX + 4&
Next
End If
End If
Else ' DIB class to DIB class rendering (4 pixel source to 4 pixel target)
If grayScale = gsclNone Then
If GlobalAlpha = &HFF& Then
' with full opaqueness, use separate loop, less calculations
For srcCol = 0& To destWidth - 1&
srcAlpha = srcBytes(sX + 3&, SrcY) ' get its alpha value
If (srcAlpha = &HFF&) Then
' copy pixel to destination, adjusting for destination row/column as needed
CopyMemory dstBytes(dX, dY), srcBytes(sX, SrcY), 4&
ElseIf Not srcAlpha = 0& Then
'-- Blend
dstAlpha = &HFF& - srcAlpha ' calculate dest alpha value
dstBytes(dX, dY) = (dstAlpha * dstBytes(dX, dY)) &HFF + srcBytes(sX, SrcY)
dstBytes(dX + 1&, dY) = (dstAlpha * dstBytes(dX + 1&, dY)) &HFF + srcBytes(sX + 1&, SrcY)
dstBytes(dX + 2&, dY) = (dstAlpha * dstBytes(dX + 2&, dY)) &HFF + srcBytes(sX + 2&, SrcY)
dstBytes(dX + 3&, dY) = (dstAlpha * dstBytes(dX + 3&, dY)) &HFF + srcBytes(sX + 3&, SrcY)
End If
dX = dX + 4&
sX = sX + 4&
Next
Else
' global alpha and per-pixel blending
For srcCol = 0& To destWidth - 1&
srcAlpha = srcBytes(sX + 3&, SrcY) ' get its alpha value
If Not srcAlpha = 0& Then
' following formula is for already pre-multiplied bytes
dstAlpha = &HFF& - ((srcAlpha * GlobalAlpha) &HFF&)
dstBytes(dX, dY) = (dstAlpha * (dstBytes(dX, dY)) + (srcBytes(sX, SrcY) * GlobalAlpha)) &HFF
dstBytes(dX + 1&, dY) = (dstAlpha * (dstBytes(dX + 1&, dY)) + (srcBytes(sX + 1&, SrcY) * GlobalAlpha)) &HFF
dstBytes(dX + 2&, dY) = (dstAlpha * (dstBytes(dX + 2&, dY)) + (srcBytes(sX + 2&, SrcY) * GlobalAlpha)) &HFF
dstBytes(dX + 3&, dY) = (dstAlpha * (dstBytes(dX + 3&, dY)) + (srcBytes(sX + 3, SrcY) * GlobalAlpha)) &HFF
End If
dX = dX + 4&
sX = sX + 4&
Next
End If
Else
Call iparseGrayScaleRatios(grayScale, Rg, Gg, Bg)
If GlobalAlpha = &HFF& Then
' with full opaqueness, use separate loop, less calculations
For srcCol = 0& To destWidth - 1&
srcAlpha = srcBytes(sX + 3&, SrcY) ' get its alpha value
If (srcAlpha = &HFF&) Then
' copy pixel to destination, adjusting for destination row/column as needed
dstBytes(dX, dY) = ((srcBytes(sX, SrcY) * Bg) + (srcBytes(sX + 1&, SrcY) * Gg) + (srcBytes(sX + 2&, SrcY) * Rg))
dstBytes(dX + 1&, dY) = dstBytes(dX, dY)
dstBytes(dX + 2&, dY) = dstBytes(dX, dY)
dstBytes(dX + 3&, dY) = &HFF
ElseIf Not srcAlpha = 0& Then
'-- Blend
dstAlpha = &HFF& - srcAlpha ' calculate dest alpha value
gScaleByte = ((srcBytes(sX, SrcY) * Bg) + (srcBytes(sX + 1&, SrcY) * Gg) + (srcBytes(sX + 2&, SrcY) * Rg) And &HFF)
dstBytes(dX, dY) = (dstAlpha * dstBytes(dX, dY)) &HFF + gScaleByte
dstBytes(dX + 1&, dY) = (dstAlpha * dstBytes(dX + 1&, dY)) &HFF + gScaleByte
dstBytes(dX + 2&, dY) = (dstAlpha * dstBytes(dX + 2&, dY)) &HFF + gScaleByte
dstBytes(dX + 3&, dY) = (dstAlpha * dstBytes(dX + 3&, dY)) &HFF + (srcBytes(sX + 3, SrcY))
End If
dX = dX + 4&
sX = sX + 4&
Next
Else
' global alpha and per-pixel blending
For srcCol = 0& To destWidth - 1&
srcAlpha = srcBytes(sX + 3&, SrcY) ' get its alpha value
If Not srcAlpha = 0& Then
' following formula is for already pre-multiplied bytes
dstAlpha = &HFF& - ((srcAlpha * GlobalAlpha) &HFF&)
gScaleByte = (((srcBytes(sX, SrcY) * Bg) + (srcBytes(sX + 1&, SrcY) * Gg) + (srcBytes(sX + 2&, SrcY) * Rg)) And &HFF) * GlobalAlpha
dstBytes(dX, dY) = (dstAlpha * (dstBytes(dX, dY)) + gScaleByte) &HFF
dstBytes(dX + 1&, dY) = (dstAlpha * (dstBytes(dX + 1&, dY)) + gScaleByte) &HFF
dstBytes(dX + 2&, dY) = (dstAlpha * (dstBytes(dX + 2&, dY)) + gScaleByte) &HFF
dstBytes(dX + 3&, dY) = (dstAlpha * (dstBytes(dX + 3&, dY)) + (srcBytes(sX + 3, SrcY) * GlobalAlpha)) &HFF
End If
dX = dX + 4&
sX = sX + 4&
Next
End If
End If
End If
Next
' remove overlay
CopyMemory ByVal VarPtrArray(srcBytes), 0&, 4&
Erase aResizedBytes()
If Err Then Err.Clear
' transfer results
If tHost Is Nothing Then
SetDIBitsToDevice destinationDC, destX, destY, destWidth, destHeight, 0&, 0&, 0&, destHeight, dstBytes(0, 0), BMPI, 0&
End If
CopyMemory ByVal VarPtrArray(dstBytes), 0&, 4&
If Not hDib = 0& Then DeleteObject hDib
Win9xBlend = True
End Function
Private Function MirrorDIB(ByRef SrcX As Long, ByRef SrcY As Long, _
ByVal srcWidth As Long, ByVal srcHeight As Long, _
ByRef newWidth As Long, ByRef newHeight As Long, _
ByRef mirrorBytes() As Byte, Optional ByRef tHost As c32bppDIB, _
Optional ByRef LightAdjustment As Single = 0!) As Boolean
' through trial and error, the rule, for mirroring images, appears to be valid for
' Windows drawing routines are: Flip first, then stretch and/or rotate, then clip as needed
' For manual rendering, this has the potential of really complex offsets whether or not
' the pixels are read left to right, right to left, top to bottom or vice versa. Not
' to mention rotation and/or scaling and offsets whether or not image is to be clipped
' because it is being rendered at negative X,Y coordinates or the image is clipped
' because its scaled size is too big for the destination bitmap area. So, we will
' not precalculate all the possible combinations of offsets in the manual rendering
' routines, rather we will flip first, then allow rendering routines to process as normal.
' srcX,Y :: position in source image where mirroring begins
' srcWidth,Height :: amount of source image that will be mirrored
' newWidth,Height :: size of destination mirrored image
' mirrorBytes() :: byte array to hold mirrored image
' tHost :: called by CopyImageTo & Resize when mirroring
' is image being mirrored?
If newWidth > 0& And newHeight > 0& Then Exit Function
Dim tSA As SafeArray, srcBytes() As Byte
Dim dSA As SafeArray, dstBytes() As Byte
Dim X As Long, Y As Long, yOffset As Long, xOffset As Long
With tSA ' overlay array on our source DIB
.cbElements = 1
.cDims = 2
.pvData = m_Pointer
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width * 4&
End With
With dSA ' overlay array on our destination object
.cbElements = 1
.cDims = 2
If tHost Is Nothing Then ' destination is mirrorBytes
ReDim mirrorBytes(0& To srcWidth * 4& - 1&, 0& To srcHeight - 1&)
.pvData = VarPtr(mirrorBytes(0&, 0&))
Else ' destination is passed DIB class
.pvData = tHost.BitsPointer ' called by CopyImageTo & Resize routines
End If
.rgSABound(0).cElements = srcHeight
.rgSABound(1).cElements = srcWidth * 4&
End With
CopyMemory ByVal VarPtrArray(srcBytes), VarPtr(tSA), 4&
CopyMemory ByVal VarPtrArray(dstBytes), VarPtr(dSA), 4&
If newHeight < 0& Then
If newWidth > 0& Then ' flipping vertically only, faster/easier
xOffset = srcWidth * 4& ' number of bytes to flip at once
Y = SrcY ' when flipping, our Y is adjusted from the bottom
X = SrcX * 4& ' starting X position in source
For yOffset = srcHeight - 1& To 0& Step -1&
CopyMemory dstBytes(0&, yOffset), srcBytes(X, Y), xOffset
Y = Y + 1& ' move source Y to next row
Next
Else ' flipping both vertically/horizontally
Y = SrcY ' when flipping vertically, adjust from the bottom
For yOffset = srcHeight - 1& To 0& Step -1&
X = (m_Width - SrcX) * 4& - 4& ' X adjusted from right when flipping
For xOffset = 0 To srcWidth * 4 - 4& Step 4&
CopyMemory dstBytes(xOffset, yOffset), srcBytes(X, Y), 4&
X = X - 4& ' move source X to next pixel
Next
Y = Y + 1& ' move source Y to next row
Next
End If
Else ' flipping horizontally only, same comments as above
Y = m_Height - SrcY - 1& ' not fipping vertically, so read from bottom up
For yOffset = srcHeight - 1& To 0& Step -1&
X = (m_Width - SrcX) * 4& - 4&
For xOffset = 0 To srcWidth * 4 - 4& Step 4&
CopyMemory dstBytes(xOffset, yOffset), srcBytes(X, Y), 4&
X = X - 4&
Next
Y = Y - 1&
Next
End If
CopyMemory ByVal VarPtrArray(srcBytes), 0&, 4&
CopyMemory ByVal VarPtrArray(dstBytes), 0&, 4&
' any rendering routines will now use the mirrored byte array
' so we ensure the bounds parameters match the mirrored array bounds
SrcX = 0&
SrcY = 0&
newWidth = Abs(newWidth)
newHeight = Abs(newHeight)
' if light adjustments, preprocess bytes
If Not LightAdjustment = 0! Then
Call LightenDarken(Nothing, LightAdjustment, mirrorBytes())
LightAdjustment = 0! ' reset, taken care of now
End If
MirrorDIB = True
End Function
Private Sub LightenDarken(cImage As c32bppDIB, ByVal Lightness As Single, rtnArray() As Byte)
' called by Render, Win9xRender, MirrorDB, & spt_pvResize drawing routines as needed
' Routine will lighten or darken non-transparent pixels and pass results in rtnArray
' Parameters:
' cImage :: if Nothing, then rtnArray has source bytes
' Lightness :: values between -100 and 100 percent. -100 will produce blackness & 100 will produce whiteness
' rtnArray :: the array that will hold the modified bytes
' Note: when rtnArray is also the source array, it must contain pre-multiplied bytes
' and be a 2-dimensional, zero-bound arrray
' Checks on the array dimensions and bounds are not made here. They are guaranteed by calling routines
If Not cImage Is Nothing Then
' ensure an image exists if passing a dib class
If cImage.Handle = 0 Then Exit Sub
End If
Dim tSA As SafeArray, srcBytes() As Byte
Dim dSA As SafeArray, dstBytes() As Byte
Dim X As Long, Y As Long, B As Long
Dim tVal As Long, alphaAdj As Long
Dim srcAlpha As Byte
With tSA ' overlay array on our source
.cbElements = 1
.cDims = 2
If cImage Is Nothing Then ' source is the return array
.pvData = VarPtr(rtnArray(0, 0))
.rgSABound(0).cElements = UBound(rtnArray, 2) + 1
.rgSABound(1).cElements = UBound(rtnArray, 1) + 1
Else ' source is a dib class
.pvData = cImage.BitsPointer
.rgSABound(0).cElements = cImage.Height
.rgSABound(1).cElements = cImage.Width * 4&
End If
End With
CopyMemory ByVal VarPtrArray(srcBytes), VarPtr(tSA), 4&
If cImage Is Nothing Then
dSA = tSA ' source & destination are same
Else
With dSA ' overlay array on rtnArray
ReDim rtnArray(0 To cImage.Width * 4 - 1, 0 To cImage.Height - 1)
.cbElements = 1
.cDims = 2
.pvData = VarPtr(rtnArray(0, 0))
.rgSABound(0).cElements = cImage.Height
.rgSABound(1).cElements = cImage.Width * 4&
End With
End If
CopyMemory ByVal VarPtrArray(dstBytes), VarPtr(dSA), 4&
Lightness = 255! * (Lightness / 100!) ' calculate pct of 255 that ligthness equates to
' when pre-multiplied bytes are in effect, we can't just add Lightness because
' the alpha value restricts what percent of the source rgb is actually used in relation to alpha.
' So we must modify lightness in relation to the alpha byte too.
' Separate loops used to prevent having to compare if the adjusted pixel is > 255 and also < 0
For Y = 0 To UBound(srcBytes, 2) ' loop thru the rows
' make lighter
If Lightness > 0! Then
For X = 0& To UBound(srcBytes, 1) Step 4&
srcAlpha = srcBytes(X + 3&, Y)
If Not srcAlpha = 0 Then
' calculate lightness in relation to alpha
alphaAdj = (srcAlpha * Lightness) 255
For B = X To X + 2&
tVal = srcBytes(B, Y) + alphaAdj
If tVal > srcAlpha Then
dstBytes(B, Y) = srcAlpha
Else
dstBytes(B, Y) = (tVal And &HFF)
End If
Next
dstBytes(B, Y) = srcAlpha ' ensure alpha is copied too
End If
Next
Else
' make darker
For X = 0& To UBound(srcBytes, 1) Step 4&
srcAlpha = srcBytes(X + 3&, Y)
If Not srcAlpha = 0 Then
' calculate lightness in relation to alpha
alphaAdj = (srcAlpha * Lightness) 255
For B = X To X + 2&
tVal = srcBytes(B, Y) + alphaAdj
If tVal < 0& Then
dstBytes(B, Y) = 0
Else
dstBytes(B, Y) = (tVal And &HFF)
End If
Next
dstBytes(B, Y) = srcAlpha ' ensure alpha is copied too
End If
Next
End If
Next
' remove overlays
CopyMemory ByVal VarPtrArray(srcBytes), 0&, 4&
CopyMemory ByVal VarPtrArray(dstBytes), 0&, 4&
End Sub
Private Sub Class_Initialize()
' Determine operating system for compatibility of 32bpp images
' http://vbnet.mvps.org/code/helpers/iswinversion.htm
' http://msdn2.microsoft.com/en-gb/library/ms724834.aspx
Dim osType As OSVERSIONINFOEX
Const VER_PLATFORM_WIN32_WINDOWS As Long = 1
' Retrieve version data for OS.
osType.dwOSVersionInfoSize = Len(osType)
If GetVersionEx(osType) = 0 Then
' The OSVERSIONINFOEX structure is only supported
' in NT4/SP6+ and NT5.x, so we're likely running
' on an earlier version of Windows. Revert structure
' size to OSVERSIONINFO and try again.
osType.dwOSVersionInfoSize = Len(osType) - 8
Call GetVersionEx(osType)
End If
' How the m_osCAP variable works and is used througout this class
' Value contains 1, then AlphaBlend enabled & used when needed. Not enabled on Win9x unless overridden via isAlphaBlendFriendly
' Value contains 2, then GDI+ enabled & used when needed (set in isGDIplusEnabled)
' Value contains 4, then zLib enabled & can be used to create/read PNGs (set in isZlibEnabled). Any O/S :: no longer used; tested as needed
' Value contains 8, then Win98+ or Win2K+: AlphaBlend capable system else it isn't
' Value contains 16, then a Win98 or WinME system
' Value contains 32, then NT4 w/less than SP6 or Win95. Otherwise system is GDI+ capable else it isn't
' Note: when m_osCap contains 17, then AlphaBlend has been overridden by user
If osType.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
If osType.dwMinorVersion = 0 Then ' Win95; can't use AlphaBlend nor GDI+
m_osCAP = 32
Else ' flag as Alphablend disabled, but capable & is Win98/ME
m_osCAP = 8 Or 16
End If
Else
If osType.dwMajorVersion > 4 Then ' if Win2K or better
m_osCAP = 1 Or 8 ' flag as AlphaBlend enabled (Win2K or better) and capable
Else ' WinNT4. If SP6 or better than GDI+ capable else not. Regardless, not AlphaBlend capable
If osType.wServicePackMajor < 6 Then m_osCAP = 32
End If
End If
Me.isGDIplusEnabled = True ' attempt to start GDI+, test system capability
If Me.isGDIplusEnabled Then Me.HighQualityInterpolation = True
End Sub
Private Sub Class_Terminate()
DestroyDIB ' simply clean up
End Sub
Public Function CreateDropShadow(Optional ByVal blurDepth As Long = 4, _
Optional ByVal Color As Long = 12632256) As c32bppDIB
' Purpose: This routine creates a separate DIB class to hold a shadow.
' The shadow is always created based of the current image contained in this class.
' Should you later modify the image, you should recreate the shadow.
' And always draw your shadow first, using same basic rendering methods you would
' use for the main image, offsetting the shadow's X,Y coordinates as needed.
' Tip: Adjust shadow's X,Y coordinates equal to the blur depth of the shadow for
' the average use. However, the shadow's X,Y coords can be adjusted as desired.
' See RenderDropShadow_JIT also. That function renders a shadow directly without
' creating a separate DIB class, but has very basic rendering options.
' this routine is basically a faster (quite faster) version of vbAccelerator's shadow class
' http://www.vbaccelerator.com/home/VB/Code/vbMedia/Image_Processing/Drop_Shadows/article.asp
' The speed efficiency is obtained by caching the total alpha values per column that
' will be used for blurring. If 10 columns are used to blur, we cache 10 alpha sums.
' Then when the next source column is queried to be added to the blur calcs, we simply
' subtract the oldest column sum from the grand total, calculate the new column sum,
' cache it, add that sum to the grand total and move on. This approach reduces
' (blurDepth*blurDepth-blurDepth) calculations per pixel. Using, say, a 10 pixel blur
' depth, the savings are immense: a 69x100 image; my version: 38 ms, vbAccelerator: 232 ms
If m_Handle = 0 Then Exit Function
Dim X As Long, Y As Long
Dim vTally() As Long
Dim tAlpha As Long, tColumn As Long, tAvg As Long
Dim dBytes() As Byte, tSA As SafeArray
Dim t2xBlur As Long
Dim R As Long, G As Long, B As Long
Dim srcBytes() As Byte, sSA As SafeArray
Dim shadowDIB As c32bppDIB
Dim initY As Long, initYstop As Long, initYstart As Long
Dim initX As Long, initXstop As Long
If blurDepth < 0 Then
blurDepth = 0
ElseIf blurDepth > 10 Then
blurDepth = 10
End If
t2xBlur = blurDepth * 2
Set shadowDIB = New c32bppDIB
shadowDIB.gdiToken = m_GDItoken
shadowDIB.InitializeDIB m_Width + t2xBlur, m_Height + t2xBlur
With tSA ' overlay array on our destination object
.cbElements = 1
.cDims = 2
.pvData = shadowDIB.BitsPointer
.rgSABound(0).cElements = m_Height + t2xBlur
.rgSABound(1).cElements = (m_Width + t2xBlur) * 4&
End With
CopyMemory ByVal VarPtrArray(dBytes), VarPtr(tSA), 4&
With sSA ' overlay array on our destination object
.cbElements = 1
.cDims = 2
.pvData = m_Pointer ' called by CopyImageTo & Resize routines
.rgSABound(0).cElements = m_Height
.rgSABound(1).cElements = m_Width * 4&
End With
CopyMemory ByVal VarPtrArray(srcBytes), VarPtr(sSA), 4&
R = Color And &HFF
G = (Color &H100&) And &HFF
B = (Color &H10000) And &HFF
tAvg = (t2xBlur + 1) * (t2xBlur + 1) ' how many pixels are being blurred
ReDim vTally(0 To t2xBlur) ' number of blur columns per pixel
For Y = 0 To m_Height + t2xBlur - 1 ' loop thru shadow dib
FillMemory vTally(0), (t2xBlur + 1) * 4, 0 ' reset column totals
If Y < t2xBlur Then ' y does not exist in source
initYstart = 0 ' use 1st row
Else
initYstart = Y - t2xBlur ' start n blur rows above y
End If
' how may source rows can we use for blurring?
If Y < m_Height Then initYstop = Y Else initYstop = m_Height - 1
tAlpha = 0 ' reset alpha sum
tColumn = 0 ' reset column counter
' the first n columns will all be zero
' only the far right blur column has values; tally them
For initY = initYstart To initYstop
tAlpha = tAlpha + srcBytes(3, initY)
Next
' assign the right column value
vTally(t2xBlur) = tAlpha
For X = 3 To (m_Width - 2) * 4 - 1 Step 4
' loop thru each source pixel's alpha
' set shadow alpha using blur average
dBytes(X, Y) = tAlpha tAvg
' and set shadow color
Select Case dBytes(X, Y)
Case 255
dBytes(X - 1, Y) = R
dBytes(X - 2, Y) = G
dBytes(X - 3, Y) = B
Case 0
Case Else
dBytes(X - 1, Y) = R * dBytes(X, Y) 255
dBytes(X - 2, Y) = G * dBytes(X, Y) 255
dBytes(X - 3, Y) = B * dBytes(X, Y) 255
End Select
' remove the furthest left column's alpha sum
tAlpha = tAlpha - vTally(tColumn)
' count the next column of alphas
vTally(tColumn) = 0&
For initY = initYstart To initYstop
vTally(tColumn) = vTally(tColumn) + srcBytes(X + 4, initY)
Next
' add the new column's sum to the overall sum
tAlpha = tAlpha + vTally(tColumn)
' set the next column to be recalculated
tColumn = (tColumn + 1) Mod (t2xBlur + 1)
Next
' now to finish blurring from right edge of source
For X = X To (m_Width + t2xBlur - 1) * 4 - 1 Step 4
dBytes(X, Y) = tAlpha tAvg
Select Case dBytes(X, Y)
Case 255
dBytes(X - 1, Y) = R
dBytes(X - 2, Y) = G
dBytes(X - 3, Y) = B
Case 0
Case Else
dBytes(X - 1, Y) = R * dBytes(X, Y) 255
dBytes(X - 2, Y) = G * dBytes(X, Y) 255
dBytes(X - 3, Y) = B * dBytes(X, Y) 255
End Select
' remove this column's alpha sum
tAlpha = tAlpha - vTally(tColumn)
' set next column to be removed
tColumn = (tColumn + 1) Mod (t2xBlur + 1)
Next
Next
CopyMemory ByVal VarPtrArray(srcBytes), 0&, 4&
CopyMemory ByVal VarPtrArray(dBytes), 0&, 4&
shadowDIB.Alpha = True
shadowDIB.ImageType = imgBmpPARGB
shadowDIB.gdiToken = m_GDItoken
Set CreateDropShadow = shadowDIB
End Function
Public Function RenderDropShadow_JIT(ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, _
Optional ByVal blurDepth As Long = 4, _
Optional ByVal Color As Long = 12632256, _
Optional ByVal Opacity As Long = 50) As Boolean
' Purpose: A simple version of the CreateShadow routine.
' Useful should the rendered image not be rotated, mirrored, or stretched and you
' simply want to draw a shadow on demand.
' FYI: JIT is an acronym meaning Just In Time
Dim dibShadow As c32bppDIB
Set dibShadow = CreateDropShadow(blurDepth, Color)
If Not dibShadow Is Nothing Then
RenderDropShadow_JIT = dibShadow.Render(hDC, X, Y, , , , , , , Opacity)
End If
End Function
Public Property Let gdiToken(Token As Long)
' Everytime a GDI+ API function is called, the class calls GDI+ apis to
' create a GDI+ token first then destroys the token after the function is called.
' This occurs quite often. However, you can create your own token by calling
' GdiplusStartup and then passing the token to each class for the class to use.
' You would call GdiplusShutdown during your main form's Terminate event to
' release the Token.
' When Token is zero, the classes will revert to creating a token on demand.
' When the Token is not zero, any other DIB class created by this class will
' pass the token. The only routine that creates a new instance is the
' CreateDropShadow method. However, CopyImageTo, Resize and others may create
' a temporary DIB class and will also pass the token to that class as needed
m_GDItoken = Token
End Property
Public Property Get gdiToken() As Long
' returns the GDI+ token if one was created
gdiToken = m_GDItoken
End Property
Public Function GetDroppedFileNames(OLEDragDrop_DataObject As DataObject) As Boolean
' This function is only included to make things a little easier for those that want
' to fully support unicode filenames whereas VB only provides ANSI filenames.
' It is designed to be called from your OLEDragDrop event, passing that event's Data
' parameter's object like so:
' If cImage.GetDroppedFileNames(Data) = True Then
' [add code here]. The Data object will contain unicode filenames as necessary
' Else
' [add code here]. No file names were dropped, something else was
' End If
' The function will return True if any files were dropped and the passed data
' object will contain valid unicode filenames as necessary.
' Caution: Editing this routine after it has been called may crash the IDE
' I believe I have fixed that issue but am not 100% positive
' See posting by John Kleinen for more information regarding this method of calling GetData
' http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=49268&lngWId=1
If OLEDragDrop_DataObject Is Nothing Then Exit Function
If OLEDragDrop_DataObject.GetFormat(vbCFFiles) = False Then Exit Function
Dim fmtEtc As FORMATETC, pMedium As STGMEDIUM
Dim dFiles As DROPFILES
Dim Vars(0 To 1) As Variant, pVars(0 To 1) As Long, pVartypes(0 To 1) As Integer
Dim varRtn As Variant
Dim iFiles As Long, iCount As Long, hDrop As Long
Dim lLen As Long, sFiles() As String
Dim IID_IDataObject As Long ' IDataObject Interface ID
Const IDataObjVTable_GetData As Long = 12 ' 4th vtable entry
Const CC_STDCALL As Long = 4&
Const TYMED_HGLOBAL = 1
Const DVASPECT_CONTENT = 1
With fmtEtc
.cfFormat = vbCFFiles ' same as CF_DROP
.lIndex = -1 ' want all data
.TYMED = TYMED_HGLOBAL ' want global ptr to files
.dwAspect = DVASPECT_CONTENT ' no rendering
End With
' The IDataObject pointer is 16 bytes after VBs DataObject
CopyMemory IID_IDataObject, ByVal ObjPtr(OLEDragDrop_DataObject) + 16, 4&
' Here we are going to do something very new to me and kinda cool
' Since we know the objPtr of the IDataObject interface, we therefore know
' the beginning of the interface's VTable
' So, if we know the VTable address and we know which function index we want
' to call, we can call it directly using the following OLE API. Otherwise we
' would need to use a TLB to define the IDataObject interface since VB doesn't
' 't expose it. This has some really neat implications if you think about it.
' The IDataObject function we want is GetData which is the 4th function in
' the VTable... http://msdn2.microsoft.com/en-us/library/ms688421.aspx
pVartypes(0) = vbLong: Vars(0) = VarPtr(fmtEtc): pVars(0) = VarPtr(Vars(0))
pVartypes(1) = vbLong: Vars(1) = VarPtr(pMedium): pVars(1) = VarPtr(Vars(1))
' The variants are required by the OLE API: http://msdn2.microsoft.com/en-us/library/ms221473.aspx
If DispCallFunc(IID_IDataObject, IDataObjVTable_GetData, CC_STDCALL, _
vbLong, 2, pVartypes(0), pVars(0), varRtn) = 0 Then
If pMedium.Data = 0 Then
Exit Function ' nothing to do
Else
' we have a pointer to the files, kinda sorta
CopyMemory hDrop, ByVal pMedium.Data, 4&
If Not hDrop = 0 Then
' the hDrop is a pointer to a DROPFILES structure
' copy the 20-byte structure for our use
CopyMemory dFiles, ByVal hDrop, 20&
End If
End If
If dFiles.fWide = 0 Then ' ansi
GlobalFree pMedium.Data
Else
' use the pFiles member to track offsets for file names
dFiles.pFiles = dFiles.pFiles + hDrop
ReDim sFiles(1 To OLEDragDrop_DataObject.Files.Count)
For iCount = 1 To UBound(sFiles)
' get the length of the current file & multiply by 2 because it is unicode
' lstrLenW is supported in Win9x
lLen = lstrlenW(ByVal dFiles.pFiles) * 2
sFiles(iCount) = String$(lLen 2, 0) ' build a buffer to hold the file name
CopyMemory ByVal StrPtr(sFiles(iCount)), ByVal dFiles.pFiles, lLen ' populate the buffer
' move the pointer to location for next file, adding 2 because of a double null separator/delimiter btwn file names
dFiles.pFiles = dFiles.pFiles + lLen + 2
Next
GlobalFree pMedium.Data
OLEDragDrop_DataObject.Files.Clear
For iCount = 1 To iCount - 1
OLEDragDrop_DataObject.Files.Add sFiles(iCount), iCount
Next
End If
GetDroppedFileNames = True
End If
End Function
Public Function GetPastedFileNames(ListOfFiles() As String) As Long
' Another support function for unicode filenames. The filenames returned by
' VB's Clipboard object only contains ANSI.
' This function will return the number of file names in the clipboard, if any.
' The returned string array will contain the unicode/ansi filenames as needed.
' If the function returns zero, then the string array is not valid
Dim hDrop As Long
Dim sFile As String
Dim lLen As Long
Dim iCount As Long
Dim dFiles As DROPFILES
' Get handle to CF_HDROP if any:
If OpenClipboard(0&) = 0 Then Exit Function
hDrop = GetClipboardData(vbCFFiles)
If Not hDrop = 0 Then ' then copied/cut files exist in memory
iCount = DragQueryFile(hDrop, -1&, vbNullString, 0)
' the hDrop is a pointer to a DROPFILES structure
' copy the 20-byte structure for our use
CopyMemory dFiles, ByVal hDrop, 20&
' use the pFiles member to track offsets for file names
dFiles.pFiles = dFiles.pFiles + hDrop
ReDim ListOfFiles(1 To iCount)
For iCount = 1 To iCount
If dFiles.fWide = 0 Then ' ANSI text, use API to get file name
lLen = DragQueryFile(hDrop, iCount - 1, vbNullString, 0&) ' query length
ListOfFiles(iCount) = String$(lLen, 0) ' set up buffer
DragQueryFile hDrop, iCount - 1, ListOfFiles(iCount), lLen + 1 ' populate buffer
Else
' get the length of the current file & multiply by 2 because it is unicode
' lstrLenW is supported in Win9x
lLen = lstrlenW(ByVal dFiles.pFiles) * 2
sFile = String$(lLen 2, 0) ' build a buffer to hold the file name
CopyMemory ByVal StrPtr(sFile), ByVal dFiles.pFiles, lLen ' populate the buffer
' move the pointer to location for next file, adding 2 because of a double null separator/delimiter btwn file names
dFiles.pFiles = dFiles.pFiles + lLen + 2
' add our file name to the list.
ListOfFiles(iCount) = sFile ' this may contain unicode characters if your system supports it
End If
Next
GetPastedFileNames = iCount - 1
End If
CloseClipboard
End Function