24-bit Picture class w/ resize, crop, transregion and exposed bits Part 2

Category:
Screen/Graphics
Type:
Classes
Difficulty:
Advanced

Author: neophile

Version Compatibility: Visual Basic 6

More information:
This is something I came up with to help make writing skinnable applications a little bit simpler. I've been playing with this stuff quite a bit lately and I thought this was worth submitting. However, it only supports 24-bit bitmaps. Anyway, here is some documentation:
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 region
Internal 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

 

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