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 region

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' Class Object: cPicture24 ' by neophile, Feb 2002 ' last update, Aug 2002 ' n_e_o_p_h_i_l_e@yahoo.com Option Explicit Private Const LR_COPYRETURNORG = &H4 Private Const RGN_XOR = &H3 Private Type BITMAP Type As Long Width As Long Height As Long WidthBytes As Long Planes As Integer BitsPixel As Integer Bits As Long End Type Private Type BITMAPBASEINFO Size As Long Width As Long Height As Long Planes As Integer BitCount As Integer Compression As Long SizeImage As Long XPelsPerMeter As Long YPelsPerMeter As Long ClrUsed As Long ClrImportant As Long End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Type PicBmpBase Size As Long Type As Long hBmp As Long End Type Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPBASEINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long Private Declare Function GetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPBASEINFO, ByVal wUsage As Long) As Long Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dX As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPBASEINFO, ByVal wUsage As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal imageType As Long, ByVal NewWidth As Long, ByVal NewHeight As Long, ByVal lFlags As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmpBase, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Declare Function GetRegionData Lib "gdi32" (ByVal hRgn As Long, ByVal dwCount As Long, lpRgnData As Any) As Long Private Declare Function ExtCreateRegion Lib "gdi32" (lpXform As Any, ByVal nCount As Long, lpRgnData As Any) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long) Private mBits() As Byte ' DIB bits buffer Private mHeight As Long ' Height Private mWidth As Long ' Width Private mRgn As Long ' Region pointer

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