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

[platypus007]

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).

Thanks

Viktor

 

[DanteAmor]

Hi @platypus007, welcome to the forum.

Do you need something like this:

Try this:

Sub Check_Shapes()
  Dim r As Range, img As Object, i As Long
  Set r = Range("D4:F15")
  Range("A2:B" & Rows.Count).ClearContents
  i = 2
  For Each img In ActiveSheet.Shapes
    Range("A" & i) = img.Name
    If Not Intersect(img.TopLeftCell, r) Is Nothing Or _
      Not Intersect(img.BottomRightCell, r) Is Nothing Then
      Range("B" & i) = "inside"
    Else
      Range("B" & i) = "outside"
    End If
    i = i + 1
  Next
End Sub

 

[platypus007]

Thanks for response, but I need Freeform like this (picture) - like polygon not defined by cells.

https://pasteboard.co/IDtXBAc.jpg

 

[DanteAmor]

I don't know how to determine that area, in the following example, apparently "G" is outside the area, but because of the range of cells that the area covers, "G" is within the range.

For the above this would be the code.

Sub Check_Shapes()
  Dim r3 As Range, img As Shape, i As Long, fForm As Shape
  Set fForm = ActiveSheet.Shapes("formarea")
  Range("A2:B" & Rows.Count).ClearContents
  i = 2
  For Each img In ActiveSheet.Shapes
    If img.Name <> fForm.Name Then
      Range("A" & i) = img.Name
      Set r3 = Range(fForm.TopLeftCell, fForm.BottomRightCell)
      If Not Intersect(img.TopLeftCell, r3) Is Nothing And _
         Not Intersect(img.BottomRightCell, r3) Is Nothing Then
        Range("B" & i) = "inside"
      Else
        Range("B" & i) = "outside"
      End If
      i = i + 1
    End If
  Next
End Sub

Hopefully someone can help you with the most accurate code.

 

[Jaafar Tribak]

You may want to take a look at this neat vba function written by Rick Rothstein

http://www.excelfox.com/forum/showt...n-A-Polygon-Or-Not?p=7379&viewfull=1#post7379

 

[Fluff]

Cross posted http://www.vbaexpress.com/forum/sho...-object-is-inside-or-outside-of-freeform-area

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

 

[Fluff]

Also posted here https://stackoverflow.com/questions...-object-is-inside-or-outside-of-freeform-area

If you have posted this anywhere else, please supply the link(s)

 

[Rick Rothstein]

You may want to take a look at this neat vba function written by Rick Rothstein

http://www.excelfox.com/forum/showt...n-A-Polygon-Or-Not?p=7379&viewfull=1#post7379

Thanks for referencing my code and your kind characterization of it. A couple of points that may help the OP if he wishes to try and use my function. First, he will have to make a polygon composed of straight lines that approximates his freeform shape so that he has a set of coordinates to feed into the function. Once that has been done, I think he will need to use the modified code that I posted in Message #14 within the thread on the ExcelFox forum you referenced. Here is a link to that particular message...

http://www.excelfox.com/forum/showt...n-A-Polygon-Or-Not?p=9267&viewfull=1#post9267

The reason I am suggesting this is because the OP will want to be checking if circular disks are within the boundary of the approximated polygon, not points. My thinking is that the OP can pass in the disk's radius plus a small amount more in as the Tolerance value to that function so as to try and avoid the problem of the edge of the disk (which has no thickness) being on top or, or extremely close to the polygon's border (which is made up of lines with no thickness)... that way, a disk whose edge calculates to within a nearly infinitesimally small distance over the polygon's border won't be failed because of it. My wording is awkward so I hope that all made sense.

 

[Jaafar Tribak]

Thanks for referencing my code and your kind characterization of it. A couple of points that may help the OP if he wishes to try and use my function. First, he will have to make a polygon composed of straight lines that approximates his freeform shape so that he has a set of coordinates to feed into the function. Once that has been done, I think he will need to use the modified code that I posted in Message #14 within the thread on the ExcelFox forum you referenced. Here is a link to that particular message...

Hi Rick,

If by "circles are inside of freeform area" the OP meant partly or Fully inside ( ie: intersection between freeform and circle is not nothing) then I have an API workaround which so far as the testing goes, it gave me pretty accurate results on my machine.

The basic idea is to make a copy of the freeform and circle shapes (as a groupe) , reformat the copies so they look plain black fill ,no text, no shape outline , no shadow etc and then extract a bitmap of the copy from the clipboard. The resulting bitmap will have two seperate black areas against a white background or one single black area against a white background depending on whether the shapes intersect or not.

I'll complete writing the code and post back later on.

Regards.

 

[Jaafar Tribak]

Workbook Example

Sorry for coming back on this so late. The reason being is that after further testings, the workaround I described in my previous post didn't work accurately enough.

It is quite a challenging task and it has taken me some effort to arrive at a decent solution.

The below Get_Shape_Relative_Location function returns all 3 possible locations of a shape in relation to the parent freeform shape : Either, Outside or Partly inside or Fully inside.

I tested the code in excel 2010,2013 and 2016 32bit as well as 64bit and it works fine.

The code makes use of some Properties and Methods of the Shape(s) class which are not available in excel 2007 so the code may need some tweaking.

1- API code in a Standard Module:

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
    
    
    On Error GoTo errHandler
    
    Application.ScreenUpdating = False
    
    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
    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
    
    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
            oShp.Line.Visible = msoFalse
            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.Visible = msoFalse
            .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.Visible = msoFalse
            .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

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

2- Code Usage:

Option Explicit

Sub Test1()
    MsgBox "Shape 'Circle' is (" & Get_Shape_Relative_Location(Sheet1.Shapes("FreeForm"), Sheet1.Shapes("Circle")) & ")"
End Sub

Sub Test2()
    MsgBox "Shape 'Triangle' is (" & Get_Shape_Relative_Location(Sheet1.Shapes("FreeForm"), Sheet1.Shapes("Triangle")) & ")"
End Sub