VBA to List of Cells Inside Area of Freeform Shape

P

platypus007

New Member
Joined
Oct 24, 2019
Messages
19
Office Version
  1. 2016
Platform
  1. Windows
Hi I have hard time solving this:

I have one Freeform Shape and I need to create VBA which will enlist all cells inside of this Freeform Shape.

What is the best way to do it?

Thank you very much

Victor
 
Sort by date Sort by votes
Hi,

In case you are still interested, here is some code which should work for identifying the cells that are located beneath the freeform area and those that are outside of it.

Workbook Download


CellsUnderFreeForm0edc5ac0891aea6b.gif




In a Standard Module :
VBA Code: 
Option Explicit

Private Enum RgnHdr
  dwSize
  iType
  nCount
  nRgnSize
  rcLeft
  rcTop
  rcRight
  rcBottom
End Enum

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

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 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
    #If VBA7 Then
        bmBits As LongPtr
    #Else
        bmBits As Long
    #End If
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function ExtCreateRegion Lib "gdi32" (lpXform As Any, ByVal nCount As Long, lpRgnData As Any) As LongPtr
    Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function PtInRegion Lib "gdi32" (ByVal hRgn As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function CreateEllipticRgnIndirect Lib "gdi32" (lpRect As RECT) As LongPtr
    Private Declare PtrSafe Function InvertRgn Lib "gdi32" (ByVal hdc As LongPtr, ByVal hRgn As LongPtr) As Long
    Private Declare PtrSafe Function RectInRegion Lib "gdi32" (ByVal hRgn As LongPtr, lpRect As RECT) As Long
#Else
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function ExtCreateRegion Lib "gdi32" (lpXform As Any, ByVal nCount As Long, 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 PtInRegion Lib "gdi32" (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" (lpRect As RECT) As Long
    Private Declare Function InvertRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
    Private Declare Function RectInRegion Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long
#End If


Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const POINTS_PER_INCH = 72
Private Const DIB_RGB_COLORS  As Long = 0&
Private Const RDH_RECTANGLES  As Long = &H1&
Private Const RGN_HDR_OFFSET  As Long = &H8&

Private Const TARGET_SHEET = "Sheet1"   '<== change sheet as required.
Private Const FREE_FORM = "Freeform 1"  '<== change freeform as required.

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



Public Sub G_O()

    Dim oCellsUnderFreeForm As Range, i As Long
    
    With Sheets(TARGET_SHEET)
        With .Shapes(FREE_FORM)
            Set oCellsUnderFreeForm = Range(.TopLeftCell, .BottomRightCell)
        End With
        Call ClearCells
        For i = 1 To oCellsUnderFreeForm.Cells.Count
            oCellsUnderFreeForm.Cells(i).Value = _
            -CLng(IsRangeBeneathFreeForm(.Shapes(FREE_FORM), oCellsUnderFreeForm.Cells(i)))
            .Cells(i + 1, 1) = oCellsUnderFreeForm.Cells(i).Address(0, 0)
            .Cells(i + 1, 2) = CBool(oCellsUnderFreeForm.Cells(i).Value)
        Next i
    End With

End Sub


Public Sub ClearCells()

    With Sheets(TARGET_SHEET)
        .Cells.ClearContents
        .Range("A1").Value = "CELL"
        .Range("B1").Value = "INSIDE"
    End With
    
End Sub


 
Private Function IsRangeBeneathFreeForm(ByVal FreeForm As Shape, Rng As Range) As Boolean
 
    #If VBA7 Then
        Static hBmp As LongPtr
        Static hRgnSkin As LongPtr
    #Else
        Static hBmp As Long
        Static hRgnSkin As Long
    #End If
 
    Static lFillColor As Long
    Static lOutlineColor As Long
    Static lFillVisible As Long
    Static oBackRange As Range
    Static trect As RECT
    Static Xoffset, Yoffset
 
    On Error GoTo errHandler

    With FreeForm
        Set oBackRange = Range(.TopLeftCell, .BottomRightCell)
    End With

    If Rng.Address = oBackRange.Cells(1).Address Then
        lFillColor = FreeForm.Fill.ForeColor.RGB
        lOutlineColor = FreeForm.Line.ForeColor.RGB
        lFillVisible = FreeForm.Fill.Visible
        FreeForm.Fill.ForeColor.RGB = RGB(0, 0, 0)
        FreeForm.Line.ForeColor.RGB = RGB(0, 0, 0)
        FreeForm.Fill.Visible = msoTrue
        hBmp = HbmpFromObj(FreeForm)
        hRgnSkin = CreateMaskRgn(hBmp, RGB(255, 255, 255))
        Xoffset = PTtoPX(FreeForm.left - Rng.Parent.Range("a1").left, False)
        Yoffset = PTtoPX(FreeForm.top - Rng.Parent.Range("a1").top, True)
    End If

    With trect
        trect = ObjRect(Rng)
        .left = .left - Xoffset
        .top = .top - Yoffset
        .right = .right - Xoffset
        .bottom = .bottom - Yoffset
    End With


    IsRangeBeneathFreeForm = CBool(RectInRegion(hRgnSkin, trect))
    
    If Rng.Address = oBackRange.Cells(oBackRange.Cells.Count).Address Then
errHandler:
        FreeForm.Fill.ForeColor.RGB = lFillColor
        FreeForm.Line.ForeColor.RGB = lOutlineColor
        FreeForm.Fill.Visible = lFillVisible
        lFillColor = 0
        lOutlineColor = 0
        lFillVisible = 0
        DeleteObject hRgnSkin
        DeleteObject hBmp
        Set oBackRange = Nothing
    End If

End Function


#If VBA7 Then
    Private Function CreateMaskRgn(ByVal hBmp As LongPtr, ByVal lMaskColor As Long) As LongPtr
        Dim hdc As LongPtr, hRgn As LongPtr
#Else
    Private Function CreateMaskRgn(ByVal hBmp As Long, ByVal lMaskColor As Long) As Long
        Dim hdc As Long, hRgn As Long
#End If

    'Credit for this routine goes to:  Nayan Patel
    'Adapted and edited from:  https://binaryworld.net/Main/CodeDetail.aspx?CodeId=3756

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

  hdc = GetDC(0)
  lRet = GetObjectAPI(hBmp, LenB(bmImage), bmImage)
  lWidth = bmImage.bmWidth
  lHeight = bmImage.bmHeight

  If (lWidth > 0) And (lHeight > 0) Then
    lMaxPxls = lWidth * lHeight
    ReDim laPixels(lMaxPxls - 1)

    With bmiImage.bmiHeader
      .biSize = 40
      .biWidth = lWidth
      .biHeight = lHeight
      .biPlanes = 1
      .biBitCount = 32
      .biCompression = 0
      .biClrUsed = 0
      .biClrImportant = 0
      .biSizeImage = lMaxPxls
    End With

    lRet = GetDIBits(hdc, hBmp, 0, lHeight, laPixels(0), bmiImage, DIB_RGB_COLORS)

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

    Call ClearRects

    For lY = 0 To lHeight - 1
      lIdx = lY * lWidth
      lPosY = (lHeight - 1) - lY
      bInRgn = False

      For lX = 0 To lWidth - 1
        If ((laPixels(lIdx) And &HFFFFFF) = lMaskColor) Then
          If bInRgn Then
            Call AddRect(lStartX, lPosY, lX, lPosY + 1)
            bInRgn = False
          End If
        Else
          If Not bInRgn Then
            lStartX = lX
            bInRgn = True
          End If
        End If
        lIdx = lIdx + 1
      Next

      If bInRgn Then
        Call AddRect(lStartX, lPosY, lWidth, lPosY + 1)
      End If
    Next

    hRgn = CreateRegion()
  End If

    Erase laPixels
    CreateMaskRgn = hRgn
    ReleaseDC 0, hdc
    Call ClearRects
    
End Function

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

  mRgnData(RgnHdr.dwSize) = 32
  mRgnData(RgnHdr.iType) = RDH_RECTANGLES

  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)
  If mlDataPosn > (mlDataSize - 4) Then
    mlDataSize = mlDataSize + 200
    ReDim Preserve mRgnData(mlDataSize - 1) As Long
  End If

  mRgnData(mlDataPosn) = lLeft
  mRgnData(mlDataPosn + 1) = lTop
  mRgnData(mlDataPosn + 2) = lRight
  mRgnData(mlDataPosn + 3) = lBottom

  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


#If VBA7 Then
    Private Function CreateRegion() As LongPtr
#Else
    Private Function CreateRegion() As Long
#End If

  If (mlDataSize <= RGN_HDR_OFFSET) Then Exit Function

  ReDim Preserve mRgnData(mlDataPosn - 1)

  mRgnData(RgnHdr.nCount) = Int((mlDataPosn - RGN_HDR_OFFSET) \ 4)
  mRgnData(RgnHdr.nRgnSize) = mRgnData(RgnHdr.nCount) * 16

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

#If VBA7 Then
    Private Function HbmpFromObj(ByVal Obj As Object) As LongPtr
        Dim hPtr As LongPtr
#Else
    Private Function HbmpFromObj(ByVal Obj As Object) As Long
        Dim hPtr As Long
#End If

    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2

    On Error GoTo errHandler

    Obj.CopyPicture xlScreen, xlBitmap
    Call OpenClipboard(0)
    hPtr = GetClipboardData(CF_BITMAP)
    
    HbmpFromObj = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    Call EmptyClipboard
    Call CloseClipboard

errHandler:
    
    Call EmptyClipboard
    Call CloseClipboard

End Function


Private Function PTtoPX(Points As Double, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function

Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC

    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function ObjRect(ByVal Obj As Object) As RECT

    Dim oPane  As Pane
    Set oPane = ThisWorkbook.Windows(1).ActivePane

    With Obj
        ObjRect.left = (oPane.PointsToScreenPixelsX(.left + 1) - oPane.PointsToScreenPixelsX(0)) / (oPane.Parent.Zoom / 100)
        ObjRect.top = (oPane.PointsToScreenPixelsY(.top + 1) - oPane.PointsToScreenPixelsY(0)) / (oPane.Parent.Zoom / 100)
        ObjRect.right = (oPane.PointsToScreenPixelsX(.left + .Width + 1) - oPane.PointsToScreenPixelsX(0)) / (oPane.Parent.Zoom / 100)
        ObjRect.bottom = (oPane.PointsToScreenPixelsY(.top + .Height + 1) - oPane.PointsToScreenPixelsY(0)) / (oPane.Parent.Zoom / 100)
    End With

End Function
'
 
Upvote 0

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
You must log in or register to reply here.

Similar threads

J
  • Solved
Copy and Paste
2
Replies
14
Views
812
Anthony47
A
J
  • Solved
Disable shapes when Workbook is protected VBA
2
Replies
12
Views
546
mumps
mumps
L
  • Solved
VBA to resize shape incrementally
Replies
3
Views
262
Lil Stinker
L
B
  • Question
Event code to give message box and change color of auto-shape
Replies
4
Views
299
bh24524
B
M
  • Question
VBA Event help, change shape of color as per option selections
Replies
5
Views
244
Jaafar Tribak
Jaafar Tribak

Forum statistics

Threads
1,216,082
Messages
6,128,709
Members
449,464
Latest member
againofsoul

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top