简体   繁体   中英

Create shape with a hole in Excel VBA

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.

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 ;) 在此输入图像描述

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM