OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 25-05-2006, 08:31
zhuyan166
Guest
 
Posts: n/a
Default a macro for concatenating lines ??

Hi Alex,
I am trying to create a macro that can clean up line art from imported cad/3dfiles.
The lines in the drawings are always broken apart instead of continous even though the nodes of separate,
adjacent lines share the exact same positionX and Y.
But there is an error in the code showing followed.Could u help me to correct it?
Thank u

Public Sub NodeClean()

Dim s As Shape, s2 As Shape
Dim n As Node, n2 As Node, o As Node, o2 As Node
Dim x As Double
Dim sp As SubPath, sp2 As SubPath


For Each s In ActivePage.FindShapes(, cdrCurveShape)

' Set s = ActivePage.FindShape(, cdrCurveShape)
If (s Is Nothing) Then
Exit For
End If

s.Selected = True
s.Selected = False


'Set n = s.Curve.Subpaths.Item(1).StartNode
'Set o = s.Curve.Subpaths.Item(1).EndNode

For Each s2 In ActivePage.FindShapes(, cdrCurveShape)

s2.Selected = True
s2.Selected = False

Set n = s.Curve.Subpaths.Item(1).StartNode
Set o = s.Curve.Subpaths.Item(1).EndNode
Set n2 = s2.Curve.Subpaths.Item (1).StartNode
Set o2 = s2.Curve.Subpaths.Item(1).EndNode

'check to see if the second line is the same as the first...
If n.PositionX <> n2.PositionX Or _
n.PositionY <> n2.PositionY Or _
o.PositionX <> o2.PositionX Or _
o.PositionY <> o2.PositionY Then

'if endnode of line A is at same point as
If n.GetDistanceFrom(o2) = 0 Then
MsgBox "final is true"
s2.Selected = True
s.Selected = True
Set s = ActiveSelection.Combine
If s.Curve.Subpaths.Count = 2 Then
With s.Curve.Subpaths.Item(2).EndNode
Set sp = s.Curve.Subpaths.Item(1)
.JoinWith sp.StartNode
' With s.Curve.Nodes(1)
' .Move 0.004
' End With
s.Selected = False
End With
End If

Set sp = Nothing

ElseIf o.GetDistanceFrom(o2) = 0 Then
MsgBox "final is true"
s2.Selected = True
s.Selected = True
Set s = ActiveSelection.Combine
If s.Curve.Subpaths.Count = 2 Then
With s.Curve.Subpaths.Item(2).EndNode
Set sp = s.Curve.Subpaths.Item(1)
.JoinWith sp.EndNode
' With s.Curve.Nodes(1)
' .Move 0.004
' End With
s.Selected = False
End With
End If

Set sp = Nothing

End If

End If

Set s2 = Nothing
Set n2 = Nothing
Set o2 = Nothing

Next

Set s = Nothing
Set o = Nothing
Set n = Nothing

Next

End Sub
Reply With Quote
  #2  
Old 25-05-2006, 12:27
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

I didn't analyze your code (no time forr the present) but I suggest you to compare with a "gap allowance" :
instead of if s1.PositionX=s2.PositionX you can try to write if abs(s1.positionX-s2.PositionX)<0.01 (decrease the number if needed)
it helped me very much because coordinates in Corel files jitter a little, so I ALWAYS compare with abs
Reply With Quote
  #3  
Old 25-05-2006, 19:51
zhuyan166
Guest
 
Posts: n/a
Default the most important is the ERROE!

Thanks for your reply,which is useful for me.

In fact, the code did concatenate lines,except producing an error:"the object refered does not exist in the current document now" ( i converted the error discription from Chinese to English,maybe there is some differences)
I tried for a long time but don't know what's wrong.
maybe the "s" does not exist after proceeding few circles.

could u cost minutes to have a look at the code,and correct the error?
That would be so appreciated
Reply With Quote
  #4  
Old 26-05-2006, 14:18
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

well, man, here it is. The trick is to maintain shaperange collections and remove combined shapes from collection manually, see the code.
UPDATED code combines all broken curves, see also removeUnderlyingDups that removes multiple lines stacked above each other

Code:
Sub removeUnderlyingDups()
   Dim s As Shape, sr As New ShapeRange, props() As Double
   Dim toDEL As New ShapeRange, stat As AppStatus, Jitter As Double, cnt&, idx&, _
       x As Double, y As Double, w As Double, h As Double, n&, match%, i&
   Jitter = 0.0001
   If ActiveSelectionRange.Count = 0 Then Set sr = ActivePage.FindShapes _
      Else Set sr = ActiveSelectionRange.Shapes.FindShapes
   If sr.Count = 0 Then Exit Sub
   ReDim props(1 To sr.Count, 1 To 5): cnt = 0: idx = 0
   Set stat = Application.Status
   stat.BeginProgress "Looking for curve duplicates...", True
   boostStart
   For Each s In sr
      idx = idx + 1: stat.Progress = idx / sr.Count * 100
      If stat.Aborted Then Exit For
      x = s.PositionX: y = s.PositionY: n = s.Curve.Nodes.Count
      w = s.SizeWidth: h = s.SizeHeight: match = False
      If w < Jitter And h < Jitter Then
         toDEL.Add s: cnt = cnt + 1
      Else
         For i = 1 To cnt
            If stat.Aborted Then Exit For
            If Abs(props(i, 1) - x) < Jitter Then _
               If Abs(props(i, 2) - y) < Jitter Then _
                  If Abs(props(i, 3) - w) < Jitter Then _
                     If Abs(props(i, 4) - h) < Jitter Then _
                        If props(i, 5) = n Then _
                           toDEL.Add s: match = True: Exit For
         Next i
         If Not match Then
            cnt = cnt + 1: props(cnt, 1) = x: props(cnt, 2) = y
            props(cnt, 3) = w: props(cnt, 4) = h: props(cnt, 5) = n
         End If
      End If
   Next s
   boostFinish
   If toDEL.Count = 0 Then Exit Sub
   toDEL.CreateSelection
   If MsgBox("Confirm delete " + CStr(toDEL.Count) + " objects", vbOKCancel) = vbOK Then _
      toDEL.Delete
End Sub

Public Sub NodeClean2()
   Dim s As Shape, s2 As Shape
   Dim n As Node, n2 As Node, o As Node, o2 As Node, IsFirstNode As Boolean
   Dim origShapes As New ShapeRange, nearShapes As ShapeRange
   Dim combineShapes As New ShapeRange, delShape As New ShapeRange, Alone%
   
   Set origShapes = ActivePage.FindShapes(, cdrCurveShape)
   boostStart "Node cleaning"
   On Error GoTo CloseUndoTransaction
   Do While origShapes.Count > 1
      Set s = origShapes(1)
      With s.Curve.SubPaths.Item(1): Set n = .StartNode: Set o = .EndNode: End With
      
      Set nearShapes = ActivePage.SelectShapesAtPoint(n.PositionX, n.PositionY, True).Shapes.All
      nearShapes.AddRange ActivePage.SelectShapesAtPoint(o.PositionX, o.PositionY, True).Shapes.All
      Alone = (nearShapes.Count = 1)
      
      Do While nearShapes.Count > 0
         Set s2 = nearShapes(1)
         If s2.Type = cdrCurveShape And s2.StaticID <> s.StaticID Then
            With s2.Curve.SubPaths.Item(1): Set n2 = .StartNode: Set o2 = .EndNode: End With
            
            If n.GetDistanceFrom(o2) = 0 Or o.GetDistanceFrom(o2) = 0 Then
               IsFirstNode = (n.GetDistanceFrom(o2) = 0)
               combineShapes.Add s: combineShapes.Add s2
               delShape.RemoveAll: delShape.Add s2
               origShapes.RemoveRange delShape
               Set s = combineShapes.Combine: combineShapes.RemoveAll
               combineShapes.RemoveAll
               With s.Curve.SubPaths
                  If .Count = 2 Then _
                     If IsFirstNode Then .Item(2).EndNode.JoinWith .Item(1).StartNode _
                        Else .Item(2).EndNode.JoinWith .Item(1).EndNode
               End With
               If s.Curve.Nodes.First.GetDistanceFrom(s.Curve.Nodes.Last) = 0 Then _
                  s.Curve.Nodes.First.JoinWith s.Curve.Nodes.Last
               origShapes.Add s
               Exit Do
            End If
         End If
         nearShapes.Remove 1
      Loop
      origShapes.Remove 1
   Loop
   
CloseUndoTransaction:
   boostFinish True
   If Err.Number Then MsgBox "Error: " + Err.Description
End Sub

Public Sub boostStart(Optional ByVal unDo As String = "")
   If unDo <> "" Then ActiveDocument.BeginCommandGroup unDo
   Optimization = True
   EventsEnabled = False
   ActiveDocument.SaveSettings
   ActiveDocument.PreserveSelection = False
End Sub

Public Sub boostFinish(Optional ByVal endUndoGroup As Boolean = False)
   Dim cs As Object
   ActiveDocument.PreserveSelection = True
   ActiveDocument.RestoreSettings
   EventsEnabled = True
   Optimization = False
   Application.Refresh
   ActiveWindow.Refresh
   Set cs = CorelDRAW.CorelScript
   cs.RedrawScreen
   If endUndoGroup Then ActiveDocument.EndCommandGroup
End Sub

Last edited by wOxxOm; 27-05-2006 at 04:23.
Reply With Quote
  #5  
Old 27-05-2006, 09:16
zhuyan166
Guest
 
Posts: n/a
Default Thanks so much!!

hi wOxxOm ,
I tried your code(I use the version 11, and there is no the method origShapes.shapes.FindShape) and it works now. Thank u

i am so appreciated, as reward,i will stand treat u and Alex to Chinese Food when u come to China.

zhu yan
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
Cannot use Curveworks macros in a user witten macro??? jon46089 CurveWorks 2 02-03-2006 14:18
Help with Replace Macro Pumpkin_Masher Macros/Add-ons 1 21-09-2005 14:41
Adding a Reference on a pwd protected macro Rick Randall CorelDRAW/Corel DESIGNER VBA 9 27-10-2004 09:27
New macro to clip curves w.r.t. a border Gerard Hermans Macros/Add-ons 0 09-06-2003 07:50
Speeding up a macro Rick Randall CorelDRAW/Corel DESIGNER VBA 2 12-12-2002 10:51


All times are GMT -5. The time now is 12:04.


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