Рисование концентрической фигуры - внутри другой фигуры

Option Explicit
'Тип, описывающий точку на плоскости.
Type GeomPoint
    x As Double 'X-координата точки.
    y As Double 'Y-координата точки.
End Type
'Тип, описывающий направляющий вектор.
Type GeomVector
    dx As Double 'Смещение по координате X.
    dy As Double 'Смещение по координате Y.
End Type
'Тип, описывающий линию на плоскости.
Type GeomLine
    p As GeomPoint 'Координаты точки, через которую проходит прямая.
    v As GeomVector 'Координаты направляющего вектора прямой.
End Type
'Процедура получения массива точек полилинии.
'shp - ссылка на полилинию, для которой требуется получить массив ее точек.
'n - ссылка на переменную, в которую будет записано количество точек полилинии.
'polyPoints - ссылка на массив, в который будут записаны координаты точек полилинии.
Sub GetPolylinePoints(ByVal shp As Shape, ByRef n As Long, ByRef polyPoints() As GeomPoint)
    Dim nds As ShapeNodes, nd As ShapeNode
    Dim dx As Double, dy As Double, d As Double
    Dim i As Long, j As Long
    Set nds = shp.Nodes
    n = nds.Count
    ReDim polyPoints(1 To n + 1)
    For i = 1 To n
        Set nd = nds(i)
        polyPoints(i).x = nd.Points(1, 1)
        polyPoints(i).y = nd.Points(1, 2)
    Next
    polyPoints(n + 1).x = polyPoints(1).x
    polyPoints(n + 1).y = polyPoints(1).y
    For i = n To 1 Step -1
        dx = polyPoints(i).x - polyPoints(i + 1).x
        dy = polyPoints(i).y - polyPoints(i + 1).y
        If dx * dx + dy * dy < 1 Then
            For j = i To n
                polyPoints(i).x = polyPoints(i + 1).x
                polyPoints(i).y = polyPoints(i + 1).y
            Next
            n = n - 1
        End If
    Next
    ReDim Preserve polyPoints(1 To n)
End Sub
'Процедура получения координат направляющего вектора.
'p1 - точка, из которой идет направляющий вектор.
'p2 - точка, в которую направлен направляющий вектор.
'v - результат.
Sub GetVector(ByRef p1 As GeomPoint, ByRef p2 As GeomPoint, ByRef v As GeomVector)
    v.dx = p2.x - p1.x
    v.dy = p2.y - p1.y
End Sub
'Процедура получения канонического уравнения прямой по двум точкам.
'p1 - первая точка прямой.
'p2 - вторая точка прямой.
'l - результат.
Sub GetLine(ByRef p1 As GeomPoint, ByRef p2 As GeomPoint, ByRef l As GeomLine)
    l.p = p1
    GetVector p1, p2, l.v
End Sub
'Процедура получения канонического уравнения прямой,
'проходящей через заданную точку и параллельной другой прямой.
'p1 - точка, через которую проходит искомая прямая.
'parallelTo - линия, которой должна быть параллельна искомая прямая.
'l - результат.
Sub GetParallelLine(ByRef p As GeomPoint, ByRef parallelTo As GeomLine, ByRef l As GeomLine)
    l.p = p
    l.v = parallelTo.v
End Sub
'Процедура получения вектора, ортогонального заданному.
'v - исходный вектор.
'leftHand - True, если обход идет по правилу левой руки, False иначе.
'o - результат.
Function OrthoVector(ByRef v As GeomVector, ByVal leftHand As Boolean, ByRef o As GeomVector)
    If leftHand Then
        o.dx = v.dy
        o.dy = -v.dx
    Else
        o.dx = -v.dy
        o.dy = v.dx
    End If
End Function
'Процедура нормализации вектора.
'v - вектор, длину которого необходимо приравнять единице.
Sub NormalizeVector(ByRef v As GeomVector)
    Dim vec_len As Double
    vec_len = Math.Sqr(v.dx * v.dx + v.dy * v.dy)
    v.dx = v.dx / vec_len
    v.dy = v.dy / vec_len
End Sub
'Процедура получения прямой, параллельной заданной
'и отстоящей от нее на некоторое расстояние.
'parallelTo - линия, которой должна быть параллельна искомая прямая.
'd - расстояние от исходной прямой до параллельной.
'leftHand - True, если искомая прямая по левую руку от исходной, False иначе.
'l - результат.
Sub GetParallelLine2(ByRef parallelTo As GeomLine, ByRef d As Double, _
ByVal leftHand As Boolean, ByRef l As GeomLine)
    Dim v As GeomVector, p As GeomPoint
    OrthoVector parallelTo.v, leftHand, v
    NormalizeVector v
    p.x = parallelTo.p.x + v.dx * d
    p.y = parallelTo.p.y + v.dy * d
    GetParallelLine p, parallelTo, l
End Sub
'Процедура получения уравнения общего вида для прямой, заданной каноническим уравнением.
'l - прямая, заданная каноническим уравнением.
'a, b, c - коэффициенты в уравнении общего вида для прямой (ax + by + c = 0).
Sub GenericCoefs(ByRef l As GeomLine, ByRef a As Double, ByRef b As Double, ByRef c As Double)
    a = l.v.dy
    b = -l.v.dx
    c = l.p.y * l.v.dx - l.p.x * l.v.dy
End Sub
'Функция, возвращающая определитель матрицы:
'| a b |
'| c d |
Function Determinant( _
    ByVal a As Double, ByVal b As Double, _
    ByVal c As Double, ByVal d As Double) As Double
    Determinant = a * d - b * c
End Function
'Процедура получения координат точки пересечения двух прямых.
'l1 - первая прямая.
'l2 - вторая прямая.
'p - результат (точка пересечения двух прямых)
Sub GetIntersectionPoint(ByRef l1 As GeomLine, ByRef l2 As GeomLine, ByRef p As GeomPoint)
    Dim a1 As Double, b1 As Double, c1 As Double
    Dim a2 As Double, b2 As Double, c2 As Double
    Dim d As Double, d1 As Double, d2 As Double
    GenericCoefs l1, a1, b1, c1
    GenericCoefs l2, a2, b2, c2
    d = Determinant(a1, b1, a2, b2)
    d1 = Determinant(-c1, b1, -c2, b2)
    d2 = Determinant(a1, -c1, a2, -c2)
    p.x = d1 / d
    p.y = d2 / d
End Sub
'Процедура рисования контура полилинии.
'shp - ссылка на исходную полилинию.
'd - расстояние от исходной полилинии до рисуемого контура.
'leftHand - True, если обход идет по правилу левой руки, False иначе.
Sub PolylineСontour(ByVal shp As Shape, ByVal d As Double, ByVal leftHand As Boolean)
    Dim polyPoints() As GeomPoint, polyPoints2() As Single
    Dim ls() As GeomLine, l As GeomLine
    Dim i As Long, n As Long
    GetPolylinePoints shp, n, polyPoints
    ReDim ls(1 To n)
    For i = 1 To n
        GetLine polyPoints(i), polyPoints(i Mod n + 1), l
        GetParallelLine2 l, d, leftHand, ls(i)
    Next
    ReDim polyPoints2(1 To n + 1, 1 To 2) As Single
    For i = 1 To n
        GetIntersectionPoint ls(i), ls(i Mod n + 1), polyPoints(i)
        polyPoints2(i, 1) = polyPoints(i).x
        polyPoints2(i, 2) = polyPoints(i).y
    Next
    polyPoints2(n + 1, 1) = polyPoints(1).x
    polyPoints2(n + 1, 2) = polyPoints(1).y
    Set shp = shp.Parent.Shapes.AddPolyline(polyPoints2)
    shp.Fill.Visible = msoFalse
    shp.Line.ForeColor.RGB = 0
    shp.Line.DashStyle = msoLineDash
End Sub
'Диалог рисования контура.
Sub СontourWizard()
    Dim shp As Shape, d As Double, res As VbMsgBoxResult
    On Error Resume Next
    Set shp = Selection.ShapeRange(1)
    On Error GoTo 0
    If shp Is Nothing Then
        MsgBox "Вы не выделили фигуру, для которой необходимо нарисовать контур.", vbExclamation, "Ошибка"
    Else
        If shp.Type <> msoFreeform Then
            MsgBox "Выделенная фигура не похожа на полилинию.", vbExclamation, "Ошибка"
        Else
            d = Val(InputBox("Введите расстояние от исходной полилинии до ее контура", "Расстояние", 10))
            If d < 1 Or d > 100 Then
                MsgBox "Расстояние либо введено неправильно, либо не удовлетворяет ограничениям", vbExclamation, "Ошибка"
            Else
                res = MsgBox("Обход ведем по правилу левой руки?", vbYesNo Or vbQuestion, "Порядок обхода")
                Select Case res
                    Case VbMsgBoxResult.vbYes
                        PolylineСontour shp, d, True
                    Case VbMsgBoxResult.vbNo
                        PolylineСontour shp, d, False
                End Select
            End If
        End If
    End If
End Sub