Sub Test() Const w As Double = 0.2 Dim x As Double, dx As Double Dim i As Long Dim s As Shape With ActiveShape.Outline If .Type = cdrOutline Then For i = 1 To .Style.DashCount dx = .Style.DashLength(i) * w Set s = ActiveLayer.CreateRectangle(x, 0, x + dx, w) s.Fill.UniformColor.RGBAssign 255, 0, 0 x = x + dx dx = .Style.GapLength(i) * w Set s = ActiveLayer.CreateRectangle(x, 0, x + dx, w) s.Fill.UniformColor.RGBAssign 255, 255, 0 x = x + dx Next i End If End WithEnd Sub