24-bit Picture class w/ resize, crop, transregion and exposed bits Part 2
Author: neophile
Version Compatibility: Visual Basic 6
PROPERTIES: Picture [StdPicture] Returns/sets the object's picture Width [Long] Returns the image's width Height [Long] Returns the image's height Bits [Byte()] Returns/sets the image's DIB bits Pixel(X, Y) [Long] Returns/sets color value of image's pixel METHODS: Resize(NewWidth, NewHeight) Resizes the image Crop(X, Y, Width, Height) Crops the image, keeping specified area CreateRegion(TransColor) Creates a region minus pixels of particular color ApplyRegion(hWnd) Sets the region to a window ClearRegion(hWnd) Sets a window's region to default (i.e, no region) DeleteRegion Deletes the created regionInternal information:
As you'll see in the code, I've documented pretty much every line ;) The image is stored in the object as a byte array, which makes working with the pixels a whole lot faster. The Pixel() property is simply a more logical mapping of that array, so it should be pretty darned fast as well... alot faster than GetPixel()/SetPixel() or, even worse, Point() and PSet()!
Anyway, have fun with it! And if you find some way to improve performance without sacrificing simplicity of use, please send me the code ;)
UPDATED AUGUST 29, 02
Instructions: Copy the declarations and code below and paste directly into your VB project.
Declarations:
Code:
Public Property Let Picture(vData As Picture)
Dim vBMP As BITMAP ' Basic image info
Dim lBmp As Long ' Copy of image
Dim lDC As Long ' Temporary device context
Dim vBMI As BITMAPBASEINFO ' Basic DIB info
Me.Reset
If Not (vData Is Nothing) Then
Call GetObject(vData.handle, Len(vBMP), vBMP) ' Get bitmap info
If (vBMP.Width > 0) And (vBMP.Height > 0) And (vBMP.BitsPixel >= 24) Then
lBmp = CopyImage(vData.handle, 0, 0, 0, LR_COPYRETURNORG) ' Create temp copy
lDC = CreateCompatibleDC(0) ' Create temp device context
Call SelectObject(lDC, lBmp) ' Select image into temp dc
ReDim mBits((vBMP.Width * 3) + CalcPadding(vBMP.Width) - 1, vBMP.Height - 1)
With vBMI
.Size = Len(vBMI) ' Set up for image
.BitCount = 24
.Width = vBMP.Width
.Height = -vBMP.Height
.Planes = 1
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
End With
Call GetDIBits(lDC, lBmp, 0, vBMP.Height, mBits(0, 0), vBMI, 0) ' Get bits
mWidth = vBMP.Width ' Store width
mHeight = vBMP.Height ' Store height
Call DeleteObject(lBmp) ' Delete temp image
Call DeleteDC(lDC) ' Delete temp dc
End If
End If
End Property
Public Property Get Picture() As Picture
Dim lDC As Long ' Temporary device context
Dim vBMI As BITMAPBASEINFO ' Basic DIB info
Dim lBmp As Long ' Copy of image
Dim vIDispatch As GUID ' IIDispatch GUID
Dim vPic As PicBmpBase ' OLE picture info
If mWidth > 0 Then
lDC = CreateCompatibleDC(0) ' Create temp dc
With vBMI ' Set up for image
.BitCount = 24
.Planes = 1
.Width = mWidth
.Height = -mHeight
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
.Size = Len(vBMI)
End With
lBmp = CreateDIBSection(lDC, vBMI, 0, 0, 0, 0) ' Create a temp blank image
Call SelectObject(lDC, lBmp) ' Select image into temp DC
Call SetDIBitsToDevice(lDC, 0, 0, mWidth, mHeight, 0, 0, 0, mHeight, mBits(0, 0), vBMI, 0) ' Set bits
With vIDispatch ' Setup for IIDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With vPic ' Setup for new picture
.Type = vbPicTypeBitmap
.hBmp = lBmp
.Size = Len(vPic)
End With
Call OleCreatePictureIndirect(vPic, vIDispatch, 1, Picture) ' Convert image to OLE picture
Call DeleteDC(lDC) ' Delete temp dc
End If
End Property
Public Function Resize(ByVal NewWidth As Long, ByVal NewHeight As Long) As Boolean
Dim lDC As Long ' Temporary device context
Dim vBMI As BITMAPBASEINFO ' Basic DIB info
Dim lBmp As Long ' Copy of image
Dim lNewBmp As Long ' Resized copy of image
If mWidth > 0 Then
lDC = CreateCompatibleDC(0) ' Create temp dc
With vBMI ' Setup for image
.BitCount = 24
.Planes = 1
.Width = mWidth
.Height = -mHeight
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
.Size = Len(vBMI)
End With
lBmp = CreateDIBSection(lDC, vBMI, 0, 0, 0, 0) ' Create temp blank image
Call SelectObject(lDC, lBmp) ' Select the image into the dc
Call SetDIBitsToDevice(lDC, 0, 0, mWidth, mHeight, 0, 0, 0, mHeight, mBits(0, 0), vBMI, 0) ' Set bits
' Reset
Erase mBits
mWidth = 0
mHeight = 0
Me.DeleteRegion
lNewBmp = CopyImage(lBmp, 0, NewWidth, NewHeight, LR_COPYRETURNORG) ' Copy resized temp image
Call DeleteObject(lBmp) ' Delete temp image
Call SelectObject(lDC, lNewBmp) ' Select new image into temp dc
ReDim mBits((NewWidth * 3) + CalcPadding(NewWidth) - 1, NewHeight - 1)
With vBMI ' Setup for resized image
.Width = NewWidth
.Height = -NewHeight
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
End With
Call GetDIBits(lDC, lNewBmp, 0, NewHeight, mBits(0, 0), vBMI, 0) ' Get new bits
mWidth = NewWidth ' Store width
mHeight = NewHeight ' Store height
Resize = True ' Return true
Call DeleteObject(lNewBmp) ' Delete new image
Call DeleteDC(lDC) ' Delete temp dc
End If
End Function
Public Function Crop(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long) As Boolean
Dim lDC As Long ' Temporary device context
Dim vBMI As BITMAPBASEINFO ' Basic DIB info
Dim lBmp As Long ' Copy of original image
Dim lNewBmp As Long ' Cropped copy of image
Dim lNewDC As Long ' Cropped image's temporary device context
If mWidth > 0 Then
lDC = CreateCompatibleDC(0) ' Create temp dc
With vBMI ' Setup for image
.BitCount = 24
.Planes = 1
.Width = mWidth
.Height = -mHeight
.SizeImage = UBound(mBits) + 1
.Size = Len(vBMI)
End With
lBmp = CreateDIBSection(lDC, vBMI, 0, 0, 0, 0) ' Create temp blank image
Call SelectObject(lDC, lBmp) ' Select image into temp dc
Call SetDIBitsToDevice(lDC, 0, 0, mWidth, mHeight, 0, 0, 0, mHeight, mBits(0, 0), vBMI, 0) ' Set bits
' Reset
Erase mBits
mWidth = 0
mHeight = 0
Me.DeleteRegion
lNewDC = CreateCompatibleDC(0) ' Create new temp dc
ReDim mBits((Width * 3) + CalcPadding(Width) - 1, Height - 1)
With vBMI ' Setup for cropped image
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
.Width = Width
.Height = -Height
End With
lNewBmp = CreateDIBSection(lDC, vBMI, 0, 0, 0, 0) ' Create new blank image
SelectObject lNewDC, lNewBmp ' Select blank into new dc
Call BitBlt(lNewDC, 0, 0, Width, Height, lDC, X, Y, vbSrcCopy) ' Transfer specified section
DeleteObject lBmp ' Delete copy
DeleteDC lDC ' Delete temp dc
Call GetDIBits(lNewDC, lNewBmp, 0, Height, mBits(0, 0), vBMI, 0) ' Get new bits
mWidth = Width ' Store width
mHeight = Height ' Store height
Crop = True ' Return true
Call DeleteObject(lNewBmp) ' Delete cropped image
Call DeleteDC(lNewDC) ' Delete new dc
End If
End Function
Public Sub FitInto(ByVal Width As Long, ByVal Height As Long, Optional ByVal EnlargeOK As Boolean)
Dim nP As Single
If mWidth > 0 Then
If (Width <> mWidth) Or (Height <> mHeight) Then
nP = mWidth / mHeight
If nP < (Width / Height) Then
Width = Height * nP
Else
Height = Width / nP
End If
If ((Width <= mWidth) And (Height <= mHeight)) Or EnlargeOK Then
Me.Resize Width, Height
End If
End If
End If
End Sub
Public Sub Rotate()
Dim bTmp() As Byte
Dim X As Long
Dim Y As Long
Dim lTmp As Long
If mWidth > 0 Then
ReDim bTmp((mHeight * 3) + CalcPadding(mHeight) - 1, mWidth - 1)
For Y = 0 To mHeight - 1
For X = 0 To mWidth - 1
CopyMemory bTmp(Y * 3, X), mBits(X * 3, mHeight - Y - 1), 3
Next
Next
lTmp = mWidth
mWidth = mHeight
mHeight = lTmp
mBits = bTmp
Erase bTmp
End If
End Sub
Public Sub FlipX()
Dim bBits() As Byte
Dim X As Long
Dim Y As Long
If mWidth > 0 Then
bBits = mBits
For Y = 0 To mHeight - 1
For X = 0 To mWidth - 1
CopyMemory mBits(X * 3, Y), bBits((mWidth - X - 1) * 3, Y), 3
Next
Next
Erase bBits
End If
End Sub
Public Sub FlipY()
Dim bBits() As Byte
Dim Y As Long
If mWidth > 0 Then
bBits = mBits
For Y = 0 To mHeight - 1
CopyMemory mBits(0, Y), bBits(0, mHeight - Y - 1), mWidth * 3
Next
Erase bBits
End If
End Sub
Public Sub Invert(Optional Red As Boolean = True, Optional Green As Boolean = True, Optional Blue As Boolean = True)
Dim X As Long
Dim Y As Long
Dim bRGB() As Byte
If (mWidth > 0) And (Red Or Green Or Blue) Then
For Y = 0 To mHeight - 1
For X = 0 To mWidth - 1
bRGB = PixelB(X, Y)
If Red Then bRGB(2) = 255 - bRGB(2)
If Green Then bRGB(1) = 255 - bRGB(1)
If Blue Then bRGB(0) = 255 - bRGB(0)
PixelB(X, Y) = bRGB
Next
Next
End If
End Sub
Public Property Let Bits(vData() As Byte)
mBits = vData
End Property
Public Property Get Bits() As Byte()
Bits = mBits
End Property
Public Property Get Width() As Long
Width = mWidth
End Property
Public Property Get Height() As Long
Height = mHeight
End Property
Public Property Let Pixel(ByVal X As Long, ByVal Y As Long, ByVal vData As Long)
CopyMemory mBits(X * 3, Y), vData, 3
End Property
Public Property Get Pixel(ByVal X As Long, ByVal Y As Long) As Long
Dim lMem As Long
CopyMemory lMem, mBits(X * 3, Y), 3
Pixel = lMem
End Property
Public Property Let PixelB(ByVal X As Long, ByVal Y As Long, vData() As Byte)
CopyMemory mBits(X * 3, Y), vData(0), 3
End Property
Public Property Get PixelB(ByVal X As Long, ByVal Y As Long) As Byte()
Dim bMem(0 To 2) As Byte
CopyMemory bMem(0), mBits(X * 3, Y), 3
PixelB = bMem
End Property
Public Sub CreateRegion(ByVal TransColor As ColorConstants)
Dim lX As Long ' X iteration
Dim lY As Long ' Y iteration
Dim lXa As Long ' XOR region start
Dim lXb As Long ' XOR region end
Dim lXor As Long ' XOR region
' Reset region
Me.DeleteRegion
If mWidth > 0 Then
mRgn = CreateRectRgn(0, 0, mWidth, mHeight) ' Create bounding rect region
For lY = 0 To mHeight - 1
lXa = -1
For lX = 0 To mWidth - 1
If Me.Pixel(lX, lY) = TransColor Then ' Check for pixel transparency
If lXa = -1 Then lXa = lX ' Set start if needed
lXb = lX + 1 ' Set/reset end
If lX = (mWidth - 1) Then ' Check for last horizontal pixel
lXor = CreateRectRgn(lXa, lY, lXb, lY + 1) ' Create XOR region (point or line)
Call CombineRgn(mRgn, lXor, mRgn, RGN_XOR) ' XOR from rect region
Call DeleteObject(lXor) ' Delete XOR region
End If
Else ' Pixel not transparent
If lXa > -1 Then ' Check for transparent pixels found
lXor = CreateRectRgn(lXa, lY, lXb, lY + 1) ' Create XOR region (point or line)
Call CombineRgn(mRgn, lXor, mRgn, RGN_XOR) ' XOR from rect region
Call DeleteObject(lXor) ' Delete XOR region
End If
lXa = -1 ' Reset start for following pixels in scanline
End If
Next
Next
End If
End Sub
Public Sub CreateBlank(ByVal Width As Long, ByVal Height As Long, Optional ByVal Fill)
Dim X As Long
Dim Y As Long
Dim lFill As Long
Dim bFill() As Byte
If (Width > 0) And (Height > 0) Then
Erase mBits
DeleteRegion
ReDim mBits((Width * 3) + CalcPadding(Width) - 1, Height - 1)
mWidth = Width
mHeight = Height
If Not IsMissing(Fill) Then
If TypeName(Fill) = "Byte()" Then
bFill = Fill
For Y = 0 To Height - 1
For X = 0 To Width - 1
CopyMemory mBits(X * 3, Y), bFill(0), 3
Next
Next
Erase bFill
Else
lFill = Fill
For Y = 0 To Height - 1
For X = 0 To Width - 1
CopyMemory mBits(X * 3, Y), lFill, 3
Next
Next
End If
End If
End If
End Sub
Public Function HasRegion() As Boolean
HasRegion = (mRgn <> 0)
End Function
Public Sub ApplyRegion(ByVal hWnd As Long)
Dim lData As Long ' Size of region data
Dim bData() As Byte ' Region data buffer
Dim lRgn As Long ' Temporary region copy
If mRgn <> 0 Then ' Check for region
lData = GetRegionData(mRgn, 0, ByVal 0&) ' Get data size
ReDim bData(lData - 1) As Byte ' Allocate region buffer
Call GetRegionData(mRgn, lData, bData(0)) ' Get region data
lRgn = ExtCreateRegion(ByVal 0&, lData, bData(0)) ' Create temp copy
Erase bData ' Empty region buffer
Call SetWindowRgn(hWnd, lRgn, True) ' Set window's region
Call DeleteObject(lRgn) ' Delete temp region
End If
End Sub
Public Sub ClearRegion(ByVal hWnd As Long)
Call SetWindowRgn(hWnd, 0, True) ' Clear window's region
End Sub
Public Sub DeleteRegion()
If mRgn <> 0 Then ' Check for region
Call DeleteObject(mRgn) ' Delete region
mRgn = 0 ' Clear pointer
End If
End Sub
Public Function ComparePicture(Picture) As Boolean
Dim oPic As cPicture24
Dim bBits() As Byte
Dim sBits1 As String
Dim sBits2 As String
Select Case TypeName(Picture)
Case "StdPicture", "IPictureDsp", "Picture"
Set oPic = New cPicture24
oPic.Picture = Picture
Case "cPicture24"
Set oPic = Picture
End Select
If Not (oPic Is Nothing) Then
If (oPic.Width = mWidth) And (oPic.Height = mHeight) Then
sBits1 = Space((UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1))
CopyMemory ByVal sBits1, mBits(0, 0), Len(sBits1)
bBits = oPic.Bits
Set oPic = Nothing
sBits2 = Space((UBound(bBits, 1) + 1) * (UBound(bBits, 2) + 1))
CopyMemory ByVal sBits2, bBits(0, 0), Len(sBits2)
Erase bBits
ComparePicture = (sBits1 = sBits2)
sBits1 = Empty
sBits2 = Empty
Else
Set oPic = Nothing
End If
End If
End Function
Public Property Get Padding() As Integer
Padding = CalcPadding(mWidth)
End Property
Public Sub Reset()
Erase mBits
mWidth = 0
mHeight = 0
Me.DeleteRegion
End Sub
Private Function CalcPadding(ByVal Width As Long) As Integer
CalcPadding = ((((Width * 3) + 3) \ 4) * 4) - (Width * 3)
End Function
Private Sub Class_Terminate()
Erase mBits ' Empty buffer
DeleteRegion ' Delete region, if any
End Sub
Dim vBMP As BITMAP ' Basic image info
Dim lBmp As Long ' Copy of image
Dim lDC As Long ' Temporary device context
Dim vBMI As BITMAPBASEINFO ' Basic DIB info
Me.Reset
If Not (vData Is Nothing) Then
Call GetObject(vData.handle, Len(vBMP), vBMP) ' Get bitmap info
If (vBMP.Width > 0) And (vBMP.Height > 0) And (vBMP.BitsPixel >= 24) Then
lBmp = CopyImage(vData.handle, 0, 0, 0, LR_COPYRETURNORG) ' Create temp copy
lDC = CreateCompatibleDC(0) ' Create temp device context
Call SelectObject(lDC, lBmp) ' Select image into temp dc
ReDim mBits((vBMP.Width * 3) + CalcPadding(vBMP.Width) - 1, vBMP.Height - 1)
With vBMI
.Size = Len(vBMI) ' Set up for image
.BitCount = 24
.Width = vBMP.Width
.Height = -vBMP.Height
.Planes = 1
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
End With
Call GetDIBits(lDC, lBmp, 0, vBMP.Height, mBits(0, 0), vBMI, 0) ' Get bits
mWidth = vBMP.Width ' Store width
mHeight = vBMP.Height ' Store height
Call DeleteObject(lBmp) ' Delete temp image
Call DeleteDC(lDC) ' Delete temp dc
End If
End If
End Property
Public Property Get Picture() As Picture
Dim lDC As Long ' Temporary device context
Dim vBMI As BITMAPBASEINFO ' Basic DIB info
Dim lBmp As Long ' Copy of image
Dim vIDispatch As GUID ' IIDispatch GUID
Dim vPic As PicBmpBase ' OLE picture info
If mWidth > 0 Then
lDC = CreateCompatibleDC(0) ' Create temp dc
With vBMI ' Set up for image
.BitCount = 24
.Planes = 1
.Width = mWidth
.Height = -mHeight
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
.Size = Len(vBMI)
End With
lBmp = CreateDIBSection(lDC, vBMI, 0, 0, 0, 0) ' Create a temp blank image
Call SelectObject(lDC, lBmp) ' Select image into temp DC
Call SetDIBitsToDevice(lDC, 0, 0, mWidth, mHeight, 0, 0, 0, mHeight, mBits(0, 0), vBMI, 0) ' Set bits
With vIDispatch ' Setup for IIDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With vPic ' Setup for new picture
.Type = vbPicTypeBitmap
.hBmp = lBmp
.Size = Len(vPic)
End With
Call OleCreatePictureIndirect(vPic, vIDispatch, 1, Picture) ' Convert image to OLE picture
Call DeleteDC(lDC) ' Delete temp dc
End If
End Property
Public Function Resize(ByVal NewWidth As Long, ByVal NewHeight As Long) As Boolean
Dim lDC As Long ' Temporary device context
Dim vBMI As BITMAPBASEINFO ' Basic DIB info
Dim lBmp As Long ' Copy of image
Dim lNewBmp As Long ' Resized copy of image
If mWidth > 0 Then
lDC = CreateCompatibleDC(0) ' Create temp dc
With vBMI ' Setup for image
.BitCount = 24
.Planes = 1
.Width = mWidth
.Height = -mHeight
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
.Size = Len(vBMI)
End With
lBmp = CreateDIBSection(lDC, vBMI, 0, 0, 0, 0) ' Create temp blank image
Call SelectObject(lDC, lBmp) ' Select the image into the dc
Call SetDIBitsToDevice(lDC, 0, 0, mWidth, mHeight, 0, 0, 0, mHeight, mBits(0, 0), vBMI, 0) ' Set bits
' Reset
Erase mBits
mWidth = 0
mHeight = 0
Me.DeleteRegion
lNewBmp = CopyImage(lBmp, 0, NewWidth, NewHeight, LR_COPYRETURNORG) ' Copy resized temp image
Call DeleteObject(lBmp) ' Delete temp image
Call SelectObject(lDC, lNewBmp) ' Select new image into temp dc
ReDim mBits((NewWidth * 3) + CalcPadding(NewWidth) - 1, NewHeight - 1)
With vBMI ' Setup for resized image
.Width = NewWidth
.Height = -NewHeight
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
End With
Call GetDIBits(lDC, lNewBmp, 0, NewHeight, mBits(0, 0), vBMI, 0) ' Get new bits
mWidth = NewWidth ' Store width
mHeight = NewHeight ' Store height
Resize = True ' Return true
Call DeleteObject(lNewBmp) ' Delete new image
Call DeleteDC(lDC) ' Delete temp dc
End If
End Function
Public Function Crop(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long) As Boolean
Dim lDC As Long ' Temporary device context
Dim vBMI As BITMAPBASEINFO ' Basic DIB info
Dim lBmp As Long ' Copy of original image
Dim lNewBmp As Long ' Cropped copy of image
Dim lNewDC As Long ' Cropped image's temporary device context
If mWidth > 0 Then
lDC = CreateCompatibleDC(0) ' Create temp dc
With vBMI ' Setup for image
.BitCount = 24
.Planes = 1
.Width = mWidth
.Height = -mHeight
.SizeImage = UBound(mBits) + 1
.Size = Len(vBMI)
End With
lBmp = CreateDIBSection(lDC, vBMI, 0, 0, 0, 0) ' Create temp blank image
Call SelectObject(lDC, lBmp) ' Select image into temp dc
Call SetDIBitsToDevice(lDC, 0, 0, mWidth, mHeight, 0, 0, 0, mHeight, mBits(0, 0), vBMI, 0) ' Set bits
' Reset
Erase mBits
mWidth = 0
mHeight = 0
Me.DeleteRegion
lNewDC = CreateCompatibleDC(0) ' Create new temp dc
ReDim mBits((Width * 3) + CalcPadding(Width) - 1, Height - 1)
With vBMI ' Setup for cropped image
.SizeImage = (UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1)
.Width = Width
.Height = -Height
End With
lNewBmp = CreateDIBSection(lDC, vBMI, 0, 0, 0, 0) ' Create new blank image
SelectObject lNewDC, lNewBmp ' Select blank into new dc
Call BitBlt(lNewDC, 0, 0, Width, Height, lDC, X, Y, vbSrcCopy) ' Transfer specified section
DeleteObject lBmp ' Delete copy
DeleteDC lDC ' Delete temp dc
Call GetDIBits(lNewDC, lNewBmp, 0, Height, mBits(0, 0), vBMI, 0) ' Get new bits
mWidth = Width ' Store width
mHeight = Height ' Store height
Crop = True ' Return true
Call DeleteObject(lNewBmp) ' Delete cropped image
Call DeleteDC(lNewDC) ' Delete new dc
End If
End Function
Public Sub FitInto(ByVal Width As Long, ByVal Height As Long, Optional ByVal EnlargeOK As Boolean)
Dim nP As Single
If mWidth > 0 Then
If (Width <> mWidth) Or (Height <> mHeight) Then
nP = mWidth / mHeight
If nP < (Width / Height) Then
Width = Height * nP
Else
Height = Width / nP
End If
If ((Width <= mWidth) And (Height <= mHeight)) Or EnlargeOK Then
Me.Resize Width, Height
End If
End If
End If
End Sub
Public Sub Rotate()
Dim bTmp() As Byte
Dim X As Long
Dim Y As Long
Dim lTmp As Long
If mWidth > 0 Then
ReDim bTmp((mHeight * 3) + CalcPadding(mHeight) - 1, mWidth - 1)
For Y = 0 To mHeight - 1
For X = 0 To mWidth - 1
CopyMemory bTmp(Y * 3, X), mBits(X * 3, mHeight - Y - 1), 3
Next
Next
lTmp = mWidth
mWidth = mHeight
mHeight = lTmp
mBits = bTmp
Erase bTmp
End If
End Sub
Public Sub FlipX()
Dim bBits() As Byte
Dim X As Long
Dim Y As Long
If mWidth > 0 Then
bBits = mBits
For Y = 0 To mHeight - 1
For X = 0 To mWidth - 1
CopyMemory mBits(X * 3, Y), bBits((mWidth - X - 1) * 3, Y), 3
Next
Next
Erase bBits
End If
End Sub
Public Sub FlipY()
Dim bBits() As Byte
Dim Y As Long
If mWidth > 0 Then
bBits = mBits
For Y = 0 To mHeight - 1
CopyMemory mBits(0, Y), bBits(0, mHeight - Y - 1), mWidth * 3
Next
Erase bBits
End If
End Sub
Public Sub Invert(Optional Red As Boolean = True, Optional Green As Boolean = True, Optional Blue As Boolean = True)
Dim X As Long
Dim Y As Long
Dim bRGB() As Byte
If (mWidth > 0) And (Red Or Green Or Blue) Then
For Y = 0 To mHeight - 1
For X = 0 To mWidth - 1
bRGB = PixelB(X, Y)
If Red Then bRGB(2) = 255 - bRGB(2)
If Green Then bRGB(1) = 255 - bRGB(1)
If Blue Then bRGB(0) = 255 - bRGB(0)
PixelB(X, Y) = bRGB
Next
Next
End If
End Sub
Public Property Let Bits(vData() As Byte)
mBits = vData
End Property
Public Property Get Bits() As Byte()
Bits = mBits
End Property
Public Property Get Width() As Long
Width = mWidth
End Property
Public Property Get Height() As Long
Height = mHeight
End Property
Public Property Let Pixel(ByVal X As Long, ByVal Y As Long, ByVal vData As Long)
CopyMemory mBits(X * 3, Y), vData, 3
End Property
Public Property Get Pixel(ByVal X As Long, ByVal Y As Long) As Long
Dim lMem As Long
CopyMemory lMem, mBits(X * 3, Y), 3
Pixel = lMem
End Property
Public Property Let PixelB(ByVal X As Long, ByVal Y As Long, vData() As Byte)
CopyMemory mBits(X * 3, Y), vData(0), 3
End Property
Public Property Get PixelB(ByVal X As Long, ByVal Y As Long) As Byte()
Dim bMem(0 To 2) As Byte
CopyMemory bMem(0), mBits(X * 3, Y), 3
PixelB = bMem
End Property
Public Sub CreateRegion(ByVal TransColor As ColorConstants)
Dim lX As Long ' X iteration
Dim lY As Long ' Y iteration
Dim lXa As Long ' XOR region start
Dim lXb As Long ' XOR region end
Dim lXor As Long ' XOR region
' Reset region
Me.DeleteRegion
If mWidth > 0 Then
mRgn = CreateRectRgn(0, 0, mWidth, mHeight) ' Create bounding rect region
For lY = 0 To mHeight - 1
lXa = -1
For lX = 0 To mWidth - 1
If Me.Pixel(lX, lY) = TransColor Then ' Check for pixel transparency
If lXa = -1 Then lXa = lX ' Set start if needed
lXb = lX + 1 ' Set/reset end
If lX = (mWidth - 1) Then ' Check for last horizontal pixel
lXor = CreateRectRgn(lXa, lY, lXb, lY + 1) ' Create XOR region (point or line)
Call CombineRgn(mRgn, lXor, mRgn, RGN_XOR) ' XOR from rect region
Call DeleteObject(lXor) ' Delete XOR region
End If
Else ' Pixel not transparent
If lXa > -1 Then ' Check for transparent pixels found
lXor = CreateRectRgn(lXa, lY, lXb, lY + 1) ' Create XOR region (point or line)
Call CombineRgn(mRgn, lXor, mRgn, RGN_XOR) ' XOR from rect region
Call DeleteObject(lXor) ' Delete XOR region
End If
lXa = -1 ' Reset start for following pixels in scanline
End If
Next
Next
End If
End Sub
Public Sub CreateBlank(ByVal Width As Long, ByVal Height As Long, Optional ByVal Fill)
Dim X As Long
Dim Y As Long
Dim lFill As Long
Dim bFill() As Byte
If (Width > 0) And (Height > 0) Then
Erase mBits
DeleteRegion
ReDim mBits((Width * 3) + CalcPadding(Width) - 1, Height - 1)
mWidth = Width
mHeight = Height
If Not IsMissing(Fill) Then
If TypeName(Fill) = "Byte()" Then
bFill = Fill
For Y = 0 To Height - 1
For X = 0 To Width - 1
CopyMemory mBits(X * 3, Y), bFill(0), 3
Next
Next
Erase bFill
Else
lFill = Fill
For Y = 0 To Height - 1
For X = 0 To Width - 1
CopyMemory mBits(X * 3, Y), lFill, 3
Next
Next
End If
End If
End If
End Sub
Public Function HasRegion() As Boolean
HasRegion = (mRgn <> 0)
End Function
Public Sub ApplyRegion(ByVal hWnd As Long)
Dim lData As Long ' Size of region data
Dim bData() As Byte ' Region data buffer
Dim lRgn As Long ' Temporary region copy
If mRgn <> 0 Then ' Check for region
lData = GetRegionData(mRgn, 0, ByVal 0&) ' Get data size
ReDim bData(lData - 1) As Byte ' Allocate region buffer
Call GetRegionData(mRgn, lData, bData(0)) ' Get region data
lRgn = ExtCreateRegion(ByVal 0&, lData, bData(0)) ' Create temp copy
Erase bData ' Empty region buffer
Call SetWindowRgn(hWnd, lRgn, True) ' Set window's region
Call DeleteObject(lRgn) ' Delete temp region
End If
End Sub
Public Sub ClearRegion(ByVal hWnd As Long)
Call SetWindowRgn(hWnd, 0, True) ' Clear window's region
End Sub
Public Sub DeleteRegion()
If mRgn <> 0 Then ' Check for region
Call DeleteObject(mRgn) ' Delete region
mRgn = 0 ' Clear pointer
End If
End Sub
Public Function ComparePicture(Picture) As Boolean
Dim oPic As cPicture24
Dim bBits() As Byte
Dim sBits1 As String
Dim sBits2 As String
Select Case TypeName(Picture)
Case "StdPicture", "IPictureDsp", "Picture"
Set oPic = New cPicture24
oPic.Picture = Picture
Case "cPicture24"
Set oPic = Picture
End Select
If Not (oPic Is Nothing) Then
If (oPic.Width = mWidth) And (oPic.Height = mHeight) Then
sBits1 = Space((UBound(mBits, 1) + 1) * (UBound(mBits, 2) + 1))
CopyMemory ByVal sBits1, mBits(0, 0), Len(sBits1)
bBits = oPic.Bits
Set oPic = Nothing
sBits2 = Space((UBound(bBits, 1) + 1) * (UBound(bBits, 2) + 1))
CopyMemory ByVal sBits2, bBits(0, 0), Len(sBits2)
Erase bBits
ComparePicture = (sBits1 = sBits2)
sBits1 = Empty
sBits2 = Empty
Else
Set oPic = Nothing
End If
End If
End Function
Public Property Get Padding() As Integer
Padding = CalcPadding(mWidth)
End Property
Public Sub Reset()
Erase mBits
mWidth = 0
mHeight = 0
Me.DeleteRegion
End Sub
Private Function CalcPadding(ByVal Width As Long) As Integer
CalcPadding = ((((Width * 3) + 3) \ 4) * 4) - (Width * 3)
End Function
Private Sub Class_Terminate()
Erase mBits ' Empty buffer
DeleteRegion ' Delete region, if any
End Sub