Topic: region2pl

[taner]

Dear all,

Can anyone write some codes to convert all kinds of regions to polylines?
Thanks in advance.

[gile]

Hi

It is not possible to convert "all kind" of regions into polylines. Polylines have only lines and arcs.

Here's a routine which convert valid selected regions (which countains onlt lines and arcs) into polylines

Code: [Select]

;;; R2PL -Gilles Chanteau- 01/01/07
;;; Transforme les régions sélectionnées en polylignes.

(defun c:r2pl (/ *error* arcbugle acdoc space
ss n reg norm expl olst
blst dlst plst tlst blg pline
)
  (vl-load-com)

;;;***************************************************************;;;

  (defun *error* (msg)
    (if (/= msg "Function cancelled")
      (princ (strcat "\nError: " msg))
    )
    (vla-EndUndoMark
      (vla-get-ActiveDocument (vlax-get-acad-object))
    )
    (princ)
  )

;;;***************************************************************;;;

  (defun arcbulge (arc)
    (/ (sin (/ (vla-get-TotalAngle arc) 4))
       (cos (/ (vla-get-TotalAngle arc) 4))
    )
  )

;;;***************************************************************;;;

  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
space (if (= 1 (getvar "CVPORT"))
  (vla-get-PaperSpace acdoc)
  (vla-get-ModelSpace acdoc)
)
  )
  (if (ssget '((0 . "REGION")))
    (progn
      (vla-StartUndoMark acdoc)
      (vlax-for reg (setq ss (vla-get-ActiveSelectionSet acdoc))
(setq norm (vlax-get reg 'Normal)
      expl (vlax-invoke reg 'Explode)
)
(if (vl-every '(lambda (x)
(or
   (= (vla-get-ObjectName x) "AcDbLine")
   (= (vla-get-ObjectName x) "AcDbArc")
)
       )
      expl
    )
  (progn
    (vla-delete reg)
    (setq olst (mapcar '(lambda (x)
  (list x
(vlax-get x 'StartPoint)
(vlax-get x 'EndPoint)
  )
)
       expl
       )
    )
    (while olst
      (setq blst nil)
      (if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
(setq blst (list (cons 0 (arcbulge (caar olst)))))
      )
      (setq plst (cdar olst)
    dlst (list (caar olst))
    olst (cdr olst)
      )
      (while
(setq
  tlst
   (vl-member-if
     '(lambda (x)
(or (equal (last plst) (cadr x) 1e-9)
    (equal (last plst) (caddr x) 1e-9)
)
      )
     olst
   )
)
(if (equal (last plst) (caddar tlst) 1e-9)
   (setq blg -1)
   (setq blg 1)
)
(if
   (= (vla-get-ObjectName (caar tlst)) "AcDbArc")
    (setq
      blst
       (cons (cons (1- (length plst))
   (* blg (arcbulge (caar tlst)))
     )
     blst
       )
    )
)
(setq plst (append plst
    (if (minusp blg)
      (list (cadar tlst))
      (list (caddar tlst))
    )
    )
       dlst (cons (caar tlst) dlst)
       olst (vl-remove (car tlst) olst)
)
      )
      (setq pline
     (vlax-invoke
       Space
       'addLightWeightPolyline
       (apply 'append
      (mapcar '(lambda (x)
(setq x (trans x 0 Norm))
(list (car x) (cadr x))
       )
      (reverse (cdr (reverse plst)))
      )
       )
     )
      )
      (vla-put-Closed pline :vlax-true)
      (mapcar
'(lambda (x) (vla-setBulge pline (car x) (cdr x)))
blst
      )
      (vla-put-Elevation
pline
(caddr (trans (car plst) 0 Norm))
      )
      (vla-put-Normal pline (vlax-3d-point Norm))
      (mapcar 'vla-delete dlst)
    )
  )
  (mapcar 'vla-delete expl)
)
      )
      (vla-delete ss)
      (vla-EndUndoMark acdoc)
    )
  )
  (princ)
)

[taner]

Hi

It is not possible to convert "all kind" of regions into polylines. Polylines have only lines and arcs.

Here's a routine which convert valid selected regions (which countains onlt lines and arcs) into polylines

Thanks very much Sir.

[Beekee]

Hello, I would like to use this routine as sub-function...

I have my routine in LISP and I need to convert a regular selection set of regions to polylines. I can't figure out how to adjust this (vlax-for reg (setq ss (vla-get-ActiveSelectionSet acdoc)) loop... to use my selection set (created by (ssadd)). I tried to add (sssetfirst nil sel) before, but you know, it did not work...

Thanks in advance.

[gile]

Hi

Replace:

Code - Auto/Visual Lisp: [Select]

1.  (vlax-for reg (setq ss (vla-get-ActiveSelectionSet acdoc))

with:

Code - Auto/Visual Lisp: [Select]

1. (repeat (setq i (sslength sel))
2.   (setq reg (vlax-ename->vla-object (ssname ss (setq i (1- i)))))

and remove:

Code - Auto/Visual Lisp: [Select]

1. (vla-Delete ss)

This should do the trick (not tested).

[lamarn]

Edit: It works!

[Beekee]

Hi and thank you, gile! It works nicely!

(just for the record... ss and sel should be the same.. )

Hi

Replace:

Code - Auto/Visual Lisp: [Select]

1.  (vlax-for reg (setq ss (vla-get-ActiveSelectionSet acdoc))

with:

Code - Auto/Visual Lisp: [Select]

1. (repeat (setq i (sslength sel))
2.   (setq reg (vlax-ename->vla-object (ssname sel (setq i (1- i)))))

and remove:

Code - Auto/Visual Lisp: [Select]

1. (vla-Delete ss)

This should do the trick (not tested).

[dexus]

I was looking for a function to convert regions into polylines.
The ones that use PEDIT do not work on regions that are perpendicular to the UCS.
I made one myself but it was a lot slower than this one. If only I found this earlier, thanks for sharing gile!

This one didn't work on combined regions like when you use "Union" on two regions that are not connected.
So I made a modification for that and thought I would share it back to the community.

Here is the function:

Code - Auto/Visual Lisp: [Select]

1. ;;-----------------------------------;;
2. ;; region->polyline                  ;;
3. ;;-----------------------------------;;
4. ;; Gilles Chanteau - 01/01/07        ;;
5. ;; Small changes by dexus - 14/07/23 ;;
6. ;;-----------------------------------;;
7. (defun region->polyline (ent / n reg norm expl olst blst dlst plst tlst blg space pline prop _arcbulge)
8.   (defun _arcbulge (arc)
9.     (/
10.       (sin (/ (vla-get-TotalAngle arc) 4))
11.       (cos (/ (vla-get-TotalAngle arc) 4))
12.     )
13.   )
14.   (if
15.     (and
16.       (setq reg (cond ((= (type ent) 'vla-object) ent) ((= (type ent) 'ename) (vlax-ename->vla-object ent))))
17.       (= (vla-get-ObjectName reg) "AcDbRegion")
18.     )
19.     (progn
20.       (setq prop (mapcar (function (lambda (p) (vlax-get reg p))) '(Layer LineType Color))
21.             norm (vlax-get reg 'Normal)
22.             expl (vlax-invoke reg 'Explode)
23.             space (vlax-get (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
24.       (cond
25.         ((vl-every (function (lambda (x) (or (= (vla-get-ObjectName x) "AcDbLine") (= (vla-get-ObjectName x) "AcDbArc")))) expl)
26.           (vla-delete reg)
27.           (setq olst (mapcar (function (lambda (x) (list x (vlax-get x 'StartPoint) (vlax-get x 'EndPoint)))) expl))
28.           (while olst
29.             (setq blst nil)
30.             (if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
31.               (setq blst (list (cons 0 (_arcbulge (caar olst)))))
32.             )
33.             (setq plst (cdar olst)
34.                   dlst (list (caar olst))
35.                   olst (cdr olst))
36.             (while (setq tlst (vl-member-if (function (lambda (x) (or (equal (last plst) (cadr x) 1e-9) (equal (last plst) (caddr x) 1e-9)))) olst))
37.               (if (equal (last plst) (caddar tlst) 1e-9)
38.                 (setq blg -1)
39.                 (setq blg 1)
40.               )
41.               (if (= (vla-get-ObjectName (caar tlst)) "AcDbArc")
42.                 (setq blst (cons (cons (1- (length plst)) (* blg (_arcbulge (caar tlst)))) blst))
43.               )
44.               (setq plst
45.                       (append plst
46.                         (if (minusp blg)
47.                           (list (cadar tlst))
48.                           (list (caddar tlst))
49.                         )
50.                       )
51.                     dlst (cons (caar tlst) dlst)
52.                     olst (vl-remove (car tlst) olst))
53.             )
54.             (setq pline (vlax-invoke space 'addLightWeightPolyline (apply 'append (mapcar (function (lambda (x) (setq x (trans x 0 Norm)) (list (car x) (cadr x)))) (reverse (cdr (reverse plst)))))))
55.             (vla-put-Closed pline :vlax-true)
56.             (mapcar (function (lambda (x) (vla-setBulge pline (car x) (cdr x)))) blst)
57.             (vla-put-Elevation pline (caddr (trans (car plst) 0 Norm)))
58.             (vla-put-Normal pline (vlax-3d-point Norm))
59.             (mapcar (function (lambda (p v) (vlax-put pline p v))) '(Layer LineType Color) prop)
60.             (mapcar 'vla-delete dlst)
61.           )
62.           (if pline (list pline))
63.         )
64.         ((vl-every (function (lambda (x) (= (vla-get-ObjectName x) "AcDbRegion"))) expl)
65.           (vla-delete reg)
66.           (apply 'append (mapcar 'region->polyline expl))
67.         )
68.         ((mapcar 'vla-delete dlst))
69.       )
70.     )
71.   )
72. )

Could be used like this:

Code - Auto/Visual Lisp: [Select]

1. ;; Active Document - Lee Mac
2. ;; Returns the VLA Active Document Object
3. (defun LM:acdoc nil
4.   (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
5.   (LM:acdoc)
6. )
7.  
8. ;; SelectionSet -> VLA Objects - by Lee Mac
9. (defun LM:ss->vla ( ss / i l )
10.   (if ss
11.     (repeat (setq i (sslength ss))
12.       (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
13.     )
14.   )
15. )
16.  
17. (defun c:r2pl nil
18.   (mapcar 'region->polyline (lm:ss->vla (ssget '((0 . "REGION")))))
19.   (princ)
20. )

[ribarm]

@dexus,
I've found some lacks in your posted code, so I corrected them...
I hope that now it should perform well...

Code - Auto/Visual Lisp: [Select]

1. (defun c:r2pl ( / LM:ss->vla LM:acdoc region->polyline )
2.  
3.   ;; SelectionSet -> VLA Objects - by Lee Mac
4.   (defun LM:ss->vla ( ss / i l )
5.     (if ss
6.       (repeat (setq i (sslength ss))
7.         (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
8.       )
9.     )
10.   )
11.  
12.   ;; Active Document  -  Lee Mac
13.   ;; Returns the VLA Active Document Object
14.    
15.   (defun LM:acdoc nil
16.     (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
17.     (LM:acdoc)
18.   )
19.  
20.   ;;-----------------------------------;;
21.   ;; region->polyline                  ;;
22.   ;;-----------------------------------;;
23.   ;; Gilles Chanteau - 01/01/07        ;;
24.   ;; Small changes by dexus - 14/07/23 ;;
25.   ;;-----------------------------------;;
26.   (defun region->polyline (ent / n reg norm expl olst blst dlst plst tlst blg space pline prop alst mlst mp pos _arcbulge)
27.     (defun _arcbulge (arc)
28.       (/
29.         (sin (/ (vla-get-TotalAngle arc) 4))
30.         (cos (/ (vla-get-TotalAngle arc) 4))
31.       )
32.     )
33.     (if
34.       (and
35.         (setq reg (cond ((= (type ent) 'vla-object) ent) ((= (type ent) 'ename) (vlax-ename->vla-object ent))))
36.         (= (vla-get-ObjectName reg) "AcDbRegion")
37.       )
38.       (progn
39.         (setq prop (mapcar (function (lambda (p) (vlax-get reg p))) '(Layer LineType Color))
40.               norm (vlax-get reg 'Normal)
41.               expl (vlax-invoke reg 'Explode)
42.               space (vlax-get (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
43.         (cond
44.           ((vl-every (function (lambda (x) (or (= (vla-get-ObjectName x) "AcDbLine") (= (vla-get-ObjectName x) "AcDbArc")))) expl)
45.             (vla-delete reg)
46.             (setq olst (mapcar (function (lambda (x) (list x (vlax-get x 'StartPoint) (vlax-get x 'EndPoint)))) expl))
47.             (while olst
48.               (setq blst nil)
49.               (if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
50.                 (setq blst (list (cons 0 (_arcbulge (caar olst)))))
51.               )
52.               (setq plst (cdar olst)
53.                     dlst (list (caar olst))
54.                     olst (cdr olst))
55.               (while (setq tlst (vl-member-if (function (lambda (x) (or (equal (last plst) (cadr x) 1e-9) (equal (last plst) (caddr x) 1e-9)))) olst))
56.                 (if (equal (last plst) (caddar tlst) 1e-9)
57.                   (setq blg -1)
58.                   (setq blg 1)
59.                 )
60.                 (if (= (vla-get-ObjectName (caar tlst)) "AcDbArc")
61.                   (setq blst (cons (cons (1- (length plst)) (* blg (_arcbulge (caar tlst)))) blst))
62.                 )
63.                 (setq plst
64.                         (append plst
65.                           (if (minusp blg)
66.                             (list (cadar tlst))
67.                             (list (caddar tlst))
68.                           )
69.                         )
70.                       dlst (cons (caar tlst) dlst)
71.                       olst (vl-remove (car tlst) olst))
72.               )
73.               (setq pline (vlax-invoke space 'addLightWeightPolyline (apply 'append (mapcar (function (lambda (x) (setq x (trans x 0 Norm)) (list (car x) (cadr x)))) (reverse (cdr (reverse plst)))))))
74.               (vla-put-Closed pline :vlax-true)
75.               (vla-put-Elevation pline (caddr (trans (car plst) 0 Norm)))
76.               (vla-put-Normal pline (vlax-3d-point Norm))
77.               (setq alst (vl-remove-if-not (function (lambda (x) (= (vla-get-ObjectName x) "AcDbArc"))) dlst))
78.               (setq mlst (mapcar (function (lambda (x) (vlax-curve-GetPointAtParam x (/ (+ (vlax-curve-GetStartParam x) (vlax-curve-GetEndParam x)) 2.0)))) alst))
79.               (mapcar (function (lambda (x) (vla-setBulge pline (car x) (cdr x)))) blst)
80.               (while (setq mp (vl-some (function (lambda (x) (if (not (vlax-curve-GetParamAtPoint pline x)) x))) mlst))
81.                 (setq pos (vl-position mp mlst))
82.                 (vla-SetBulge pline (car (nth pos blst)) (- (cdr (nth pos blst))))
83.                 (setq mp nil)
84.               )
85.               (mapcar (function (lambda (p v) (vlax-put pline p v))) '(Layer LineType Color) prop)
86.               (mapcar 'vla-delete dlst)
87.             )
88.             (if pline (list pline))
89.           )
90.           ((vl-every (function (lambda (x) (= (vla-get-ObjectName x) "AcDbRegion"))) expl)
91.             (vla-delete reg)
92.             (apply 'append (mapcar 'region->polyline expl))
93.           )
94.           ((mapcar 'vla-delete dlst))
95.         )
96.       )
97.     )
98.   )
99.  
100.   (mapcar 'region->polyline (lm:ss->vla (ssget "_:L" '((0 . "REGION")))))
101.   (princ)
102. )
103.  

Regards, M.R.

[ScottMC]

Boundary [selective]?

[dexus]

@dexus,
I've found some lacks in your posted code, so I corrected them...
I hope that now it should perform well...

Code - Auto/Visual Lisp: [Select]

1. (defun c:r2pl ( / LM:ss->vla LM:acdoc region->polyline )
2.  
3.   ;; SelectionSet -> VLA Objects - by Lee Mac
4.   (defun LM:ss->vla ( ss / i l )
5.     (if ss
6.       (repeat (setq i (sslength ss))
7.         (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
8.       )
9.     )
10.   )
11.  
12.   ;; Active Document  -  Lee Mac
13.   ;; Returns the VLA Active Document Object
14.    
15.   (defun LM:acdoc nil
16.     (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
17.     (LM:acdoc)
18.   )
19.  
20.   ;;-----------------------------------;;
21.   ;; region->polyline                  ;;
22.   ;;-----------------------------------;;
23.   ;; Gilles Chanteau - 01/01/07        ;;
24.   ;; Small changes by dexus - 14/07/23 ;;
25.   ;;-----------------------------------;;
26.   (defun region->polyline (ent / n reg norm expl olst blst dlst plst tlst blg space pline prop alst mlst mp pos _arcbulge)
27.     (defun _arcbulge (arc)
28.       (/
29.         (sin (/ (vla-get-TotalAngle arc) 4))
30.         (cos (/ (vla-get-TotalAngle arc) 4))
31.       )
32.     )
33.     (if
34.       (and
35.         (setq reg (cond ((= (type ent) 'vla-object) ent) ((= (type ent) 'ename) (vlax-ename->vla-object ent))))
36.         (= (vla-get-ObjectName reg) "AcDbRegion")
37.       )
38.       (progn
39.         (setq prop (mapcar (function (lambda (p) (vlax-get reg p))) '(Layer LineType Color))
40.               norm (vlax-get reg 'Normal)
41.               expl (vlax-invoke reg 'Explode)
42.               space (vlax-get (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
43.         (cond
44.           ((vl-every (function (lambda (x) (or (= (vla-get-ObjectName x) "AcDbLine") (= (vla-get-ObjectName x) "AcDbArc")))) expl)
45.             (vla-delete reg)
46.             (setq olst (mapcar (function (lambda (x) (list x (vlax-get x 'StartPoint) (vlax-get x 'EndPoint)))) expl))
47.             (while olst
48.               (setq blst nil)
49.               (if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
50.                 (setq blst (list (cons 0 (_arcbulge (caar olst)))))
51.               )
52.               (setq plst (cdar olst)
53.                     dlst (list (caar olst))
54.                     olst (cdr olst))
55.               (while (setq tlst (vl-member-if (function (lambda (x) (or (equal (last plst) (cadr x) 1e-9) (equal (last plst) (caddr x) 1e-9)))) olst))
56.                 (if (equal (last plst) (caddar tlst) 1e-9)
57.                   (setq blg -1)
58.                   (setq blg 1)
59.                 )
60.                 (if (= (vla-get-ObjectName (caar tlst)) "AcDbArc")
61.                   (setq blst (cons (cons (1- (length plst)) (* blg (_arcbulge (caar tlst)))) blst))
62.                 )
63.                 (setq plst
64.                         (append plst
65.                           (if (minusp blg)
66.                             (list (cadar tlst))
67.                             (list (caddar tlst))
68.                           )
69.                         )
70.                       dlst (cons (caar tlst) dlst)
71.                       olst (vl-remove (car tlst) olst))
72.               )
73.               (setq pline (vlax-invoke space 'addLightWeightPolyline (apply 'append (mapcar (function (lambda (x) (setq x (trans x 0 Norm)) (list (car x) (cadr x)))) (reverse (cdr (reverse plst)))))))
74.               (vla-put-Closed pline :vlax-true)
75.               (vla-put-Elevation pline (caddr (trans (car plst) 0 Norm)))
76.               (vla-put-Normal pline (vlax-3d-point Norm))
77.               (setq alst (vl-remove-if-not (function (lambda (x) (= (vla-get-ObjectName x) "AcDbArc"))) dlst))
78.               (setq mlst (mapcar (function (lambda (x) (vlax-curve-GetPointAtParam x (/ (+ (vlax-curve-GetStartParam x) (vlax-curve-GetEndParam x)) 2.0)))) alst))
79.               (mapcar (function (lambda (x) (vla-setBulge pline (car x) (cdr x)))) blst)
80.               (while (setq mp (vl-some (function (lambda (x) (if (not (vlax-curve-GetParamAtPoint pline x)) x))) mlst))
81.                 (setq pos (vl-position mp mlst))
82.                 (vla-SetBulge pline (car (nth pos blst)) (- (cdr (nth pos blst))))
83.                 (setq mp nil)
84.               )
85.               (mapcar (function (lambda (p v) (vlax-put pline p v))) '(Layer LineType Color) prop)
86.               (mapcar 'vla-delete dlst)
87.             )
88.             (if pline (list pline))
89.           )
90.           ((vl-every (function (lambda (x) (= (vla-get-ObjectName x) "AcDbRegion"))) expl)
91.             (vla-delete reg)
92.             (apply 'append (mapcar 'region->polyline expl))
93.           )
94.           ((mapcar 'vla-delete dlst))
95.         )
96.       )
97.     )
98.   )
99.  
100.   (mapcar 'region->polyline (lm:ss->vla (ssget "_:L" '((0 . "REGION")))))
101.   (princ)
102. )
103.  

Regards, M.R.

Thanks for the addition Marko.
Could you explain what the change does?
As far as I can tell you get all the midpoints of arcs, and if they do not exist on the polyline you try flip the bulge.

Edit: The while loop sets mp to the output of vl-some. Which will return T or Nil.
Then tries to find the vl-position of T, which will not exist in mlst returning Nil.
And Nil is not a valid argument for nth.
So when it does find a arc that is flipped the wrong way, it will return a bad argument type error.

[dexus]

Boundary [selective]?

I'm not sure if I'm not using the boundary function incorrectly, but I cant seem to get it to work when the lines are not flat on the ucs.

[ribarm]

So when it does find a arc that is flipped the wrong way, it will return a bad argument type error.

So when it does find a arc that is flipped the wrong way, it'll flip it with negative bulge right way...

[dexus]

So when it does find a arc that is flipped the wrong way, it will return a bad argument type error.

So when it does find a arc that is flipped the wrong way, it'll flip it with negative bulge right way...

How does it know which one?
It does find the arc, but then it saves True to the mp variable.
Because vl-some doesn't return the variable from the lambda function, it only returns True or Nil.
Which doesn't have a position in mlst, therefore it doesn't know which one to flip.
Am I missing something here?

[ribarm]

So when it does find a arc that is flipped the wrong way, it will return a bad argument type error.

So when it does find a arc that is flipped the wrong way, it'll flip it with negative bulge right way...

How does it know which one?
It does find the arc, but then it saves True to the mp variable.
Because vl-some doesn't return the variable from the lambda function, it only returns True or Nil.
Which doesn't have a position in mlst, therefore it doesn't know which one to flip.
Am I missing something here?

Yes, you are missing the fact that (vl-some) not always return T or nil... In our particular case it returns variable mp which is mid point of exploded arc...
So if polyline at some position where is placed arc don't have parameter at mp - meaning that exploded arc don't pass - overlap with pline, at that position bulge should be negative from that that was calculated through (_arcbulge) sub...