Lisp for diagonal lines for selected rectangles

November 22, 2016

Hi friends,

i have rectangles and develop diagonal lines for selected rectangles as shown in figure.

Thank you all in advance.

November 22, 2016

You connect every opposite pair of points with line entity... What is here problem? It's simple task... (simpler than this can't be...)

November 22, 2016

Practiced for fun:

(defun C:test ( / SS e i lst )
(if 
	(and
		(princ "\nSelect rectangles to draw their diagonals: ")
		(setq SS (ssget (list (cons 0 "LWPOLYLINE"))))
	)
	(repeat (setq i (sslength SS))
		(setq e (ssname SS (setq i (1- i))))
		(and
			(rectangle-p e 1e-5)
			(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox (list (vlax-ename->vla-object e) 'll 'ur))))
			(setq lst (mapcar 'vlax-safearray->list (list ll ur)))
			(apply 'Line lst)
			(apply 'Line
				(mapcar 'append
					(mapcar 'list (reverse (mapcar 'car lst)))
					(mapcar 'cdr lst)
				)
			)
		)
	)
)
(princ)
) (vl-load-com) (princ)

; Lee Mac
(defun Line (p1 p2)
(entmakex 
	(list 
		(cons 0 "LINE")
		(cons 10 p1)
		(cons 11 p2)
	)
)
)

; Marko Ribar I guess?
(defun rectangle-p ( e f / nobulge-p dpar stp enp ptn k parpts index ptlst rtn)
(if (and e (= (cdr (assoc 0 (entget e))) "LWPOLYLINE"))
	(progn
		(defun nobulge-p ( e i f ) (apply 'and (mapcar '(lambda (x) (equal (vla-getbulge e x) 0.0 f)) i)))
		(setq dpar (/ (+ (abs (setq enp (vlax-curve-getendparam e))) (abs (setq stp (vlax-curve-getstartparam e)))) (setq ptn (cdr (assoc 90 (entget e))))))
		(setq k -1.0)
		(repeat ptn (setq parpts (append parpts (setq parpts (list (+ stp (* (setq k (1+ k)) dpar)))))))
		(setq k -1)
		(repeat ptn (setq index (append index (setq index (list (setq k (1+ k)))))))
		(setq ptlst (mapcar '(lambda (x) (vlax-curve-getpointatparam e x)) parpts))
		(setq rtn
			(and
				(eq ptn 4)
				(nobulge-p (if (eq (type e) 'ENAME) (vlax-ename->vla-object e) e) index f)
				(equal (distance (nth 0 ptlst) (nth 1 ptlst)) (distance (nth 2 ptlst) (nth 3 ptlst)) f)
				(equal (distance (nth 1 ptlst) (nth 2 ptlst)) (distance (nth 3 ptlst) (nth 0 ptlst)) f)
				(equal (distance (nth 0 ptlst) (nth 2 ptlst)) (distance (nth 1 ptlst) (nth 3 ptlst)) f)
			)
		)
	)
)
rtn
); defun rectangle-p

EDIT: Won't work for rectangles with rotation other than 0 90 180 270 360 degrees.

Edited November 23, 2016 by Grrr

November 22, 2016

Grr

Need to consider "other" rectangles.

November 22, 2016

Another:

(defun c:rdia ( / ent idx pt1 pt2 pt3 pt4 sel )
   (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))))
           (mapcar
              '(lambda ( a b ) (set b (trans (cdr a) ent 0)))
               (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ent))
              '(pt1 pt2 pt3 pt4)
           )
           (if (and (equal (distance pt1 pt2) (distance pt3 pt4) 1e-8)
                    (equal (distance pt2 pt3) (distance pt1 pt4) 1e-8)
                    (equal (distance pt1 pt3) (distance pt2 pt4) 1e-8)
               )
               (mapcar '(lambda ( a b ) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b))))
                   (list pt1 pt2)
                   (list pt3 pt4)
               )
           )
       )
   )
   (princ)
)

Edited September 9, 2019 by Lee Mac

November 23, 2016

Another method, need to just add the ssget for multiples.

; 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
(setq co-ords (getcoords (car (entsel "\nplease pick pline"))))
(co-ords2xy) ; list of 2d points making pline

(command "line" (nth 0 co-ordsxy )(nth 2 co-ordsxy ) "")
(command "line" (nth 1 co-ordsxy )(nth 3 co-ordsxy ) "")

November 23, 2016

Dear All Friends,

thank you for your great support. please test with this drawing. cross lines are not developed.

Thanks.

Test file.dwg

Edited November 23, 2016 by structo

November 23, 2016

Here is Lee's code corrected with some issues I've found...

(defun c:rdia ( / ent idx pt1 pt2 pt3 pt4 sel )
   (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))))
           (mapcar
              '(lambda ( a b ) (set b (trans [color=red](list (car (cdr a)) (cadr (cdr a)) (cdr (assoc 38 (entget ent))))[/color] ent 0)))
               (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ent))
              '(pt1 pt2 pt3 pt4)
           )
           (if (and (equal (distance pt1 pt2) (distance pt3 pt4) 1e-
                    (equal (distance pt2 pt3) (distance pt1 pt4) 1e-
                    (equal (distance pt1 pt3) (distance pt2 pt4) 1e-
               )
               (mapcar '(lambda ( a b ) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b))))
                   (list pt1 pt2)
                   (list pt3 pt4)
               )
           )
       )
   )
   (princ)
)

Edited November 23, 2016 by marko_ribar

November 23, 2016

Here is Lee's code corrected with some issues I've found...

Hi friend, thank you for modification. cross lines are not developed. please test your code with my sample file.

Thanks.

Test file.dwg

November 23, 2016

structo

In your polyline 8 points.

You can change the 4?

November 23, 2016

There seems to be an extra line of length zero at each corner of your rectangle.

November 23, 2016

That is what i meant by "other" rectangles, may not be closed or rotated at 0/90. not necessarily 4 vertices.....

An opposite sides are the same length, i.e. they are equal:
An opposite sides are parallel:

An adjacent sides are always perpendicular:

All four angles is right:

The sum all of the angles of a rectangle is equal to 360 degrees:

A diagonals are equal:

The sum of the squares two diagonals is equal to the sum of the squares of the sides:

The each diagonal divides the rectangle into two equal shape, namely a right triangle.

A diagonal of a rectangle in half divides each other:

Intersection point of the diagonals is called the center and also a center of the circumcircle (incenter).

Diagonal of a rectangle is the diameter of the circumcircle.

Around the rectangle can always describe a circle, because the sum of the opposite angles is 180 degrees:

That is probably how i'm going to approach this

November 23, 2016

Sorry friends,

just i saw my drawing. yes there is zero length lines at each corner. these rectangles are taken from one other software output. please ignore those zero length lines to develop diagonal lines by lisp.

Thank you all.

November 23, 2016

I am

Couple of days before created for me,

Lisp experts have given excellent codes

(defun c:polycross (/ ss vl_naam_lst lst plst asoc )
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
(defun LM:ssget ( msg arg / sel )
   (princ msg)
   (setvar 'nomutt 1)
   (setq sel (vl-catch-all-apply 'ssget arg))
   (setvar 'nomutt 0)
   (if (not (vl-catch-all-error-p sel)) sel)
)
;;------------=={ SelectionSet -> VLA Objects }==-------------;;
;;                                                            ;;
;;  Converts a SelectionSet to a list of VLA Objects          ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url]       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ss - Valid SelectionSet (Pickset)                         ;;
;;------------------------------------------------------------;;
;;  Returns:  List of VLA Objects, else nil                   ;;
;;------------------------------------------------------------;;
(defun LM:ss->vla ( ss / i l )
   (if ss
       (repeat (setq i (sslength ss))
           (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
       )
   )
)
   
(setq ss (LM:ssget "Select Polyline(s)" '(((-4 . "<AND") (0 . "LWPOLYLINE") (70 . 1) (-4 . "AND>"))))
vl_naam_lst (LM:ss->vla ss))  
 (foreach n vl_naam_lst
(if  (=  (length (setq coords (vlax-safearray->list (vlax-variant-value (vla-get-coordinates n))))) 
   (progn    
  (setq plst (list (list (trans (list (nth 0 coords) (nth 1 coords) 0) 0 1)
(trans (list (nth 4 coords) (nth 5 coords) 0) 0 1))
(list (trans (list (nth 2 coords) (nth 3 coords) 0) 0 1)
  (trans (list (nth 6 coords) (nth 7 coords) 0) 0 1))))
  (foreach lst plst
    (entmakex 
           (append (list (cons 0 "LWPOLYLINE")
                         (cons 100 "AcDbEntity")
                         (cons 100 "AcDbPolyline")
                         (cons 90 (length lst))
                         (cons 70 0))
(vl-remove nil (mapcar (function (lambda (a) (if (setq asoc (assoc a (entget (vlax-vla-object->ename n))))  asoc))) '(8 62 6)))
(mapcar (function (lambda (p) (cons 10 p))) lst)
        ))                
    )
  
  )
 )
)
(PRINC)
 )

November 23, 2016

A quick edit.

(defun c:rdia ( / ent idx pt1 pt2 pt3 pt4 sel )
   (if (setq sel
           (ssget
              '(   (00 . "LWPOLYLINE")
                  [color="magenta"] ;(90 . 4)[/color]
                   (-4 . "&=")   (70 . 1)
                   (-4 . "<NOT") (-4 . "<>") (42 . 0.0) (-4 . "NOT>")
               )
           )
       )
       (repeat (setq idx (sslength sel))
           (setq ent (ssname sel (setq idx (1- idx))))
           (mapcar
              '(lambda ( a b ) (set b (trans (cdr a) ent 0)))
       
               [color="magenta"](_removeDuplciates[/color] (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ent))[color="magenta"])[/color]
              '(pt1 pt2 pt3 pt4)
           )
           (if (and (equal (distance pt1 pt2) (distance pt3 pt4) 1e-
                    (equal (distance pt2 pt3) (distance pt1 pt4) 1e-
                    (equal (distance pt1 pt3) (distance pt2 pt4) 1e-
               )
               (mapcar '(lambda ( a b ) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b))))
                   (list pt1 pt2)
                   (list pt3 pt4)
               )
           )
       )
   )
   (princ)
)

[color="blue"](defun _removeDuplciates (lst)
 (if (car lst)
   (cons (car lst) (_removeDuplciates (vl-remove (car lst) (cdr lst))))
 )
)[/color]

November 23, 2016

Dear friend pBe,

now your code is perfect working. thank you for your kind help.

Thanking you all for supporting.

November 23, 2016

Dear friend pBe,

now your code is perfect working. thank you for your kind help.

Thanking you all for supporting.

Thank LM sturcto, Lee did all the coding.

And that's just one way of dealing with rectangles (zero length segments), pretty sure there will be more issues as we go along.

v1 to v2 (angle) v2 to v3 (if (angle same as previous or ZERO length) (igmore)(check if 90deg)).......... (= distance between v1 v3 & v2 v4 )) (do it))

November 23, 2016

yes pBe, Lee did all the coding. thank you Lee and all supporters from this post.

Thank you all.

November 23, 2016

Another:

([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])
	)
)
)

After this I feel that I have limited thinking.

Anyway I wrote another solution (better than my first).

Will work for "true" rectangles (4 vertices LWPOLYLINES), with any rotation on any UCS, uncluding such with zero bulges (is that the right term?).

(defun C:test ( / SS i e o )
(if (setq SS (ssget (list (cons 0 "LWPOLYLINE")(cons 70 1) (cons 90 4))))
	(repeat (setq i (sslength SS))
		(setq e (ssname SS (setq i (1- i))))
		(setq o (vlax-ename->vla-object e))
		(and
			(Rectangle-p o 1e-
			(mapcar 
				'(lambda (a b) 
					(entmake 
						(list 
							(cons 0 "LINE") 
							(cons 10 (vlax-curve-getPointAtParam o a)) 
							(cons 11 (vlax-curve-getPointAtParam o b))
						)
					)
				)
				'(0 1) '(2 3)
			)
		)
	)
); if SS
(princ)
)


(defun Rectangle-p ( eo fuzz / eo rtn ) ; Grrr
(cond 
	((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.
	)
	((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
);| defun Rectangle-p |; (or vlax-get-acad-object (vl-load-com)) (princ)

Although It won't support lookalike LWpolyline rectangles like in the OP's dwg. (sorry)

November 23, 2016

A quick edit.

Thanks pBe - I would have opted for the same modification given the OP's corrupted rectangles.

Sign In

Lisp for diagonal lines for selected rectangles

Recommended Posts

structo

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

handasa

Posted Images

marko_ribar

Grrr

pBe

Lee Mac

BIGAL

structo

marko_ribar

structo

maratovich

eldon

pBe

structo

MURAl_KMD

pBe

structo

pBe

structo

Grrr

Lee Mac

Join the conversation

handasa

Tutorials

Forums

Activity