Incorrect distribution of the arrow on the open curve

A sample macro converted from Corel X4. Is it possible to improve the code for the open curve in order to avoid the error shown in the screenshot?

Private Sub Polecenie_Click()
Rem: Pozycjonowanie prostopad?ych lub poziomych strza?ek na wybranej krzywej
Rem: "ileKopii" - zmienna liczba strza?ek na krzywej.
    If ActiveDocument.SelectionInfo.Count = 0 Then
        MsgBox "Prosz? zaznaczy? jeden obiekt.", vbInformation, "strza?kiNAkrzywej"
        Exit Sub
    End If
    If ileKopii.Text = "" Then
        MsgBox "Wpisz ile utworzy? strza?ek.", vbInformation, "strza?kiNAkrzywej"
        Exit Sub
    End If
Optimization = True
ActiveDocument.SaveSettings
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrCenter
ActiveDocument.BeginCommandGroup "strza?kiNAkrzywej"
On Error GoTo naprawKOD
    Dim s As Shape
    Dim sp As SubPath
    Dim t As Double, n As Double
    n = Val(ileKopii.Text)
Set s = ActiveShape
If s.Type <> cdrCurveShape Then s.ConvertToCurves
    For Each sp In s.Curve.SubPaths
        If Not sp.Closed Then
            For t = 0 To 0.999999999999999 Step 1 / (n - 1)
                MarkPoint sp, t
            Next t
            For t = 1 To 1
                MarkPoint sp, t
            Next t
        Else
            For t = 0 To 0.999999999999999 Step 1 / n
                MarkPoint sp, t
            Next t
        End If
    Next sp
s.CreateSelection
ExitSub:
    ActiveDocument.EndCommandGroup
    ActiveDocument.RestoreSettings
    Optimization = False
    ActiveWindow.Refresh
    Application.Refresh
    Exit Sub
naprawKOD:
    MsgBox "Wyst?pi? b??d: " & Err.Description
    Resume ExitSub
End Sub

Private Sub MarkPoint(sp As SubPath, t As Double)
Dim x As Double, y As Double
Dim dx As Double, dy As Double
Dim a1 As Double, a2 As Double
    sp.GetPointPositionAt x, y, t, cdrRelativeSegmentOffset
If poziome = True Then
    a1 = sp.GetTangentAt(t, cdrRelativeSegmentOffset) * 3.1415926 / 180
    dx = 7 * Cos(a1)
    dy = 7 * Sin(a1)
    With ActiveLayer.CreateLineSegment(x, y, x + dx, y + dy)
        .Outline.EndArrow = ArrowHeads(1)
    End With
End If
If pionowe = True Then
    a2 = sp.GetPerpendicularAt(t, cdrRelativeSegmentOffset) * 3.1415926 / 180 'pion
    dx = 7 * Cos(a2) 'dla pionu
    dy = 7 * Sin(a2) 'dla pionu
    With ActiveLayer.CreateLineSegment(x, y, x + dx, y + dy)   'dla pionu
        .Outline.EndArrow = ArrowHeads(1) 'dla pionu
    End With   'dla pionu
End If
End Sub

Private Sub cofnij_Click()
Rem: Wycofaj si? z wykonanego makra i przywró? pierwotne zaznaczenie.
    Set s = ActiveShape
        ActiveDocument.Undo
    's.CreateSelection
End Sub

[runflacruiser]

Hi.
Here's some revised code for it.
You'll have to uncomment needed parts as I made this so testing is easy.
~John

'Option Explicit

Private Sub Polecenie_Click()
Rem: Pozycjonowanie prostopad?ych lub poziomych strza?ek na wybranej krzywej
Rem: "ileKopii" - zmienna liczba strza?ek na krzywej.
'    If ActiveDocument.SelectionInfo.count = 0 Then
'        MsgBox "Prosz? zaznaczy? jeden obiekt.", vbInformation, "strza?kiNAkrzywej"
'        Exit Sub
'    End If
'    If ileKopii.text = "" Then
'        MsgBox "Wpisz ile utworzy? strza?ek.", vbInformation, "strza?kiNAkrzywej"
'        Exit Sub
'    End If
'Optimization = true
'ActiveDocument.SaveSettings
ActiveDocument.Unit = cdrMillimeter
'ActiveDocument.ReferencePoint = cdrCenter
ActiveDocument.BeginCommandGroup "strza?kiNAkrzywej"
'On Error GoTo naprawKOD
    Dim s As Shape
    Dim sp As SubPath
    Dim t As Double, n As Double
    'n = Val(ileKopii.text)
    
'modified by me................................begin.
n = Val(7)
Set s = ActiveShape
If ActiveShape Is Nothing Then MsgBox "nothing selected!": Exit Sub
Dim dSpace As Double
Dim bFirst As Boolean

If s.Type <> cdrCurveShape Then s.ConvertToCurves
    For Each sp In s.Curve.SubPaths
        If sp.Closed Then bFirst = True
        dSpace = 1 / (IIf(sp.Closed, n, n - 1))
        Do
            If t > 0.999999999999999 And CStr(t) <> "1" Then Exit Do
            If Not bFirst Then MarkPoint sp, t
            t = t + dSpace
            bFirst = False
        Loop
    Next sp
'modified by me................................end.
s.CreateSelection
'ExitSub:
    ActiveDocument.EndCommandGroup
'    ActiveDocument.RestoreSettings
'    Optimization = False
'    ActiveWindow.Refresh
'    Application.Refresh
'    Exit Sub
'naprawKOD:
'    MsgBox "Wyst?pi? b??d: " & Err.Description
'    Resume ExitSub
End Sub

Private Function MarkPoint(sp As SubPath, t As Double)
Dim x As Double, y As Double
Dim dx As Double, dy As Double
Dim a1 As Double, a2 As Double
    'If t = 1 Then t = 0.999999999999999
    sp.GetPointPositionAt x, y, t, cdrRelativeSegmentOffset
If poziome = True Then
    a1 = sp.GetTangentAt(t, cdrRelativeSegmentOffset) * 3.1415926 / 180
    dx = 7 * Cos(a1)
    dy = 7 * Sin(a1)
    With ActiveLayer.CreateLineSegment(x, y, x + dx, y + dy)
        .Outline.EndArrow = ArrowHeads(1)
    End With
End If
'If pionowe = True Then
    a2 = sp.GetPerpendicularAt(t, cdrRelativeSegmentOffset) * 3.1415926 / 180 'pion
    dx = 7 * Cos(a2) 'dla pionu
    dy = 7 * Sin(a2) 'dla pionu
    With ActiveLayer.CreateLineSegment(x, y, x + dx, y + dy)   'dla pionu
        .Outline.EndArrow = ArrowHeads(1) 'dla pionu
    End With   'dla pionu
'End If
End Function

Private Sub cofnij_Click()
Rem: Wycofaj si? z wykonanego makra i przywró? pierwotne zaznaczenie.
    Set s = ActiveShape
        ActiveDocument.unDo
    's.CreateSelection
End Sub

Thanks John,

My knowledge of VBA is too small (experiments and errors), sometimes something will succeed. This problem I will not solve. Above code is for an open curve but does not inserts the last arrow, the last segment is shorter (as in my version of the code) and shows an error (screenshot below).

John thanks for your help, there's always something more I recognize. I clear the codes and a closed curve can be OK (I will put it on the forum, someone can us it.) Regards.

[runflacruiser]

Hi.
Try this new revision:

'Option Explicit

Private Sub Polecenie_Click()
Rem: Pozycjonowanie prostopad?ych lub poziomych strza?ek na wybranej krzywej
Rem: "ileKopii" - zmienna liczba strza?ek na krzywej.
'    If ActiveDocument.SelectionInfo.count = 0 Then
'        MsgBox "Prosz? zaznaczy? jeden obiekt.", vbInformation, "strza?kiNAkrzywej"
'        Exit Sub
'    End If
'    If ileKopii.text = "" Then
'        MsgBox "Wpisz ile utworzy? strza?ek.", vbInformation, "strza?kiNAkrzywej"
'        Exit Sub
'    End If
'Optimization = true
'ActiveDocument.SaveSettings
ActiveDocument.Unit = cdrMillimeter
'ActiveDocument.ReferencePoint = cdrCenter
ActiveDocument.BeginCommandGroup "strza?kiNAkrzywej"
'On Error GoTo naprawKOD
    Dim s As Shape
    Dim sp As SubPath
    Dim t As Double, n As Double
    'n = Val(ileKopii.text)



n = Val(7)
Set s = ActiveShape
If ActiveShape Is Nothing Then MsgBox "nothing selected!": Exit Sub
Dim dSpace As Double
Dim bFirst As Boolean

If s.Type <> cdrCurveShape Then s.ConvertToCurves
    For Each sp In s.Curve.SubPaths
        dSpace = 1 / n
        Do
            If CStr(t) <> "0" And Len(CStr(t)) = 1 Then Exit Do
            MarkPoint sp, t, True
            t = t + dSpace
        Loop
        If Not sp.Closed Then
            sp.ReverseDirection
            MarkPoint sp, 0, False
            sp.ReverseDirection
        End If
    Next sp
s.CreateSelection


'ExitSub:
    ActiveDocument.EndCommandGroup
'    ActiveDocument.RestoreSettings
'    Optimization = False
'    ActiveWindow.Refresh
'    Application.Refresh
'    Exit Sub
'naprawKOD:
'    MsgBox "Wyst?pi? b??d: " & Err.Description
'    Resume ExitSub
End Sub

Private Function MarkPoint(sp As SubPath, t As Double, bInner As Boolean)
Dim x As Double, y As Double
Dim dx As Double, dy As Double
Dim a1 As Double, a2 As Double
    sp.GetPointPositionAt x, y, t, cdrRelativeSegmentOffset
If poziome = True Then
    a1 = sp.GetTangentAt(t, cdrRelativeSegmentOffset) * 3.1415926 / 180
    dx = 7 * Cos(a1)
    dy = 7 * Sin(a1)
    If bInner Then dy = dy * -1: dx = dx * -1
    With ActiveLayer.CreateLineSegment(x, y, x + dx, y + dy)
        .Outline.EndArrow = ArrowHeads(1)
    End With
End If
'If pionowe = True Then
    a2 = sp.GetPerpendicularAt(t, cdrRelativeSegmentOffset) * 3.1415926 / 180 'pion
    dx = 7 * Cos(a2) 'dla pionu
    dy = 7 * Sin(a2) 'dla pionu
    If bInner Then dy = dy * -1: dx = dx * -1
    With ActiveLayer.CreateLineSegment(x, y, x + -dx, y + -dy)   'dla pionu
        .Outline.EndArrow = ArrowHeads(1) 'dla pionu
    End With   'dla pionu
'End If
End Function

Private Sub cofnij_Click()
Rem: Wycofaj si? z wykonanego makra i przywró? pierwotne zaznaczenie.
    Set s = ActiveShape
        ActiveDocument.unDo
    's.CreateSelection
End Sub

~John

The codes above are possibilities, which I see for the first time, magic . John at which point of the code can I delete one arrow at the open curve (instead of 7 is 8). Probably the last segment can not be equal with all segments (probably an internal error Corel). Macro with your corrections always gives me the courage to further trials. Thank.

[runflacruiser]

Hi.
Thank you.

Ooops. Put this line back from first revision.

dSpace = 1 / (IIf(sp.Closed, n, n - 1))

~John

Hi,
below is the macro with the changes suggested by John and a small additional options. Choosing options performs a variety of arrangement on the open and closed curve. Several examples in the screenshot. However, when macro perform tens of arrows, executes them for a few less, communicating an error. Probable internal error system or imperfect code. Macro codes are available and if it's possible to improve it, please post the new code on the forum. Macro is in English and Polish. Macro icon in attachment.
AJ

Hi,
I fixed errors in the selection of options in the macro code and add a new icon.
AJ