Nhờ chỉnh sửa lisp boudary nhiều hình

[nh0kdkny 2]

Em muốn tìm lisp có thể bo đc nhiều hình và tách riêng các đường bo thành polyline

em có tìm được 1 lisp của bác phamngoctukts nhưng load vào gõ lệnh không được không biết có đúng lệnh không nhờ mọi người xem giúp. Trong lisp có phần đánh số nữa thì nhờ mọi người bỏ giúp em chỉ giữ lại phần bo các hình

;; free lisp from cadviet.com
(defun ndt();Nhom doi tuong
(setq tbl (tblsearch "layer" "point_template"))
(if (= tbl nil) (command "-layer" "n" "point_template" ""))
(setq sn 1 list_plmoi nil list_pl nil lss nil)
(while (setq ss (ssget "x" '((0 . "lwpolyline"))))
(command "explode" ss)
)
(setq ss (ssget '((0 . "line,arc"))))
(setq lss (append lss (list ss)))
(command "zoom" "e")
(creatbo lss)
)

(defun creatbo ( lss / )
(setq k 0 list_point (ssadd))
(while (< k (length lss))
(setq ss (nth k lss))
(setq i 0)
(while (< i (sslength ss))
(setq name (ssname ss i)
ent (entget name))
(if (/= (cdr (assoc 0 ent)) "ARC")
(progn
(setq p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent)))
)
)
(if (= (cdr (assoc 0 ent)) "ARC")
(progn
(setq dgiua (midarc name)
p1 pdau
p2 pcuoi)
)
)
(setq j 0)
(while (and (< j (sslength ss)) (/= j i))
(setq name1 (ssname ss j)
ent1 (entget name1))
(if (/= (cdr (assoc 0 ent1)) "ARC")
(progn
(setq p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1)))
)
)
(if (= (cdr (assoc 0 ent1)) "ARC")
(progn
(setq dgiua (midarc name1)
p3 pdau
p4 pcuoi)
)
)
(setq giao (inter name name1))
(if (and (/= (cdr (assoc 0 ent1)) "ARC") (/= (cdr (assoc 0 ent2)) "ARC")) 
(progn
(if (and (/= giao nil) (not (equal giao p1 0.01)) (not (equal giao p2 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent) ent))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent) ent))
)
)
(if (and (/= giao nil) (not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent)) "ARC") (/= (cdr (assoc 0 ent1)) "ARC")
(not (equal giao p1 0.01)) (not (equal giao p2 0.01)))
(progn
(breakarc name giao)
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent1)) "ARC") (/= (cdr (assoc 0 ent)) "ARC")
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn 
(breakarc name1 giao)
(entmake (subst (cons 11 giao) (assoc 11 ent) ent))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent) ent))
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent)) "ARC") (= (cdr (assoc 0 ent1)) "ARC")
(not (equal giao p1 0.01)) (not (equal giao p2 0.01)) 
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(breakarc name giao)
(breakarc name1 giao)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(command "region" ss "")
(command "erase" ss "")
(setq ss (ssget "x" '((0 . "region"))))
(setq i 0)
(setq list_pl (ssadd))
(while (< i (sslength ss))
(setq reg (ssname ss i))
(command "explode" reg)
(setq plp (ssget "p"))
(command "pedit" "l" "" "j" plp "" "")
(setq boun (entlast))
(setq list_pl (ssadd boun list_pl))
(setq i (1+ i))
)
(locbo)
(setq k (1+ k))
)
)

(defun locbo ()
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ptt (centroid namel))
(command "point" ptt)
(setq poi (entlast)
list_point (ssadd poi list_point))
(command "change" list_point "" "p" "la" "point_template" "")
(setq i (1+ i))
)
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ob (vlax-ename->vla-object namel)
c 0 dsp nil)
(while (/= (vlax-curve-getPointAtParam ob c) nil)
(setq pt (vlax-curve-getPointAtParam ob c))
(setq dsp (append (list pt) dsp))
(setq c (1+ c))
)
(setq ssdk (ssget "Wp" dsp (list (cons 0 "point") (cons 8 "point_template"))))
(if (> (sslength ssdk) 2)
(progn
(command "erase" namel "")
(setq ss_pl (ssdel namel list_pl))
(setq nhomss (append (list (ssget "cp" dsp '((0 . "lwpolyline")))) nhomss))
)
)
(if (= (sslength (ssget "cp" dsp '((0 . "lwpolyline")))) 1)
(setq nhomss (append (list (ssget "cp" dsp '((0 . "lwpolyline")))) nhomss))
)
(setq i (1+ i))
)
(command "erase" list_point "")
)


(defun c:tddmoi ()
(inittdd)
(command "undo" "be")
(setq dlst (list (strcat "X" "\t" "\t" "Y" "\n"))
oldos (getvar "osmode")
pg (getvar "ucsorg")
pw (getpoint "\n Chon goc toa do ")
id 1
ptlst nil
dlst1 nil
list_pl nil
list_chu (ssadd)
nhomss nil
)
(ndt)
(setvar "osmode" 0)
(if (= pw nil) (setq pW (list 0 0 0)))
(setq k 0)
(while (< k (length nhomss))
(setq sscon (nth k nhomss))
(setq ssmoi (sapxep sscon))
(setq p 0)
(while (< p (sslength ssmoi))
(setq name (ssname ssmoi p)) 
(command "area" "o" name)
(setq i 0
ptlst nil
obj (vlax-ename->vla-object name)
dlst1 (append (list (strcat "hinh thu: " (rtos id 2 0) " dien tich: " (rtos (getvar "area") 2 3))) dlst1)
)
(setq ptam (centroid name))
(if (eq (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))) 0)
(command "text" "j" "m" ptam "" "" (rtos id 2 0))
(command "text" "j" "m" ptam "" (rtos id 2 0))
)
(setq list_chu (ssadd (entlast) list_chu))
(while (/= (vlax-curve-getPointAtParam obj (1+ i)) nil)
(setq p1 (vlax-curve-getPointAtParam obj i))
(setq dlst1 (append (list (strcat (rtos (- (car p1) (car pw) (car pg)) 2 3) 
"\t"
"\t"
(rtos (- (cadr p1) (cadr pw) (cadr pg)) 2 3)
)
)
dlst1))
(setq ptlst (append (list p1) ptlst))
(setq i (1+ i))
)
(setq p (1+ p))
(setq dlst1 (append (list "\n") dlst1))
(setq dlst (append dlst1 dlst))
(setq dlst1 nil)
(setq id (1+ id))
)
(setq k (1+ k))
)
(setq dlst (reverse dlst))
(alert (strcat "Qua trinh da hoan thanh. Chon duong dan de luu file toa do"))
(setq file (getfiled "chon duong dan de luu file" (getvar "DWGPREFIX") "txt" 1))
(setq opw (open file "w"))
(foreach n dlst (write-line n opw))
(close opw)
(command "_.copyclip" list_chu "")
(command "block" "chu" "0,0" list_chu "")
(command "insert" "chu" "0,0" "" "" "")
(setq pchu (nth 0 (acet-ent-geomextents (entlast))))
(setvar "osmode" oldos)
(command "undo" "e")
(command "undo" "")
(command "_.pasteclip" pchu)
(alert (strcat "file da duoc luu tai: " file))
(startapp "notepad" file)
)

(defun inittdd ()
(setq 
tdd_old_er *error*
*error* tdderror
)
)

(defun tdderror (errmsg)
(loitdd)
)


(defun loitdd ()
(setq *error* tdd_old_er)
(command "undo" "end")
(command "undo" "")
(princ "xay ra loi trong qua trinh thao tac")
)

(defun centroid (e / op ptam)
(vl-load-com)
(command "region" e "")
(setq re (entlast))
(setq ob (vlax-ename->vla-object re) 
ptam (vlax-safearray->list (vlax-variant-value (vla-get-Centroid ob)))
)
(command "undo" 1)
ptam
)

(defun sapxep ( sscu /)
(setq i 0 l_i nil l_ps nil)
(while (< i (sslength sscu))
(setq ename (ssname sscu i))
(setq ps (centroid ename))
(setq l_ps (append (list (+ (cadr ps) (* i 0.001))) l_ps)
l_i (append (list i) l_i)
)
(setq i (1+ i))
)
(setq ssmoi (ssadd))
(setq m 0)
(while (/= l_i nil)
(setq nho (apply 'max l_ps))
(setq kt (nth (vl-position nho l_ps) l_i))
(setq ssmoi (ssadd (ssname sscu kt) ssmoi))
(setq l_ps (vl-remove nho l_ps))
(setq l_i (vl-remove kt l_i))
(setq m (1+ m))
)
ssmoi
)


(defun inter ( t1 t2 / ob1 ob2 g kq sd)
(Vl-Load-Com)
(setq ob1 (vlax-ename->vla-object t1)
ob2 (vlax-ename->vla-object t2)
)
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1)
(setq g (vlax-safearray->list g))
(setq g nil)
)
g
)

(defun breakarc ( n1 pn / )
(setq entarc (entget n1)
tam (cdr (assoc 10 entarc))
bk (cdr (assoc 40 entarc))
pdau (polar tam (cdr (assoc 50 entarc)) bk)
pcuoi (polar tam (cdr (assoc 51 entarc)) bk)
ang (angle tam pn)
)
(entmod (subst (cons 50 ang) (assoc 50 entarc) entarc))
(entmakex (subst (cons 51 ang) (assoc 51 entarc) entarc)) 
(setq lm (entlast) ss (ssadd lm ss))
)

(defun midarc ( n1 /)
(setq entarc (entget n1)
tam (cdr (assoc 10 entarc))
bk (cdr (assoc 40 entarc))
pdau (polar tam (cdr (assoc 50 entarc)) bk)
pcuoi (polar tam (cdr (assoc 51 entarc)) bk)
pgiua (polar pdau (angle pdau pcuoi) (/ (distance pdau pcuoi) 2))
)
pgiua
)

New Text.lsp

[nh0kdkny 2]

còn 1 lisp này của bác DuongTrungHuy em mới test qua thấy có vẻ ổn nhưng nó bị mấy cái như hiện blipmode ( dấu cộng), chưa trả lại biến hệ thống (các cài đặt  bắt điểm bị mất, size pickbox bị về mặc định, ai test thử và xử lý giúp em mấy vấn đề còn tồn tại để lisp đc ổn định hơn với

(defun giaoHuy(ob1 ob2)
  (setq ob1 (vlax-ename->vla-object ob1)
        ob2 (vlax-ename->vla-object ob2)
		inter_lst '()
  )
  (if (not (vl-catch-all-error-p (setq iplist (vl-catch-all-apply 'vlax-safearray->list 
                                                 (list (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
                                              )
                                 )
		   )
      )
  (progn
    (while (setq inter_lst (cons (list (car iplist) (cadr iplist) (caddr iplist)) inter_lst) 
	             iplist (cdddr iplist)
	       )
	)
	(reverse inter_lst) 
  )
  )
)
(Defun Mid0(ddA ddB)

(setq diemgiua (list (* 0.5 (+ (car dda)(car ddb))) (* 0.5 (+ (cadr dda)(cadr ddb)))))

)

(defun cBomien(dskq)
   (setvar "Delobj" 1)(setvar "Pickbox" 0)
   (setq dskq1 '() dstam '())
   (Foreach pt dskq
      (command "region" pt "")
	  (setq dskq1 (append dskq1 (list (entlast)))
	        ob (vlax-ename->vla-object (entlast))
	        tamO (vlax-safearray->list (vlax-variant-value (vla-get-Centroid ob)))
			dstam (append dstam (list tamO))
	  )
   )   
   (setq dskq dskq1 nmien (length dskq) i 0 ptdau (car dskq) dsbo '())
   (setq dskqclai (cdr dskq)) 
   (While dskqclai
     (If (or (null dsbo)(null (member (1+ i) dsbo)))
	 (progn
	  (setq tamO (nth i dstam)
		    i1 0 
	  )
	  (Prompt (strcat "\r" (itoa (- nmien i)) "   "))
	  (Foreach pt dskqclai
		(setq tam (nth (+ i i1 1) dstam)
              i1 (1+ i1)	 
		)
        (If (< (distance tam tamO) 0.00001)
		(Progn
		   (If (or (not (member (+ i i1 1) dsbo))(null dsbo))(setq dsbo (append dsbo (list (+ i i1 1)))))
		)
		)
	  )
      )
      )	  
	  (setq ptdau (car dskqclai) dskqclai (cdr dskqclai) i (1+ i))
   )
  (setq i 0)	 
  (Repeat nmien
    (If (member (1+ i) dsbo)(entdel (nth i dskq)))
	(setq i (1+ i))
  )
  (setvar "Delobj" 0)(setvar "Pickbox" 4)  
) 

(defun c:test1 (/ ss111)
  (vl-load-com)
  (setvar "Osmode" 0) (setvar "Cmdecho" 0) (Setvar "orthomode" 0)
  (Setvar "Blipmode" 1)
  (setq ss (ssget (list (cons 0 "*LINE,ARC,CIRCLE,ELLIPSE"))))
  (if ss
  (Progn
    (setq dsdiem_0 '() dy 1000000.0)
    (foreach pt (getSS_Inter ss)
      (entmake (list (cons '0 "POINT")(cons '10 pt)))
	  (If (and (< 0 (length dsdiem_0))(> dy (abs (- (cadr (last dsdiem_0)) (cadr pt)))))
	      (setq dy (abs (- (cadr (last dsdiem_0)) (cadr pt))))
	  )
	  (setq dsdiem_0 (append dsdiem_0 (list pt)))
    )
    (setq dsdiem_1 (vl-sort dsdiem_0 '(lambda (x y)(< (cadr x)(cadr y))))
	      dsdiem_2 (vl-sort-i dsdiem_0 '(lambda (x y)(< (cadr x)(cadr y))))
		  dsdy (list (lambda (x y)(- (cadr x)(cadr y))))
		  dsdy '()
          ndiem (length dsdiem_1)
	      ymin (cadr (car dsdiem_1))
		  ymax (cadr (last dsdiem_1))
	)
	(setq dy (/ dy 2.0)
		  i 0 i1 0
		  dskq '()
		  dsdy (list (- (cadr (nth 1 dsdiem_1)) (cadr (nth 0 dsdiem_1))))
		  y0 (- ymin (car dsdy))
          nlan (1- ndiem)		  
	)
	(Repeat (1- nlan)
	  (setq dy1 (- (cadr (nth (1+ i1) dsdiem_1)) (cadr (nth i1 dsdiem_1)))
	        i1 (1+ i1)
			dy2 (- (cadr (nth (1+ i1) dsdiem_1)) (cadr (nth i1 dsdiem_1)))
			dsdy (append dsdy (list (/ (+ dy1 dy2) 2.0)))
	  )
	)	
	(command "Undo" "be")
	(Repeat nlan
	   (setq y0 (+ y0 (nth i dsdy))) 
	   (entmake (list (cons '0 "LINE")(cons '10 (list -10000000.0 y0))(cons '11 (list 10000000.0 y0))))
	   (setq e2 (entlast) ii 0 dsgiao_0 '() 	         
			 i1 0 i (1+ i) 
	   )
	   (Repeat (sslength ss)
	      (setq e1 (ssname ss ii) ii (1+ ii))
		  (GiaoHuy e1 e2)
		  (If inter_lst (setq dsgiao_0 (append dsgiao_0 inter_lst)))
	   )
	   (prompt (strcat "\r" (itoa (- nlan i)) "    "))
	   (entdel e2)
	   (If dsgiao_0
	   (Progn
	     (setq dsgiao_1 (vl-sort dsgiao_0 '(lambda (x y)(< (car x)(car y))))
               n2 (1- (length dsgiao_1))
	     )
	     (Repeat n2
		    (setq d0 (Mid0 (nth i1 dsgiao_1) (nth (1+ i1) dsgiao_1))
			      i1 (1+ i1)
				  ecu (entlast)
			)
			(command "-boundary" "A" "O" "P" "" d0 "")
			(If (not (equal ecu (entlast)))(setq dskq (append dskq (list (entlast)))))
		 )
	   )
	   )
    )
    (command "Undo" "e")	
  )	
  )
  (cBomien dskq)
  (princ)
)

(defun giao(ob1 ob2 / inter_lst iplist)
  (if (not (vl-catch-all-error-p (setq iplist (vl-catch-all-apply 'vlax-safearray->list (list (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))))))
  (progn
    (while (setq inter_lst (cons (list (car iplist) (cadr iplist) (caddr iplist)) inter_lst) 
	             iplist (cdddr iplist)
	       )
	) 
	(reverse inter_lst) 
  )
  )
)

(defun getSS_Inter (ss / e giao_lst i lst obj tmp_lst)
  (setq i -1)
  (while (setq e (ssname ss (setq i (1+ i))))
    (setq lst (cons (vlax-ename->vla-object e) lst))
  )
  (repeat (1- (vl-list-length lst))
    (setq obj (car lst))
    (foreach ob1 (setq lst (vl-remove obj lst ))
      (if (setq tmp_lst (giao ob1 obj))
        (foreach pt tmp_lst
          (if (not (vl-position pt giao_lst)) (setq giao_lst (cons pt giao_lst)))
        )
      )
	  (print tmp_lst)
    )
  )
  giao_lst
)