structo Posted November 22, 2016 Share Posted November 22, 2016 Hi friends, i have rectangles and develop diagonal lines for selected rectangles as shown in figure. Thank you all in advance. Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted November 22, 2016 Share Posted 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...) Quote Link to comment Share on other sites More sharing options...
Grrr Posted November 22, 2016 Share Posted November 22, 2016 (edited) 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 Quote Link to comment Share on other sites More sharing options...
pBe Posted November 22, 2016 Share Posted November 22, 2016 Grr Need to consider "other" rectangles. Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted November 22, 2016 Share Posted November 22, 2016 (edited) 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 Quote Link to comment Share on other sites More sharing options...
BIGAL Posted November 23, 2016 Share Posted 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 ) "") Quote Link to comment Share on other sites More sharing options...
structo Posted November 23, 2016 Author Share Posted November 23, 2016 (edited) 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 Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted November 23, 2016 Share Posted November 23, 2016 (edited) 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 Quote Link to comment Share on other sites More sharing options...
structo Posted November 23, 2016 Author Share Posted 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 Quote Link to comment Share on other sites More sharing options...
maratovich Posted November 23, 2016 Share Posted November 23, 2016 structo In your polyline 8 points. You can change the 4? Quote Link to comment Share on other sites More sharing options...
eldon Posted November 23, 2016 Share Posted November 23, 2016 There seems to be an extra line of length zero at each corner of your rectangle. Quote Link to comment Share on other sites More sharing options...
pBe Posted November 23, 2016 Share Posted 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 Quote Link to comment Share on other sites More sharing options...
structo Posted November 23, 2016 Author Share Posted 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. Quote Link to comment Share on other sites More sharing options...
MURAl_KMD Posted November 23, 2016 Share Posted 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) ) Quote Link to comment Share on other sites More sharing options...
pBe Posted November 23, 2016 Share Posted 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] Quote Link to comment Share on other sites More sharing options...
structo Posted November 23, 2016 Author Share Posted November 23, 2016 Dear friend pBe, now your code is perfect working. thank you for your kind help. Thanking you all for supporting. Quote Link to comment Share on other sites More sharing options...
pBe Posted November 23, 2016 Share Posted 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)) Quote Link to comment Share on other sites More sharing options...
structo Posted November 23, 2016 Author Share Posted November 23, 2016 yes pBe, Lee did all the coding. thank you Lee and all supporters from this post. Thank you all. Quote Link to comment Share on other sites More sharing options...
Grrr Posted November 23, 2016 Share Posted 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) Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted November 23, 2016 Share Posted November 23, 2016 A quick edit. Thanks pBe - I would have opted for the same modification given the OP's corrupted rectangles. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.