OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Corel User Forums > CorelDRAW > Macros/Add-ons

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 02-05-2011, 11:57
ajesion
Guest
 
Posts: n/a
Default 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?
Code:
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
Attached Images
 
Attached Files
File Type: zip strzalkiNAkrzywej.zip (12.4 KB, 215 views)

Last edited by ajesion; 02-05-2011 at 12:06.
Reply With Quote
  #2  
Old 02-05-2011, 19:23
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

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

Code:
'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
Reply With Quote
  #3  
Old 03-05-2011, 02:15
ajesion
Guest
 
Posts: n/a
Default

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).
Attached Images
 

Last edited by ajesion; 03-05-2011 at 06:19.
Reply With Quote
  #4  
Old 03-05-2011, 09:05
ajesion
Guest
 
Posts: n/a
Default

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.
Attached Images
 
Reply With Quote
  #5  
Old 03-05-2011, 09:11
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hi.
Try this new revision:

Code:
'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
Reply With Quote
  #6  
Old 03-05-2011, 10:01
ajesion
Guest
 
Posts: n/a
Default

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.
Reply With Quote
  #7  
Old 03-05-2011, 10:26
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hi.
Thank you.

Ooops. Put this line back from first revision.

Code:
dSpace = 1 / (IIf(sp.Closed, n, n - 1))
~John
Reply With Quote
  #8  
Old 04-05-2011, 08:07
ajesion
Guest
 
Posts: n/a
Default

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
Attached Images
  

Last edited by ajesion; 17-05-2011 at 12:34.
Reply With Quote
  #9  
Old 05-05-2011, 10:21
ajesion
Guest
 
Posts: n/a
Default

Hi,
I fixed errors in the selection of options in the macro code and add a new icon.
AJ
Attached Images
 
Attached Files
File Type: zip arrowsONcurve.zip (17.8 KB, 234 views)
File Type: zip strzalkiNAkrzywej.zip (17.5 KB, 209 views)
File Type: zip ICO_AonC.zip (557 Bytes, 212 views)
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
VBA TextRange class TextLineRects property returns incorrect values Janga CorelDRAW/Corel DESIGNER VBA 4 23-07-2008 22:09
Property Bar shows incorrect page size Alex FAQ 1 29-11-2005 08:34
CD11. IDrawShape::CreateDropShadow works incorrect... geHucKa CorelDRAW/Corel DESIGNER VBA 0 19-08-2005 16:02
Creating custom arrow heads Alex FAQ 1 27-04-2005 16:05
Creating executable for distribution with PhotoPaint 9 pmj7 Corel Photo-Paint CS 0 17-11-2003 15:18


All times are GMT -5. The time now is 08:13.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com