Xin lỗi vì chưa tìm thấy...

Em muốn tạo một chủ đề mới nhưng đọc bài này chưa tìm thấy nút "GỬI BÀI MỚI" ở đâu hết. Mong mọi người chỉ giúp.

Và em có đoạn code này muốn tham khảo ý kiến mọi người:

(defun c:ART()
	(setvar "cmdecho" 0)
	(while
  		(vl-load-com)
  		(setq tx (vlax-ename->vla-object (car (entsel "\nSelect text to rotate counterclockwise 90...
>>

Xin lỗi vì chưa tìm thấy...

Em muốn tạo một chủ đề mới nhưng đọc bài này chưa tìm thấy nút "GỬI BÀI MỚI" ở đâu hết. Mong mọi người chỉ giúp.

Và em có đoạn code này muốn tham khảo ý kiến mọi người:

(defun c:ART()
	(setvar "cmdecho" 0)
	(while
  		(vl-load-com)
  		(setq tx (vlax-ename->vla-object (car (entsel "\nSelect text to rotate counterclockwise 90 degrees!"))))
		(setq gbd (vla-get-Rotation tx))
		(if (or (= gbd 0) (= gbd (* 0.5 pi))(= gbd (* 1 pi))(= gbd (* 1.5 pi)))
	  		(vla-put-Rotation tx (+ gbd (* 0.5 pi)))
			(vla-put-Rotation tx 0)
		)
	)
	(setvar "cmdecho" 1)
	(princ "\Completed command!")
  	(princ)
)

Khi em chuyển nó từ .lsp thành .vlx thì nó autocad báo thế này: 

; Compilation aborted

; error: compiler found fatal error "3302-ART.lsp"

Các bạn cho tôi hỏi về vấn đề này với.

đây là lisp vẽ tatuy mà tôi dùng rất hữu ích

nhưng có 1 điều là khi tôi muồn vẽ taluy có thông số khác với thông số của taluy ban đầu thì tôi lại  ko biết cách thay đổi thông số của taluy

xin hãy giúp tôi.

;; free lisp from cadviet.com
;;; this lisp was downloaded from...
>>

Các bạn cho tôi hỏi về vấn đề này với.

đây là lisp vẽ tatuy mà tôi dùng rất hữu ích

nhưng có 1 điều là khi tôi muồn vẽ taluy có thông số khác với thông số của taluy ban đầu thì tôi lại  ko biết cách thay đổi thông số của taluy

xin hãy giúp tôi.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=5947&st=20
 
 
;;;;;;;;;vtl;;;;;;;;;;;;;;;;
;Ve ta luy.lenh VTL1
(defun nsl ()
(if (/= scale nil)
    (progn
         (setq thongbao (strcat "Ty le ban ve ?, <1/" (itoa scale) ">:"))
         (if (not (setq scaletmp (getint thongbao)))
            (setq scaletmp scale)
         )
    )
    (progn
         (setq thongbao "Ty le ban ve ? <1/1000>:")
         (if (not (setq scaletmp (getint thongbao)))
             (setq scaletmp 1000)
         )
    )
)
 
(setq scale scaletmp)
 
(setq Defaultdist (* (* scale 2) 0.002))
(if (setq tg (getreal (strcat "\nKhoang cach ky hieu ta luy <" (rtos Defaultdist 2 2) ">:")))
       (setq Defaultdist tg)
)
 
(setq chieutaluy1 1 sodoan 0)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun nsl1 ()
(if (not ktdoantaluy1)
    (setq ktdoantaluy1 250  tg (getreal (strcat "\nChi\U+1EC1u d\U+00E0i \U+0111o\U+1EA1n ng\U+1EAFn<" (rtos ktdoantaluy1 2 2) ">:")))
)
(if tg
    (setq ktdoantaluy1 tg tg nil)
)
(if (not ktdoantaluy2)
    (setq ktdoantaluy2 500 tg (getreal (strcat "\nChi\U+1EC1u d\U+00E0i \U+0111o\U+1EA1n d\U+00E0i<" (rtos ktdoantaluy2 2 2) ">:")))
)
(if tg
    (setq ktdoantaluy2 tg tg nil)
)
(if (not khoangcachtl)
    (setq khoangcachtl 200 tg (getreal (strcat "\Kho\U+1EA3ng c\U+00E1ch gi\U+1EEFa c\U+00E1c \U+0111o\U+1EA1n<" (rtos khoangcachtl 2 2) ">:")))
)
(if tg
    (setq khoangcachtl tg tg nil)
)
(if (not sodoanngan)
    (setq sodoanngan 1 tg (getint (strcat "\nS\U+1ED1 \U+0111o\U+1EA1n ng\U+1EAFn tr\U+00EAn m\U+1ED9t \U+0111o\U+1EA1n d\U+00E0<" (rtos sodoanngan 2 0) ">:")))
)
(if tg
    (setq sodoanngan tg tg nil)
)
 
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun PlMake (Plist) ; Create polyline entities
(entmake '((0 . "POLYLINE")))
(setq n (length Plist)
ic 0
)
(while (< ic n)
(entmake (list (cons 0 "VERTEX") (cons 10 (nth ic Plist))))
(setq ic (1+ ic)
)
)
(entmake '((0 . "SEQEND")))
 
)
 
 
;;;----------------------------------------------------------------
(defun ve1doantaluy (p1 p2 / pvt diemcu ktdoantaluy ketthuc)
(setq pvt (+ (angle p1 p2) (* (/ pi 2) chieutaluy)))
;;;;(setq ketthuc 1)
(if (< sodoan sodoanngan)
(progn
(setq ktdoantaluy ktdoantaluy1)
(setq sodoan (1+ sodoan))
)
(progn
(setq ktdoantaluy ktdoantaluy2)
(setq sodoan 0)
)
)
(setq p2 (polar p1 pvt ktdoantaluy))
(plmake (list p1 p2))
(setq dem (1+ dem))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun xddsd (com epl kc / e0 e p dsd)
(setq e0 (entlast))
(while e0
(setq e e0)
(setq e0 (entnext e0))
)
(command com epl kc)
(setq e (entnext e))
(while e
(setq p (cdr (assoc 10 (entget e))))
(if p
(setq dsd (cons p dsd))
)
(setq e (entnext e))
)
(command "_.Undo" 1)
(setq dsd dsd)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ve ta luy cho 1 doi tuong
(Defun vetaluy (ep / le e ketthuc them dsd thutu)
(setq dem 0)
(setq sodoan 0)
(setq ss (ssadd))
(setq e (entget (car ep)))
(if (or (= (cdr (assoc 0 e)) "LWPOLYLINE")
(= (cdr (assoc 0 e)) "POLYLINE")
(= (cdr (assoc 0 e)) "SPLINE")
(= (cdr (assoc 0 e)) "LINE")
(= (cdr (assoc 0 e)) "ARC")
(= (cdr (assoc 0 e)) "CIRCLE")
)
 
(setq ketthuc 1)
(prompt "\nDoi tuong duoc chon khong hop le")
)
(if ketthuc
(progn
(setq thutu 0)
(setq dsd (xddsd "_.Measure" ep khoangcachtl))
(setq dsd (append dsd (list (vlax-curve-getstartpoint (car ep)))))
(setq p1 (car dsd))
(repeat (1- (length dsd))
(setq thutu (1+ thutu))
(setq p2 (nth thutu dsd))
(ve1doantaluy p1 p2)
(setq p1 p2)
(setq ss (ssadd (entlast) ss))
)
)
)
(setq dem dem)
)
 
;;;==================================================
(Defun C:TL (/ ep chon lai solan chon ss tg)
(vl-load-com)
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(command "undo" "g")
;;;;(nsl)
 
(setq ep 1)
(while ep
       (setq solan 0  chieutaluy 1)
       (setq ep (entsel "\nCh\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng v\U+1EBD ta luy..."))
       (if ep
            (progn
                   (nsl1)
                   (setq solan (vetaluy ep))
                   (initget "Undo Change")
                   (while
                            (setq chon (getkword "Undo/Change <enter for exit>: "))
                            (if (= chon "Undo")
                                (command "_.Undo" solan)
                            )
                            (if (= chon "Change")
                                (progn
                                        (nsl1)
                                        (setq chieutaluy -1)
                                        (command "_.Undo" solan)
                                        (setq solan (vetaluy ep))
                                )
                             )
                             (initget "Undo Change")
                    )
                    (setq blname (getstring t "\nNh\U+1EADp t\U+00EAn block m\U+1ED1n t\U+1EA1o: "))
                    (if (/= blname "")
                        (command "block" blname (list 0.0 0.0 0.0) ss "")
                    )
                    (setq ep nil)
             )
         )
)
(command "undo" "e")
(princ)
)

 

các bác cho em hỏi máy em bị sao khi load các lisp cũ dạng xuống hàng như mẫu 1 thì chạy đc, nhưng mới down môt số lisp của diễn đàn mình mới bây giờ dạng thẳng hàng như mẫu 2 thì chạy không được, mong các bác giải đáp dùm em. em xin cảm ơn ạ!

 

mẫu 1

;; free lisp from cadviet.com
;;; this lisp was downloaded from...
>>

các bác cho em hỏi máy em bị sao khi load các lisp cũ dạng xuống hàng như mẫu 1 thì chạy đc, nhưng mới down môt số lisp của diễn đàn mình mới bây giờ dạng thẳng hàng như mẫu 2 thì chạy không được, mong các bác giải đáp dùm em. em xin cảm ơn ạ!

 

mẫu 1

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/13131-lisp-anh-xa-gia-tri-doi-tuong-thay-doi-gia-tri-nguon-dich-cap-nhat-theo/page-2
(defun C:L2T (/ OBJLINE SS OBJLST OBJ;|OBJ-REACTOR|;)
(vl-load-com)
 (setq OBJLINE (vlax-ename->vla-object (car (entsel "\nChon duong thang nguon: "))))
 (while (/= (vla-get-objectname OBJLINE) "AcDbLine")
  (setq OBJLINE (vlax-ename->vla-object (car (entsel "\nChon duong thang nguon: "))))
 )
 (princ "\nChon cac text dich: ")
 (setq SS (ssget '((0 . "TEXT"))))
 (setq OBJLST (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))))
 (foreach OBJ OBJLST
  (vla-put-textstring OBJ (rtos (* (vla-get-length OBJLINE) (getvar "DIMLFAC"))))
 )
 (setq OBJLST (append OBJLST (list OBJLINE)))
 (if (and OBJ-REACTOR (vlr-added-p OBJ-REACTOR))
  (vlr-remove OBJ-REACTOR)
 )
 (setq OBJ-REACTOR
  (vlr-pers
(vlr-object-reactor OBJLST
NIL
'((:vlr-modified . UPDATETEXT)
 (:vlr-erased . ERASEENT)
)
) 
  )
 ) 
 (princ (strcat "\nDa link duong thang voi " (itoa (sslength SS)) " text"))
 (princ)
) 
(defun UPDATETEXT (NOTIFIER-OBJECT OBJ-REACTOR PARAMETER-LIST / OBJLST OBJ)
 (setq *ERROR* REACTOR-ERR)
 (if (= (vla-get-objectname NOTIFIER-OBJECT) "AcDbLine")
  (progn
   (princ (strcat "\nTy le 1/" (rtos (getvar "DIMLFAC"))))
   (setq OBJLST (vlr-owners OBJ-REACTOR))
   (foreach OBJ OBJLST
(if (= (vla-get-objectname OBJ) "AcDbText")
(vla-put-textstring OBJ (rtos (* (vla-get-length NOTIFIER-OBJECT) (getvar "DIMLFAC"))))
) 
   )
  ) 
 )
 (setq *ERROR* NIL)
)
(defun ERASEENT (NOTIFIER-OBJECT OBJ-REACTOR PARAMETER-LIST / OBJLST)
 (alert "Ban da thuc hien lenh Erase tu doi tuong REACTOR.\nCac doi tuong khong con link voi nhau!")
 (vlr-owner-remove OBJ-REACTOR NOTIFIER-OBJECT)
 (vlr-remove OBJ-REACTOR)
 (princ)
)
(defun REACTOR-ERR (MSG)
 (cond ((= MSG "Automation Error. Object was open for undo") (princ "\nObject was open for undo"))
  ((= MSG "Automation Error. Object was erased") (princ "\nObject was erased"))
  ((= MSG "quit / exit abort") (princ "\t\texit"))
  (t (progn (princ MSG) (princ)))
 )
 (setq *ERROR* NIL)
 (princ)
)

mẫu 2

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/13131-lisp-anh-xa-gia-tri-doi-tuong-thay-doi-gia-tri-nguon-dich-cap-nhat-theo/page-2
(defun c:LinkT (/ ss objlst ); Link Text  (if (setq ss (ssget  '((0 . "TEXT"))) )    (progn      (vl-load-com)      (setq objlst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))      (if (and obj_reactor (vlr-added-p obj_reactor)) (vlr-remove obj_reactor))      (setq obj_reactor (vlr-pers (vlr-object-reactor  objlst  nil '((:vlr-modified . LinkText)     (:vlr-erased . eraseEnt)  ))))      (princ (strcat "\n   Da thuc hien Link " (itoa(sslength ss)) " Text voi nhau !"     "\n   Goi lenh Edit Text (ddedit) de cap nhat gia tri."))      (princ)      )    )  )(defun LinkText (notifier-object obj_reactor parameter-list / objlist str)  (setq objlist (vlr-owners obj_reactor) str (vla-get-TextString notifier-object))  (foreach obj objlist    (if (/= (vla-get-TextString obj)str)      (vla-put-TextString obj str)      )    )  )(defun eraseEnt (notifier-object obj_reactor parameter-list)  (alert "Ban da thuc hien lenh Erase tu doi tuong REACTOR.\nLinkText da bi huy bo : Cac Text khong con Link voi nhau !")  (vlr-owner-remove  obj_reactor notifier-object)  (vlr-remove obj_reactor)  (princ)  )

 

Mình xuống dòng hộ bạn cái lisp bạn quote, và nhìn code chẳng thấy chỗ nào liên quan đến diện tích cả :)

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/9764-da-xong-lisp-lam-the-nao-de-tim-so-doi-tuong-sinh-ra-boi-lenh-boundary/
(defun c:gb(/ po frome toe cur ss st LA CA)
(setq po (getpoint "\n Pick diem :"))
(setq frome (entlast)) ;; chon doi tuong cuoi cung truoc...
>>

Mình xuống dòng hộ bạn cái lisp bạn quote, và nhìn code chẳng thấy chỗ nào liên quan đến diện tích cả :)

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/9764-da-xong-lisp-lam-the-nao-de-tim-so-doi-tuong-sinh-ra-boi-lenh-boundary/
(defun c:gb(/ po frome toe cur ss st LA CA)
(setq po (getpoint "\n Pick diem :"))
(setq frome (entlast)) ;; chon doi tuong cuoi cung truoc khi boundary
(command "boundary" "A" "O" "R" "" po "") ;; Region
(setq toe (entlast)) ;; chon doi tuong cuoi cung sau khi Region
(setq cur frome ; khoi taoss 
ss (ssadd))
(while (not (eq cur toe)) ;; chon cac doi tuong tu frome den toe
	(setqcur (entnext cur)ss (ssadd cur ss)))
(setq st (ss2ent ss))
(setq LA (car st))
(setq CA (ssdel LA ss))
(Command "subtract" LA "" CA "")
(princ))
;;
(defun ss2ent (ss / sodt index lstent)(setqsodt (if ss (sslength ss) 0)index 0)(repeat sodt(setq ent (ssname ss index)index (1+ index)lstent (cons ent lstent)))(reverse lstent))

Lấy ý tưởng từ bài

http://www.cadviet.com/forum/topic/93584-nho-viet-lisp-hatch-vung-kin-cua-cac-doi-tuong-giao-nhau/

Tôi sửa lại lisp của bạn Doan Van Ha như sau:

- Sửa hàm chính: MBCK

- Sửa lỗi hàm HA:PointInOut luôn trả về nil nếu flag là...

Lấy ý tưởng từ bài

http://www.cadviet.com/forum/topic/93584-nho-viet-lisp-hatch-vung-kin-cua-cac-doi-tuong-giao-nhau/

Tôi sửa lại lisp của bạn Doan Van Ha như sau:

- Sửa hàm chính: MBCK

- Sửa lỗi hàm HA:PointInOut luôn trả về nil nếu flag là "N"

- Các hàm khác như cũ.

Các bạn check xem còn lỗi nào không

 

(defun SsNext (e f / ss)
    (setq ss (ssadd))
    (while (setq e (entnext e))
        (if (or (not f) (vl-position (cons 0 f) (entget e)))(ssadd e ss))    )
)
(defun C:MBKC(/ c col ent giao i kc ll lst lstb lstg1 lsti n o ss sv sy)
 (command "undo" "be") (redraw)
    (setq sy '("CMDECHO" "OSMODE" "PEDITACCEPT" "DELOBJ") sv (mapcar 'getvar sy))
    (mapcar 'setvar sy '(0 0 1 1))
 (setq col 1)
 (while
  (and
   (princ "\nChon cac Line duong truc...")
   (setq ss (ssget '((0 . "LINE"))))
   (setq lsti (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (or kc (setq kc 110))
   (setq kc (cond ((getdist (strcat "\nBe rong tuong/dam <" (rtos kc 2 2) ">:"))) (kc))))
  (mapcar '(lambda(ent) (grdraw (vlax-curve-getStartPoint ent) (vlax-curve-getEndPoint ent) col)) lsti)
  (setq lst (append (mapcar '(lambda(ent) (list ent kc)) lsti) lst))
  (setq lstb (append lsti lstb))
  (setq col (1+ col)))
 (command "zoom" "w" (car (setq c (LM:ListBoundingBox lstb))) (cadr c))
 (setq lst (reverse lst))
    (setq ll (entlast))
 (foreach n1 lst
  (setq lstg1 nil)
  (foreach n2 lst
   (if (setq giao (car (HA:Giao (vlax-ename->vla-object (car n1)) (vlax-ename->vla-object (car n2)) acExtendNone)))
    (setq lstg1 (cons giao lstg1)))
        )
     (if lstg1
         (progn
             (setq i 0 o (cdr (assoc 10 (entget (car n1)))))
             (setq lstg1 (LM:UniqueFuzz(vl-sort lstg1 '(lambda(p q) (< (distance p o) (distance q o)) ))1e-10))
             (repeat (1- (length lstg1))
                 (entmake (list (cons 0 "LINE") (cons 10 (nth i lstg1)) (cons 11 (nth (setq i (1+ i)) lstg1)) ))         )
         )
    ))
 ;(load "overkillsup.lsp")
    (vl-cmdf "._REGION" (SsNext ll nil) "")
    (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (SsNext ll "REGION"))))
        (vl-cmdf "._EXPLODE" ent)
        ;(acet-overkill2 (list (ssget "P") 1E-3))
        (vl-cmdf "PEDIT" "M" "p" "" "J" "" "" )
        )
    
    (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (SsNext ll "LWPOLYLINE")))))
    (setq ss (vl-sort ss '(lambda(p q) (> (vlax-curve-getarea p) (vlax-curve-getarea q)) )))
 (HA:OffsetInOut (car ss) lst "N")
 (foreach ent (cdr ss)
  (HA:OffsetInOut ent lst "T"))
    (mapcar 'setvar sy sv)(command "undo" "e")
    (redraw) (princ))

(defun HA:PointInOut (p obj flag / flag1 obj1 obj2 lon nho)
 (setq obj1 (car (vlax-invoke obj 'Offset 1E-1))
       obj2 (car (vlax-invoke obj 'Offset -1E-1)))
 (if (> (vla-get-area obj1)(vla-get-area obj2))
  (setq lon obj1 nho obj2)
  (setq lon obj2 nho obj1))
 (if (> (distance p (vlax-curve-getClosestPointTo lon p))(distance p (vlax-curve-getClosestPointTo nho p)))
  (if (= flag "T")(setq flag1 T))
     (if (= flag "N")(setq flag1 T)
   ))
 (mapcar 'vla-delete (list lon nho))
 flag1)
 

Chào các bác!

Em đang viết lại LISP Convert Text 2D sang Text 3D nhưng đang vướng một lỗi chỗ nào đó mà không thể mò ra được. Các Text vẫn không thể cập nhật được cao độ từ nội dung Text. Các bác xem và chỉ dùm em chỗ sai. Cảm ơn các bác nhiều.

(defun C:00(/ ss0 ss item Caodo Ma_Pnt Tdo Pnt)
(setq ss0 (ssget (list (cons 0  "TEXT"))))
(setq ss (acet-ss-to-list...
>>

Chào các bác!

Em đang viết lại LISP Convert Text 2D sang Text 3D nhưng đang vướng một lỗi chỗ nào đó mà không thể mò ra được. Các Text vẫn không thể cập nhật được cao độ từ nội dung Text. Các bác xem và chỉ dùm em chỗ sai. Cảm ơn các bác nhiều.

(defun C:00(/ ss0 ss item Caodo Ma_Pnt Tdo Pnt)
(setq ss0 (ssget (list (cons 0  "TEXT"))))
(setq ss (acet-ss-to-list ss0))
(foreach item ss
	(setq temp  (entget item))
	(setq Caodo  (cdr (assoc 1 temp)))
	(setq Ma72 (car (TD:Ma_And_Pnt item )))
	(setq Ma73 (cadr (TD:Ma_And_Pnt item )))
	(setq Ma_Pnt (caddr (TD:Ma_And_Pnt item )))
	(setq Pnt  (cdr (assoc Ma_Pnt temp)))
	(entmod
		(subst (list Ma_Pnt (car Pnt) (cadr Pnt) (atof Caodo)) (assoc Ma_Pnt temp)
			(subst (cons 72 Ma72) (assoc 72 temp)
				       (subst (cons 73 Ma73) (assoc 73 temp) temp)
			)
		)
	)
   
)
(princ)
)

(defun TD:Ma_And_Pnt (Ent / e z p   )
(setq e (entget Ent))
(setq  Ma72 (cdr (assoc 72 e))
       Ma73 (cdr (assoc 73 e))
)
(setq Ma7273Pnt (list '(0 0 10) '(2 0 11) '(1 0 11) '(3 0 11) '(4 0 11)
		      '(5 0 10) '(0 3 10) '(1 3 11) '(2 3 11) '(0 2 11)
		      '(1 2 11) '(2 2 11) '(0 1 11) '(1 1 11) '(2 1 11)
		)
)
(setq Ma_And_Pnt (nth 0 (vl-remove nil (mapcar '(lambda(x) (if (and (= Ma72 (car x) ) (= Ma73 (cadr x))) x nil)) Ma7273Pnt))))
Ma

Đúng như bạn tien2005 nói, vừa sửa xong, up cho bạn luôn.

Đã viết xong phần tìm trắc ngang

nhờ mọi người viết tiếp cho lựa chọn nút 

radio_button để làm sao chọn 1 trong 2 lựa chọn 

đây là lisp đã viết

(defun C:timc (/ datalist)
(vl-load-com)
(defun sosanh (e1 e2 / p1 p2)
	(setq p1...
>>

Đã viết xong phần tìm trắc ngang

nhờ mọi người viết tiếp cho lựa chọn nút 

radio_button để làm sao chọn 1 trong 2 lựa chọn 

đây là lisp đã viết

(defun C:timc (/ datalist)
(vl-load-com)
(defun sosanh (e1 e2 / p1 p2)
	(setq p1 (car e1)
		p2 (car e2)
	)
	(if (equal (cadr p1) (cadr p2) 1)
		(< (car p1) (car p2))
		(> (cadr p1) (cadr p2))
	)
	)
(prompt "\nChon doi tuong coc hoac ly trinh lam lop chuan.")  
(setq dtltc (car (entsel)))
(setq lop1 (cdr (assoc 8 (entget dtltc))))
(setq danhsachc (acet-ss-to-list (ssget "X" (list (cons 8 lop1) (cons 1 "C*")))))
(setq danhsachkm (acet-ss-to-list (ssget "X" (list (cons 8 lop1) (cons 1 "K*")))))
(setq coc (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) danhsachc))
(setq km (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
(setq coc (vl-sort coc 'sosanh))
(setq km (vl-sort km 'sosanh))
(if (/= (length coc) (length km))
  (alert "Yeu cau so luong 'coc' & 'Ly trinh' phai bang nhau!")
  (progn
   (foreach ent1 coc
	(setq pt1 (car ent1))
	(setq dis (* 2 (distance pt1 (car (nth 0 km)))))
	(foreach ent2 km
	(setq pt2 (car ent2))
	(if (< (distance pt1 pt2) dis)
  	(setq dis (distance pt1 pt2) ent3 ent2)))
	(if (null datalist)
	(setq datalist (list (strcat (cdr ent1) "-" (cdr ent3))))
	(setq datalist (append datalist (list (strcat (cdr ent1) "-" (cdr ent3)))))
	))))
(setq datalist (vl-sort datalist '(lambda(x y / tmx tmy) (setq tmx (timlt x) tmy (timlt y))
               (or (< (car tmx) (car tmy))
   (and (= (car tmx) (car tmy)) (< (last tmx) (last tmy)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq numside (nth 0 datalist))
(setq numsidetd (nth 0 datalist))
(setq DCL_ID (load_dialog (strcat odiachay "\\tlkt\\dcl\\timcoc.DCL")))
(new_dialog "Ha1" DCL_ID)
(HA:SetVal (setq lstkey '("timtn" "timtd"))
            (setq lstvar '(timtn timtd)) '("1" "0"))
(mode_tile "td" 1)
(mode_tile "TCTD" 1)
(mode_tile "TCTN" 2)
(action_tile "timtn" "(mode_tile \"td\"1)(mode_tile \"TCTD\"1)")
(action_tile "timtd" "(mode_tile \"tn\"1)(mode_tile \"TCTN\"1)")
(action_tile "TCTN" "(Setgt $reason)")
(start_list "tn")
(mapcar 'add_list datalist)
(end_list)
(set_tile "tn" (itoa (vl-position numside datalist)))
(action_tile "tn" "(setq numside (nth (atoi $value) datalist))")
(start_list "td")
(mapcar 'add_list datalist)
(end_list)
(set_tile "td" (itoa (vl-position numsidetd datalist)))
(action_tile "td" "(setq numsidetd (nth (atoi $value) datalist))")
(action_tile "btn_tim" "(done_dialog 1)")
(action_tile "btn_thoat" "(done_dialog 14)")
(setq phepchon (start_dialog))
(cond 
      ((= phepchon 1) (tim))
      ((= phepchon 14) (thoi))
 )
 (if (< 0 DCL_ID) (unload_dialog DCL_ID))
 	(princ)
  )
(defun tim ( / vitri kmtim)
(setq vitri (VL-STRING-POSITION 75 numside))
(setq kmtim (SUBSTR numside (+ vitri 1)))
(foreach ent2 km
(if (= (cdr ent2) kmtim)
(setq point (car ent2))
))
(command "ZOOM" "c" point 25)
)
(defun timlt (st / tm)
  (setq tm (vl-string->list (substr (strcase st) (+ 4 (vl-string-search "-KM" (strcase st))))))
  (read (strcat "(" (vl-list->string (subst 32 43 (subst 32 58 tm))) ")"))
)
(defun HA:SetVal (lstkey lstvar lstval) 
  (mapcar '(lambda (var val) (if (not (eval var)) (set var val))) lstvar lstval)
  (mapcar '(lambda (key val) (set_tile key (set (read key) val))) lstkey (mapcar 'eval lstvar))
)
(defun Setgt (chon1 / vitri coctim datalist1)
(if (= chon1 1)
(progn
(set_tile "TCTN" (strcat "Cäc:" (get_tile "TCTN")))
(setq numside1 (strcase (get_tile "TCTN")))
(foreach ent datalist
(setq vitri (VL-STRING-POSITION 75 ent))
(setq coctim (strcase (SUBSTR ent 1 (- vitri 1))))
(if (= coctim numside1)
(progn
(if (null datalist1)
(setq datalist1 (list ent))
(setq datalist1 (append datalist1 (list ent)))
) 
)
))
(if (null datalist1)
(alert "Khong tim thay coc")
(progn
(setq datalist datalist1)
(setq numside (nth 0 datalist))
(start_list "tn")
(mapcar 'add_list datalist)
(end_list)
(set_tile "tn" (itoa (vl-position numside datalist)))
(action_tile "tn" "(setq numside (nth (atoi $value) datalist))")
))
(mode_tile "btn_tim" 2)
)))

còn DCL như ở trên

Bạn thử cái này.

(defun c:cop()
  (setq a (car (entsel "\nChon text de copy:"))
pt (cdr (assoc 10 (entget a)))
b (list "A" "B" "C")
  ) (setvar 'cmdecho 0)
  (while pt
    (command "copy" a "" pt (setq pt (getpoint pt)) )
    (if pt
      (progn
        (setq c (entlast)
 d (cdr (assoc 1 (entget c)))
 so (itoa (1+ (atoi d)))
 chu (1+ (vl-position (substr d (strlen d)) b))
        )
        (if (> chu (1-...
>>

Bạn thử cái này.

(defun c:cop()
  (setq a (car (entsel "\nChon text de copy:"))
pt (cdr (assoc 10 (entget a)))
b (list "A" "B" "C")
  ) (setvar 'cmdecho 0)
  (while pt
    (command "copy" a "" pt (setq pt (getpoint pt)) )
    (if pt
      (progn
        (setq c (entlast)
 d (cdr (assoc 1 (entget c)))
 so (itoa (1+ (atoi d)))
 chu (1+ (vl-position (substr d (strlen d)) b))
        )
        (if (> chu (1- (length b))) (setq chu 0))
        (setq chu (nth chu b))
        (entmod (subst (cons 1 (strcat so chu)) (assoc 1 (entget c)) (entget c)))
        (setq a c)
)
      )
  ) (setvar 'cmdecho 1)
  (princ)
)
 

Cho em hỏi 1 chút.

Muốn biến đoạn Code này về dạng (mapcar '(lambda (......thì viết như thế nào các bác nhỉ?

(defun c:77(/ Lts1 Lts2 Lts i)
(setq Lts1 (list))
(setq Lts2 (list))
(setq i 0)
(setq lts (list '(8 9 nil) '(5 8 nil) '(nil 8 4) '(2 3 nil) '(8 nil 2)))
(while (< i (length Lts))
	(setq Lts1 (mapcar '(lambda (x) (if (= x nil) (not x) x)) (nth i lts)))
	(setq Lts2 (append Lts2 (list...
>>

Cho em hỏi 1 chút.

Muốn biến đoạn Code này về dạng (mapcar '(lambda (......thì viết như thế nào các bác nhỉ?

(defun c:77(/ Lts1 Lts2 Lts i)
(setq Lts1 (list))
(setq Lts2 (list))
(setq i 0)
(setq lts (list '(8 9 nil) '(5 8 nil) '(nil 8 4) '(2 3 nil) '(8 nil 2)))
(while (< i (length Lts))
	(setq Lts1 (mapcar '(lambda (x) (if (= x nil) (not x) x)) (nth i lts)))
	(setq Lts2 (append Lts2 (list Lts1)))
	(setq i (1+ i))
)
(princ Lts2)
(princ)
)

không phải lệnh shell để gọi cửa sổ dos mà shell để tạo vỏ cho solid 3d.
mình vô tình thao tác lệnh shell (tạo vỏ)sai 1 lần thi sau đó không thê shell tất cả các solid trên file bản vẻ đó kể cả copy sang ban vẻ mói va tạo chi tiết mới cũng không shell đuọc.mà lối này thường hay gạp lám.chi co cách là tạo ban vẻ mói và ve lại từ đầu.nhưng bản vẽ của mình thì đa có chuẩn dim va...

không phải lệnh shell để gọi cửa sổ dos mà shell để tạo vỏ cho solid 3d.
mình vô tình thao tác lệnh shell (tạo vỏ)sai 1 lần thi sau đó không thê shell tất cả các solid trên file bản vẻ đó kể cả copy sang ban vẻ mói va tạo chi tiết mới cũng không shell đuọc.mà lối này thường hay gạp lám.chi co cách là tạo ban vẻ mói và ve lại từ đầu.nhưng bản vẽ của mình thì đa có chuẩn dim va text mình tạo sẳn.nếu tạo mới thì rất khổ.mong bác Hoanh và các bac chỉ mình cách khắc phục lỗi đó và tiếp tục shell với nhũng solid trong file bản vẽ đang gạp lối đó,thanks!
xem dzùm các dòng lệnh và cách sủa nhũng lỗi này:
Command: _solidedit
Solids editing automatic checking: SOLIDCHECK=1
Enter a solids editing option <eXit>: _body
Enter a body editing option
<eXit>: _shell
Select a 3D solid:
Remove faces or : 1 face found, 1 removed.

Remove faces or :

Enter the shell offset distance: 2


Modeling Operation Error:
Change in topology detected.

Hoặc là:

Command: _solidedit
Solids editing automatic checking: SOLIDCHECK=1
Enter a solids editing option <eXit>: _body
Enter a body editing option
<eXit>: _shell
Select a 3D solid:
Remove faces or : 1 face found, 1 removed.

Remove faces or :

Enter the shell offset distance: 2


Modeling Operation Error:
No solution for a vertex.

Bạn thử cái này. Tôi chỉ sửa hàm xulytext thôi , còn chỗ khác để nguyên.

(defun ketthuc ()
  (setvar "cmdecho" luuecho)
  (setq *error* luu
luu nil
luuecho nil
  ) 
  (princ)
)
 
(defun modau ()
  (setq luu *error
luuecho (getvar "cmdecho")
*error (ketthuc)
  )
)
 
(defun xulytext (text / sokt  )
  (setq sokt (last (read (strcat "(" (vl-list->string (mapcar '(lambda(x) (if (or (< x 48) (> x 57)) 32 x))...
>>

Bạn thử cái này. Tôi chỉ sửa hàm xulytext thôi , còn chỗ khác để nguyên.

(defun ketthuc ()
  (setvar "cmdecho" luuecho)
  (setq *error* luu
luu nil
luuecho nil
  ) 
  (princ)
)
 
(defun modau ()
  (setq luu *error
luuecho (getvar "cmdecho")
*error (ketthuc)
  )
)
 
(defun xulytext (text / sokt  )
  (setq sokt (last (read (strcat "(" (vl-list->string (mapcar '(lambda(x) (if (or (< x 48) (> x 57)) 32 x)) (vl-string->list text))) ")")))
luusokt (1+ sokt))  
  (if (> luusokt 1000)
    (setq luusokt 1)
  )
  (setq text (vl-string-subst (rtos luusokt 2 0) (rtos sokt 2 0) text ))
)
 
(defun doitext (tendoituong     /       chuoi doituong
thoat   tam     dsach     kieu text
vitri10   vitri11   dem       canle
      )
 
  (setq doituong (entget tendoituong)
kieu  (cdr (assoc 0 doituong))
canle  (cdr (assoc 72 doituong))
  )
  (if (or (= kieu "TEXT")
 (= kieu "MTEXT")
      )
    (progn
      (setq textxl  (xulytext textxl)
   text    (cons 1 textxl)
   vitri10 (cdr (assoc 10 doituong))
   vitri10 (list (+ (car vitri10) (car vitrilech))
 (+ (nth 1 vitri10) (nth 1 vitrilech))
   )
   vitri10 (cons 10 vitri10)
   vitri11 (cdr (assoc 11 doituong))
   vitri11 (list (+ (car vitri11) (car vitrilech))
 (+ (nth 1 vitri11) (nth 1 vitrilech))
   )
   vitri11 (cons 11 vitri11)
   dem     0
   dsach   nil
      )
      (foreach tam doituong
(cond
 ((= (car tam) 1) (setq dsach (append dsach (list text))))
 ((= (car tam) 10)
  (setq dsach (append dsach (list vitri10)))
 )
 ((= (car tam) 11)
  (setq dsach (append dsach (list vitri11)))
 )
 ((setq dsach (append dsach (list tam))))
)
      )
      (entmake dsach)
    ) ;progn
  ) ;if
) ;
;*********************************************************************
;sao doi tuong cu sang vi tri moi
 
(defun copy_dt (tendoituong)
  (command "copy" tendoituong "" goc toi)
) ;defun
 
;*********************************************************************
(defun c:coo (/ cumdt dodai thoat dem ten doituong textxl dem goc toi)
; Khoi dau cua chuong trinh
  (princ "\nCopy Inteligent...\n")
  (setq luuecho (getvar "cmdecho")
luu *error*
*error* ketthuc
cumdt (ssget)
dodai (sslength cumdt)
goc (getpoint "\nSelect base point:")
thoat nil
dem 0
textxl nil
  ) ;
  (setvar "cmdecho" 0)
; Loc ra duoc ong text de xu ly
  (while (and (= thoat nil)
     (< dem dodai)
)
    (setq ten    (ssname cumdt dem)
 dem    (1+ dem)
 doituong (entget ten)
 kieu    (cdr (assoc 0 doituong))
    )
 
    (if (or (= kieu "TEXT")
   (= kieu "MTEXT")
)
      (setq thoat  T
   textxl (cdr (assoc 1 doituong))
      )
    )
  ) ;
  (while T
    (setq toi     (getpoint "\nSelect next point: " goc)
 vitrilech (list (- (car toi) (car goc))
 (- (nth 1 toi) (nth 1 goc))
   )
 dem     0
    )
    (while (< dem dodai)
      (setq ten      (ssname cumdt dem)
   dem      (1+ dem)
   doituong (entget ten)
   kieu     (cdr (assoc 0 doituong))
      )
 
      (if (or (= kieu "TEXT")
     (= kieu "MTEXT")
 )
(doitext ten)
(copy_dt ten)
 
      ) ;if
    )
  ) ;while
  (ketthuc)
) ;defun
(princ "Type \"DG\" to start")

Có 2 cách:

1. Dùng nentsel nhấp ngay vào text dim.

2. Tạo một hàm để tìm Mtext trong Dim, vì dim cũng là dynamic block nên có nhiều thành phần.

Code như sau:

(defun c:tmp()
  (setq mtxt (car (nentsel "\nChon Text Dim:"))
txt (strcat (cdr (assoc 1 (entget mtxt))) "\\PBlaBla"))
  (entmod (subst (cons 1 txt) (assoc 1 (entget mtxt)) (entget mtxt)))
  (vl-cmdf "regen")
  (princ)
)
 
(defun...
>>

Có 2 cách:

1. Dùng nentsel nhấp ngay vào text dim.

2. Tạo một hàm để tìm Mtext trong Dim, vì dim cũng là dynamic block nên có nhiều thành phần.

Code như sau:

(defun c:tmp()
  (setq mtxt (car (nentsel "\nChon Text Dim:"))
txt (strcat (cdr (assoc 1 (entget mtxt))) "\\PBlaBla"))
  (entmod (subst (cons 1 txt) (assoc 1 (entget mtxt)) (entget mtxt)))
  (vl-cmdf "regen")
  (princ)
)
 
(defun c:tmp1()
  (defun GeD(v / l en)
    (setq l nil)
    (vlax-for item (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
    (cdr (assoc 2 (entget v))))
      (if (= "MTEXT" (cdr (assoc 0 (entget (setq en (vlax-vla-object->ename item))))))
(setq l en))
    ) l
  )
  
  (setq mtxt (Ged (car (entsel "\nChon Dim:")))
txt (strcat (cdr (assoc 1 (entget mtxt))) "\\PBlaBla"))
  (entmod (subst (cons 1 txt) (assoc 1 (entget mtxt)) (entget mtxt)))
  (vl-cmdf "regen")
  (princ)
)

Bạn dùng thử cái này. Khi muốn undo thì bấm u, còn tiếp tục thì enter. 

Bạn esc thì nó dứt lệnh và osnap trở về trạng thái trước khi chạy lisp.

(defun DXF (code elist)
  (cdr (assoc code elist))
)
 
(defun c:tn (); / DZ pt y ptside ang OT sc1 scale)
  (vl-load-com)
 
  (defun *error* (msg)
    (setq tmp *error*)
    (if OSLAST (setvar "OSMODE" OSLAST))
    (setq *error* tmp)
  )
 ...
>>

Bạn dùng thử cái này. Khi muốn undo thì bấm u, còn tiếp tục thì enter. 

Bạn esc thì nó dứt lệnh và osnap trở về trạng thái trước khi chạy lisp.

(defun DXF (code elist)
  (cdr (assoc code elist))
)
 
(defun c:tn (); / DZ pt y ptside ang OT sc1 scale)
  (vl-load-com)
 
  (defun *error* (msg)
    (setq tmp *error*)
    (if OSLAST (setvar "OSMODE" OSLAST))
    (setq *error* tmp)
  )
  (setvar "cmdecho" 0)
  (if (not scale)   (setq scale 1))
  (setq sc1 (getreal (strcat "\n Cao text <" (rtos scale 2 0) ">:")))
  (if sc1   (setq scale sc1)  )
  (SETQ OSLAST (getvar "OSMODE"))
  (setq DZ (getvar "DIMZIN"))
  (setvar "DIMZIN" 0)
  (setq OT (getvar "ORTHOMODE"))
  (setvar "ORTHOMODE" 0)
  (command "osmode" 99)
  (setq pt0 (osnap (getpoint "Diem tim TN tu nhien <end of> : ") "end"))
  (print)
  (setq x0 (car pt0)
y0 (cadr pt0)
  )
  (setq ed (entget (car (entsel "\nChon cao do tim: ")))
H0 (read (DXF 1 ed))
  )
  (command "osmode" 15359)  
 
  (While (setq pt (getpoint "\nDiem chen: "))    
    (setq ptside (getpoint pt "\nPhia chen:" )
 ang  (angle pt ptside))
    (setq y (- (cadr pt) y0 (- H0))
 x (- (car pt) x0))
    (cond ((> x 0) (setq x (strcat "" (rtos x 2 2))))
 ((< x 0) (setq x (rtos (abs x) 2 2)))
 ((= x 0) (setq x "0.00"))
  )
    (cond ((> y 0) (setq y (strcat "+" (rtos y 2 2))))
 ((< y 0) (setq y (rtos y 2 2)))
 ((= y 0) (setq y "%%p0.00"))
  )
     ;(setq x (ustr 0 "Khoang cach: " x T))
;(setq y (ustr 0 "Cao do: " y T))     
   (if (not (tblsearch "block" "LCD1"))
     (progn (command "insert" "C:\\Lisp CAD\\BVTN.dwg" "" "" "" "")
            (command "erase" (entlast) ""))
   )
   (if (AND (>= ang 0) (< ang 1.5708))
     (command "INSERT" "LCD1" pt scale scale "0" x y))
    (if (AND (>= ang 1.5708) (< ang 3.1416))
      (command "INSERT" "LCD2" pt scale scale "0" y x))
    (if (AND (>= ang 3.1416) (< ang 4.7124))
      (command "INSERT" "LCD3" pt scale scale "0" x y))
    (if (AND (>= ang 4.7124) (< ang 6.2832))
      (command "INSERT" "LCD4" pt scale scale "0" y x))
 
    (while (= "U" (strcase (getstring "\nEnter = Tiep tuc / U = undo : ")))
      (command "undo" 1)) 
  )
  (setvar "OSMODE" OSLAST)
  (setvar "DIMZIN" DZ)
  (setvar "ORTHOMODE" OT)
)
;---------------------------------------------------------------------------
 

Đây là lisp mình sửa lại để phục vụ cho công việc của mình

nhưng đang bị lỗi không xuất được những trắc ngang cuối cùng khoảng 7-8 trắc ngang chi đó

nhờ mọi người giúp đỡ

đây là lisp

 (defun c:Nhan (/ lstkm point kcach point1 pointtim diemtam)
 (defun sosanh (e1 e2 / p1 p2)
	(setq p1 (car e1)
		p2 (car e2)
	)
	(if (equal (cadr p1) (cadr p2) fuzz)
		(< (car p1) (car...
>>

Đây là lisp mình sửa lại để phục vụ cho công việc của mình

nhưng đang bị lỗi không xuất được những trắc ngang cuối cùng khoảng 7-8 trắc ngang chi đó

nhờ mọi người giúp đỡ

đây là lisp

 (defun c:Nhan (/ lstkm point kcach point1 pointtim diemtam)
 (defun sosanh (e1 e2 / p1 p2)
	(setq p1 (car e1)
		p2 (car e2)
	)
	(if (equal (cadr p1) (cadr p2) fuzz)
		(< (car p1) (car p2))
		(> (cadr p1) (cadr p2))
	)
	)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (prompt "\nChon doi tuong coc hoac ly trinh lam lop chuan.")  
  (setq dtltc (car (entsel)))
  (setq lop1 (cdr (assoc 8 (entget dtltc))))
  (prompt "\nChon doi tuong ghi dien tich lam lop chuan.")
  (setq lop2 (car (entsel)))
  (setq lop2 (cdr (assoc 8 (entget lop2))))
  ;(setq cot (getint "\nSo cot can xuat ra Excel:"))
(setq danhsachkm (acet-ss-to-list (ssget (list (cons 8 lop1) (cons 1 "K*")))))
(setq lstkm (mapcar '(lambda (e) (cons (cdr (assoc 11 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
(setq lstkm (vl-sort lstkm '(lambda(x y / tmx tmy) (setq tmx (timlt x) tmy (timlt y))
               (or (< (car tmx) (car tmy))
   (and (= (car tmx) (car tmy)) (< (last tmx) (last tmy)))))))
(setq ss (acet-ss-to-list (ssget "X" '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq fn (getfiled "Chon file de save" "" "csv" 1))
(setq fid (open fn "w"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(foreach ent lstkm
(setq point (car ent))
(setq kcach (distance point (cdr (assoc 11 (entget (nth 0 ss))))))
(foreach enxt ss
(setq point1 (cdr (assoc 11 (entget enxt))))
(setq toay (cadr point1))
(if (and (< (distance point1 point) kcach) (< toay (cadr point)) (equal (car point1) (car point) 1))
(progn
(setq pointtim (cdr (assoc 11 (entget enxt))))
(setq kcach (distance pointtim point))
)
)
)
(setq diemtam (polar pointtim (/ pi 2) (/ kcach 2)))
(command "ZOOM" "c" diemtam (+ kcach 5))
(setq dd (acet-ss-to-list (ssget "C" (polar pointtim (/ pi 4) 0.1 ) (polar pointtim (/ pi -4) 0.1 ) '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
(setq diemdau (cdr (assoc 10 (entget (car dd)))))
(setq diemcuoi (cdr (assoc 11 (entget (car dd)))))
(setq diemtren (polar point (/ pi 2) 3))
(command ".RECTANGLE" diemdau diemtren)
(setq text (ssget "C" diemdau diemtren (list (cons 0 "text"))))
(setq lst0 (ss2ent text lop1))
(setq lst0 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst0))
(setq lst2 (ss2ent text lop2))
(setq lst2 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst2))
(setq
	caotext (cdr (assoc 40 (entget (ssname text 0))))
	fuzz (* caotext 1.0)
	lst0 (vl-sort lst0 'sosanh)
	lst2 (vl-sort lst2 'sosanh)
	index 1
	oldy nil
)
(setq xuongdong 1)
	(foreach em lst0
	(if (= dong 0)
	(progn
	   (princ (cdr em) fid)
	   (princ "\n" fid)
	)
	(progn
	(if (= xuongdong 1)
	   (progn
	   (princ "\n" fid)
	   (princ (cdr em) fid)
	   (princ "\n" fid)
	   (setq xuongdong 2)
	   )
	(princ (cdr em) fid)
	)
	)
	)
	)
(setq dong 1)
	(foreach en lst2
	(if (equal oldy (cadr (car en)) fuzz)
  		(progn
     			(if (< index 4)
  			(progn
        		(princ "," fid)
        		(setq index (1+ index))
  			)
       		(progn
       		(setq index 1)
       		(princ "\n" fid)
       		)
      		)
  		)
 		(progn
  		(if hangdau
            		(progn
            		(setq index 1)
            		(princ "\n" fid)
           	 )
   		(setq hangdau t)
   		)
 		)
	)
	(princ (cdr en) fid)
	(setq oldy (cadr (car en)))
	)
(command ".RECTANGLE" diemcuoi diemtren)
(setq text1 (ssget "C" diemcuoi diemtren (list (cons 0 "text"))))
(setq lst3 (ss2ent text1 lop2))
(setq lst3 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst3))
(setq
	lst3 (vl-sort lst3 'sosanh)
	index 1
	oldy nil
)
(setq dong 1)
	(foreach en lst3
	(if (equal oldy (cadr (car en)) fuzz)
  		(progn
     			(if (< index 4)
  			(progn
        		(princ "," fid)
        		(setq index (1+ index))
  			)
       		(progn
       		(setq index 1)
       		(princ "\n" fid)
       		)
      		)
  		)
 		(progn
  		(if hangdau
            		(progn
            		(setq index 1)
            		(princ "\n" fid)
           	 )
   		(setq hangdau t)
   		)
 		)
	)
	(princ (cdr en) fid)
	(setq oldy (cadr (car en)))
	)
)
)

(defun timlt (st / tm)
  (setq tm (vl-string->list (substr (strcase (cdr st)) (+ 3 (vl-string-search "KM" (strcase (cdr st)))))))
  (read (strcat "(" (vl-list->string (subst 32 43 (subst 32 58 tm))) ")"))
)
(defun ss2ent (ss lop / sodt index lstent)
(setq
sodt (if ss
(sslength ss)
0
)
index 0
)
(repeat sodt
(setq ent (ssname ss index))
(setq index (1+ index))
(if (= (cdr (assoc 8 (entget ent))) lop)
(setq lstent (cons ent lstent))
)
)
(reverse lstent)

)

đây là file thực hiện

http://www.cadviet.com/upfiles/3/66960_tn_khong_dc_dia_chat.dwg

Không biết cái này có được không, test thì vẫn đưa ra đủ.

Tôi phải sửa cho nó gọn lại cho dễ nhìn.

 (defun c:Nhan (/ lstkm point kcach point1 pointtim diemtam)
   (defun sosanh (e1 e2 / p1 p2)
(setq p1 (car e1)
p2 (car e2)
)
(if (equal (cadr p1) (cadr p2) fuzz)
(< (car p1) (car p2))
(> (cadr p1) (cadr p2))
)
   )
   
   (defun inra(lst)
    (setq index 1
 oldy nil)
    (foreach en...
>>

Không biết cái này có được không, test thì vẫn đưa ra đủ.

Tôi phải sửa cho nó gọn lại cho dễ nhìn.

 (defun c:Nhan (/ lstkm point kcach point1 pointtim diemtam)
   (defun sosanh (e1 e2 / p1 p2)
(setq p1 (car e1)
p2 (car e2)
)
(if (equal (cadr p1) (cadr p2) fuzz)
(< (car p1) (car p2))
(> (cadr p1) (cadr p2))
)
   )
   
   (defun inra(lst)
    (setq index 1
 oldy nil)
    (foreach en lst
      (if (equal oldy (cadr (car en)) fuzz)
(progn (if (< index 4)
 (progn (princ "," fid) (setq index (1+ index)))
 (progn (setq index 1) (princ "\n" fid) )
       )
    )
(progn  (if hangdau
 (progn (setq index 1) (princ "\n" fid))
 (setq hangdau t))
  )
      )
      (princ (cdr en) fid)
      (setq oldy (cadr (car en)))
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (prompt "\nChon doi tuong coc hoac ly trinh lam lop chuan.")  
  (setq dtltc (car (entsel)))
  (setq lop1 (cdr (assoc 8 (entget dtltc))))
  (prompt "\nChon doi tuong ghi dien tich lam lop chuan.")
  (setq lop2 (car (entsel)))
  (setq lop2 (cdr (assoc 8 (entget lop2))))
  ;(setq cot (getint "\nSo cot can xuat ra Excel:"))
  (setq danhsachkm (acet-ss-to-list (ssget (list (cons 8 lop1) (cons 1 "K*")))))
  (setq lstkm (mapcar '(lambda (e) (cons (cdr (assoc 11 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
  (setq lstkm (vl-sort lstkm '(lambda(x y / tmx tmy) (setq tmx (timlt x) tmy (timlt y))
                 (or (< (car tmx) (car tmy))
    (and (= (car tmx) (car tmy)) (< (last tmx) (last tmy)))))))
  (setq ss (acet-ss-to-list (ssget "X" '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq fn (getfiled "Chon file de save" "" "csv" 1))
  (setq fid (open fn "w"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (foreach ent lstkm
    (setq point (car ent))
    (setq kcach (distance point (cdr (assoc 11 (entget (nth 0 ss))))))
    (foreach enxt ss
      (setq point1 (cdr (assoc 11 (entget enxt))))
      (setq toay (cadr point1))
      (if (and (< (distance point1 point) kcach) (< toay (cadr point)) (equal (car point1) (car point) 1))
(progn
 (setq pointtim (cdr (assoc 11 (entget enxt))))
 (setq kcach (distance pointtim point))
)
      )
    )
    (setq diemtam (polar pointtim (/ pi 2) (/ kcach 2)))
    (command "ZOOM" "c" diemtam (+ kcach 5))
    (setq dd (acet-ss-to-list (ssget "C" (polar pointtim (/ pi 4) 0.1 ) (polar pointtim (/ pi -4) 0.1 ) '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
    (setq diemdau (cdr (assoc 10 (entget (car dd)))))
    (setq diemcuoi (cdr (assoc 11 (entget (car dd)))))
    (setq diemtren (polar point (/ pi 2) 3))
    
    (command ".RECTANGLE" diemdau diemtren)
    (setq text (ssget "C" diemdau diemtren (list (cons 0 "text"))))
    (setq lst0 (ss2ent text lop1))
    (setq lst0 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst0))
    (setq lst2 (ss2ent text lop2))
    (setq lst2 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst2))
    (setq
caotext (cdr (assoc 40 (entget (ssname text 0))))
fuzz (* caotext 1.0)
lst0 (vl-sort lst0 'sosanh)
lst2 (vl-sort lst2 'sosanh)
    )
    (setq xuongdong 1)
    (foreach em lst0
(if (= dong 0)
 (progn (princ (cdr em) fid) (princ "\n" fid))
 (if (= xuongdong 1)
   (progn (princ "\n" fid) (princ (cdr em) fid) (princ "\n" fid) (setq xuongdong 2))
   (princ (cdr em) fid)
)
      )
    ) 
    (inra lst2)
 
    (command ".RECTANGLE" diemcuoi diemtren)
    (setq text1 (ssget "C" diemcuoi diemtren (list (cons 0 "text"))))
    (setq lst3 (ss2ent text1 lop2))
    (setq lst3 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst3))
    (setq lst3 (vl-sort lst3 'sosanh))
    (inra lst3)
  )
  (if fid (close fid))
)
 
(defun timlt (st / tm)
  (setq tm (vl-string->list (substr (strcase (cdr st)) (+ 3 (vl-string-search "KM" (strcase (cdr st)))))))
  (read (strcat "(" (vl-list->string (subst 32 43 (subst 32 58 tm))) ")"))
)
 
(defun ss2ent (ss lop / sodt index lstent)
  (setq sodt (if ss (sslength ss) 0)
index 0)
  (repeat sodt
    (setq ent (ssname ss index))
    (setq index (1+ index))
    (if (= (cdr (assoc 8 (entget ent))) lop)
      (setq lstent (cons ent lstent))
    )
  )
  (reverse lstent)
)
 

LISP của bạn còn nhiều hạn chế quá. Bạn dùng LISP này xem, do bác TUE_NV viết:

 

(defun c:TDTNV( / ss lst fid lstEn h) ;;;;TINH DIEN TICH NHIEU VUNG
(vl-load-com)
;;;KHONG CHO HIEN THI CAC THONG TIN LEN MAN HINH TEXT SCREEN
(setvar "CMDECHO" 0)
;;;;;;;;NHAP KHOANG CHO PHEP POLYLINE BI HO 
(setvar "hpgaptol" 0.5)
(defun *error* ( msg )
	(if Olmode (setvar 'osmode Olmode))
  	(if Clor (setvar "CECOLOR"...
>>

LISP của bạn còn nhiều hạn chế quá. Bạn dùng LISP này xem, do bác TUE_NV viết:

 

(defun c:TDTNV( / ss lst fid lstEn h) ;;;;TINH DIEN TICH NHIEU VUNG
(vl-load-com)
;;;KHONG CHO HIEN THI CAC THONG TIN LEN MAN HINH TEXT SCREEN
(setvar "CMDECHO" 0)
;;;;;;;;NHAP KHOANG CHO PHEP POLYLINE BI HO 
(setvar "hpgaptol" 0.5)
(defun *error* ( msg )
	(if Olmode (setvar 'osmode Olmode))
  	(if Clor (setvar "CECOLOR" Clor))
	(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
	    (princ (strcat "\nError: " msg))
	)
	(princ)
)
(setq Olmode (getvar 'osmode))
(setq Clor (getvar "CECOLOR"))
(setvar 'osmode 0)
(setvar "CECOLOR" "1")
;;;;TAO LAYER TEXT_AREA VOI COLOR LA 3
(MLA "TEXT_AREA" 3)
;;;;;;;;;;;;NHAP VA LUU CHIEU CAO TEXT;;;;;;;
(or *h* (setq *h* 1))
(setq h (getdist (strcat "\n Nhap chieu cao Text <"
		  (rtos *h* 2 2)
		 ">: "
	  )
 )
)
(if (not h) (setq h *h*) (setq *h* h))

;;;;;;CHUONG TRINH TINH LIEN TUC
(while
	(setq pnt (getpoint "\n Pick diem trong cac vung kin :"))
	(setq DT1 (TDTL pnt))
  	(wtxt (rtos DT1 2 3) Pnt h 0 "C" "TEXT_AREA")
)
(setvar 'osmode Olmode)
(setvar "CECOLOR" Clor)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun TDTL (Pnt / frome toe cur ssSmal H1 );;;tinh dien tich le
(vl-load-com)
(setvar 'osmode 0)
(setq frome (entlast));; chon doi tuong cuoi cung truoc khi boundary
;;;(setq pnt (getpoint "\n Pick diem trong cac vung kin :"))

(command "-boundary" Pnt "");; boundary
(setq toe (entlast));; chon doi tuong cuoi cung sau khi boundary
(setq cur frome; khoi tao
      ssSmal (ssadd)
       DTichLe 0
)
;;;;;KHI TAO BOUNDARY THI NO SE TAO RA MOT SO DOI TUONG (NEU TRONG VUNG KIN DO CO DOI TUONG CHIEM DIEN TICH)
(while (not (eq cur toe));; chon cac doi tuong tu frome den toe
  (progn
	(setq cur (entnext cur)
	       ssSmal (ssadd cur ssSmal)
	)
    	;;;TINH DIEN TICH CUA CAC DOI TUONG SINH RA
    	;;;;DTICH BAN DAU GAN = 0, TRU DI CAC DOI TUONG VUA SINH RA
	(command "area" "S" "O" ssSmal "" "")
    	;;;;;;;GOI DIEN TICH VUA 
	(setq H1 (getvar "area"))
    	;;;TINH DIEN TICH TUNG DOI TUONG SINH RA
	(setq DTichLe (+ DTichLe H1))
  )
)
;;;TINH DIEN TICH TONG TAT CA CAC DOI TUONG 
(command "area" "A" "O" "L" "" "")
;;;;;;;GOI DIEN TICH VUA TINH
(setq H1 (getvar "area"))
(setq DTichLe (+ DTichLe (* H1 2)))
;;;;;;XOA CAC POLYLINE SINH RA SAU LENH BOUNDARY
(command "erase" ssSmal "")
;;;(entmake (list (cons 0 "TEXT") (cons 10 Pnt) (cons 40  5) (cons 1  (rtos DTichLe 2 3))))
DTichLe
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TAO TEXT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun wtxt (string Point Height Ang justify Layer / Lst)
 (setq Lst (list '(0 . "TEXT")
   (cons 8 (if Layer Layer (getvar "Clayer")))
   (cons 62 (if Color Color 256))
   (cons 10 point)
   (cons 40 Height)
   (cons 1 string)
   (if Ang (cons 50 Ang))
   (cons 7 (if Style Style (getvar "Textstyle"))))
  justify (strcase justify))
 (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
       		((= justify "L") (setq Lst (append Lst (list (cons 72 0)(cons 73 0) (cons 10 point)))))
        	((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
        	((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
        	((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
        	((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
        	((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))   
        	((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
        	((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
        	((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
        	((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
        	((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
        	((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))
 (entmake Lst)
)
;;;;;;;;;;;;;;;;;;;TAO LAYER MOI ;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun MLA ( name colour );;;;MAKE LAYER
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)