VBA to check if circles are inside of freeform area or not

P

platypus007

New Member
Joined
Oct 24, 2019
Messages
19
Office Version
  1. 2016
Platform
  1. Windows
Hi, Im newbie on this site and I need help with this : I have Freeform area and shapes in form of circles named from A to G. Some of this points are inside of Freeform area and some of them no. I need macro which will check each of this points if this point is inside/ outside of freeform area. It will be nice if I will have result in form of table where in Column A are Names of shapes (circles-points) and in column B result state (inside/outside).

IDtXBAc.jpg


Thanks

Viktor
 
Sort by date Sort by votes
UPDATE

The above code works well but fails if the current worksheet zoom is other than 100%... I had completely forgotten about the current zoom and how it would affect the final result.

Anyway below is an update (for future reference) of the API code that takes into account the current worksheet zoom along with few other enhancements.

WORKBOOK EXAMPLE UPDATE

Code: 
Option Explicit

Enum FormatWhat
    SmallShp
    BigShp
    ShpGroup
End Enum

Private Type uPicDesc
    Size As Long
    Type As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
       hPic As Long
       hPal As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        bmBits As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        bmBits As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
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 RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type

Private Type RGB
    R As Long
    G As Long
    B As Long
End Type

Private Type RGBA
   R As Byte
   G As Byte
   B As Byte
   A As Byte
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPictureDisp) As Long
    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 CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 TransparentBlt Lib "msimg32.dll" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hDC As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDC As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    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 Any, ByVal wUsage As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPictureDisp) As Long
    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 CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 TransparentBlt Lib "msimg32.dll" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
    Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hDC As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDC As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) 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 Any, ByVal wUsage As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If



Public Function Get_Shape_Relative_Location(ByVal BigShape As Shape, ByVal SmallShape As Shape) As String

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hDC As LongPtr, hMemDC As LongPtr, hMemBmp As LongPtr
        Dim hBufferDC1 As LongPtr, hBufferDC2 As LongPtr, hBufferDC3 As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hDC As Long, hMemDC As Long, hMemBmp As Long
        Dim hBufferDC1 As Long, hBufferDC2 As Long, hBufferDC3 As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Const DIB_RGB_COLORS = 0&
    Const BI_RGB = 0&
    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    Const SRCCOPY = &HCC0020
    Const CAPTUREBLT = &H40000000
    Const AC_SRC_OVER = &H0
    
    Dim tBF As BLENDFUNCTION, lBF As Long, tBMP As BITMAP, iPic As IPictureDisp
    Dim tBMInfo As BITMAPINFO, tPixels() As RGBQUAD
    Dim iNew_R As Integer, iNew_G As Integer, iNew_B As Integer
    Dim lPixelsCount2 As Long, lPixelsCount1 As Long
    Dim X As Long, Y As Long, dCurrentZoom As Double
    
    
    On Error GoTo errHandler
    
    Application.ScreenUpdating = False
    dCurrentZoom = ActiveWindow.Zoom
    ActiveWindow.Zoom = 100
    
    Call FormatShapes(BigShape, SmallShape, ShpGroup)
    Set iPic = PicFromObject(Selection)
    Selection.Delete
    hDC = GetDC(0)
    Call GetObjectAPI(iPic.handle, LenB(tBMP), tBMP)
    
    hMemDC = CreateCompatibleDC(hDC)
    Call DeleteObject(SelectObject(hMemDC, iPic.handle))
    hBufferDC1 = CreateCompatibleDC(hDC)
    hMemBmp = CreateCompatibleBitmap(hDC, tBMP.bmWidth, tBMP.bmHeight)
    Call DeleteObject(SelectObject(hBufferDC1, hMemBmp))
    
    Call TransparentBlt(hBufferDC1, 0, 0, tBMP.bmWidth, tBMP.bmHeight, hMemDC, 0, 0, tBMP.bmWidth, tBMP.bmHeight, 0)
    Call FormatShapes(BigShape, SmallShape, BigShp)
    Set iPic = PicFromObject(Selection)
    Selection.Delete
    hBufferDC2 = CreateCompatibleDC(hDC)
    Call DeleteObject(SelectObject(hBufferDC2, iPic.handle))
    
    With tBF
        .BlendOp = AC_SRC_OVER
        .BlendFlags = 0
        .SourceConstantAlpha = 100
        .AlphaFormat = 0
    End With
    Call CopyMemory(lBF, tBF, LenB(lBF))
    Call AlphaBlend(hBufferDC2, 0, 0, tBMP.bmWidth, tBMP.bmHeight, hBufferDC1, 0, 0, tBMP.bmWidth, tBMP.bmHeight, lBF)
    
    tBMInfo.bmiHeader.biSize = LenB(tBMInfo.bmiHeader)
    Call GetDIBits(hBufferDC2, iPic.handle, 0, 0, 0, tBMInfo, DIB_RGB_COLORS)
    ReDim tPixels(tBMInfo.bmiHeader.biWidth, tBMInfo.bmiHeader.biHeight)
    tBMInfo.bmiHeader.biCompression = BI_RGB
    Call GetDIBits(hBufferDC2, iPic.handle, 0, tBMInfo.bmiHeader.biHeight, tPixels(1, 1), tBMInfo, DIB_RGB_COLORS)
    iNew_R = CInt((255 - ColorToRGB(0).R) * (100 / 255#) + ColorToRGB(0).R)
    iNew_G = CInt((255 - ColorToRGB(0).G) * (100 / 255#) + ColorToRGB(0).G)
    iNew_B = CInt((255 - ColorToRGB(0).B) * (100 / 255#) + ColorToRGB(0).B)
    For X = 0 To tBMInfo.bmiHeader.biWidth
        For Y = 0 To tBMInfo.bmiHeader.biHeight
            With tPixels(X, Y)
                If .rgbRed = iNew_R And .rgbGreen = iNew_G And .rgbBlue = iNew_B Then
                    lPixelsCount1 = lPixelsCount1 + 1
                End If
            End With
        Next Y
    Next X
    
    If lPixelsCount1 Then
        Call FormatShapes(BigShape, SmallShape, SmallShp)
        Set iPic = PicFromObject(Selection)
        Selection.Delete
        hBufferDC3 = CreateCompatibleDC(hDC)
        
        tBMInfo.bmiHeader.biSize = LenB(tBMInfo.bmiHeader)
        Call GetDIBits(hBufferDC3, iPic.handle, 0, 0, 0, tBMInfo, DIB_RGB_COLORS)
        ReDim tPixels(tBMInfo.bmiHeader.biWidth, tBMInfo.bmiHeader.biHeight)
        tBMInfo.bmiHeader.biCompression = BI_RGB
        Call GetDIBits(hBufferDC3, iPic.handle, 0, tBMInfo.bmiHeader.biHeight, tPixels(1, 1), tBMInfo, DIB_RGB_COLORS)
        For X = 0 To tBMInfo.bmiHeader.biWidth
            For Y = 0 To tBMInfo.bmiHeader.biHeight
            With tPixels(X, Y)
                If .rgbRed = 255 And .rgbGreen = 0 And .rgbBlue = 0 Then
                    lPixelsCount2 = lPixelsCount2 + 1
                End If
            End With
            Next Y
        Next X
        
            If lPixelsCount1 = lPixelsCount2 Then
                Get_Shape_Relative_Location = "Fully Inside"
            Else
                Get_Shape_Relative_Location = "Partly Inside"
            End If
        Else
        Get_Shape_Relative_Location = "Outside"
    End If
    
errHandler:

    ReleaseDC 0, hDC
    DeleteObject hMemDC
    DeleteObject hBufferDC1
    DeleteObject hBufferDC2
    DeleteObject hBufferDC3
    DeleteObject hMemBmp
    
    ActiveWindow.Zoom = dCurrentZoom
    Application.ScreenUpdating = True
    If Err Then MsgBox "Error!" & vbNewLine & Err.Description, vbCritical

End Function


Private Sub FormatShapes(ByVal BigShape As Shape, ByVal SmallShape As Shape, Format_What As FormatWhat)

    Dim oObj As Object, oShp As Shape
    
    On Error GoTo errHandler
    
    If Format_What = ShpGroup Then
    
        Set oObj = BigShape.Parent.Shapes.Range(Array(BigShape.Name, SmallShape.Name))
        Set oObj = oObj.Duplicate
        Set oObj = oObj.Group
        
        For Each oShp In oObj.GroupItems
            If oShp.Name = BigShape.Name Then
                oShp.Line.ForeColor.RGB = RGB(0, 0, 0)
            Else
                oShp.Line.ForeColor.RGB = RGB(255, 255, 255)
            End If
            oShp.Line.Weight = 0.25
            oShp.ThreeD.Visible = msoFalse
            oShp.Shadow.Visible = msoFalse
            oShp.SoftEdge.Type = msoSoftEdgeTypeNone
            oShp.Glow.Radius = 0
            With oShp.Fill
                .Visible = msoTrue
                .ForeColor.RGB = IIf(oShp.Name = BigShape.Name, RGB(0, 0, 0), RGB(255, 255, 255))
                .ForeColor.TintAndShade = 0
                .ForeColor.Brightness = 0
                .Transparency = 0
                .Solid
            End With
            oShp.TextFrame2.TextRange.Characters.Text = ""
        Next oShp
        
    ElseIf Format_What = BigShp Then
    
        Set oObj = BigShape.Duplicate
        With oObj
            .Line.ForeColor.RGB = RGB(0, 0, 0)
            .Line.Weight = 0.25
            .ThreeD.Visible = msoFalse
            .Shadow.Visible = msoFalse
            .SoftEdge.Type = msoSoftEdgeTypeNone
            .Glow.Radius = 0
            With .Fill
                .Visible = msoTrue
                .ForeColor.RGB = RGB(0, 0, 0)
                .ForeColor.TintAndShade = 0
                .ForeColor.Brightness = 0
                .Transparency = 0
                .Solid
            End With
            .TextFrame2.TextRange.Characters.Text = ""
        End With
        
    Else
    
        Set oObj = SmallShape.Duplicate
        With oObj
            .Line.Weight = 0.25
            .Line.ForeColor.RGB = RGB(255, 0, 0)
            .ThreeD.Visible = msoFalse
            .Shadow.Visible = msoFalse
            .SoftEdge.Type = msoSoftEdgeTypeNone
            .Glow.Radius = 0
            With .Fill
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .ForeColor.TintAndShade = 0
                .ForeColor.Brightness = 0
                .Transparency = 0
                .Solid
            End With
            .TextFrame2.TextRange.Characters.Text = ""
        End With
        
    End If
    
    oObj.Select
    With Selection.ShapeRange
        If SmallShape.Left < BigShape.Left Then
            .Flip msoFlipHorizontal
        End If
        If SmallShape.Top < BigShape.Top Then
            .Flip msoFlipVertical
        End If
    End With
    
    Exit Sub
    
errHandler:

    oObj.Delete

End Sub


Private Function PicFromObject(ByVal Obj As Object) As IPictureDisp

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hPtr As LongPtr, hLib As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hPtr As Long, hLib As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Const IMAGE_BITMAP = 0
    Const IMAGE_ICON = 1
    Const PICTYPE_BITMAP = 1
    Const PICTYPE_ICON = 3
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
    Dim iPic As IPictureDisp, lRet As Long, lPictype As Long

    On Error GoTo errHandler

    Obj.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Call OpenClipboard(0)
    hPtr = GetClipboardData(CF_BITMAP)
    hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    
    Call EmptyClipboard
    Call CloseClipboard
    lPictype = PICTYPE_BITMAP

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = lPictype
        .hPic = hPtr
        .hPal = 0
    End With
    
    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
    End If
    Call FreeLibrary(hLib)
    
    If lRet = S_OK Then
        Set PicFromObject = iPic
    End If

errHandler:
    Call FreeLibrary(hLib)
    Call EmptyClipboard
    Call CloseClipboard

End Function


Private Function ColorToRGB(ByVal Col As Long) As RGB
    ColorToRGB.R = &HFF& And Col
    ColorToRGB.G = (&HFF00& And Col) \ 256
    ColorToRGB.B = (&HFF0000 And Col) \ 65536
End Function
 
Last edited:
Upvote 0

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
LAST UPDATE.

Note: Please ignore all the codes I published in my previous posts and use this one only.


WORKBOOK DEMO

New adjustements have been made for more accurate results and faster processing of images (Bitmap flipping is now done in memory DCs).

Should also work regardless of the current worksheet Zoom.


1- New API code in a Standard Module:
Code: 
Option Explicit

Public Enum FormatWhat
    Shapes_Group
    Big_Shape
    Small_Shape
End Enum

Public Type Info
    ShapeName As String
    Location As String
    Pixels As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
       hPic As Long
       hPal As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        bmBits As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        bmBits As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
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 RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type

Private Type RGB
    R As Long
    G As Long
    B As Long
End Type

Private Type RGBA
   R As Byte
   G As Byte
   B As Byte
   A As Byte
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPictureDisp) As Long
    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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 TransparentBlt Lib "msimg32.dll" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    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 Any, ByVal wUsage As Long) As Long
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function StretchBlt Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPictureDisp) As Long
    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 CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 TransparentBlt Lib "msimg32.dll" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
    Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hDC As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDC As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) 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 Any, ByVal wUsage As Long) 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 Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If



Public Function IsShapeInside(ByVal BigShape As Shape, ByVal SmallShape As Shape, Info As Info) As Boolean

    Const DIB_RGB_COLORS = 0&
    Const BI_RGB = 0&
    Const SRCCOPY = &HCC0020

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hdc As LongPtr, hBufferDC1 As LongPtr, hBufferDC2 As LongPtr, hBufferDC3 As LongPtr
        Dim hTempDC1 As LongPtr, hTempDC2 As LongPtr, hTempDC3 As LongPtr, hTempDC4 As LongPtr, hTempBmp As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hdc As Long, hBufferDC1 As Long, hBufferDC2 As Long, hBufferDC3 As Long
        Dim hTempDC1 As Long, hTempDC2 As Long, hTempDC3 As Long, hTempDC4 As Long, hTempBmp As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim tBMP As BITMAP, iPic As IPictureDisp, tBMInfo As BITMAPINFO, tPixels() As RGBQUAD
    Dim iNew_R As Integer, iNew_G As Integer, iNew_B As Integer
    Dim lTotalPixels As Long, lOverlappingPixels As Long
    Dim X As Long, Y As Long, oCurObj As Object


    On Error GoTo errHandler

    Application.ScreenUpdating = False
    hdc = GetDC(0)

    Set oCurObj = DuplicateAndFormatShapes(BigShape, SmallShape, Shapes_Group)
    Set iPic = PicFromObject(oCurObj)
    oCurObj.Delete
    hBufferDC1 = FlipBmpInBufferDc(BigShape, SmallShape, iPic)
    hTempDC1 = MakeBlackTransparent(iPic, hBufferDC1)
        
    Set oCurObj = DuplicateAndFormatShapes(BigShape, SmallShape, Shapes_Group)
    Set iPic = PicFromObject(oCurObj)
    oCurObj.Delete
    hBufferDC2 = FlipBmpInBufferDc(BigShape, SmallShape, iPic)
    hTempDC2 = MakeBlackTransparent(iPic, hBufferDC2)

    Set oCurObj = DuplicateAndFormatShapes(BigShape, SmallShape, Big_Shape)
    Set iPic = PicFromObject(oCurObj)
    oCurObj.Delete
    hBufferDC3 = FlipBmpInBufferDc(BigShape, SmallShape, iPic)

    Call BlendDCs(iPic, hTempDC2, hBufferDC3)

    Call GetObjectAPI(iPic.handle, LenB(tBMP), tBMP)
    hTempDC3 = CreateCompatibleDC(hdc)
    hTempBmp = CreateCompatibleBitmap(hdc, tBMP.bmWidth, tBMP.bmHeight)
    Call DeleteObject(SelectObject(hTempDC3, hTempBmp))
    Call BitBlt(hTempDC3, 0, 0, tBMP.bmWidth, tBMP.bmHeight, hBufferDC3, 0, 0, SRCCOPY)

   [COLOR=#008000] 'UNCOMMENT FOR DEBUGGING ONLY !!!
    '    Call BitBlt(hdc, 50, 200, tBMP.bmWidth, tBMP.bmHeight, hTempDC3, 0, 0, SRCCOPY)
    '    Sleep 3000[/COLOR]

    tBMInfo.bmiHeader.biSize = LenB(tBMInfo.bmiHeader)
    Call GetDIBits(hBufferDC3, hTempBmp, 0, 0, 0, tBMInfo, DIB_RGB_COLORS)
    ReDim tPixels(tBMInfo.bmiHeader.biWidth, tBMInfo.bmiHeader.biHeight)
    tBMInfo.bmiHeader.biCompression = BI_RGB
    Call GetDIBits(hBufferDC3, hTempBmp, 0, tBMInfo.bmiHeader.biHeight, tPixels(1, 1), tBMInfo, DIB_RGB_COLORS)
    iNew_R = CInt((255 - ColorToRGB(0).R) * (100 / 255#) + ColorToRGB(0).R)
    iNew_G = CInt((255 - ColorToRGB(0).G) * (100 / 255#) + ColorToRGB(0).G)
    iNew_B = CInt((255 - ColorToRGB(0).B) * (100 / 255#) + ColorToRGB(0).B)
    
    For X = 0 To tBMInfo.bmiHeader.biWidth
        For Y = 0 To tBMInfo.bmiHeader.biHeight
            With tPixels(X, Y)
                If .rgbRed = iNew_R And .rgbGreen = iNew_G And .rgbBlue = iNew_B Then
                    lOverlappingPixels = lOverlappingPixels + 1
                End If
            End With
        Next Y
    Next X
    
    If lOverlappingPixels Then
        Set oCurObj = DuplicateAndFormatShapes(BigShape, SmallShape, Small_Shape)
        Set iPic = PicFromObject(oCurObj)
        oCurObj.Delete
        hTempDC4 = CreateCompatibleDC(hdc)
        tBMInfo.bmiHeader.biSize = LenB(tBMInfo.bmiHeader)
        Call GetDIBits(hTempDC4, iPic.handle, 0, 0, 0, tBMInfo, DIB_RGB_COLORS)
        ReDim tPixels(tBMInfo.bmiHeader.biWidth, tBMInfo.bmiHeader.biHeight)
        tBMInfo.bmiHeader.biCompression = BI_RGB
        Call GetDIBits(hTempDC4, iPic.handle, 0, tBMInfo.bmiHeader.biHeight, tPixels(1, 1), tBMInfo, DIB_RGB_COLORS)
        For X = 0 To tBMInfo.bmiHeader.biWidth
            For Y = 0 To tBMInfo.bmiHeader.biHeight
            With tPixels(X, Y)
                If .rgbRed = 255 And .rgbGreen = 0 And .rgbBlue = 0 Then
                    lTotalPixels = lTotalPixels + 1
                End If
            End With
            Next Y
        Next X
       
        IsShapeInside = True
        If lTotalPixels = lOverlappingPixels Then
            Info.Location = "Fully Inside"
        Else
            Info.Location = "Partly Inside"
        End If
    Else
        Info.Location = "Outside"
    End If
    
    Info.ShapeName = SmallShape.Name: Info.Pixels = lOverlappingPixels
 
errHandler:

    Application.ScreenUpdating = True

    ReleaseDC 0, hdc: DeleteObject hBufferDC1: DeleteObject hBufferDC2
    DeleteObject hBufferDC3: DeleteObject hTempDC1: DeleteObject hTempDC2
    DeleteObject hTempDC3: DeleteObject hTempDC4: DeleteObject hTempBmp

    If Err Then MsgBox "Error!" & vbNewLine & Err.Description, vbCritical

End Function



Private Function DuplicateAndFormatShapes(ByVal BigShape As Shape, ByVal SmallShape As Shape, Format_What As FormatWhat) As Object

    Dim oObj As Object, oShp As Shape

    If Format_What = Shapes_Group Then

        Set oObj = BigShape.Parent.Shapes.Range(Array(BigShape.Name, SmallShape.Name))
        Set oObj = oObj.Duplicate
        Set oObj = oObj.Group
        
        For Each oShp In oObj.GroupItems
            If oShp.Line.Visible = msoTrue Then oShp.Line.ForeColor.RGB = IIf(oShp.Name = BigShape.Name, RGB(0, 0, 0), RGB(255, 255, 255))
            oShp.TextFrame2.TextRange.Characters.Text = ""
            With oShp.Fill
                .ForeColor.RGB = IIf(oShp.Name = BigShape.Name, RGB(0, 0, 0), RGB(255, 255, 255))
                .Solid
            End With
        Next oShp
    
    ElseIf Format_What = Big_Shape Then

        Set oObj = BigShape.Duplicate
        With oObj
            If .Line.Visible = msoTrue Then .Line.ForeColor.RGB = RGB(0, 0, 0)
            .TextFrame2.TextRange.Characters.Text = ""
            With .Fill
                .ForeColor.RGB = RGB(0, 0, 0)
                .Solid
            End With
        End With

    Else

        Set oObj = SmallShape.Duplicate
        With oObj
            If .Line.Visible = msoTrue Then .Line.ForeColor.RGB = RGB(255, 0, 0)
            .TextFrame2.TextRange.Characters.Text = ""
            With .Fill
                .ForeColor.RGB = RGB(255, 0, 0)
                .Solid
            End With
        End With

    End If

    oObj.Select
    Set DuplicateAndFormatShapes = Selection

End Function


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Function FlipBmpInBufferDc(ByVal BigShape As Shape, ByVal SmallShape As Shape, ByVal Pic As IPictureDisp) As LongPtr
        Dim hdc As LongPtr, hMemDc As LongPtr, hBufferDC As LongPtr, hMemBmp As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Function FlipBmpInBufferDc(ByVal BigShape As Shape, ByVal SmallShape As Shape, ByVal Pic As IPictureDisp) As Long
        Dim hdc As Long, hMemDc As Long, hBufferDC As Long, hMemBmp As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Const SRCCOPY = &HCC0020
    Dim tBMP As BITMAP

    hdc = GetDC(0)
    Call GetObjectAPI(Pic.handle, LenB(tBMP), tBMP)
    hMemDc = CreateCompatibleDC(hdc)
    Call DeleteObject(SelectObject(hMemDc, Pic.handle))
    hBufferDC = CreateCompatibleDC(hdc)
    hMemBmp = CreateCompatibleBitmap(hdc, tBMP.bmWidth, tBMP.bmHeight)
    Call DeleteObject(SelectObject(hBufferDC, hMemBmp))

    Select Case True
    
        Case SmallShape.Top <= BigShape.Top And SmallShape.Left <= BigShape.Left
            StretchBlt _
            hBufferDC, tBMP.bmWidth, tBMP.bmHeight, -tBMP.bmWidth, -tBMP.bmHeight, _
            hMemDc, 0, 0, _
            tBMP.bmWidth, tBMP.bmHeight, SRCCOPY
    
        Case SmallShape.Left <= BigShape.Left
            StretchBlt _
            hBufferDC, tBMP.bmWidth, 0, -tBMP.bmWidth, tBMP.bmHeight, _
            hMemDc, 0, 0, _
            tBMP.bmWidth, tBMP.bmHeight, SRCCOPY
    
        Case SmallShape.Top <= BigShape.Top
            StretchBlt _
            hBufferDC, 0, tBMP.bmHeight, tBMP.bmWidth, -tBMP.bmHeight, _
            hMemDc, 0, 0, _
            tBMP.bmWidth, tBMP.bmHeight, SRCCOPY
    
        Case Else
            hBufferDC = hMemDc

    End Select

  FlipBmpInBufferDc = hBufferDC
  ReleaseDC 0, hdc
  DeleteObject hMemBmp

End Function


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Function MakeBlackTransparent(ByVal Pic As IPictureDisp, ByVal Buffer As LongPtr) As LongPtr
        Dim hdc As LongPtr, hMemDc As LongPtr, hMemBmp As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Function MakeBlackTransparent(ByVal Pic As IPictureDisp, ByVal Buffer As Long) As Long
        Dim hdc As Long, hMemDc As Long, hMemBmp As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Const SRCCOPY = &HCC0020
    Dim tBMP As BITMAP
    
    hdc = GetDC(0)
    Call GetObjectAPI(Pic.handle, LenB(tBMP), tBMP)
    hMemDc = CreateCompatibleDC(hdc)
    hMemBmp = CreateCompatibleBitmap(hdc, tBMP.bmWidth, tBMP.bmHeight)
    Call DeleteObject(SelectObject(hMemDc, hMemBmp))
    Call TransparentBlt(hMemDc, 0, 0, tBMP.bmWidth, tBMP.bmHeight, Buffer, 0, 0, tBMP.bmWidth, tBMP.bmHeight, 0)
    MakeBlackTransparent = hMemDc
    
    ReleaseDC 0, hdc
    DeleteObject hMemBmp
    
End Function


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Function BlendDCs(ByVal Pic As IPictureDisp, ByVal DC1 As LongPtr, ByRef DC2 As LongPtr) As LongPtr
        Dim hdc As LongPtr, hMemDc As LongPtr, hMemBmp As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Function BlendDCs(ByVal Pic As IPictureDisp, ByVal DC1 As Long, ByRef DC2 As Long) As Long
        Dim hdc As Long, hMemDc As Long, hMemBmp As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Const AC_SRC_OVER = &H0
    Dim tBF As BLENDFUNCTION, lBF As Long
    Dim tBMP As BITMAP
    
    Call GetObjectAPI(Pic.handle, LenB(tBMP), tBMP)
    With tBF
        .BlendOp = AC_SRC_OVER
        .BlendFlags = 0
        .SourceConstantAlpha = 100
        .AlphaFormat = 0
    End With
    Call CopyMemory(lBF, tBF, LenB(lBF))
    Call AlphaBlend(DC2, 0, 0, tBMP.bmWidth, tBMP.bmHeight, DC1, 0, 0, tBMP.bmWidth, tBMP.bmHeight, lBF)
    BlendDCs = hMemDc
    
    ReleaseDC 0, hdc
    DeleteObject hMemDc
    DeleteObject hMemBmp

End Function


Private Function PicFromObject(ByVal Obj As Object) As IPictureDisp

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hPtr As LongPtr, hLib As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hPtr As Long, hLib As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Const IMAGE_BITMAP = 0
    Const IMAGE_ICON = 1
    Const PICTYPE_BITMAP = 1
    Const PICTYPE_ICON = 3
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
    Dim iPic As IPictureDisp, lRet As Long, lPictype As Long

    On Error GoTo errHandler

    Obj.Copy
    Call OpenClipboard(0)
    hPtr = GetClipboardData(CF_BITMAP)
    hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    Call EmptyClipboard
    Call CloseClipboard
    lPictype = PICTYPE_BITMAP

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = lPictype
        .hPic = hPtr
        .hPal = 0
    End With

    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
    End If
    Call FreeLibrary(hLib)

    If lRet = S_OK Then
        Set PicFromObject = iPic
    End If

errHandler:
    Call FreeLibrary(hLib)
    Call EmptyClipboard
    Call CloseClipboard

End Function


Private Function ColorToRGB(ByVal Col As Long) As RGB
    ColorToRGB.R = &HFF& And Col
    ColorToRGB.G = (&HFF00& And Col) \ 256
    ColorToRGB.B = (&HFF0000 And Col) \ 65536
End Function



2- Code Usage Example:
Code: 
Option Explicit

Sub Test1()

    Dim Info As Info

    Call IsShapeInside(Sheet1.Shapes("FreeForm"), Sheet1.Shapes("Circle"), Info)
    
    With Info
        MsgBox "Info" & vbNewLine & _
        "===" & vbNewLine & vbNewLine & _
        "Shape: [" & .ShapeName & "]" & vbNewLine & _
        "State: [" & .Location & "]" & vbNewLine & _
        "Overlapping Pixels: [" & Info.Pixels & "px]", vbInformation
    End With

End Sub


Sub Test2()

    Dim Info As Info

    Call IsShapeInside(Sheet1.Shapes("FreeForm"), Sheet1.Shapes("Triangle"), Info)
    
    With Info
        MsgBox "Info" & vbNewLine & _
        "===" & vbNewLine & vbNewLine & _
        "Shape: [" & .ShapeName & "]" & vbNewLine & _
        "State: [" & .Location & "]" & vbNewLine & _
        "Overlapping Pixels: [" & Info.Pixels & "px]", vbInformation
    End With

End Sub
 
Last edited:
Upvote 0
Thanks a lot! I have one more question to Usage Example . How I translate to form of Function located inside cell - to check if shape /name/ - is inside, outside FreeForm, with use of your API code ?
Code: 
Call IsShapeInside(Sheet1.Shapes("FreeForm"), Sheet1.Shapes("Circle"), Info)
 
Upvote 0
platypus007 said:
Thanks a lot! I have one more question to Usage Example . How I translate to form of Function located inside cell - to check if shape /name/ - is inside, outside FreeForm, with use of your API code ?
Click to expand...

How many shapes do you have in total ?
 
Upvote 0
You can find my work (based on your API) xlsb file here https://we.tl/t-8fnMGIqMOa


Purpose of file is to automatically create shapes (selling points) on map - and then by creating shape (area of distribution) - to exclude/ include this selling points to multiple distribution areas - freeform shape - by editing points of area. All in background of real map.
So answer for how many shapes we have - 18.350


 
Upvote 0
platypus007 said:
So answer for how many shapes we have - 18.350
Click to expand...

Reason I asked how many shapes is because using the code in UDFs in worksheet formulaes can be a bit slow if there happens to be many shapes.

Workbook Demo


Preview:
ShapInsideShapeUDF2.gif




Anyway, see how you can adapt the following to your specific needs :

1- API code stays the same.

2- UDF's in a new Standard Module:
Code: 
Option Explicit

Public Function Location(ByVal ShapeName As String) As String

    Dim Info As Info
    
    Call IsShapeInside(Sheet1.Shapes("FreeForm"), Sheet1.Shapes(ShapeName), Info)
    Location = Info.Location
    
End Function


Public Function OverlappingPixels(ByVal ShapeName As String) As Long

    Dim Info As Info

    Call IsShapeInside(Sheet1.Shapes("FreeForm"), Sheet1.Shapes(ShapeName), Info)
    OverlappingPixels = Info.Pixels
    
End Function

3- Code in the Thisworkbook Module:
Code: 
Option Explicit

Private WithEvents cmndbars As CommandBars


Private Sub Workbook_Open()
    Sheet1.Shapes("Check Box 1").ControlFormat.Value = 0
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set cmndbars = Nothing
    Sheet1.Shapes("Check Box 1").ControlFormat.Value = 0
End Sub


Private Sub cmndbars_OnUpdate()

    Static sPrevLefts As String
    Static sPrevTops As String
    
    With Sheet1
    
        If sPrevLefts <> CStr(.Shapes("FreeForm").Left) + CStr(.Shapes("A").Left) _
            + CStr(.Shapes("B").Left) + CStr(.Shapes("D").Left) _
            + CStr(.Shapes("E").Left) + CStr(.Shapes("F").Left) + CStr(.Shapes("G").Left) Or _
            sPrevTops <> CStr(.Shapes("FreeForm").Top) + CStr(.Shapes("A").Top) _
            + CStr(.Shapes("B").Top) + CStr(.Shapes("D").Top) _
            + CStr(.Shapes("E").Top) + CStr(.Shapes("F").Top) + CStr(.Shapes("G").Top) Then
        
            Application.CalculateFull
        
        End If
        
        sPrevLefts = CStr(.Shapes("FreeForm").Left) + CStr(.Shapes("A").Left) _
        + CStr(.Shapes("B").Left) + CStr(.Shapes("D").Left) _
        + CStr(.Shapes("E").Left) + CStr(.Shapes("F").Left) + CStr(.Shapes("G").Left)
        
        sPrevTops = CStr(.Shapes("FreeForm").Top) + CStr(.Shapes("A").Top) _
        + CStr(.Shapes("B").Top) + CStr(.Shapes("D").Top) _
        + CStr(.Shapes("E").Top) + CStr(.Shapes("F").Top) + CStr(.Shapes("G").Top)
        
    End With

End Sub


Public Sub ToggleAutomaticUpdate()

    If Sheet1.Shapes(Application.Caller).ControlFormat.Value = 1 Then
        Call cmndbars_OnUpdate
        Set cmndbars = Application.CommandBars
    Else
        Set cmndbars = Nothing
    End If

End Sub

Public Sub UpdateTable()
    Application.CalculateFull
End Sub


Note:
If you don't want to have the UDFs cells update automatically when moving the shapes, just skip the entire code in the ThisWorkbook Module and perform a full calculation of the application or add Application.Volatile to the Location and OverlappingPixels UDFs.
 
Upvote 0
I have hard time to modify your API code to do same thing (with same shapes A-F) but with multiple freeforms area inside one sheet original Freeform and new Freeform 2. It needs to be done by add Location2
function and OverlappingPixels2 in APIbas - for new Freeform2 ?

areanew.jpg
 
Upvote 0
After testing your solution - its computing capacity is limited to check something around 200 circles (with i9 processor and 32GB RAM) about 6 minutes to result - for each cell is need to run whole API code. So I think is there any other way how to do it ? Make list of cells under the polygon? The Circles remain all the time static and their positions (linked cell) are known - only the FreeformArea is subject to change (by edit node points).
 
Upvote 0
platypus007 said:
After testing your solution - its computing capacity is limited to check something around 200 circles (with i9 processor and 32GB RAM) about 6 minutes to result - for each cell is need to run whole API code. So I think is there any other way how to do it ? Make list of cells under the polygon? The Circles remain all the time static and their positions (linked cell) are known - only the FreeformArea is subject to change (by edit node points).
Click to expand...
Hi sorry for responding late .

Unfortynately, the code becomes cpu intensive when applied to a big number of shapes... Using the code in cell formulaes makes it even slower.

The example in post#16 updates the formula cells automatically each time a shapes is moved. This can further slow down he process.
You could avoid this by removing the entire code in the ThisWorkbook Module and updating the formula cells manually after you are done moving the shape(s) via ( F9 or ALT+CTRL+F9 )

Regards.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Trouble deleting only freeform shapes in excel chart using VBA and not the chart.
Replies
5
Views
606
NdNoviceHlp
NdNoviceHlp
J
  • Question
Changing file explorer directories to Sharepoint directories
Replies
0
Views
200
jon1315
J
J
  • Solved
Disable shapes when Workbook is protected VBA
2
Replies
12
Views
423
mumps
mumps
J
  • Solved
Message box display
Replies
7
Views
379
julhs
J
M
  • Question
Clipboard error when copying shape
Replies
4
Views
411
marc81
M

Forum statistics

Threads
1,214,918
Messages
6,122,249
Members
449,075
Latest member
staticfluids

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