Topic: mjoin.lsp - help in debuging

[ribarm]

I thought that variant in Auto Lisp will be easier to make, but I am having trouble in solving it... It should do the job like gile's mjoin.dll only I wanted to make it work in any transformed UCS where 2d entities are placed...

Here is code, please help me... Bug is occuring when obtaining second point through (vlax-curve-getpointatparam ent param) :

Code: [Select]

(vl-load-com)
(defun c:mjoin ( / CH DPAR DXF70 ENENT ENENTDXF0 ENPT ENPTT ENT K N NXTENTDXF0 NXTENTEN NXTENTST PT PTLST QAF SEPT SEPTS SS STEN STENT STENTDXF0 STPT X )
  (setq ss (ssget '((0 . "LWPOLYLINE,LINE,SPLINE,ELLIPSE,ARC")) ))
  (repeat (setq k (sslength ss))
    (setq ent (ssname ss (setq k (1- k))))
    (setq stpt (vlax-curve-getstartpoint ent))
    (setq enpt (vlax-curve-getendpoint ent))
    (setq septs (cons stpt septs))
    (setq septs (cons enpt septs))
  )
  (setq sept septs)
  (foreach pt septs
    (if (member pt (cdr (member pt septs))) (setq sept (vl-remove pt sept)))
  )
  (setq sept (list (car sept) (cadr sept)))
  (initget 1 "Open Close")
  (setq ch (getkword "\nIs selection Open or Closed (O/C) : "))
  (if (eq ch "Open") (setq dxf70 0) (setq dxf70 1))
  (setq qaf (getvar 'qaflags))
  (setvar 'qaflags 1)
  (vl-cmdf "_.explode" ss "")
  (prompt "\nSelect objects once again")
  (setq ss (ssget '((0 . "LINE,SPLINE,ELLIPSE,ARC")) ))
  (setvar 'qaflags qaf)
  (initget 7)
  (setq n (getint "\nEnter segmentation level - segments per curve : "))
  (repeat (setq k (sslength ss))
    (setq ent (ssname ss (setq k (1- k))))
    (setq stpt (vlax-curve-getstartpoint ent))
    (if (equal stpt (car sept) 1e-6) (setq stent ent))
  )
  (if (eq stent nil)
    (repeat (setq k (sslength ss))
      (setq ent (ssname ss (setq k (1- k))))
      (setq enpt (vlax-curve-getendpoint ent))
      (if (equal enpt (car sept) 1e-6) (setq enent ent))
    )
  )   
  (if stent
  (progn
  (setq stentdxf0 (assoc 0 (entget stent)))
  (if (eq (cdr stentdxf0) "LINE")
    (progn
      (setq ptlst (cons (trans (cdr (assoc 10 (entget stent))) 0 1) ptlst))
      (setq ptlst (cons (trans (cdr (assoc 11 (entget stent))) 0 1) ptlst))
      (setq enpt (cdr (assoc 11 (entget stent))))
    )
    (progn
      (setq dpar (/ (vlax-curve-getendparam stent) (float n)))
      (setq k -1.0)
      (repeat (+ n 1)
        (setq pt (vlax-curve-getpointatparam stent (* dpar (setq k (1+ k)))))
        (setq ptlst (cons (trans pt 0 1) ptlst))
      )
      (setq enpt (vlax-curve-getendpoint stent))
    )
  )
  (ssdel stent ss)
  )
  (progn
  (setq enentdxf0 (assoc 0 (entget enent)))
  (if (eq (cdr enentdxf0) "LINE")
    (progn
      (setq ptlst (cons (trans (cdr (assoc 11 (entget enent))) 0 1) ptlst))
      (setq ptlst (cons (trans (cdr (assoc 10 (entget enent))) 0 1) ptlst))
      (setq enpt (cdr (assoc 10 (entget enent))))
    )
    (progn
      (setq dpar (/ (vlax-curve-getendparam enent) (float n)))
      (setq k -1.0)
      (repeat (+ n 1)
        (setq pt (vlax-curve-getpointatparam enent (* dpar (- (float n) (setq k (1+ k))))))
        (setq ptlst (cons (trans pt 0 1) ptlst))
      )
      (setq enpt (vlax-curve-getstartpoint enent))
    )
  )
  (ssdel enent ss)
  )
  )
  (while ss
    (setq nxtentst nil)
    (setq nxtenten nil)
    (repeat (setq k (sslength ss))
      (setq ent (ssname ss (setq k (1- k))))
      (setq stpt (vlax-curve-getstartpoint ent))
      (if (equal enpt stpt 1e-6) (setq nxtentst ent))
    )
    (if nxtentst nil
      (repeat (setq k (sslength ss))
        (setq ent (ssname ss (setq k (1- k))))
        (setq enptt (vlax-curve-getendpoint ent))
        (if (equal enpt enptt 1e-6) (setq nxtenten ent))
      )
    )
    (if nxtentst
    (progn
    (setq nxtentdxf0 (assoc 0 (entget nxtentst)))
    (if (eq (cdr nxtentdxf0) "LINE")
      (progn
        (setq ptlst (cons (trans (cdr (assoc 10 (entget nxtentst))) 0 1) ptlst))
        (setq ptlst (cons (trans (cdr (assoc 11 (entget nxtentst))) 0 1) ptlst))
        (setq enpt (cdr (assoc 11 (entget nxtentst))))
      )
      (progn
        (setq dpar (/ (vlax-curve-getendparam nxtentst) (float n)))
        (setq k -1.0)
        (repeat (+ n 1)
          (setq pt (vlax-curve-getpointatparam nxtentst (* dpar (setq k (1+ k)))))
          (setq ptlst (cons (trans pt 0 1) ptlst))
        )
        (setq enpt (vlax-curve-getendpoint nxtentst))
      )
    )
    (ssdel nxtentst ss)
  )
  (progn
    (setq nxtentdxf0 (assoc 0 (entget nxtenten)))
    (if (eq (cdr nxtentdxf0) "LINE")
      (progn
        (setq ptlst (cons (trans (cdr (assoc 11 (entget nxtenten))) 0 1) ptlst))
        (setq ptlst (cons (trans (cdr (assoc 10 (entget nxtenten))) 0 1) ptlst))
        (setq enpt (cdr (assoc 10 (entget nxtenten))))
      )
      (progn
        (setq dpar (/ (vlax-curve-getendparam nxtenten) (float n)))
        (setq k -1.0)
        (repeat (+ n 1)
          (setq pt (vlax-curve-getpointatparam nxtenten (* dpar (- (float n) (setq k (1+ k))))))
          (setq ptlst (cons (trans pt 0 1) ptlst))
        )
        (setq enpt (vlax-curve-getstartpoint nxtenten))
      )
    )
    (ssdel nxtenten ss)
  )
  )
  )
  (setq ptlst (acet-list-remove-duplicates ptlst 1e-6))
  (entmakex
    (append
      (list
        (cons 0 "LWPOLYLINE")
        (cons 100 "AcDbEntity")
        (cons 100 "AcDbPolyline")
        (cons 62 3)
        (cons 90 (length ptlst))
        (cons 70 dxf70)
        (cons 210 (trans '(0.0 0.0 1.0) 1 0))
      )
      (mapcar '(lambda ( x ) (cons 10 (trans x 1 0))) ptlst)
    )
  )
(princ)
)

M.R.
 

[ribarm]

I've solved the problem, but only lack of code is that it now segments all arcs as well...

Here is revised code that works with 2d entities connected in 3d space (any 3d plane) :

Code: [Select]

(vl-load-com)

(defun LM:Clockwise-p ( p1 p2 p3 )
  (< (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
     (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  )
)

(defun c:mjoin ( / CH CHK DPAR DXF70 ENENT ENENTDXF0 ENPT ENPTT ENT K N NXTENTDXF0 NXTENTEN NXTENTST PT PTLST QAF SEPT SEPTN SEPTS SS SSS STEN STENT STENTDXF0 STPT V X )
  (vl-cmdf "_.UCS" "w")
  (setq ss (ssget '((0 . "LWPOLYLINE,LINE,SPLINE,ELLIPSE,ARC")) ))
  (repeat (setq k (sslength ss))
    (setq ent (ssname ss (setq k (1- k))))
    (setq stpt (vlax-curve-getstartpoint ent))
    (setq enpt (vlax-curve-getendpoint ent))
    (setq septs (cons stpt septs))
    (setq septs (cons enpt septs))
  )
  (setq sept septs)
  (defun chkduppt (pt lst / chk)
    (foreach ptt lst
      (if (equal pt ptt 1e-6) (setq chk (cons T chk)))
    )
    chk
  )
  (foreach pt septs
    (if (eq (length (chkduppt pt sept)) 2) (setq septn (cons pt septn)))
  )
  (foreach pt septn
    (setq sept (vl-remove pt sept))
  )
  (setq sept (list (car sept) (cadr sept) (car (vl-remove (cadr sept) (vl-remove (car sept) septs)))))
  (if (or (eq (car sept) nil) (eq sept nil)) (setq sept (acet-list-remove-duplicates septs 1e-6)))
  (initget 1 "Open Close")
  (setq ch (getkword "\nDo you want selection to be Opened or Closed (O/C) : "))
  (if (eq ch "Open") (setq dxf70 0) (setq dxf70 1))
  (setq qaf (getvar 'qaflags))
  (setvar 'qaflags 1)
  (setq sss (ssadd))
  (repeat (setq k (sslength ss))
    (setq ent (ssname ss (setq k (1- k))))
    (if (not (eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE")) (ssadd ent sss))
  )
  (vl-cmdf "_.explode" ss "")
  (setq ss (ssget "_P"))
  (if ss nil (setq ss (ssadd)))
  (repeat (setq k (sslength sss))
    (setq ent (ssname sss (setq k (1- k))))
    (ssadd ent ss)
  )
  (setvar 'qaflags qaf)
  (initget 7)
  (setq n (getint "\nEnter segmentation level - segments per curve : "))
  (repeat (setq k (sslength ss))
    (setq ent (ssname ss (setq k (1- k))))
    (setq stpt (vlax-curve-getstartpoint ent))
    (if (equal stpt (car sept) 1e-6) (setq stent ent))
  )
  (if (eq stent nil)
    (repeat (setq k (sslength ss))
      (setq ent (ssname ss (setq k (1- k))))
      (setq enpt (vlax-curve-getendpoint ent))
      (if (equal enpt (car sept) 1e-6) (setq enent ent))
    )
  )   
  (if stent
  (progn
  (setq stentdxf0 (assoc 0 (entget stent)))
  (if (eq (cdr stentdxf0) "LINE")
    (progn
      (setq ptlst (cons (cdr (assoc 10 (entget stent))) ptlst))
      (setq ptlst (cons (cdr (assoc 11 (entget stent))) ptlst))
      (setq enpt (cdr (assoc 11 (entget stent))))
    )
    (progn
      (setq dpar (/ (- (vlax-curve-getendparam stent) (vlax-curve-getstartparam stent)) (float n)))
      (setq k -1.0)
      (repeat (+ n 1)
        (setq pt (vlax-curve-getpointatparam stent (+ (vlax-curve-getstartparam stent) (* dpar (setq k (1+ k))))))
        (setq ptlst (cons pt ptlst))
      )
      (setq enpt (vlax-curve-getendpoint stent))
    )
  )
  (ssdel stent ss)
  )
  (progn
  (setq enentdxf0 (assoc 0 (entget enent)))
  (if (eq (cdr enentdxf0) "LINE")
    (progn
      (setq ptlst (cons (cdr (assoc 11 (entget enent))) ptlst))
      (setq ptlst (cons (cdr (assoc 10 (entget enent))) ptlst))
      (setq enpt (cdr (assoc 10 (entget enent))))
    )
    (progn
      (setq dpar (/ (- (vlax-curve-getendparam enent) (vlax-curve-getstartparam enent)) (float n)))
      (setq k -1.0)
      (repeat (+ n 1)
        (setq pt (vlax-curve-getpointatparam enent (- (vlax-curve-getendparam enent) (* dpar (setq k (1+ k))))))
        (setq ptlst (cons pt ptlst))
      )
      (setq enpt (vlax-curve-getstartpoint enent))
    )
  )
  (ssdel enent ss)
  )
  )
  (while (/= (sslength ss) 0)
    (setq nxtentst nil)
    (setq nxtenten nil)
    (repeat (setq k (sslength ss))
      (setq ent (ssname ss (setq k (1- k))))
      (setq stpt (vlax-curve-getstartpoint ent))
      (if (equal enpt stpt 1e-6) (setq nxtentst ent))
    )
    (if nxtentst nil
      (repeat (setq k (sslength ss))
        (setq ent (ssname ss (setq k (1- k))))
        (setq enptt (vlax-curve-getendpoint ent))
        (if (equal enpt enptt 1e-6) (setq nxtenten ent))
      )
    )
    (if nxtentst
    (progn
    (setq nxtentdxf0 (assoc 0 (entget nxtentst)))
    (if (eq (cdr nxtentdxf0) "LINE")
      (progn
        (setq ptlst (cons (cdr (assoc 10 (entget nxtentst))) ptlst))
        (setq ptlst (cons (cdr (assoc 11 (entget nxtentst))) ptlst))
        (setq enpt (cdr (assoc 11 (entget nxtentst))))
      )
      (progn
        (setq dpar (/ (- (vlax-curve-getendparam nxtentst) (vlax-curve-getstartparam nxtentst)) (float n)))
        (setq k -1.0)
        (repeat (+ n 1)
          (setq pt (vlax-curve-getpointatparam nxtentst (+ (vlax-curve-getstartparam nxtentst) (* dpar (setq k (1+ k))))))
          (setq ptlst (cons pt ptlst))
        )
        (setq enpt (vlax-curve-getendpoint nxtentst))
      )
    )
    (ssdel nxtentst ss)
  )
  (progn
    (setq nxtentdxf0 (assoc 0 (entget nxtenten)))
    (if (eq (cdr nxtentdxf0) "LINE")
      (progn
        (setq ptlst (cons (cdr (assoc 11 (entget nxtenten))) ptlst))
        (setq ptlst (cons (cdr (assoc 10 (entget nxtenten))) ptlst))
        (setq enpt (cdr (assoc 10 (entget nxtenten))))
      )
      (progn
        (setq dpar (/ (- (vlax-curve-getendparam nxtenten) (vlax-curve-getstartparam nxtenten)) (float n)))
        (setq k -1.0)
        (repeat (+ n 1)
          (setq pt (vlax-curve-getpointatparam nxtenten (- (vlax-curve-getendparam nxtenten) (* dpar (setq k (1+ k))))))
          (setq ptlst (cons pt ptlst))
        )
        (setq enpt (vlax-curve-getstartpoint nxtenten))
      )
    )
    (ssdel nxtenten ss)
  )
  )
  )
  (setq ptlst (acet-list-remove-duplicates ptlst 1e-6))
  (vl-cmdf "_.UCS" "3p" (car sept) (cadr sept) (caddr sept))
  (if (LM:Clockwise-p (trans (car sept) 0 1) (trans (cadr sept) 0 1) (trans (caddr sept) 0 1)) (setq v (caddr (trans '(0.0 0.0 0.0) 0 1))) (setq v (- (caddr (trans '(0.0 0.0 0.0) 0 1)))))
  (entmakex
    (append
      (list
        (cons 0 "LWPOLYLINE")
        (cons 100 "AcDbEntity")
        (cons 100 "AcDbPolyline")
        (cons 62 3)
        (cons 38 v)
        (cons 90 (length ptlst))
        (cons 70 dxf70)
        (cons 210 (mapcar '- (trans '(0.0 0.0 1.0) 1 0) (trans '(0.0 0.0 0.0) 1 0)))
      )
      (mapcar '(lambda ( x ) (cons 10 (trans x 0 (mapcar '- (trans '(0.0 0.0 1.0) 1 0) (trans '(0.0 0.0 0.0) 1 0))))) ptlst)
    )
  )
  (vl-cmdf "_.UCS" "p")
  (vl-cmdf "_.UCS" "p")
(princ)
)

M.R.

[ribarm]

Sorry there was little mistake when there were no lwpolyline objects... I've corrected this... In addition to this here is my new lines23dpoly based on same algorithm :

Code: [Select]

(defun c:l3dpl ( / CHOICE1 CHOICE2 ENENT ENPT ENPTT ENT K NXTENTEN NXTENTST OSM PTLST SEPT SEPTN SEPTS SS SSS STENT STPT )
  (vl-cmdf "_.UCS" "w")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (prompt "\nSelect all connected lines")
  (setq ss (ssget '((0 . "LINE")) ))
  (setq sss (ssadd))
  (repeat (setq k (sslength ss))
    (setq ent (ssname ss (setq k (1- k))))
    (ssadd ent sss)
  )   
  (repeat (setq k (sslength ss))
    (setq ent (ssname ss (setq k (1- k))))
    (setq stpt (cdr (assoc 10 (entget ent))))
    (setq enpt (cdr (assoc 11 (entget ent))))
    (setq septs (cons stpt septs))
    (setq septs (cons enpt septs))
  )
  (setq sept septs)
  (defun chkduppt (pt lst / chk)
    (foreach ptt lst
      (if (equal pt ptt 1e-6) (setq chk (cons T chk)))
    )
    chk
  )
  (foreach pt septs
    (if (eq (length (chkduppt pt septs)) 2) (setq septn (cons pt septn)))
  )
  (foreach pt septn
    (setq sept (vl-remove pt sept))
  )
  (if (eq sept nil) (setq sept (acet-list-remove-duplicates septs 1e-6)))
  (repeat (setq k (sslength ss))
    (setq ent (ssname ss (setq k (1- k))))
    (setq stpt (cdr (assoc 10 (entget ent))))
    (if (equal stpt (car sept) 1e-6) (setq stent ent))
  )
  (if (eq stent nil)
    (repeat (setq k (sslength ss))
      (setq ent (ssname ss (setq k (1- k))))
      (setq enpt (cdr (assoc 11 (entget ent))))
      (if (equal enpt (car sept) 1e-6) (setq enent ent))
    )
  )
  (if stent
  (progn
    (setq ptlst (cons (cdr (assoc 10 (entget stent))) ptlst))
    (setq ptlst (cons (cdr (assoc 11 (entget stent))) ptlst))
    (setq enpt (cdr (assoc 11 (entget stent))))
    (ssdel stent ss)
  )
  (progn
    (setq ptlst (cons (cdr (assoc 11 (entget enent))) ptlst))
    (setq ptlst (cons (cdr (assoc 10 (entget enent))) ptlst))
    (setq enpt (cdr (assoc 10 (entget enent))))
    (ssdel enent ss)
  )
  )
  (while (/= (sslength ss) 0)
    (setq nxtentst nil)
    (setq nxtenten nil)
    (repeat (setq k (sslength ss))
      (setq ent (ssname ss (setq k (1- k))))
      (setq stpt (cdr (assoc 10 (entget ent))))
      (if (equal enpt stpt 1e-6) (setq nxtentst ent))
    )
    (if nxtentst nil
      (repeat (setq k (sslength ss))
        (setq ent (ssname ss (setq k (1- k))))
        (setq enptt (cdr (assoc 11 (entget ent))))
        (if (equal enpt enptt 1e-6) (setq nxtenten ent))
      )
    )
    (if nxtentst
    (progn
      (setq ptlst (cons (cdr (assoc 10 (entget nxtentst))) ptlst))
      (setq ptlst (cons (cdr (assoc 11 (entget nxtentst))) ptlst))
      (setq enpt (cdr (assoc 11 (entget nxtentst))))
      (ssdel nxtentst ss)
    )
    (progn
      (setq ptlst (cons (cdr (assoc 11 (entget nxtenten))) ptlst))
      (setq ptlst (cons (cdr (assoc 10 (entget nxtenten))) ptlst))
      (setq enpt (cdr (assoc 10 (entget nxtenten))))
      (ssdel nxtenten ss)
    )
    )
  )
  (setq ptlst (acet-list-remove-duplicates ptlst 1e-6))
  (initget 1 "Open Close")
  (setq choice1 (getkword "\nIs 3dpolyline opened or closed (Open/Close) : "))
  (if (eq choice1 "Open")
    (progn
    (command "_.3dpoly")
    (foreach pt ptlst
      (command pt)
    )
    (command "")
    )
    (progn
    (command "_.3dpoly")
    (foreach pt ptlst
      (command pt)
    )
    (command "c")
    )
  )
  (initget 1 "Keep Delete")
  (setq choice2 (getkword "\nDo you want to keep lines, or do you want me to delete them (Keep/Delete) : "))
  (if (eq choice2 "Delete")
    (command "erase" sss "")
  )
  (vl-cmdf "_.UCS" "p")
  (setvar 'osmode osm)
(princ)
)

Sincerely, M.R.

[BlackBox]

Marco, be careful of ss = nil