Jump to content

Lisp for diagonal lines for selected rectangles


structo

Recommended Posts

A few points to note:

 

Note that the following filter will exclude closed polylines with linetype generation enabled (since DXF group 70 is bit-coded):

 

(ssget (list (cons 0 "LWPOLYLINE")(cons 70 1) (cons 90 4)))

 

If an entity name argument is supplied, only the highlighted code will be evaluated (I don't think this is the intention):

 

(defun Rectangle-p ( eo fuzz / eo rtn ) ; Grrr
   (cond
       [highlight]((eq 'ENAME (type eo))
           (setq rtn
               (vl-every '(lambda (x) (member x '((0 . "LWPOLYLINE") (90 . 4) (70 . 1) (42 . 0))))
                   (vl-remove-if-not '(lambda (x) (member (car x) '(0 90 70 42))) (entget eo))
               )
           )
           (setq eo (vlax-ename->vla-object eo)); yes go thru the vla check aswell.
       )[/highlight]
       ((eq 'VLA-OBJECT (type eo))
           (setq rtn
               (and
                   (= "AcDbPolyline" (vla-get-ObjectName eo))
                   (vlax-curve-isClosed eo)
                   (= 4 (vlax-curve-getEndParam eo))
                   (equal ; opposite sides are equal AB-CD, will accept non-curved arcs/bulges
                       (apply '- (mapcar '(lambda (x) (vlax-curve-getDistAtParam eo x)) '(1 0)))
                       (apply '- (mapcar '(lambda (x) (vlax-curve-getDistAtParam eo x)) '(3 2)))
                       fuzz
                   )
                   (equal  ; opposite sides are equal BC-AD, will accept non-curved arcs/bulges
                       (apply '- (mapcar '(lambda (x) (vlax-curve-getDistAtParam eo x)) '(2 1)))
                       (apply '- (mapcar '(lambda (x) (vlax-curve-getDistAtParam eo x)) '(4 3)))
                       fuzz
                   )
                   (equal ; diagonals are eq length (not romboid) dist A C = dist B D
                       (apply 'distance (mapcar '(lambda (x) (vlax-curve-getPointAtParam eo x)) '(1 3)))
                       (apply 'distance (mapcar '(lambda (x) (vlax-curve-getPointAtParam eo x)) '(2 4)))
                       fuzz
                   )
               )
           )    
       )
       (T nil)
   )
   rtn
)

Link to comment
Share on other sites

A few points to note:

Note that the following filter will exclude closed polylines with linetype generation enabled (since DXF group 70 is bit-coded):

Thanks Lee,

With the risk to sound stupid, how do you know what bits exactly to use, I mean in the DXF Reference is only described this:

70 Polyline flag (bit-coded); default is 0:

1 = Closed; 128 = Plinegen

But I've seen sometimes you use (70 . 80), and sometimes 3 digits per bit for other GCs.

 

If an entity name argument is supplied, only the highlighted code will be evaluated (I don't think this is the intention):

I really tried to inspect this issue in VLIDE, stepping thru the evaluations [F8],

but when it gets up to the (entget eo) evaluation, VLIDE opens up some Source #1 page and displays this:

;;; Copied to window at 10:45 PM 11/23/16

(LAMBDA (X) (MEMBER (CAR X) (QUOTE (0 90 70 42))))

;;; End of text

And seems to stop, so I cannot see what evaluates further (is there a way to go thru this? - dummy question #2).

Link to comment
Share on other sites

Thanks Lee,

With the risk to sound stupid, how do you know what bits exactly to use, I mean in the DXF Reference is only described this:

70 Polyline flag (bit-coded); default is 0:

1 = Closed; 128 = Plinegen

But I've seen sometimes you use (70 . 80), and sometimes 3 digits per bit for other GCs.

 

DXF group 70 has indeed only two meaningful bit codes for an LWPolyline; perhaps you are thinking of a 2D (heavy) polyline?

 

I really tried to inspect this issue in VLIDE, stepping thru the evaluations [F8],

but when it gets up to the (entget eo) evaluation, VLIDE opens up some Source #1 page and displays this:

;;; Copied to window at 10:45 PM 11/23/16

(LAMBDA (X) (MEMBER (CAR X) (QUOTE (0 90 70 42))))

;;; End of text

And seems to stop, so I cannot see what evaluates further (is there a way to go thru this? - dummy question #2).

 

You can declare the lambda expression as a function using the function function:

(vl-remove-if-not (function (lambda (x) (member (car x) '(0 90 70 42)))) (entget eo))

But in my opinion, it is easier to use the 'Animate' option offered by the Visual LISP IDE, with an appropriate animation delay (set under Tools > Environment Options > General Options > Diagnostic > Animation delay).

Link to comment
Share on other sites

Another way back to co-ords, did not expect all the zero length lines but it would be easy here (setq co-ordsxy (cons xy co-ordsxy))

to add a check compare new point to the last and if same skip the cons.

Link to comment
Share on other sites

Interesting thread. Even for none "lispers" like myself. :)

Good work coders!

 

I am curious, would it be possible to create just one diagonal in each of the multiple selection of rectangles?

Possibly by stating the corner where the diagonal line originates from, for example "Bottom Left Hand" or "Bottom Right Hand"?

Link to comment
Share on other sites

DXF group 70 has indeed only two meaningful bit codes for an LWPolyline; perhaps you are thinking of a 2D (heavy) polyline?

I'll try to work on my drawbacks, maybe I have to do a list where I'm performing badly - oh the irony.

Like bit-handling, ssget filter list operators, wcmatch, dictionaries.

 

You can declare the lambda expression as a function using the function function:

(vl-remove-if-not (function (lambda (x) (member (car x) '(0 90 70 42)))) (entget eo))

But in my opinion, it is easier to use the 'Animate' option offered by the Visual LISP IDE, with an appropriate animation delay (set under Tools > Environment Options > General Options > Diagnostic > Animation delay).

It worked, thats a handy info on apostrophe vs function.

Thank you Lee, you're the best!

Link to comment
Share on other sites

Manilla wolf if you look at what I posted it draws 2 lines you could at the point of drawing the 1st line zoom in and ask is this correct press or any key and keep or draw the second line. See code below.

 

The second method a bit more complex would need to work out which point is lower left and use that bearing in mind that a pline can exist clockwise or anticlockwise so the need to compare the two diagonal corner points not 1. You can sort a list of points to find the minimum answer which would be lower left.

 

This is a starting point, the code could be expanded for do 1, 2, 1 horizontal, 1 vertical, 2 hor & vert, do 4. It does not have the check for zero length lines as per sample dwg.

 

; pline co-ords example
; By Alan H
(defun getcoords (ent)
 (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property
   (vlax-ename->vla-object ent)
   "Coordinates"
     )
   )
 )
)

(defun co-ords2xy ()
; convert now to a list of xy as co-ords are x y x y x y if 3d x y z x y z
(setq len (length co-ords))
(setq numb (/ len 2)) ; even and odd check required
(setq I 0)
(repeat numb
(setq xy (list (nth i co-ords)(nth (+ I 1) co-ords) ))
; odd (setq xy (list (nth i co-ords)(nth (+ I 1) co-ords)(nth (+ I 2) co-ords) ))
(setq co-ordsxy (cons xy co-ordsxy))
(setq I (+ I 2))
)
)
; program starts here
; change the entsel to a ssget and use repeat for multiple rectangs version 2
(setq co-ords (getcoords (car (entsel "\nplease pick pline"))))
(co-ords2xy) ; list of 2d points making pline

; add a second option here for single line or 2 lines
(command "line" (nth 0 co-ordsxy )(nth 2 co-ordsxy ) "")
(command "zoom" "c" (nth 0 co-ordsxy ) 100)
(setq ans (getstring "is this correct <cr> for ok any other key for no"))
(if (= ans nil)
(princ)
(progn
(command "erase" (entlast) "")
(command "line" (nth 1 co-ordsxy )(nth 3 co-ordsxy ) "")
)
)

Edited by BIGAL
Link to comment
Share on other sites

Thank you BIGAL. I appreciate your contribution.

 

I comprehend your explanation and logic. You have highlighted that there are many parameters to take into account.

I did get the code to successfully work on a single rectangle. Indeed it worked well.

It may be a little inefficient if adapted to work for multiple rectangles.

 

I can certainly learn from you code.

 

Cheers.

Link to comment
Share on other sites

If your doing multiple rectangs as i posted

 

; change the entsel to a ssget and use repeat for multiple rectangs version 2

 

Have a go at changing the code

hint
(setq ss (ssget))
(repeat (setq x (sslength ss))
(setq co-ords (getcoords (ssname ss (setq x (- x 1)))))
(co-ords2xy) ; list of 2d points making pline

..........

Link to comment
Share on other sites

If your doing multiple rectangs as i posted

 

; change the entsel to a ssget and use repeat for multiple rectangs version 2

 

Have a go at changing the code

hint
(setq ss (ssget))
(repeat (setq x (sslength ss))
(setq co-ords (getcoords (ssname ss (setq x (- x 1)))))
(co-ords2xy) ; list of 2d points making pline

..........

 

 

Thanks BIGAL. Unfortunately, it's a little beyond my capabilities.

 

For reference this is what I tried.

 

; pline co-ords example
; By Alan H
(defun getcoords (ent)
 (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property
   (vlax-ename->vla-object ent)
   "Coordinates"
     )
   )
 )
)

(defun co-ords2xy ()
; convert now to a list of xy as co-ords are x y x y x y if 3d x y z x y z
(setq len (length co-ords))
(setq numb (/ len 2)) ; even and odd check required
(setq I 0)
(repeat numb
(setq xy (list (nth i co-ords)(nth (+ I 1) co-ords) ))
; odd (setq xy (list (nth i co-ords)(nth (+ I 1) co-ords)(nth (+ I 2) co-ords) ))
(setq co-ordsxy (cons xy co-ordsxy))
(setq I (+ I 2))
)
)
; program starts here
; change the entsel to a ssget and use repeat for multiple rectangs version 2
(setq co-ords (getcoords (car (entsel "\nplease pick pline"))))
(co-ords2xy) ; list of 2d points making pline

; add a second option here for single line or 2 lines
(command "line" (nth 0 co-ordsxy )(nth 2 co-ordsxy ) "")
(command "zoom" "c" (nth 0 co-ordsxy ) 100)
(setq ans (getstring "is this correct <cr> for ok any other key for no"))
(if (= ans nil)
(princ)
(progn
(command "erase" (entlast) "")
(command "line" (nth 1 co-ordsxy )(nth 3 co-ordsxy ) "")
)
)

Link to comment
Share on other sites

Manila Wolf said:
Interesting thread. Even for none "lispers" like myself. :)

Good work coders!

 

Thank you :)

 

Manila Wolf said:
I am curious, would it be possible to create just one diagonal in each of the multiple selection of rectangles?

Possibly by stating the corner where the diagonal line originates from, for example "Bottom Left Hand" or "Bottom Right Hand"?

 

Consider the following:

(defun c:rdia ( )
   (initget "BLTR TLBR Both")
   (rdia (vl-position (cond ((getkword "\nConstruct diagonal [bLTR/TLBR/Both] <Both>: "))("Both")) '(nil "BLTR" "TLBR" "Both")))
   (princ)
)
(defun rdia ( bit / ent enx idx lne lst sel zco )
   (if
       (setq sel
           (ssget
              '(   (00 . "LWPOLYLINE")
                   (90 . 4)
                   (-4 . "&=")   (70 . 1)
                   (-4 . "<NOT") (-4 . "<>") (42 . 0.0) (-4 . "NOT>")
               )
           )
       )
       (repeat (setq idx (sslength sel))
           (setq ent (ssname sel (setq idx (1- idx)))
                 enx (entget ent)
                 lst (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
           )
           (if (and (equal (distance (car  lst) (cadr  lst)) (distance (caddr lst) (cadddr lst)) 1e-8)
                    (equal (distance (cadr lst) (caddr lst)) (distance (car   lst) (cadddr lst)) 1e-8)
                    (equal (distance (car  lst) (caddr lst)) (distance (cadr  lst) (cadddr lst)) 1e-8)
               )
               (progn
                   (repeat
                       (car
                           (vl-sort-i lst
                              '(lambda ( a b )
                                   (if (equal (cadr a) (cadr b) 1e-8)
                                       (< (car  a) (car  b))
                                       (< (cadr a) (cadr b))
                                   )
                               )
                           )
                       )
                       (setq lst (append (cdr lst) (list (car lst))))
                   )
                   (setq zco (cdr (assoc 38 enx))
                         lne
                       (lambda ( a b )
                           (entmake
                               (list
                                   '(0 . "LINE")
                                    (cons 10 (trans (append a (list zco)) ent 0))
                                    (cons 11 (trans (append b (list zco)) ent 0))
                               )
                           )
                       )
                   )
                   (if (= 1 (logand 1 bit)) (lne (car  lst) (caddr  lst)))
                   (if (= 2 (logand 2 bit)) (lne (cadr lst) (cadddr lst)))
               )
           )
       )
   )
)
(princ)
 
Edited by Lee Mac
Link to comment
Share on other sites

Consider the following:

 

I don't want to sound picky, but from the user's perspective might be more preferable tabbing thru the options with grread.

Similar to:

;; MLeader Arrowhead Toggle - Lee Mac

;)

Link to comment
Share on other sites

Thank you :)

 

 

 

Consider the following:

([color=BLUE]defun[/color] c:rdia ( )
   ([color=BLUE]initget[/color] [color=MAROON]"BLTR TLBR Both"[/color])
   (rdia ([color=BLUE]vl-position[/color] ([color=BLUE]cond[/color] (([color=BLUE]getkword[/color] [color=MAROON]"\nConstruct diagonal [bLTR/TLBR/Both] <Both>: "[/color]))([color=MAROON]"Both"[/color])) '([color=BLUE]nil[/color] [color=MAROON]"BLTR"[/color] [color=MAROON]"TLBR"[/color] [color=MAROON]"Both"[/color])))
   ([color=BLUE]princ[/color])
)
([color=BLUE]defun[/color] rdia ( bit [color=BLUE]/[/color] ent enx idx lne lst sel zco )
   ([color=BLUE]if[/color]
       ([color=BLUE]setq[/color] sel
           ([color=BLUE]ssget[/color]
              '(   (00 . [color=MAROON]"LWPOLYLINE"[/color])
                   (90 . 4)
                   (-4 . [color=MAROON]"&="[/color])   (70 . 1)
                   (-4 . [color=MAROON]"<NOT"[/color]) (-4 . [color=MAROON]"<>"[/color]) (42 . 0.0) (-4 . [color=MAROON]"NOT>"[/color])
               )
           )
       )
       ([color=BLUE]repeat[/color] ([color=BLUE]setq[/color] idx ([color=BLUE]sslength[/color] sel))
           ([color=BLUE]setq[/color] ent ([color=BLUE]ssname[/color] sel ([color=BLUE]setq[/color] idx ([color=BLUE]1-[/color] idx)))
                 enx ([color=BLUE]entget[/color] ent)
                 lst ([color=BLUE]mapcar[/color] '[color=BLUE]cdr[/color] ([color=BLUE]vl-remove-if-not[/color] '([color=BLUE]lambda[/color] ( x ) ([color=BLUE]=[/color] 10 ([color=BLUE]car[/color] x))) enx))
           )
           ([color=BLUE]if[/color] ([color=BLUE]and[/color] ([color=BLUE]equal[/color] ([color=BLUE]distance[/color] ([color=BLUE]car[/color]  lst) ([color=BLUE]cadr[/color]  lst)) ([color=BLUE]distance[/color] ([color=BLUE]caddr[/color] lst) ([color=BLUE]cadddr[/color] lst)) 1e-
                    ([color=BLUE]equal[/color] ([color=BLUE]distance[/color] ([color=BLUE]cadr[/color] lst) ([color=BLUE]caddr[/color] lst)) ([color=BLUE]distance[/color] ([color=BLUE]car[/color]   lst) ([color=BLUE]cadddr[/color] lst)) 1e-
                    ([color=BLUE]equal[/color] ([color=BLUE]distance[/color] ([color=BLUE]car[/color]  lst) ([color=BLUE]caddr[/color] lst)) ([color=BLUE]distance[/color] ([color=BLUE]cadr[/color]  lst) ([color=BLUE]cadddr[/color] lst)) 1e-
               )
               ([color=BLUE]progn[/color]
                   ([color=BLUE]repeat[/color]
                       ([color=BLUE]car[/color]
                           ([color=BLUE]vl-sort-i[/color] lst
                              '([color=BLUE]lambda[/color] ( a b )
                                   ([color=BLUE]if[/color] ([color=BLUE]equal[/color] ([color=BLUE]cadr[/color] a) ([color=BLUE]cadr[/color] b) 1e-
                                       ([color=BLUE]<[/color] ([color=BLUE]car[/color]  a) ([color=BLUE]car[/color]  b))
                                       ([color=BLUE]<[/color] ([color=BLUE]cadr[/color] a) ([color=BLUE]cadr[/color] b))
                                   )
                               )
                           )
                       )
                       ([color=BLUE]setq[/color] lst ([color=BLUE]append[/color] ([color=BLUE]cdr[/color] lst) ([color=BLUE]list[/color] ([color=BLUE]car[/color] lst))))
                   )
                   ([color=BLUE]setq[/color] zco ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 38 enx))
                         lne
                       ([color=BLUE]lambda[/color] ( a b )
                           ([color=BLUE]entmake[/color]
                               ([color=BLUE]list[/color]
                                   '(0 . [color=MAROON]"LINE"[/color])
                                    ([color=BLUE]cons[/color] 10 ([color=BLUE]trans[/color] ([color=BLUE]append[/color] a ([color=BLUE]list[/color] zco)) ent 0))
                                    ([color=BLUE]cons[/color] 11 ([color=BLUE]trans[/color] ([color=BLUE]append[/color] b ([color=BLUE]list[/color] zco)) ent 0))
                               )
                           )
                       )
                   )
                   ([color=BLUE]if[/color] ([color=BLUE]=[/color] 1 ([color=BLUE]logand[/color] 1 bit)) (lne ([color=BLUE]car[/color]  lst) ([color=BLUE]caddr[/color]  lst)))
                   ([color=BLUE]if[/color] ([color=BLUE]=[/color] 2 ([color=BLUE]logand[/color] 2 bit)) (lne ([color=BLUE]cadr[/color] lst) ([color=BLUE]cadddr[/color] lst)))
               )
           )
       )
   )
)
([color=BLUE]princ[/color])

 

Lee, that's amazing.

 

For my own scenario it's perfect. I do not need to consider rotated rectangles.

I tried the code on over 100 rectangles and it worked very well and very quickly.

 

Thank you Lee.

(I call you SuperMac. Do you wear your Y Fronts outside your trousers? :D)

Link to comment
Share on other sites

I don't want to sound picky, but from the user's perspective might be more preferable tabbing thru the options with grread.

;)

 

A nice idea Grrr.

 

Lee, that's amazing.

 

For my own scenario it's perfect. I do not need to consider rotated rectangles.

I tried the code on over 100 rectangles and it worked very well and very quickly.

 

Thank you Lee.

 

Thanks Manila Wolf, I'm pleased the program is working well :thumbsup:

 

(I call you SuperMac. Do you wear your Y Fronts outside your trousers? :D)

 

Only when writing code...! :lol:

Link to comment
Share on other sites

  • 1 year later...
Thank you :)

 

 

 

Consider the following:

([color=BLUE]defun[/color] c:rdia ( )
   ([color=BLUE]initget[/color] [color=MAROON]"BLTR TLBR Both"[/color])
   (rdia ([color=BLUE]vl-position[/color] ([color=BLUE]cond[/color] (([color=BLUE]getkword[/color] [color=MAROON]"\nConstruct diagonal [bLTR/TLBR/Both] <Both>: "[/color]))([color=MAROON]"Both"[/color])) '([color=BLUE]nil[/color] [color=MAROON]"BLTR"[/color] [color=MAROON]"TLBR"[/color] [color=MAROON]"Both"[/color])))
   ([color=BLUE]princ[/color])
)
([color=BLUE]defun[/color] rdia ( bit [color=BLUE]/[/color] ent enx idx lne lst sel zco )
   ([color=BLUE]if[/color]
       ([color=BLUE]setq[/color] sel
           ([color=BLUE]ssget[/color]
              '(   (00 . [color=MAROON]"LWPOLYLINE"[/color])
                   (90 . 4)
                   (-4 . [color=MAROON]"&="[/color])   (70 . 1)
                   (-4 . [color=MAROON]"<NOT"[/color]) (-4 . [color=MAROON]"<>"[/color]) (42 . 0.0) (-4 . [color=MAROON]"NOT>"[/color])
               )
           )
       )
       ([color=BLUE]repeat[/color] ([color=BLUE]setq[/color] idx ([color=BLUE]sslength[/color] sel))
           ([color=BLUE]setq[/color] ent ([color=BLUE]ssname[/color] sel ([color=BLUE]setq[/color] idx ([color=BLUE]1-[/color] idx)))
                 enx ([color=BLUE]entget[/color] ent)
                 lst ([color=BLUE]mapcar[/color] '[color=BLUE]cdr[/color] ([color=BLUE]vl-remove-if-not[/color] '([color=BLUE]lambda[/color] ( x ) ([color=BLUE]=[/color] 10 ([color=BLUE]car[/color] x))) enx))
           )
           ([color=BLUE]if[/color] ([color=BLUE]and[/color] ([color=BLUE]equal[/color] ([color=BLUE]distance[/color] ([color=BLUE]car[/color]  lst) ([color=BLUE]cadr[/color]  lst)) ([color=BLUE]distance[/color] ([color=BLUE]caddr[/color] lst) ([color=BLUE]cadddr[/color] lst)) 1e-
                    ([color=BLUE]equal[/color] ([color=BLUE]distance[/color] ([color=BLUE]cadr[/color] lst) ([color=BLUE]caddr[/color] lst)) ([color=BLUE]distance[/color] ([color=BLUE]car[/color]   lst) ([color=BLUE]cadddr[/color] lst)) 1e-
                    ([color=BLUE]equal[/color] ([color=BLUE]distance[/color] ([color=BLUE]car[/color]  lst) ([color=BLUE]caddr[/color] lst)) ([color=BLUE]distance[/color] ([color=BLUE]cadr[/color]  lst) ([color=BLUE]cadddr[/color] lst)) 1e-
               )
               ([color=BLUE]progn[/color]
                   ([color=BLUE]repeat[/color]
                       ([color=BLUE]car[/color]
                           ([color=BLUE]vl-sort-i[/color] lst
                              '([color=BLUE]lambda[/color] ( a b )
                                   ([color=BLUE]if[/color] ([color=BLUE]equal[/color] ([color=BLUE]cadr[/color] a) ([color=BLUE]cadr[/color] b) 1e-
                                       ([color=BLUE]<[/color] ([color=BLUE]car[/color]  a) ([color=BLUE]car[/color]  b))
                                       ([color=BLUE]<[/color] ([color=BLUE]cadr[/color] a) ([color=BLUE]cadr[/color] b))
                                   )
                               )
                           )
                       )
                       ([color=BLUE]setq[/color] lst ([color=BLUE]append[/color] ([color=BLUE]cdr[/color] lst) ([color=BLUE]list[/color] ([color=BLUE]car[/color] lst))))
                   )
                   ([color=BLUE]setq[/color] zco ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 38 enx))
                         lne
                       ([color=BLUE]lambda[/color] ( a b )
                           ([color=BLUE]entmake[/color]
                               ([color=BLUE]list[/color]
                                   '(0 . [color=MAROON]"LINE"[/color])
                                    ([color=BLUE]cons[/color] 10 ([color=BLUE]trans[/color] ([color=BLUE]append[/color] a ([color=BLUE]list[/color] zco)) ent 0))
                                    ([color=BLUE]cons[/color] 11 ([color=BLUE]trans[/color] ([color=BLUE]append[/color] b ([color=BLUE]list[/color] zco)) ent 0))
                               )
                           )
                       )
                   )
                   ([color=BLUE]if[/color] ([color=BLUE]=[/color] 1 ([color=BLUE]logand[/color] 1 bit)) (lne ([color=BLUE]car[/color]  lst) ([color=BLUE]caddr[/color]  lst)))
                   ([color=BLUE]if[/color] ([color=BLUE]=[/color] 2 ([color=BLUE]logand[/color] 2 bit)) (lne ([color=BLUE]cadr[/color] lst) ([color=BLUE]cadddr[/color] lst)))
               )
           )
       )
   )
)
([color=BLUE]princ[/color])

 

what if the rectangles are not perfect, mean to say not exact 90 degree but 89.xx degree and slight variation in length of sides.

 

Thanks in advance.

Link to comment
Share on other sites

what if the rectangles are not perfect, mean to say not exact 90 degree but 89.xx degree and slight variation in length of sides.

 

Thanks in advance.

 

Change 1e-8 fuzz factor to reflect your deviation from correct rectangle shape... I mean change all 1e-8 to some bigger value...

Link to comment
Share on other sites

  • 3 weeks later...
(defun c:diago ( / CC CNTR ENTX I IT LINEPR PL_OBJ PT_LST PT_LST_CNT SSPX)

(setq sspx (ssget (list '(0 . "*POLYLINE"))))

(setq i -1)
(repeat (sslength sspx)
(setq pt_lst nil)
(setq it (ssname sspx (setq i (1+ i))))

(setq entx (entget it))
(setq linepr '())
(if (cdr (assoc 6 entx)) (setq linepr (cons (cons 6 (cdr (assoc 6 entx))) linepr)))
(if (cdr (assoc 8 entx)) (setq linepr (cons (cons 8 (cdr (assoc 8 entx))) linepr)))
(if (cdr (assoc 43 entx)) (setq linepr (cons (cons 43 (cdr (assoc 43 entx))) linepr)))
(if (cdr (assoc 62 entx)) (setq linepr (cons (cons 62 (cdr (assoc 62 entx))) linepr)))


  (setq	pl_obj (vlax-ename->vla-object it) cc (vla-get-Coordinates pl_obj))

  (setq	pt_lst_cnt
		 (/	(length
			  (vlax-safearray->list
				(vlax-variant-value cc)
				)
			  )
			2
			)
		)

  (setq cntr 0)
  (repeat pt_lst_cnt
	(setq pt_lst
				 (cons
				   (append 
				   (vlax-safearray->list
					 (vlax-variant-value (vla-get-Coordinate pl_obj cntr))
					 )
					 (list 0))
				   pt_lst
				   )
		  cntr	 (1+ cntr)
		  )
	)
	
(if (> (length pt_lst) 3)
(progn
(LWPoly (list (nth 0 pt_lst)(nth 2 pt_lst)) linepr)
(LWPoly (list (nth 1 pt_lst)(nth 3 pt_lst)) linepr)
)
)		

);repeat
)


;;;;; By Lee MAC
(defun LWPoly (lst lprx)
(setq ll (list 
                         (cons 0 "LWPOLYLINE")
                         (cons 100 "AcDbEntity")
                         (cons 100 "AcDbPolyline")
                         (cons 90 (length lst))
                   ))

(setq all (append ll lprx )) 
(entmakex (append all (mapcar (function (lambda (p) (cons 10 p))) lst))) 
)

  • Thanks 1
Link to comment
Share on other sites

  • 1 year later...
On 12/28/2017 at 4:33 PM, handasa said:

(defun c:diago ( / CC CNTR ENTX I IT LINEPR PL_OBJ PT_LST PT_LST_CNT SSPX)

(setq sspx (ssget (list '(0 . "*POLYLINE"))))

(setq i -1)
(repeat (sslength sspx)
(setq pt_lst nil)
(setq it (ssname sspx (setq i (1+ i))))

(setq entx (entget it))
(setq linepr '())
(if (cdr (assoc 6 entx)) (setq linepr (cons (cons 6 (cdr (assoc 6 entx))) linepr)))
(if (cdr (assoc 8 entx)) (setq linepr (cons (cons 8 (cdr (assoc 8 entx))) linepr)))
(if (cdr (assoc 43 entx)) (setq linepr (cons (cons 43 (cdr (assoc 43 entx))) linepr)))
(if (cdr (assoc 62 entx)) (setq linepr (cons (cons 62 (cdr (assoc 62 entx))) linepr)))


  (setq	pl_obj (vlax-ename->vla-object it) cc (vla-get-Coordinates pl_obj))

  (setq	pt_lst_cnt
		 (/	(length
			  (vlax-safearray->list
				(vlax-variant-value cc)
				)
			  )
			2
			)
		)

  (setq cntr 0)
  (repeat pt_lst_cnt
	(setq pt_lst
				 (cons
				   (append 
				   (vlax-safearray->list
					 (vlax-variant-value (vla-get-Coordinate pl_obj cntr))
					 )
					 (list 0))
				   pt_lst
				   )
		  cntr	 (1+ cntr)
		  )
	)
	
(if (> (length pt_lst) 3)
(progn
(LWPoly (list (nth 0 pt_lst)(nth 2 pt_lst)) linepr)
(LWPoly (list (nth 1 pt_lst)(nth 3 pt_lst)) linepr)
)
)		

);repeat
)


;;;;; By Lee MAC
(defun LWPoly (lst lprx)
(setq ll (list 
                         (cons 0 "LWPOLYLINE")
                         (cons 100 "AcDbEntity")
                         (cons 100 "AcDbPolyline")
                         (cons 90 (length lst))
                   ))

(setq all (append ll lprx )) 
(entmakex (append all (mapcar (function (lambda (p) (cons 10 p))) lst))) 
)
 

 

I like this.It simple and perfect to use

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...