Binaryworld - How to create Region from a Bitmap and perform Hit Testing within a Re ... [ VB -> Windows ]

Hello friends, In this article you will learn two basic concept of Regions.
1. Creating Region from a Bitmap.
2. Hit Testing within a Region.

Creating Region from a Bitmap

In my previous article Working with Region API you learned how to create regions of different shapes. Now in this article we will talk more complex technique to create more complex skinned regions using Bitmap.

You can use a Bitmap to define your region and then you can apply this region to any window (for skin it will be form). To define region from a bitmap you have to define a mask color in a Bitmap. Points with mask color in the loaded bitmap will be ignored when you create a region.

Click here to copy the following block

Option Explicit

Private Const DIB_RGB_COLORS  As Long = 0&
Private Const FLOODFILLSURFACE As Long = 1&
Private Const RGN_DIFF     As Long = 4&
Private Const OBJ_BITMAP    As Long = 7&
Private Const RDH_RECTANGLES  As Long = &H1&
Private Const RGN_HDR_OFFSET  As Long = &H8&

'Enumerate Offsets into Region Header Struct
Private Enum RgnHdr
  dwSize
  iType
  nCount
  nRgnSize
  rcLeft
  rcTop
  rcRight
  rcBottom
End Enum

Private Type BITMAPINFOHEADER
  biSize     As Long
  biWidth     As Long
  biHeight    As Long
  biPlanes    As Integer
  biBitCount   As Integer
  biCompression As Long
  biSizeImage   As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed    As Long
  biClrImportant As Long
End Type

Private Type RGBQUAD
  rgbBlue   As Byte
  rgbGreen  As Byte
  rgbRed   As Byte
  rgbReserved As Byte
End Type

Private Type BITMAPINFOC
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type

Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
End Type

Private Type BITMAP
  bmType     As Long
  bmWidth     As Long
  bmHeight    As Long
  bmWidthBytes  As Long
  bmPlanes    As Integer
  bmBitsPixel   As Integer
  bmBits     As Long
End Type

Private Type ColorRef
  Blue  As Byte
  Green As Byte
  Red   As Byte
End Type

Private Type RECT
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type

Private mRgnData() As Long
Private mlDataSize As Long
Private mlDataPosn As Long

Private Declare Function ExtCreateRegion Lib "gdi32" ( _
    ByRef lpXform As Any, ByVal nCount As Long, _
    ByRef lpRgnData As Any) As Long

Private Declare Function GetDIBits Lib "gdi32" ( _
    ByVal aHDC As Long, ByVal hBitmap As Long, _
    ByVal nStartScan As Long, ByVal nNumScans As Long, _
    lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" ( _
    ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function SetWindowRgn Lib "user32.dll" ( _
    ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function PtInRegion Lib "gdi32.dll" ( _
    ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" ( _
    ByVal hObject As Long) As Long

Private Declare Function CreateEllipticRgnIndirect Lib "gdi32.dll" ( _
    lpRect As RECT) As Long

Private Declare Function InvertRgn Lib "gdi32.dll" ( _
    ByVal hdc As Long, ByVal hRgn As Long) As Long

Private bMoving As Boolean ' flag to indicate drag operation
Private sngXStart As Single ' original mouse X offset
Private sngYStart As Single ' original mouse Y offset
Private WndRect As RECT, RetVal As Long

Dim hRgnSkin As Long, hRgnCloseButton As Long

Private Sub Form_Load()
  hRgnSkin = CreateMaskRgn(Me.Picture.Handle, RGB(255, 0, 128))
  SetWindowRgn hWnd, hRgnSkin, True

  WndRect.left = 118
  WndRect.top = 46
  WndRect.right = 130
  WndRect.bottom = 58

  '//Region to detect click in a little close button
  hRgnCloseButton = CreateEllipticRgnIndirect(WndRect)

  Timer1.Enabled = True
  Timer1.Interval = 500
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  If PtInRegion(hRgnCloseButton, x / 15, y / 15) Then
    End         '//Exit application if clicked on a little close button
  End If

  If Button <> 1 Then Exit Sub  ' only left button
  SetCapture Me.hWnd    ' Get all mouse events
  sngXStart = x      ' save current offset
  sngYStart = y
  bMoving = True      ' start move

  'MsgBox X & " " & Y
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Not bMoving Then Exit Sub
  ' move form so that new mouse position is same as original
  Me.Move Me.left - sngXStart + x, Me.top - sngYStart + y
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Not bMoving Then Exit Sub  ' ignore if not moving
  ReleaseCapture      ' stop the moving operation
  bMoving = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  If bMoving = True Then ReleaseCapture

  DeleteObject hRgnCloseButton
  DeleteObject hRgnSkin
End Sub

Public Function CreateMaskRgn(ByVal hBmp As Long, ByVal lMaskColor As Long) As Long
  'Creates a Region from a bitmap which excludes
  'all pixels that match lMaskColor.

  Dim bInRgn   As Boolean
  Dim lX     As Long
  Dim lY     As Long
  Dim lRet    As Long
  Dim lIdx    As Long
  Dim lWidth   As Long
  Dim lHeight   As Long
  Dim lMaxPxls  As Long
  Dim lStartX   As Long
  Dim lPosY    As Long
  Dim hRgn    As Long
  Dim laPixels() As Long
  Dim sTemp    As String
  Dim bmImage   As BITMAP
  Dim bmiImage  As BITMAPINFO
  Dim hdc As Long

  'We need a DC (Lets grab desktop DC, you can pass form DC too)
  hdc = GetDC(0)

  'Get the size of the bitmap.
  lRet = GetObjectAPI(hBmp, Len(bmImage), bmImage)
  lWidth = bmImage.bmWidth
  lHeight = bmImage.bmHeight

  If (lWidth > 0) And (lHeight > 0) Then
    'Set the buffer sizes for the bitmap bits
    'Width must be DWord aligned (32-bits or 4 bytes)
    lMaxPxls = lWidth * lHeight
    ReDim laPixels(lMaxPxls - 1)

    'Setup the bitmap header for 32-bit data
    With bmiImage.bmiHeader
      .biSize = 40
      .biWidth = lWidth
      .biHeight = lHeight
      .biPlanes = 1
      .biBitCount = 32 'convert to 32-bit bitmap
      .biCompression = 0
      .biClrUsed = 0
      .biClrImportant = 0
      .biSizeImage = lMaxPxls
    End With

    'Get the bitmap bits from the DC.
    lRet = GetDIBits(hdc, hBmp, 0, lHeight, _
        laPixels(0), bmiImage, DIB_RGB_COLORS)

    'Note: the colors actually come in backwards
    'when reading them into an array of longs.
    '(i.e., A=00; B=80; G=C0; R=FF should be &H0080C0FF, but the
    'bytes are in RRGGBBAA order so they come in as &HFFC08000.)
    'Instead of reversing all the bytes in the array,
    '/just reverse the MaskColor and strip the alpha byte.

    sTemp = right("000000" & Hex$(lMaskColor), 6)
    sTemp = Mid$(sTemp, 5, 2) & Mid$(sTemp, 3, 2) & Mid$(sTemp, 1, 2)
    lMaskColor = Val("&H" & sTemp & "&")

    'Clear out existing region
    Call ClearRects

    'Compare the pixels in the bitmap and add all
    'that do not match lMaskColor to the region.
    For lY = 0 To lHeight - 1
      lIdx = lY * lWidth
      lPosY = (lHeight - 1) - lY
      bInRgn = False

      For lX = 0 To lWidth - 1
        'Strip the alpha byte
        If ((laPixels(lIdx) And &HFFFFFF) = lMaskColor) Then
          'Matching color does not get added to the region
          If bInRgn Then
            'Add the current Rect to the Region
            Call AddRect(lStartX, lPosY, lX, lPosY + 1)
            bInRgn = False
          End If
        Else
          'Different color gets added to the region
          If Not bInRgn Then
            'Different color starts here
            lStartX = lX
            bInRgn = True
          End If
        End If
        'Next pixel
        lIdx = lIdx + 1
      Next

      'Add the last Rect, if any, to the Region
      If bInRgn Then
        Call AddRect(lStartX, lPosY, lWidth, lPosY + 1)
      End If
    Next

    'Create the region
    hRgn = CreateRegion()
  End If

  'Clean Up
  Erase laPixels
  CreateMaskRgn = hRgn
  Call ClearRects
End Function

Private Sub ClearRects()
  ReDim mRgnData(RGN_HDR_OFFSET - 1)
  mlDataSize = RGN_HDR_OFFSET - 1
  mlDataPosn = RGN_HDR_OFFSET

  'These properties stay the same
  mRgnData(RgnHdr.dwSize) = 32  'sizeOf(RGNDataHeader)
  mRgnData(RgnHdr.iType) = RDH_RECTANGLES

  'Initialise to null bounds rectangle
  mRgnData(RgnHdr.rcLeft) = &H7FFFFFFF
  mRgnData(RgnHdr.rcTop) = &H7FFFFFFF
  mRgnData(RgnHdr.rcRight) = &H80000000
  mRgnData(RgnHdr.rcBottom) = &H80000000
End Sub

Private Sub AddRect(ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
  'Make more room in the array, if needed
  If mlDataPosn > (mlDataSize - 4) Then
    mlDataSize = mlDataSize + 200
    ReDim Preserve mRgnData(mlDataSize - 1) As Long
  End If

  'Add this rectangle
  mRgnData(mlDataPosn) = lLeft
  mRgnData(mlDataPosn + 1) = lTop
  mRgnData(mlDataPosn + 2) = lRight
  mRgnData(mlDataPosn + 3) = lBottom

  'Update the Region's Bounding rectangle
  If (lLeft < mRgnData(RgnHdr.rcLeft)) Then mRgnData(RgnHdr.rcLeft) = lLeft
  If (lRight > mRgnData(RgnHdr.rcRight)) Then mRgnData(RgnHdr.rcRight) = lRight
  If (lTop < mRgnData(RgnHdr.rcTop)) Then mRgnData(RgnHdr.rcTop) = lTop
  If (lBottom > mRgnData(RgnHdr.rcBottom)) Then mRgnData(RgnHdr.rcBottom) = lBottom

  mlDataPosn = mlDataPosn + 4
End Sub

Private Function CreateRegion() As Long
  'Get out if the region has no RECTS
  If (mlDataSize <= RGN_HDR_OFFSET) Then Exit Function

  'Get rid of excess Data space in the array
  ReDim Preserve mRgnData(mlDataPosn - 1)

  'Fill in header sizes
  mRgnData(RgnHdr.nCount) = Int((mlDataPosn - RGN_HDR_OFFSET) \ 4)
  mRgnData(RgnHdr.nRgnSize) = mRgnData(RgnHdr.nCount) * 16  'sizeOf(RECT)

  'Create the Region
  CreateRegion = ExtCreateRegion(ByVal 0&, mRgnData(RgnHdr.dwSize) _
      + mRgnData(RgnHdr.nRgnSize), mRgnData(0))
End Function

Private Sub l8_Click()
  Shell "explorer http://www.binaryworld.net", vbNormalFocus
End Sub

Private Sub Timer1_Timer()
  InvertRgn hdc, hRgnCloseButton
  Me.Refresh
End Sub