Jump to content
structo

Lisp for diagonal lines for selected rectangles

Recommended Posts

structo

Hi friends,

 

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

 

Thank you all in advance.

Crosslines.jpg

Share this post


Link to post
Share on other sites
marko_ribar

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

Share this post


Link to post
Share on other sites
Grrr

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 by Grrr

Share this post


Link to post
Share on other sites
pBe

Grr

 

Need to consider "other" rectangles.

Share this post


Link to post
Share on other sites
Lee Mac

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 by Lee Mac

Share this post


Link to post
Share on other sites
BIGAL

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 ) "")

Share this post


Link to post
Share on other sites
structo

Dear All Friends,

 

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

 

Thanks.

Test file.dwg

Edited by structo

Share this post


Link to post
Share on other sites
marko_ribar

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 by marko_ribar

Share this post


Link to post
Share on other sites
structo
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

Share this post


Link to post
Share on other sites
maratovich

structo

In your polyline 8 points.

You can change the 4?

Share this post


Link to post
Share on other sites
eldon

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

Share this post


Link to post
Share on other sites
pBe

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

Share this post


Link to post
Share on other sites
structo

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.

Share this post


Link to post
Share on other sites
MURAl_KMD

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)
 )

Share this post


Link to post
Share on other sites
pBe

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]

Share this post


Link to post
Share on other sites
structo

Dear friend pBe,

 

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

 

Thanking you all for supporting.

Share this post


Link to post
Share on other sites
pBe
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))

Share this post


Link to post
Share on other sites
structo

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

 

Thank you all.

Share this post


Link to post
Share on other sites
Grrr
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. :oops:

 

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)

Share this post


Link to post
Share on other sites
Lee Mac
A quick edit.

 

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

Share this post


Link to post
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
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  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...