Home » excel » Create shape with a hole in Excel VBA

Create shape with a hole in Excel VBA

Posted by: admin May 14, 2020 Leave a comment

Questions:

How do I create a shape with a hole in Excel VBA?

    Private Sub test_freeform()
      Dim ws As Worksheet
      Set ws = ActiveSheet
      With ws.Shapes.BuildFreeform(msoEditingAuto, 20, 20) ' returns FreeFormBuilder
        .AddNodes msoSegmentLine, msoEditingAuto, 100, 20
        .AddNodes msoSegmentLine, msoEditingAuto, 100, 100
        .AddNodes msoSegmentLine, msoEditingAuto, 20, 100
        .AddNodes msoSegmentLine, msoEditingAuto, 20, 20
        .AddNodes msoSegmentLine, msoEditingAuto, 30, 30

        .AddNodes msoSegmentLine, msoEditingAuto, 30, 60
        .AddNodes msoSegmentLine, msoEditingAuto, 60, 60
        .AddNodes msoSegmentLine, msoEditingAuto, 60, 30
        .AddNodes msoSegmentLine, msoEditingAuto, 30, 30

        .AddNodes msoSegmentLine, msoEditingAuto, 20, 20
        .ConvertToShape
      End With
    End Sub

This creates the shape with a segment that connects top left corner of the outer rectangle with top left corner of the hole. I want to somehow get rid of that segment.
Some of the predefined Excel shapes have proper holes in them, so I know it is possible for such shape to exist.

How to&Answers:

Maybe this will help you, it’s kind of a workaround:

Tested and Working on Excel 2003

Edited code: kept just the rectangle

Private Sub test_freeform()
    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim rectShp As Shape
    With ws.Shapes.BuildFreeform(msoEditingAuto, 20, 20) ' returns FreeFormBuilder
        .AddNodes msoSegmentLine, msoEditingAuto, 100, 20
        .AddNodes msoSegmentLine, msoEditingAuto, 100, 100
        .AddNodes msoSegmentLine, msoEditingAuto, 20, 100
        .AddNodes msoSegmentLine, msoEditingAuto, 20, 20

        Set rectShp = .ConvertToShape
    End With

    Dim bRed As Byte, bGreen As Byte, bBlue As Byte
    bRed = 255:  bGreen = 0: bBlue = 0

    Dim cirShp As Shape
    Set cirShp = ws.Shapes.AddShape(msoShapeOval, 50, 40, 20, 20)

    With cirShp.Fill
        .Solid
        .ForeColor.RGB = RGB(bRed, bGreen, bBlue)
        Dim holeColor As Long
        holeColor = .ForeColor.RGB
    End With

    cirShp.Line.ForeColor.RGB = rectShp.Line.ForeColor.RGB

    Dim grouped As Shape
    Set grouped = ws.Shapes.Range(Array(rectShp.Name, cirShp.Name)).Group

    grouped.Copy
    Dim imgShp As Shape
    ws.PasteSpecial Format:="Image (GIF)"
    grouped.Delete
    Set imgShp = ws.Shapes(1)

    imgShp.PictureFormat.TransparencyColor = holeColor
    imgShp.PictureFormat.TransparentBackground = msoTrue

End Sub

Edit: Picture added:

Here is what it looks like on 2003, that’s why I thought it was good enough 😉
enter image description here