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
'