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.