在Excel VBA中创建带孔的形状

Question

如何在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

这将创建一个带有一个段的形状，该段连接外部矩形的左上角和孔的左上角。我想以某种方式摆脱那一段。 一些预定义的Excel形状中有适当的孔，所以我知道这种形状可能存在。

Answer 1

也许这会对你有所帮助，这是一种解决方法：

经过测试并使用Excel 2003

已编辑的代码：仅保留矩形

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

修改：已添加图片：

这是2003年的样子，这就是为什么我觉得它足够好了;）