Sub CreateContour()
    '##创建并提取轮廓
    Dim rect As Shape
    Dim cSr As ShapeRange
    Set rect = ActiveShape
    ActiveDocument.Unit = 3
    Set e = rect.CreateContour(cdrContourToCenter, 10)
    Set cSr = e.Separate
    Set s = cSr(1)
End Sub