Đây là 1 bài toán đưa đến việc phải giải 1 phương trình bậc cao >> cách giải gần đúng là chấp nhận được (vì theo lý thuyết thì không phải pt nào cũng giải được kết quả đúng tuyệt đối).

Làm cú lisp, với chấp nhận sai số ~ 1E-6 thì pt có 2 nghiệm, với L là đường chéo nối 2 cạnh 4.000 và 4.050 ta được:

- Với L=7.71455 >> S=45.0099936850

- Với L=7.41764 >>...

Đây là 1 bài toán đưa đến việc phải giải 1 phương trình bậc cao >> cách giải gần đúng là chấp nhận được (vì theo lý thuyết thì không phải pt nào cũng giải được kết quả đúng tuyệt đối).

Làm cú lisp, với chấp nhận sai số ~ 1E-6 thì pt có 2 nghiệm, với L là đường chéo nối 2 cạnh 4.000 và 4.050 ta được:

- Với L=7.71455 >> S=45.0099936850

- Với L=7.41764 >> S=45.0100003754

Cad đây:

http://www.cadviet.com/upfiles/7/67029_dung_hinh.dwg

Lisp đây:

(defun C:HA(/ a1 a2 a3 a4 a5 step p1 p2 s1 s2 lst)
 (setq a1 4.000 a2 4.050 a3 11.150 a4 11.260 step 1E-6 a5 (+ a1 step))
 (while (< a1 a5 (+ a1 a2))
  (setq p1 (/ (+ a1 a2 a5) 2))
  (setq p2 (/ (+ a3 a4 a5) 2))
  (setq s1 (sqrt (* p1 (- p1 a1) (- p1 a2) (- p1 a5))))
  (setq s2 (sqrt (* p2 (- p2 a3) (- p2 a4) (- p2 a5))))
  (if (equal (+ s1 s2) 45.01 step) (setq lst (cons a5 lst)))
  (setq a5 (+ a5 step)))
 lst) 
; L=(7.71455 7.41764)
; S=(45.0099936850 45.0100003754)

Đây là 2 hình thỏa mãn yêu cầu ngộ của bạn:

Cad:

http://www.cadviet.com/upfiles/7/67029_dung_hinh_1.dwg

Lisp:

(defun C:HA(/ a1 a2 a3 a4 a5 step p1 p2 s1 s2 lst)
 (setq a1 4.050 a2 11.260 a3 4.00 a4 11.150 step 1E-6 a5 (+ (- a2 a1) step))
 (while (< (- a2 a1) a5 (+ a3 a4))
  (setq p1 (/ (+ a1 a2...
>>

Đây là 2 hình thỏa mãn yêu cầu ngộ của bạn:

Cad:

http://www.cadviet.com/upfiles/7/67029_dung_hinh_1.dwg

Lisp:

(defun C:HA(/ a1 a2 a3 a4 a5 step p1 p2 s1 s2 lst)
 (setq a1 4.050 a2 11.260 a3 4.00 a4 11.150 step 1E-6 a5 (+ (- a2 a1) step))
 (while (< (- a2 a1) a5 (+ a3 a4))
  (setq p1 (/ (+ a1 a2 a5) 2))
  (setq p2 (/ (+ a3 a4 a5) 2))
  (setq s1 (sqrt (* p1 (- p1 a1) (- p1 a2) (- p1 a5))))
  (setq s2 (sqrt (* p2 (- p2 a3) (- p2 a4) (- p2 a5))))
  (if (equal (+ s1 s2) 45.01 step) (setq lst (cons a5 lst)))
  (setq a5 (+ a5 step)))
 lst) 
; L=(12.1367 11.6696)
; S=(45.00994873 45.01000977)

Chuyển rectangle sẵn có sang có arc segment (cạnh nhỏ sẽ chuyển thành arc) 

(defun c:xrec ( / s e i el bl d1 d2)
  
  (if (setq s (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1))))
    (repeat (setq i (sslength s))
      (setq e  (ssname s (setq i (1- i))) el (entget e)
	    vl (_massoc 10 el)  e (vlax-ename->vla-object e))
      
      (if (Rectangle-p el)
	(progn
          (if (LM:Clockwise-p (car vl) (cadr...
>>

Chuyển rectangle sẵn có sang có arc segment (cạnh nhỏ sẽ chuyển thành arc) 

(defun c:xrec ( / s e i el bl d1 d2)
  
  (if (setq s (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1))))
    (repeat (setq i (sslength s))
      (setq e  (ssname s (setq i (1- i))) el (entget e)
	    vl (_massoc 10 el)  e (vlax-ename->vla-object e))
      
      (if (Rectangle-p el)
	(progn
          (if (LM:Clockwise-p (car vl) (cadr vl) (caddr vl)) (setq bl '(-1 -1)) (setq bl '(1 1)))
	  (setq d1 (vlax-curve-getdistatparam e 1)
		d2 (- (vlax-curve-getdistatparam e 2) d1))
	  (if (<= d1 d2)
	    (mapcar '(lambda (i b) (vla-SetBulge e i b)) '(0 2) bl)
	    (mapcar '(lambda (i b) (vla-SetBulge e i b)) '(1 3) bl) 
	  )
	)
      )
    )
  )
  (princ)
)
;;==============================================================;;
(defun Rectangle-p (el / lst p1 p2 p3 p4)
  (and
    (= "LWPOLYLINE" (cdr (assoc 0 el)))
    (= 1 (cdr (assoc 70 el)))
    (setq lst (_massoc 10 el))
    (= 4 (length lst))
    (vl-every
      '(lambda (x) (zerop x))
      (_massoc 42 el)
    )
    (mapcar '(lambda (v p) (set v p)) '(p1 p2 p3 p4) lst)
    (equal 1 (/ (distance p1 p2) (distance p3 p4)) 1e-9)
    (equal 1 (/ (distance p1 p4) (distance p2 p3)) 1e-9)
    (equal 1 (/ (distance p1 p3) (distance p2 p4)) 1e-9)
  )
)
(defun _massoc (key lst)
  (if (setq itm (assoc key lst))
    (cons (cdr itm) (_massoc key (cdr (member itm lst))))
  )
)

;; Clockwise-p  -  Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
                 
(defun LM:Clockwise-p ( p1 p2 p3 )
    (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
            (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
        )
        1e-8
    )
)

Sao đọc mà k hiểu ý hỏi ta ....

Sao đọc mà k hiểu ý hỏi ta ....

(defun c:arf ( / ss->list copyv dx dy gr i1 i2 nx ny obs obx oby p0 px py vx vy ) (vl-load-com)
(defun ss->list ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
(defun copyv ( ob n v / i b l ) (setq i 1 b (vlax-3D-point '(0. 0. 0.)))
(repeat n
(foreach obj ob
(vla-move (car (setq l (cons (vla-copy obj) l))) b (vlax-3D-point (mapcar '* v (list i i...
>>

(defun c:arf ( / ss->list copyv dx dy gr i1 i2 nx ny obs obx oby p0 px py vx vy ) (vl-load-com)
(defun ss->list ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
(defun copyv ( ob n v / i b l ) (setq i 1 b (vlax-3D-point '(0. 0. 0.)))
(repeat n
(foreach obj ob
(vla-move (car (setq l (cons (vla-copy obj) l))) b (vlax-3D-point (mapcar '* v (list i i i))))
)
(setq i (1+ i))
)
l
)
(if
(and
(setq obs (ss->list (ssget '((0 . "~VIEWPORT")))))
(setq p0 (getpoint "\nBase Point (P0): "))
(setq px (getpoint "\nArray X-Vector (Px): " p0))
(setq py (getpoint "\nArray Y-Vector (Py): " p0))
)
(progn
(setq vx (mapcar '- px p0) dx (distance '(0. 0. 0.) vx)
vy (mapcar '- py p0) dy (distance '(0. 0. 0.) vy)
)
(princ "\nArray Endpoint: ")
(while (= 5 (car (setq gr (grread 't 13 0)))) (redraw)
(setq obx (car (mapcar 'vla-delete obx))
oby (car (mapcar 'vla-delete oby))
gr (mapcar '- (cadr gr) p0)
i1 (inters '(0. 0. 0.) vx gr (mapcar '+ gr vy) nil)
i2 (inters '(0. 0. 0.) vy gr (mapcar '+ gr vx) nil)
nx (fix (/ (caddr (trans i1 1 vx)) dx))
ny (fix (/ (caddr (trans i2 1 vy)) dy))
obx (copyv obs (abs nx) (mapcar (if (minusp nx) '- '+) vx))
oby (copyv (append obs obx) (abs ny) (mapcar (if (minusp ny) '- '+) vy))
)
(grvecs (list -3 '(0. 0. 0.) i1 i1 gr '(0. 0. 0.) i2 i2 gr)
(list
(list 1. 0. 0. (car p0))
(list 0. 1. 0. (cadr p0))
(list 0. 0. 1. (caddr p0))
(list 0. 0. 0. 1.)
)
)
)
)
)
(redraw) (princ)
)

Em mò trên mạng, ra cái Polylines Program của Lee-Mac, nhưng cái này khi mình mirror tất cả, rồi join, thì với các đường giao nhau, nó sẽ join loạn lên, không join chuẩn các đường đối xứng qua trục Y như em cần.

>>

Em mò trên mạng, ra cái Polylines Program của Lee-Mac, nhưng cái này khi mình mirror tất cả, rồi join, thì với các đường giao nhau, nó sẽ join loạn lên, không join chuẩn các đường đối xứng qua trục Y như em cần.

http://www.lee-mac.com/polylineprograms.html#polyjoin

 

em mò theo kiểu thủ công như cái này, thì lượng polyline bị xót rất nhiều, vì nhiều poliline quá gần nhau, nên chọn không chuẩn :wacko: .

http://www.cadviet.com/upfiles/7/12799_123.lsp

 

Làm sao để mình chọn tất cả objects, rồi nó tự chạy lisp theo kiểu one by one đc các bác ơi  :blush:

Quả Lisp thô sơ này chắc chạy ngon. Nhớ move chuẩn trục Y ở 0.0 nhé. ^_^

(defun c:test (/ ss n ss1)
  (setq ss (ssget))
  (setq n 0)
  (setq ss1 (ssadd))
  (repeat (sslength ss)
    (setq ss1 (ssadd (ssname ss n) ss1))    
    (command "mirror" ss1 "" "0,0" "0,1" "N" "")
    (setq ss1 (ssadd (entlast) ss1))
    (command ".PEDIT" "m" ss1 "" "j" "0.025" "" )
    (setq ss1 (ssadd))
    (setq n (1+ n))
    )
  (princ)
  )

<<

Mình có đoạn lsp dùng để viết chữ (chữ mặc định), nhưng sau khi gõ lệnh và dùng thì nó bị lỗi font 

Mình muốn dùng font arial (bảng mã unicode, kiểu gõ vni)

Mình muốn ghi ra là chữ" MẶT BẰNG TÔN MÁI 

Mong mọi người sửa dùm tí, mình xin cảm ơn ! 

(DEFUN C:MB (/ TILE P)
  (IF (= (TBLOBJNAME "STYLE" "ARIAL") NIL)
  	(command ".STYLE" "ARIAL"...
>>

Mình có đoạn lsp dùng để viết chữ (chữ mặc định), nhưng sau khi gõ lệnh và dùng thì nó bị lỗi font 

Mình muốn dùng font arial (bảng mã unicode, kiểu gõ vni)

Mình muốn ghi ra là chữ" MẶT BẰNG TÔN MÁI 

Mong mọi người sửa dùm tí, mình xin cảm ơn ! 

(DEFUN C:MB (/ TILE P)
  (IF (= (TBLOBJNAME "STYLE" "ARIAL") NIL)
  	(command ".STYLE" "ARIAL" "VNI-ARIAL" "" "" "" "" "" "")
    )
  (SETQ
	tile (getint "\nTi le: ")
	p (getpoint "\nChon diem chen text: ")
	)
  (COMMAND "TEXT" "S" "ARIAL" "J" "MC" P (* TILE 2) "0" "%%UMẶT BẰNNG TÔN MÁI"
	            )
)

(defun c:AttDef2Text ( / ss )
  ;; © Lee Mac  ~  01.06.10
  (vl-load-com)

  (if (setq ss (ssget "_:L" '((0 . "ATTDEF"))))
    (
      (lambda ( i / e o )
        (while (setq e (ssname ss (setq i (1+ i))))
          (if
            (
              (if (and (vlax-property-available-p
                         (setq o (vlax-ename->vla-object e)) 'MTextAttribute)
                       (eq :vlax-true (vla-get-MTextAttribute o)))

               ...
>>

(defun c:AttDef2Text ( / ss )
  ;; © Lee Mac  ~  01.06.10
  (vl-load-com)

  (if (setq ss (ssget "_:L" '((0 . "ATTDEF"))))
    (
      (lambda ( i / e o )
        (while (setq e (ssname ss (setq i (1+ i))))
          (if
            (
              (if (and (vlax-property-available-p
                         (setq o (vlax-ename->vla-object e)) 'MTextAttribute)
                       (eq :vlax-true (vla-get-MTextAttribute o)))

                MAttDef2MText AttDef2Text
              )
              (entget e)
            )
            (entdel e)
          )
        )
      )
      -1
    )
  )
  (princ)
)

(defun AttDef2Text ( eLst / dx74 dx2 )
  ;; © Lee Mac  ~  01.06.10

  (setq dx74 (cdr (assoc 74 eLst)) dx2 (cdr (assoc 2 eLst)))

  (entmake
    (append '( (0 . "TEXT") ) (RemovePairs '(0 100 1 2 3 73 74 70 280) eLst)
      (list
        (cons 73 dx74)
        (cons  1  dx2)
      )
    )
  )
)

(defun MAttDef2MText ( eLst )
  ;; © Lee Mac  ~  01.06.10

  (entmake
    (append '( (0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText") )
      (RemoveFirstPairs '(40 50 41 7 71 72 71 72 73 10 11 11 210)
        (RemovePairs '(-1 102 330 360 5 0 100 101 1 2 3 42 43 51 74 70 280) eLst)
      )
      (list (cons 1 (cdr (assoc 2 eLst))))
    )
  )
)

(defun RemoveFirstPairs ( pairs lst )
  ;; © Lee Mac

  (defun foo ( pair lst )
    (if lst
      (if (eq pair (caar lst))
        (cdr lst)
        (cons (car lst) (foo pair (cdr lst)))
      )
    )
  )

  (foreach pair pairs
    (setq lst (foo pair lst))
  )
  lst
)


(defun RemovePairs ( pairs lst )
  ;; © Lee Mac
  (vl-remove-if
    (function
      (lambda ( pair )
        (vl-position (car pair) pairs)
      )
    )
    lst
  )
)

Gửi bác VanHoa

Vâng ạ. Mong muốn được giúp đỡ, vì em cắt thủ công mất nhiều time quá!

Em cần để thiết kế file dạng này :

Viết nhanh xem Người phán xử, ^_^ Lỗi gì...

Vâng ạ. Mong muốn được giúp đỡ, vì em cắt thủ công mất nhiều time quá!

Em cần để thiết kế file dạng này :

Viết nhanh xem Người phán xử, ^_^ Lỗi gì chỉnh sau. Chạy thử đi nhé.

(defun c:test ()
  (princ "\nChon doi tuong can cat: ")
  (setq ss (ssget))
  (setq foo (getdist "\nChon khoang cach cat: "))
  (setq n (getint "\nChon so luong cat: "))
  (if (and foo ss n)
    (progn      
      (foreach e (ssnamex ss); 
	(command "divide" (cadr e) (1+ n))
	(setq ss1 (ssadd))
	(setq pts (ssget "_P"))
	(foreach pt (ssnamex pts)
	  (command "circle" "_none" (cdr (assoc 10 (entget (cadr pt)))) (/ foo 2))
	  (setq ci (entlast))
	  (setq ss1 (ssadd ci ss1))
	  (command "erase" (cadr pt) "")
	  )
	(foreach c (ssnamex ss1)
	  (command "trim" (cadr c) "" (cdr (assoc 10 (entget (cadr c)))) "")
	  )
	(command "erase" ss1 "")
	);for
      );progn
    );if
  (princ)
  )

Bác ơi cái file của em đây, làm như nào hả bác?

 

Các frames nẳm trên mặt x0z, giờ move từng Frame (từ trong ra ngoài ) theo trục y, , mỗi đường cách nhau 500, thì làm như nào hả bác?

 

>>

Bác ơi cái file của em đây, làm như nào hả bác?

 

Các frames nẳm trên mặt x0z, giờ move từng Frame (từ trong ra ngoài ) theo trục y, , mỗi đường cách nhau 500, thì làm như nào hả bác?

 

http://www.cadviet.com/upfiles/7/12799_frames_1.dwg

Để nguyên Pline sau khi join trên mặt phẳng XoY. Chạy lisp mới chọn những pline trước sau đó chọn Line // trục X với điểm bắt đầu từ trục Y trở đi để tính 1 điểm cắt với pline thôi nhé. Sau khi move hết theo trục Z xuống cách 1 khoảng 500 thì xoay toàn bộ đối tượng sau nhé. Chúc ngon miệng ^_^

(defun LM:intersections	(ob1 ob2 mod / lst rtn)
  (if (and (vlax-method-applicable-p ob1 'intersectwith)
	   (vlax-method-applicable-p ob2 'intersectwith)
	   (setq lst (vlax-invoke ob1 'intersectwith ob2 mod))
      )
    (repeat (/ (length lst) 3)
      (setq rtn	(cons (list (car lst) (cadr lst) (caddr lst)) rtn)
	    lst	(cdddr lst)
      )
    )
  )
  (reverse rtn)
)
(vl-load-com)

(defun c:test2 ()
  (setq osm (getvar "osmode"))
  (setvar "osmode" 0)
  (command "undo" "be")
  (princ "\nChon doi tuong: ")
  (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
    (progn
      (if (setq line_X (car (entsel "\nChon doan thang // X: ")))
	(progn
	  (setq	lst_e (vl-remove-if
			'listp
			(mapcar 'cadr (ssnamex ss))
		      )
	  )
	  (setq lst_pt nil)
	  (foreach e lst_e
	    (setq pt (LM:intersections
		       (vlax-ename->vla-object e)
		       (vlax-ename->vla-object line_X)
		       acextendnone
		     )
	    )
	    (setq lst_pt (cons (cons e (car pt)) lst_pt))
	  )
	  (vl-sort lst_pt '(lambda (e1 e2) (< (cadr e1) (cadr e2)))) ;
	  (setq n 500)
	  (foreach pl (cdr lst_pt)
	    (command "move"
		     (car pl)
		     ""
		     "0,0,0"
		     (strcat "0,0,-" (rtos n 2 0))
	    )
	    (setq n (+ n 500))
	  )
	)				;progn line_X
	(princ "\nBan da khong chon doan thang // X.")
      )					;if
    )					;progn ss
    (princ "\nBan da khong chon doi tuong.")
  )					;if

  (command "undo" "end")
  (setvar "osmode" osm)
  (princ)
)					;defun

<<

Em muốn hoán đổi vị trí 2 text cho nhau, dùng lệnh này cũng đc nhưng phải làm nhièu thao tác qua,mà em cần phải hoán đổi vị trí text rất nhiều. Em muốn chỉ cần chon 2 text là nó tự chuyển vị trí cho nhau. Bac nào có thể sửa lại cho em đc không?Cam ơn các bác!!

Nghịch cái này nhìn 2 text...

Em muốn hoán đổi vị trí 2 text cho nhau, dùng lệnh này cũng đc nhưng phải làm nhièu thao tác qua,mà em cần phải hoán đổi vị trí text rất nhiều. Em muốn chỉ cần chon 2 text là nó tự chuyển vị trí cho nhau. Bac nào có thể sửa lại cho em đc không?Cam ơn các bác!!

Nghịch cái này nhìn 2 text hoàn đổi vui phết ^_^

(defun c:test ()
  (while (and (setq a (car (entsel "\nChon text 1: ")))
	      (setq b (car (entsel "\nChon text 2: ")))
	      )
    (setq b_ins (assoc 10 (entget b)))
    (entmod (subst (assoc 10 (entget a)) (assoc 10 (entget b)) (entget b)))
    (entmod (subst b_ins (assoc 10 (entget a)) (entget a)))
    )
  (princ)
  )

Em có 2 cái lisp sưu tầm, do Em download về, mà lâu quá rồi nên không nhớ nguồn gốc.

1. Lisp chia dim ( hiện tại cứ click là chia )

2. Lisp nối dim ( chọn 2 dim là tự nối với nhau thành 1 dim )

 

Mong mọi người giúp Em nâng cao lên

1. Lisp chia dim ( hiện tại cứ click là chia ), thêm option...

>>

Em có 2 cái lisp sưu tầm, do Em download về, mà lâu quá rồi nên không nhớ nguồn gốc.

1. Lisp chia dim ( hiện tại cứ click là chia )

2. Lisp nối dim ( chọn 2 dim là tự nối với nhau thành 1 dim )

 

Mong mọi người giúp Em nâng cao lên

1. Lisp chia dim ( hiện tại cứ click là chia ), thêm option 2

       +  click là chia

       +  nhập số lần để chia đều, ví dụ chia 10 thì nhập 10, dim tự chia ra 10 phần bằng nhau

 

2. Lisp nối dim ( chọn 2 dim là tự nối với nhau thành 1 dim ), thêm option 2

       +  chọn nhiều dim => nối với nhau thành 1 dim

 

http://www.cadviet.com/upfiles/7/5798_21a_cdd__cat_dim_2.lsp

http://www.cadviet.com/upfiles/7/5798_21_jd__noi_dim_.lsp

 

Mong mọi người giúp Em.

Tóm tắt cái lisp trên tí thôi. Không dài dòng các kiểu. Trường hợp đặc biệt là các dim cùng hàng và chân dim dài như nhau nhé. 

Nghịch thử nhé ^_^

(defun c:merge ()
  (if (setq ss (ssget '((0 . "DIMENSION"))))
    (progn
      (setq lst nil)
      (setq pt (cdr (assoc 10 (entget (ssname ss 0)))))
      (foreach dim (ssnamex ss)
	(if (= 'ename (type (cadr dim)))
	  (progn
	    (setq lst (cons (cdr (assoc 13 (entget (cadr dim)))) lst))
	    (setq lst (cons (cdr (assoc 14 (entget (cadr dim)))) lst))
	  )
	)
      )
      (setq lst (vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2)))))
      (command "erase" ss "")
      (command "dimrotated"
	       (RtD (angle (car lst)
			   (car (reverse lst))
		    )
	       )
	       (car lst)
	       (car (reverse lst))
	       pt
      )
    )
  )
  (princ)
)
(defun RtD (r) (* 180.0 (/ r pi)))

<<

(defun c:brc (/ retcen osmode idx rectangles ins );Chen Block vao tam rectang
(defun rectcen (rect / pl p1 p2 p3 p4 pm1 pm2 an di ceo)
(setq ceo (vlax-ename->vla-object rect))
(setq pl (vlax-safearray->list (vlax-variant-value (vla-get-coordinates ceo))))
(if (> (length pl) 6)
(progn
(setq p1 (list (nth 0 pl) (nth 1 pl)))
(setq p2 (list (nth 2 pl) (nth 3 pl)))
(setq p3 (list (nth 4 pl) (nth 5 pl)))
(setq p4 (list (nth 6 pl) (nth 7 pl)))
(setq pm1 (mapcar '/...
>>

(defun c:brc (/ retcen osmode idx rectangles ins );Chen Block vao tam rectang
(defun rectcen (rect / pl p1 p2 p3 p4 pm1 pm2 an di ceo)
(setq ceo (vlax-ename->vla-object rect))
(setq pl (vlax-safearray->list (vlax-variant-value (vla-get-coordinates ceo))))
(if (> (length pl) 6)
(progn
(setq p1 (list (nth 0 pl) (nth 1 pl)))
(setq p2 (list (nth 2 pl) (nth 3 pl)))
(setq p3 (list (nth 4 pl) (nth 5 pl)))
(setq p4 (list (nth 6 pl) (nth 7 pl)))
(setq pm1 (mapcar '/ (mapcar '+ p1 p3) '(2.0 2.0 2.0)))
(setq pm2 (mapcar '/ (mapcar '+ p2 p4) '(2.0 2.0 2.0)))
(cond
((and
(equal (distance pm1 p1)(distance pm2 p1) 0.001)
(equal (distance pm1 p2)(distance pm2 p2) 0.001)
(equal (distance pm1 p3)(distance pm2 p3) 0.001)
(equal (distance pm1 p4)(distance pm2 p4) 0.001)
)
(inters p1 p3 p2 p4 nil)
)
)
)
)
)
;----------------------------------------------
(vl-load-com)
(command "undo" "begin")
(command "ucs" "w")
(setq osmode (getvar "osmode"))
(setvar "osmode" 0)
(if
(setq rectangles (ssget '((0 . "LWPOLYLINE"))))
(progn
(setq idx 0)
(repeat (sslength rectangles)
(setq ins (rectcen (ssname rectangles idx)))
(if ins (command "-insert" "s" ins "" "" ""))
(setq idx (1+ idx))
)
)
(princ "\n Selected(s) object(s) are not Lwpolyline!")
)
(command "undo" "end")
(setvar "osmode" osmode)
(princ)
) 

thay từ "S" bôi đỏ bằng tên block của bạn

Góp vui tí :)

(defun c:cbr (/ dt bl sdt id en)
  (command "Undo" "be")
  (setq osm (getvar "osmode")
	bl (cdr (assoc 2 (entget(car (entsel "\nSelect block:")))))
	dt (ssget '((-4 . "<OR")
		(0 . "LWPOLYLINE")
		(-4 . "OR>")	
		))
	sdt (sslength dt)
	id 0
	)
  (setvar "osmode" 0)
  (repeat sdt
    (setq en (ssname dt id)
	  id (1+ id)
	  )
    (midp en)
    )
  (setvar "osmode" osm)
  (command "undo" "end")
  (princ)
  )
   ...
>>

Góp vui tí :)

(defun c:cbr (/ dt bl sdt id en)
  (command "Undo" "be")
  (setq osm (getvar "osmode")
	bl (cdr (assoc 2 (entget(car (entsel "\nSelect block:")))))
	dt (ssget '((-4 . "<OR")
		(0 . "LWPOLYLINE")
		(-4 . "OR>")	
		))
	sdt (sslength dt)
	id 0
	)
  (setvar "osmode" 0)
  (repeat sdt
    (setq en (ssname dt id)
	  id (1+ id)
	  )
    (midp en)
    )
  (setvar "osmode" osm)
  (command "undo" "end")
  (princ)
  )
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;	
(defun midp (en / p2 p4 pm)
  (setq p2 (vlax-curve-getPointAtParam en 2)
	p4 (vlax-curve-getPointAtParam en 4)
	pm (list (/(+(car p2)(car p4))2) (/(+(cadr p2)(cadr p4))2))
	)
  (entmake (list  (cons 0 "insert")  (cons 2 bl) (cons 10 pm)))
  )

Có thể viết được chọn theo layer, nhưng tốt hơn bạn nên quét chọn các pl để cloud. Thao tác là bạn chọn block revision, tiếp theo chọn các pl.
Còn về arc và kiểu cloud bạn có thể chọn bằng cách dùng lệnh revclound bên ngoài để trong lisp tự động theo

(defun c:cld (/ dt bl sdt id en)
  (command "Undo" "be")
  (setq osm (getvar "osmode")
	bl (cdr (assoc 2 (entget(car (entsel "\nSelect...
>>

Có thể viết được chọn theo layer, nhưng tốt hơn bạn nên quét chọn các pl để cloud. Thao tác là bạn chọn block revision, tiếp theo chọn các pl.
Còn về arc và kiểu cloud bạn có thể chọn bằng cách dùng lệnh revclound bên ngoài để trong lisp tự động theo

(defun c:cld (/ dt bl sdt id en)
  (command "Undo" "be")
  (setq osm (getvar "osmode")
	bl (cdr (assoc 2 (entget(car (entsel "\nSelect Revision block:")))))
	dt (ssget '((-4 . "<OR")
		(0 . "LWPOLYLINE")		    
		(-4 . "OR>")	
		))
	sdt (sslength dt)
	id 0
	)
  (setvar "osmode" 0)
  (repeat sdt
    (while
      (setq en (ssname dt id)
	    id (1+ id)
	    )
      (cloud en)
      )
    )
  (setvar "osmode" osm)
  (command "undo" "end")
  (princ)
  )
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;	
(defun cloud (en / p0 p1 pm)
  (setq p0 (vlax-curve-getPointAtParam en 0)
	p1 (vlax-curve-getPointAtParam en 1)
	pm (list (/(+(car p0)(car p1))2) (+(/(+(cadr p0)(cadr p1 ))2)8))
	)
  (command "revcloud" "o" en "")
  (entmake (list  (cons 0 "insert")  (cons 2 bl) (cons 10 pm)))
  )