Jump to content
InfoFile
Tác giả: nhoclangbat
Bài viết gốc: 312525
Tên lệnh: dd
Xin lisp tính độ dốc giữa 2 điểm nằm trên một đường polyline

hihi cho nhoc quậy ké lsp anh Tot77 luyện tay hen ^^

;; free lisp from cadviet.com
(defun emk_style (MyStyle MyFont)
(entmake (list    (cons 0 "STYLE")    
(cons 100 "AcDbSymbolTableRecord")    
(cons 100 "AcDbTextStyleTableRecord")    
(cons 2 MyStyle)    (cons 3  MyFont)    
(cons 70 0))))
;;;;
(defun RTD (a) (* 180 (/ a PI)))
;;;;
(defun c:dd(/ t1 t2 pl dai pt1 pt2 gocpl pt3 pt4 dodoc old lst_var gocpl)
(setq lst_var '("cmdecho" "clayer"...
>>

hihi cho nhoc quậy ké lsp anh Tot77 luyện tay hen ^^

;; free lisp from cadviet.com
(defun emk_style (MyStyle MyFont)
(entmake (list    (cons 0 "STYLE")    
(cons 100 "AcDbSymbolTableRecord")    
(cons 100 "AcDbTextStyleTableRecord")    
(cons 2 MyStyle)    (cons 3  MyFont)    
(cons 70 0))))
;;;;
(defun RTD (a) (* 180 (/ a PI)))
;;;;
(defun c:dd(/ t1 t2 pl dai pt1 pt2 gocpl pt3 pt4 dodoc old lst_var gocpl)
(setq lst_var '("cmdecho" "clayer" "textstyle"))
(setq old (mapcar 'getvar lst_var))
(setvar "cmdecho" 0)
(cond 
       ((null (tblsearch "style" "Vnavant")) ((emk_style "Vnavant" "VNAVAN.TTF") (setvar "textstyle" "Vnavant")))
	   ((tblsearch "style" "Vnavant") (setvar "textstyle" "Vnavant"))
)
(if (tblsearch "layer" "Do-doc-TK") (setvar "clayer" "Do-doc-TK") (command "-layer" "m" "Do-doc-TK" "c" 1 "" ""))
  (setq t1 (car (entsel "\nChon text cao do 1:"))
          t2 (car (entsel "\nChon text cao do 2:"))
         pl (car (entsel "\nChon polyline:"))
		 pt1 (vlax-curve-getStartPoint pl)
		 pt2 (vlax-curve-getEndPoint pl)
		 gocpl (angle pt1 pt2) 
        dai (vlax-curve-getDistAtParam pl (vlax-curve-getEndParam pl))
		pt3 (polar pt1 gocpl (/ dai 2))
		pt4 (polar pt3 (+ gocpl (/ PI 2)) 2)
		)
  (setq dodoc (rtos (/ (- (atof (cdr (assoc 1 (entget t1)))) (atof (cdr (assoc 1 (entget t2))))) dai) 2 3))
  (command ".text" "m" pt4 1.5 (rtd gocpl) (strcat "i = " dodoc "%"))
(mapcar 'setvar lst_var old)  
                                                                                  
  (princ)
)


<<

Filename: 312525_dd.lsp
Tác giả: Tot77
Bài viết gốc: 312519
Tên lệnh: dd
Xin lisp tính độ dốc giữa 2 điểm nằm trên một đường polyline

Bạn dùng cái này.

 

(defun c:dd(/ t1 t2 pl dai eg pnt)
  (setq t1 (car (entsel "\nChon text cao do 1:"))
t2 (car (entsel "\nChon text cao do 2:"))
pl (car (entsel "\nChon polyline:"))
pnt (getpoint "\nVi tri dat text:")
eg (entget t1)
dai (vlax-curve-getDistAtParam pl (vlax-curve-getEndParam pl))
  )
  (entmake (list '(0 . "TEXT") (assoc 7 eg) (assoc 72 eg) (assoc 73 eg) (assoc 8 eg)
(assoc 40 eg) (assoc 41 eg) (cons 10 pnt) (cons...
>>

Bạn dùng cái này.

 

(defun c:dd(/ t1 t2 pl dai eg pnt)
  (setq t1 (car (entsel "\nChon text cao do 1:"))
t2 (car (entsel "\nChon text cao do 2:"))
pl (car (entsel "\nChon polyline:"))
pnt (getpoint "\nVi tri dat text:")
eg (entget t1)
dai (vlax-curve-getDistAtParam pl (vlax-curve-getEndParam pl))
  )
  (entmake (list '(0 . "TEXT") (assoc 7 eg) (assoc 72 eg) (assoc 73 eg) (assoc 8 eg)
(assoc 40 eg) (assoc 41 eg) (cons 10 pnt) (cons 11 pnt) (cons 50 0)
(cons 1 (strcat (rtos (* 100 (/ (- (atof (cdr (assoc 1 (entget t1))))
                                (atof (cdr (assoc 1 (entget t2))))) dai)) 2 3) "%"))))
  (princ)
)

Bác Bình nói tôi không hiểu ý bác, ở đây chỉ lấy chiều dài pline thôi, không để ý đến hai đầu, vả lại text mình nhấp chọn từng cái chứ không quét. Lúc đầu cũng định quét nhưng nghĩ nhiều khi user muốn có số âm, nên nhấp chọn là tốt nhất, tuy có hoi nhiều thao tác.


<<

Filename: 312519_dd.lsp
Tác giả: quydiachat
Bài viết gốc: 13555
Tên lệnh: kk kl
kích con trỏ chọn đối tượng chỉ chọn được 1 đối tượng


cái này đơn giản thôi:
trên thanh toolbas > Tools >options (dòng cuối cùng ấy)
Bảng options hiện ra bạn vào Selection rồi sau đó bỏ dấu chữ V trong mục Use Shilt to Add to Seclection
Sau đó ấn ok là ngon!!!!

Filename: 13555_kk_kl.lsp
Tác giả: thanhduan2407
Bài viết gốc: 312710
Tên lệnh: ttd
Lisp lọc text số nguyên và text có số thập phân.

Em đã dùng cách này để tách

(defun C:TTD (/ ss ss1 ss2 e1 e2 txt);;;;;TACH THUA DAT
(MakeLayer_ "LOAIDAT" 1)
(MakeLayer_ "SOTHUA" 2)
(MakeLayer_ "DIENTICH" 3)
(setq ss (ssget (list (cons 0 "TEXT"))))
(setq ss2 (ChonTextSo ss))
(setq sstemp (LM:ListDifference (acet-ss-to-list ss) (acet-ss-to-list ss2)))
(setq ss1 (vl-remove nil (mapcar '(lambda(x) (if (or (= (strlen (acet-dxf 1 (entget x))) 2) (= (strlen (acet-dxf 1 (entget x))) 3)) x...
>>

Em đã dùng cách này để tách

(defun C:TTD (/ ss ss1 ss2 e1 e2 txt);;;;;TACH THUA DAT
(MakeLayer_ "LOAIDAT" 1)
(MakeLayer_ "SOTHUA" 2)
(MakeLayer_ "DIENTICH" 3)
(setq ss (ssget (list (cons 0 "TEXT"))))
(setq ss2 (ChonTextSo ss))
(setq sstemp (LM:ListDifference (acet-ss-to-list ss) (acet-ss-to-list ss2)))
(setq ss1 (vl-remove nil (mapcar '(lambda(x) (if (or (= (strlen (acet-dxf 1 (entget x))) 2) (= (strlen (acet-dxf 1 (entget x))) 3)) x nil)) sstemp)))
(foreach e1 ss1
	(vla-put-Layer (vlax-ename->vla-object e1) "LOAIDAT")
)

(foreach e2 (acet-ss-to-list ss2)
	(setq txt (type (read (cdr (assoc 1 (entget e2))))))
  	(if (= txt 'INT)
	    (vla-put-Layer (vlax-ename->vla-object e2) "SOTHUA")
	    (vla-put-Layer (vlax-ename->vla-object e2) "DIENTICH")
	 )
)
(princ)  
)

(defun ChonTextSo (ss / i ent str ss1) 
    (progn
      (setq i	0
	    ss1	(ssadd)
      )
      (repeat (sslength ss)
	(setq ent (ssname ss i)
	      str (cdr(assoc 1 (entget ent)))
	      i	  (+ 1 i)
	)
	(if (distof str 2)
	  (ssadd ent ss1)
	)
      )
      (if (> (sslength ss1) 0)
	ss1
      )      
    )
)

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

(defun LM:ListDifference ( l1 l2 )
  (if l1
    (if (member (car l1) l2)
      (LM:ListDifference (cdr l1) l2)
      (cons (car l1) (LM:ListDifference (cdr l1) l2))
    )
  )
)

Các bác cho em lời nhận xét nhé


<<

Filename: 312710_ttd.lsp
Tác giả: nhoclangbat
Bài viết gốc: 312730
Tên lệnh: tachthua
Lisp lọc text số nguyên và text có số thập phân.

hihi ko pit anh Thanhduan2407 còn nhớ cái y/c viết lsp của nhoc hồi mới tham gia 4rum ko nhỉ, anh chê nhoc trình bày ko trong sáng đó ^^, nhìn qua y/c của bạn này thấy cũng hao hao giống y/c của nhoc hồi đó. anh Ket với anh HHVD có giúp nhoc hoàn thiện ^^.

- lsp a nhoc thử nếu loai đất có số hình như nó ko hiểu nên ko chuyển được layer

- lsp a Ket với HHVD giúp nhoc nó chuyễn đc lun, nhưng điểm yếu...

>>

hihi ko pit anh Thanhduan2407 còn nhớ cái y/c viết lsp của nhoc hồi mới tham gia 4rum ko nhỉ, anh chê nhoc trình bày ko trong sáng đó ^^, nhìn qua y/c của bạn này thấy cũng hao hao giống y/c của nhoc hồi đó. anh Ket với anh HHVD có giúp nhoc hoàn thiện ^^.

- lsp a nhoc thử nếu loai đất có số hình như nó ko hiểu nên ko chuyển được layer

- lsp a Ket với HHVD giúp nhoc nó chuyễn đc lun, nhưng điểm yếu của lsp là phải xác định trước layer cần chuyển trong lsp, nên nhoc có set thêm user nhập tên layer, anh xem thử có thể  kết hợp sao đó để ko cần xác định trước layer chỉ cần quyét phát hết chuyển đc lun tì tốt quá ạ :)

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/67432-yeu-cau-lsp-tach-1-nhom-layer-thanh-nhieu-layer-khac-nhau/page-2
(defun dxf (code e) (cdr (assoc code (entget e))))
(defun PUT-GC (VALUE GROUP ENTITY / PROPERTIES)
(setq PROPERTIES (entget ENTITY))
(setq PROPERTIES (subst (cons GROUP VALUE) (assoc GROUP PROPERTIES) PROPERTIES))
(entmod PROPERTIES)
)
(defun CreatLayer(MyLayer / MyColor)
(if (not (tblsearch "LAYER" MyLayer))
(progn
  (entmakex
   (list
(cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 70 0)
(cons 2 MyLayer)
   )
  )
)
)
)
(defun ChangeLayer(kq / i dt type_dt)
(repeat (setq i (sslength kq))
  (setq dt (ssname kq (setq i (1- i))))
  (setq type_dt (type (read (dxf 1 dt))))
  (cond
   ((= type_dt 'INT) (PUT-GC "SOTHUA" 8 dt))
   ((= type_dt 'REAL) (PUT-GC "DIENTICH" 8 dt))
   ((= type_dt 'SYM) (PUT-GC "LOAIRUONGDAT" 8 dt))
  )
)
)
(defun c:tachthua (/ ss el qa kq i as)
(vl-load-com)
(CreatLayer "SOTHUA")
(CreatLayer "DIENTICH")
(CreatLayer "LOAIRUONGDAT")
(setq as (getstring "\nnhap ten layer can tach:"))
(setq ss  (ssget (list (cons 8 as))) kq (ssadd))
(setq qa (getvar 'QAFLAGS))
(setvar 'QAFLAGS 1)
(repeat (setq i (sslength ss))
  (setq e (ssname ss (setq i (1- i))))
  (setq dxf0 (dxf 0 e))
  (cond
   ((= dxf0 "TEXT") (ssadd e kq))
   (
    (= dxf0 "INSERT")
    (progn
	(setq el (entlast))    
	(command "explode" ss "")
    
	(while (setq en (entnext el))
      (if (= (dxf 0 en) "TEXT") (ssadd en kq))
      (setq el en)
	)
    )
   )  
  )
)
(setvar 'QAFLAGS qa)
(ChangeLayer kq)
(princ "\nHochoaivandot - Cadviet.com")
(princ)
)


<<

Filename: 312730_tachthua.lsp
Tác giả: nhoclangbat
Bài viết gốc: 312603
Tên lệnh: ghidim hiep vinh
Bài tập chương 4

-  ^^ Vinh chưa xem lại kỹ lý thuyết rùi, Vinh chịu khó đọc lại lý thuyết hoặc có thể xem các bài post của các bạn học trước trong topic này để rút kinh nghiệm

- câu 2 hàm (defun lcm ()) để làm gì nhỉ ^^

- câu 3 khởi tạo hàm star gồm các biến đó để lưu giá trị các ban đầu của biến hệ thống mà vinh để sau (/ xx xx xx ...) thì thì load vô cad nó khủ ngay tức  thì rùi lấy gì mà...

>>

-  ^^ Vinh chưa xem lại kỹ lý thuyết rùi, Vinh chịu khó đọc lại lý thuyết hoặc có thể xem các bài post của các bạn học trước trong topic này để rút kinh nghiệm

- câu 2 hàm (defun lcm ()) để làm gì nhỉ ^^

- câu 3 khởi tạo hàm star gồm các biến đó để lưu giá trị các ban đầu của biến hệ thống mà vinh để sau (/ xx xx xx ...) thì thì load vô cad nó khủ ngay tức  thì rùi lấy gì mà lưu ^^, hàm end có tác dụng trả lại giá trị các biến hàm star đã lưu

- ek câu 4 Vinh hiểu sai ý nhoc rùi, không phải với mỗi layer mình phải tạo 1 hàm như vậy, tạo hàm giúp mình tiết kiệm thời gian và rút ngắn code cho đơn giản mà, Vinh viết vậy  đầu khác gì cứ mỗi layer mình phải dùng command dài dòng như vậy để tạo đâu ^^, ý là tạo 1 hàm tạo layer tổng quát viết dài 1 lần thui, các lần sau ko cần phải viết dài vậy nữa, 1 cách khác có thể tạo 1 hàm tạo lun 3 layer đó, nếu biết trước trong bản vẽ chỉ cần 3 layer đó, nhưng tạo với tham số "new", đến khi lệnh nào cần dùng layer nào thì set layer đó là layer hiện hành thui

- câu áp dụng giống như cái lsp đầu Vinh hỏi sao nó không chuyển màu layer vậy đó, chỉ khác là dựa vào các hàm mình đã tạo áp dụng cho các lệnh đó đc ngắn gọn hơn, nhoc ví dụ 1 lệnh hoàn chỉnh cho Vinh dễ nắm vấn đề , Vinh có thể load chạy thử sẽ hiểu đc

;;ham luu bien
(defun start () 
 (setq oldcm (getvar "cmdecho"))
 (setq oldos (getvar "osmode"))
 (setq oldab (getvar "angbase"))
 (setq oldad (getvar "angdir"))
 (setq oldcl (getvar "clayer"))
 )
 ;;;ham tra bien
(defun end()
 (setvar "cmdecho" oldcm)
 (setvar "osmode" oldos)
 (setvar "angbase" oldab)
 (setvar "angdir" oldad)
 (setvar "clayer" oldcl)
 )
 ;;ham tao layer tong quat cho bat ky lay nao mun tao voi cac tham so
(defun taolayer ( ten mau net day)
(command "-layer" "m" ten "c" mau "" "L" net "" "LW" day "" "")
)
;;;1 ham tao layer khac do ban Hiep viet
(defun MKL( / ten mau Kieu)
(setq oldcmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ten (getstring "\nNhap ten: ")
	mau (getint "\nNhap ma mau: ")
	Kieu (getstring "\nNhap kieu duong (enter se lay kieu continuous): "))
(if (= Kieu nil) (setq Kieu "continuous"))
(command "-layer" "n" ten "c" mau ten "l" Kieu ten "lw" (getreal "\nNhap be rong net (0-2.11mm): ") ten "")
(princ (strcat "layer (" (vl-princ-to-string ten) ") da duoc tao"))
(setvar "cmdecho" oldcmd)
(princ)
);;;=> hoi phuc tap phai ko ^^, do ban Hiep pro ^^


;cau 4 cach nay cua ban Vinh cung dc nhung can chinh ti ^^, bỏ hết các tham số đi, vì tham số mình đã pit trước nên gán trực tiếp vao bieu thuc dưới ^^
(defun dim()
 (command "-layer" "n" "dim" "c" 1 "dim" "l" "continuous" "dim" "lw" 0.1 "dim" ""))
(defun hacth()
 (command "-layer" "n" "hacth" "c" 3 "hacth" "l" "continuous" "hacth" "lw" 0.15 "hacth" ""))
(defun text()
 (command "-layer" "n" "text" "c" 4 "text" "l" "continuous" "text" "lw" 0.2 "text" ""))
;;;;

;;;lenh tao ghi dim dùng hàm tao layer của nhoc
(defun c:ghidim (/ pt1 pt2 oldcm oldos oldcl oldab oldad)
(start ) ;=> dung ham start de luu cac bien he thong hien hanh truoc khi chay lenh
(setvar "cmdecho" 0) (setvar "osmode" 33) ;=> gan gia tri mun dung doi voi cac bien he thong khi chay lenh
(taolayer "dim" 1 "continuous" 0.15) ;=> tao layer dim  voi cac tham so tu set trong lsp cho lenh ghi dim dong thoi set nó là layer hien hành, cach này của nhoc 
(setq pt1 (getpoint "\nchon diem 1:") pt2 (getpoint pt1 "\nchon diem 2:"))
(command ".DIMALIGNED" pt1 pt2)
(end ) ;=> tra lại gia tri ban dau cac bien he thong da luu o ham start
)
;;;;;theo cach cua ban Hiep
(defun c:hiep (/ pt1 pt2 oldcm oldos oldcl oldab oldad)
(start ) ;=> dung ham start de luu cac bien he thong hien hanh truoc khi chay lenh
(setvar "cmdecho" 0) (setvar "osmode" 33) ;=> gan gia tri mun dung doi voi cac bien he thong khi chay lenh
(MKL ) ;=> theo cach ban Hiep, khi lsp chạy tới dòng này nó sẽ hỏi tùm lum ^^ các thông số để taolayer theo ý mún, cách này cần thêm 1 dòng vì tao = new
(setvar "clayer" "dim"); hoặc (command "-layer" "s" "dim" "")
(setq pt1 (getpoint "\nchon diem 1:") pt2 (getpoint pt1 "\nchon diem 2:"))
(command ".DIMALIGNED" pt1 pt2)
(end ) ;=> tra lại gia tri ban dau cac bien he thong da luu o ham start
)
;;;; theo cach củ bạn
(defun c:vinh (/ pt1 pt2 oldcm oldos oldcl oldab oldad)
(start ) ;=> dung ham start de luu cac bien he thong hien hanh truoc khi chay lenh
(setvar "cmdecho" 0) (setvar "osmode" 33) ;=> gan gia tri mun dung doi voi cac bien he thong khi chay lenh
(dim ); => lsp chay toi day se tao layer dim như bạn đã tạo trong hàm ko cân hỏi gì hết, gọi cái có lun ^^, nhưng cũng phải thêm 1 trong 2 lệnh dưới 
(setvar "clayer" "dim"); hoặc (command "-layer" "s" "dim" "")
(setq pt1 (getpoint "\nchon diem 1:") pt2 (getpoint pt1 "\nchon diem 2:"))
(command ".DIMALIGNED" pt1 pt2)
(end ) ;=> tra lại gia tri ban dau cac bien he thong da luu o ham start
)



 


<<

Filename: 312603_ghidim_hiep_vinh.lsp
Tác giả: thanhduan2407
Bài viết gốc: 312746
Tên lệnh: ttd
Lisp lọc text số nguyên và text có số thập phân.

hihi ko pit anh Thanhduan2407 còn nhớ cái y/c viết lsp của nhoc hồi mới tham gia 4rum ko nhỉ, anh chê nhoc trình bày ko trong sáng đó ^^

Không biết ngày xưa mình nói gì để bạn  nhoclangbat giận mình nhỉ? Chắc là làm điều gì mang tính tiêu cực nên mình mới nói là ko trong sáng. ^^ (có thể là...

>>

hihi ko pit anh Thanhduan2407 còn nhớ cái y/c viết lsp của nhoc hồi mới tham gia 4rum ko nhỉ, anh chê nhoc trình bày ko trong sáng đó ^^

Không biết ngày xưa mình nói gì để bạn  nhoclangbat giận mình nhỉ? Chắc là làm điều gì mang tính tiêu cực nên mình mới nói là ko trong sáng. ^^ (có thể là bịa số liệu. Hehehehe)

Lisp của mình gửi lên đã làm được rồi mà, không cần chọn layer trước.

Tuy nhiên thì lisp của mình và lisp của nhoclangbat đều không giải thích được vì sao quét với số lượng nhiều lại không thực hiện được.

Gửi Lisp của mình và file test để bạn thử nhé!

(defun C:TTD (/ ss ss1 ss2 e1 e2 txt);;;;;TACH THUA DAT
(MakeLayer_ "LOAIDAT" 1)
(MakeLayer_ "SOTHUA" 2)
(MakeLayer_ "DIENTICH" 3)
(setq ss (ssget (list (cons 0 "TEXT"))))
(setq ss2 (ChonTextSo ss))
(setq sstemp (LM:ListDifference (acet-ss-to-list ss) (acet-ss-to-list ss2)))
(setq ss1 (vl-remove nil (mapcar '(lambda(x) (if (or (= (strlen (acet-dxf 1 (entget x))) 2) (= (strlen (acet-dxf 1 (entget x))) 3)) x nil)) sstemp)))
(foreach e1 ss1
	(vla-put-Layer (vlax-ename->vla-object e1) "LOAIDAT")
)
(foreach e2 (acet-ss-to-list ss2)
	(setq txt (type (read (cdr (assoc 1 (entget e2))))))
  	(cond
	   ((= txt 'INT)
	    (vla-put-Layer (vlax-ename->vla-object e2) "SOTHUA")
	   )
	   ((= txt 'REAL)
	    (vla-put-Layer (vlax-ename->vla-object e2) "DIENTICH")
	   )
	 )
)
(princ)  
)



(defun ChonTextSo (ss / i ent str ss1) 
    (progn
      (setq i	0
	    ss1	(ssadd)
      )
      (repeat (sslength ss)
	(setq ent (ssname ss i)
	      str (cdr(assoc 1 (entget ent)))
	      i	  (+ 1 i)
	)
	(if (distof str 2)
	  (ssadd ent ss1)
	)
      )
      (if (> (sslength ss1) 0)
	ss1
      )      
    )
)

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

(defun LM:ListDifference ( l1 l2 )
  (if l1
    (if (member (car l1) l2)
      (LM:ListDifference (cdr l1) l2)
      (cons (car l1) (LM:ListDifference (cdr l1) l2))
    )
  )
)

http://www.cadviet.com/upfiles/3/36665_file_test.dwg


<<

Filename: 312746_ttd.lsp
Tác giả: Tot77
Bài viết gốc: 312828
Tên lệnh: ttd
Lisp lọc text số nguyên và text có số thập phân.

Bạn có thể viết như vầy cho gọn và không bị lỗi.

(defun C:TTD (/ ss ss1 ss2 e1 e2 txt);;;;;TACH THUA DAT
(MakeLayer_ "LOAIDAT" 1)
(MakeLayer_ "SOTHUA" 2)
(MakeLayer_ "DIENTICH" 3)
(setq ss (ssget (list (cons 0 "TEXT"))))
(foreach e2 (acet-ss-to-list ss)
  (setq txt (cdr (assoc 1 (entget e2))))
  (cond ((not (distof txt))
 (vla-put-Layer (vlax-ename->vla-object e2) "LOAIDAT"))
((vl-string-search "." txt)
(vla-put-Layer...
>>

Bạn có thể viết như vầy cho gọn và không bị lỗi.

(defun C:TTD (/ ss ss1 ss2 e1 e2 txt);;;;;TACH THUA DAT
(MakeLayer_ "LOAIDAT" 1)
(MakeLayer_ "SOTHUA" 2)
(MakeLayer_ "DIENTICH" 3)
(setq ss (ssget (list (cons 0 "TEXT"))))
(foreach e2 (acet-ss-to-list ss)
  (setq txt (cdr (assoc 1 (entget e2))))
  (cond ((not (distof txt))
 (vla-put-Layer (vlax-ename->vla-object e2) "LOAIDAT"))
((vl-string-search "." txt)
(vla-put-Layer (vlax-ename->vla-object e2) "DIENTICH"))
   (t (vla-put-Layer (vlax-ename->vla-object e2) "SOTHUA"))
)
)
(princ)  
)
 
(defun MakeLayer_ ( name colour /)
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)
 
 
 

<<

Filename: 312828_ttd.lsp
Tác giả: thanhduan2407
Bài viết gốc: 312843
Tên lệnh: chm chd clt
Xin lisp nội suy cao độ ?

Bạn sử dụng lisp này xem

(vl-load-com)
(defun c:chm( / Olmode  chieucao item1  temp1 Tdo1 x1 y1 z1 diem1 item2  temp2 Tdo2 Caodo2 x2 y2 z2 diem2 x3 y3 z3  d n kcl pt_i kcdai dz12 d1 d2  dhz )
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar "OSMODE"))
(setq i 1)
(_layer2 "TNS" 6)

(or *chieucao* (setq...
>>

Bạn sử dụng lisp này xem

(vl-load-com)
(defun c:chm( / Olmode  chieucao item1  temp1 Tdo1 x1 y1 z1 diem1 item2  temp2 Tdo2 Caodo2 x2 y2 z2 diem2 x3 y3 z3  d n kcl pt_i kcdai dz12 d1 d2  dhz )
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar "OSMODE"))
(setq i 1)
(_layer2 "TNS" 6)

(or *chieucao* (setq *chieucao* 1))
(setq chieucao (getreal (strcat "\n Chieu cao text <"
			  (rtos *chieucao* 2 2)
			 "> :"
		  )
	 )
)
(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
(progn
	    (setq item1 (entsel "\nChon text thu nhat : "))
	    (setq temp1  (entget (car item1)))
	    (setq Tdo1 (TD:Text-Base (car item1 )))
	    (setq  Caodo1 (cdr (assoc 1 temp1))
	              x1 (car Tdo1)
	              y1 (cadr Tdo1)
	    )
	    (setq  z1 (atof Caodo1))
	    (setq diem1 (list x1 y1))
	    

	    (setq item2 (entsel "\nChon text thu hai : "))
	    (setq temp2  (entget (car item2)))
	    (setq Tdo2 (TD:Text-Base (car item2 )))
	    (setq  Caodo2 (cdr (assoc 1 temp2))
	              x2 (car Tdo2)
	              y2 (cadr Tdo2)
	    )
	    (setq z2 (atof Caodo2))
	    (setq diem2 (list x2 y2 ))
	    
	)
(setq d (distance diem1 diem2))
(or *n* (setq *n* 1))
(setq n (getreal (strcat "\Nhap so diem can chen <"
			  (rtos *n* 2 0)
			 "> :"
		  )
	 )
)
(if (not n) (setq n *n*) (setq *n* n))


(if (not sle)
    (setq sle 2)
)
(setq sle0 (getint (strcat "\nS\U+1ED1 l\U+1EBB sau ph\U+1EA7n th\U+1EADp ph\U+00E2n (T\U+1ED1i \U+0111a = 10, t\U+1ED1i thi\U+1EC3u = 0) <" (itoa sle) ">: ")))
(if sle0
   (progn
	(if (< sle0 0)(setq sle0 0))
	(if (> sle0 10)(setq sle0 10))
        (setq sle sle0)
   )
)
(setq kcl (/ d (+ n 1)))
(setq gocdt (angle diem1 diem2))
	(while  (<= i n)
	    (setvar "OSMODE" 0)
	    (setq pt_i (polar diem1 gocdt (* i kcl)))
	    (setq x3 (car pt_i))
	    (setq y3 (cadr pt_i))
	    (setq d1 (distance diem1 pt_i))
	    (setq d2 (distance diem2 pt_i))
	    (setq kcdai (+ d1 d2))
	    (setq dz12 (- z2 z1))
	    (setq dhz (* dz12 (/ d1 kcdai)))
	    (setq z3 (+ z1 dhz))
	    (setq Caodo (rtos z3 2 sle))
	    (setq pt_i (list x3 y3 z3))
	    (MakeText pt_i Caodo chieucao 0 "L" "TNS")
	    (setq i (1+ i))
	)
(setvar "OSMODE" Olmode)
(princ)
)


(defun c:chd( /  Olmode  chieucao item1  temp1 Tdo1 x1 y1 z1 diem1 item2  temp2 Tdo2 Caodo2 x2 y2 z2 diem2 x3 y3 z3  d n kcl pt_i kcdai dz12 d1 d2  dhz)
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar "OSMODE"))
(setq i 1)
(_layer2 "TNS" 6)

(if (not sle)
    (setq sle 2)
)
  
(or *chieucao* (setq *chieucao* 1))
(setq chieucao (getreal (strcat "\n Chieu cao text <"
				  (rtos *chieucao* 2 2)
				 "> :"
			  )
		)
)
  (if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
	(progn
	    (setq item1 (entsel "\nChon text thu nhat : "))
	    (setq temp1  (entget (car item1)))
	    (setq Tdo1 (TD:Text-Base (car item1 )))
	    (setq  Caodo1 (cdr (assoc 1 temp1))
	              x1 (car Tdo1)
	              y1 (cadr Tdo1)
	    )
	    (setq  z1 (atof Caodo1))
	    (setq pt1 (list x1 y1 ))
	    

	    (setq item2 (entsel "\nChon text thu hai : "))
	    (setq temp2  (entget (car item2)))
	    (setq Tdo2 (TD:Text-Base (car item2 )))
	    (setq  Caodo2 (cdr (assoc 1 temp2))
	              x2 (car Tdo2)
	              y2 (cadr Tdo2)
	    )
	    (setq z2 (atof Caodo2))
	    (setq pt2 (list x2 y2 ))
	    
	)
	(setq Diem1 (list x1 y1))
	(setq Diem2 (list x2 y2))
	(setq d (distance diem1 diem2))
  	(or *kcl* (setq *kcl* 0))
	(setq kcl (getreal (strcat "\nNhap khoang cach giua cac diem: <"
				  (rtos *kcl* 2 2)
				 "> :"
			  )
		 )
	)
	(if (not kcl) (setq kcl *kcl*) (setq *kcl* kcl))

	(setq sle0 (getint (strcat "\nS\U+1ED1 l\U+1EBB sau ph\U+1EA7n th\U+1EADp ph\U+00E2n (T\U+1ED1i \U+0111a = 10, t\U+1ED1i thi\U+1EC3u = 0) <" (itoa sle) ">: ")))
	(if sle0
	   (progn
		(if (< sle0 0)(setq sle0 0))
		(if (> sle0 10)(setq sle0 10))
	        (setq sle sle0)
	   )
	)

  
	(setq n (/ d kcl))
	(setq gocdt (angle diem1 diem2))

	(while  (< i n)
	    (setvar "OSMODE" 0)
	    (setq pt_i (polar diem1 gocdt (* i kcl)))
	    (setq x3 (car pt_i))
	    (setq y3 (cadr pt_i))
	    (setq d1 (distance diem1 pt_i))
	    (setq d2 (distance diem2 pt_i))
	    (setq kcdai (+ d1 d2))
	    (setq dz12 (- z2 z1))
	    (setq dhz (* dz12 (/ d1 kcdai)))
	    (setq z3 (+ z1 dhz))
	    (setq Caodo (rtos z3 2 sle))
	    (setq pt_i (list x3 y3 z3))
	    (MakeText pt_i Caodo chieucao 0 "L" "TNS")
	    (setq i (1+ i))
	)
(setvar "OSMODE" Olmode)
(princ)
)

(defun c:clt(/ chieucao  stt  item1 temp1 Tdo1 X1 Y1 Z1 Caodo1 item2 Tdo2 X2 Y2 Z2 Caodo2 pt1 pt2 pt3 X3 Y3 Z3 d1 d2 d dh dhz Caodo3) ;chen lien tiep tu 2 diem
	(defun *error* ( msg )
		(if Olmode (setvar 'osmode Olmode))
		(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
		    (princ (strcat "\nError: " msg))
		)
		(princ)
	)
  	
  	
	(or *chieucao* (setq *chieucao* 1))
	(setq chieucao (getreal (strcat "\n Chieu cao text <"
			  (rtos *chieucao* 2 2)
			 "> :"
		  )
	 )
	)
	(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
	(setq stt 1)
	(_layer2 "TNS" 6)
	(setq Olmode (getvar "OSMODE"))
  	    
  (progn
            (setq item1 (entsel "\nChon text thu nhat : "))
  	    (setq temp1  (entget (car item1)))
	    (setq Tdo1 (TD:Text-Base (car item1 )))
	    (setq  Caodo1 (cdr (assoc 1 temp1))
	              x1 (car Tdo1)
	              y1 (cadr Tdo1)
            )
	    (setq pt1 (list x1 y1))
            (setq  z1 (atof Caodo1))
  
            (setq item2 (entsel "\nChon text thu hai : "))
  	    (setq temp2  (entget (car item2)))
	    (setq Tdo2 (TD:Text-Base (car item2 )))
	    (setq  Caodo2 (cdr (assoc 1 temp2))
	              x2 (car Tdo2)
	              y2 (cadr Tdo2)
            )
            (setq pt2 (list x2 y2))
            (setq z2 (atof Caodo2))
    )
  (if (not sle)
    (setq sle 2)
)
(setq sle0 (getint (strcat "\nS\U+1ED1 l\U+1EBB sau ph\U+1EA7n th\U+1EADp ph\U+00E2n (T\U+1ED1i \U+0111a = 10, t\U+1ED1i thi\U+1EC3u = 0) <" (itoa sle) ">: ")))
(if sle0
   (progn
	(if (< sle0 0)(setq sle0 0))
	(if (> sle0 10)(setq sle0 10))
        (setq sle sle0)
   )
)
       
  (while
         (progn
         (setvar "OSMODE" 0 );;512
            (setq pt3 (getpoint "\nVi tri chen diem : "))
            (setq x3 (car pt3))
            (setq y3 (cadr pt3))
            (setq d1 (distance pt1 pt3))
            (setq d2 (distance pt2 pt3))
            (setq d (+ d1 d2))
            (setq dh (- z2 z1))
            (setq dhz (* dh (/ d1 d)))
            (setq z3 (+ z1 dhz))
            (setq Caodo3 (rtos z3 2 sle))
            (setq pt3 (list x3 y3 z3))
	    (MakeText pt3 Caodo3 chieucao 0 "L" "TNS")
	   (setq stt (+ stt 1))
      )
   )
   (setvar "OSMODE" Olmode )
   (princ)
)

(defun LM:GetXWithDefault ( _function _prompt _symbol _default / _toString )
	(setq _toString
		(lambda ( x )
			(cond
				( (eq getangle _function) (angtos x) )
				( (eq 'REAL (type x)) (rtos x) )
				( (eq 'INT (type x)) (itoa x) )
				( x )
			)
		)
	)

	(set _symbol
	(
	(lambda ( input ) (if (or (not input) (eq "" input)) (eval _symbol) input))
	(_function (strcat _prompt "<" (_toString (set _symbol (cond ( (eval _symbol) ) ( _default )))) "> : "))
	)
	)
)
(defun TD:Text-Base (ent)
  (setq Ma10  (cdr (assoc 10 (entget ent))))
  (setq Ma11  (cdr (assoc 11 (entget ent))))
  (setq X11 (car Ma11))
  (setq Ma71  (cdr (assoc 71 (entget ent))))
  (setq Ma72  (cdr (assoc 72 (entget ent))))
  (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
	  (and (= Ma71 0) (= Ma72 3) )
	  (and (= Ma71 0) (= Ma72 5) )
      )
    Ma10
    Ma11
   )
)

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


(defun MakeText (point string Height Ang justify  Layer  / Lst); Ang: Radial
	(setq Lst (list '(0 . "TEXT")
									(cons 10 point)
									(cons 40 Height)
									(cons 1 string)
								        (cons 50 Ang)
									(cons 8 Layer)
			)
				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))))))
	(entmakex Lst)
  )

<<

Filename: 312843_chm_chd_clt.lsp
Tác giả: Tot77
Bài viết gốc: 312918
Tên lệnh: dca
Nhờ Giúp Lisp Đánh Cấp

Bạn thử cái này.  Chon diem dau, diem cuoi, goc nghieng (theo do), be rong ngang, chieu cao.

 

(defun c:dca(/ dda dcu l pt0 pt os goc1 ngang1 dung1 ngang2)
  (defun d2r(a) (* pi (/ a 180)))  
  (setq dda (getpoint "\nDiem dau:") 
dcu (getpoint dda "\nDiem cuoi:")
l (list dda)
pt0 dda
pt pt0
os (getvar 'osmode))
  (setq goc1 (getreal (strcat "\nGoc nghieng <" (rtos (if (not goc) (setq goc 0) goc)) "> :")))
  (if...
>>

Bạn thử cái này.  Chon diem dau, diem cuoi, goc nghieng (theo do), be rong ngang, chieu cao.

 

(defun c:dca(/ dda dcu l pt0 pt os goc1 ngang1 dung1 ngang2)
  (defun d2r(a) (* pi (/ a 180)))  
  (setq dda (getpoint "\nDiem dau:") 
dcu (getpoint dda "\nDiem cuoi:")
l (list dda)
pt0 dda
pt pt0
os (getvar 'osmode))
  (setq goc1 (getreal (strcat "\nGoc nghieng <" (rtos (if (not goc) (setq goc 0) goc)) "> :")))
  (if goc1 (setq goc goc1))
  (setq ngang1 (getdist (strcat "\nChieu ngang <" (rtos (if (not ngang) (setq ngang 1) ngang)) "> :")))
  (if ngang1 (setq ngang ngang1))
  (setq dung1 (getdist (strcat "\nChieu cao <" (rtos (if (not dung) (setq dung 1) dung)) "> :")))
  (if dung1 (setq dung dung1)) 
  (if (> (car dcu) (car dda)) (setq lenh +) (setq lenh -))
  (setq ngang2 (* (cos (d2r goc)) (/ dung (sin (d2r goc)))))
  
  (while (> (cadr pt) (cadr dcu))
    (setq pt (polar (polar pt 0 (lenh ngang2)) (* -0.5 pi) dung))
    (if (> (cadr pt) (cadr dcu))
      (setq l (append l (list pt))
   pt (polar pt 0 (lenh ngang))
   l (append l (list pt))
   pt0 pt)
      (setq pt (inters pt0 pt (list 0 (cadr dcu)) (list 1 (cadr dcu)) nil)
   l (append l (list pt)))
    )
  )
  (setvar 'osmode 0)
  (command "pline") (foreach v l (command v)) (command "")
  (setvar 'osmode os)
)

 

p/s : Dao nay danh tieng viet co dau trong cadviet no nhay tum lum, danh phai danh khong dau vay.


<<

Filename: 312918_dca.lsp
Tác giả: Tot77
Bài viết gốc: 313072
Tên lệnh: dca
Nhờ Giúp Lisp Đánh Cấp

Ngoài cái đó bạn cần bổ sung gì nữa không?

Nếu không thì xài cái này.

(defun c:dca(/ dda dcu l pt0 pt os goc1 ngang1 dung1 ngang2)
  (defun d2r(a) (* pi (/ a 180)))  
  (setq dda (getpoint "\nDiem dau:") 
dcu (getpoint dda "\nDiem cuoi:")
l (list dda)
pt0 dda
pt pt0
os (getvar 'osmode))
  (setq goc1 (getreal (strcat "\nGoc nghieng <" (rtos (if (not goc) (setq goc 0) goc)) "> :")))
  (if goc1 (setq goc...
>>

Ngoài cái đó bạn cần bổ sung gì nữa không?

Nếu không thì xài cái này.

(defun c:dca(/ dda dcu l pt0 pt os goc1 ngang1 dung1 ngang2)
  (defun d2r(a) (* pi (/ a 180)))  
  (setq dda (getpoint "\nDiem dau:") 
dcu (getpoint dda "\nDiem cuoi:")
l (list dda)
pt0 dda
pt pt0
os (getvar 'osmode))
  (setq goc1 (getreal (strcat "\nGoc nghieng <" (rtos (if (not goc) (setq goc 0) goc)) "> :")))
  (if goc1 (setq goc goc1))
  (setq ngang1 (getdist (strcat "\nChieu ngang <" (rtos (if (not ngang) (setq ngang 1) ngang)) "> :")))
  (if ngang1 (setq ngang ngang1))
  (setq dung1 (getdist (strcat "\nChieu cao <" (rtos (if (not dung) (setq dung 1) dung)) "> :")))
  (if dung1 (setq dung dung1)) 
  (if (> (car dcu) (car dda)) (setq lenh +) (setq lenh -))
  (setq ngang2 (* (cos (d2r goc)) (/ dung (sin (d2r goc)))))
  
  (while (< (cadr pt) (cadr dcu))
    (setq pt (polar (polar pt 0 (lenh ngang2)) (* 0.5 pi) dung))
    (if (< (cadr pt) (cadr dcu))
      (setq l (append l (list pt))
   pt (polar pt 0 (lenh ngang))
   l (append l (list pt))
   pt0 pt)
      (setq pt (inters pt0 pt (list 0 (cadr dcu)) (list 1 (cadr dcu)) nil)
   l (append l (list pt)))
    )
  )
  (setvar 'osmode 0)
  (command "pline") (foreach v l (command v)) (command "")
  (setvar 'osmode os)
)

<<

Filename: 313072_dca.lsp
Tác giả: Tot77
Bài viết gốc: 313233
Tên lệnh: tac
Xin nhờ các Pro trên diễn đàn Tách và gán level cho nhãn thửa đất

Cảm ơn bạn phamthanhbinh đã chia sẻ lisp tách thông tin thửa đất , mình đã dùng thử rồi về thuật toán giải quyết được yêu cầu, việc tách và chuyển layer  thực hiện bằng tay từng thửa một, bạn có cách nào làm (select all) sau đó chỉ duyệt những Layer nằm trên cùng một dòng : LUC 223 \ 2345 thỏa  mạn điều kiện...

>>

Cảm ơn bạn phamthanhbinh đã chia sẻ lisp tách thông tin thửa đất , mình đã dùng thử rồi về thuật toán giải quyết được yêu cầu, việc tách và chuyển layer  thực hiện bằng tay từng thửa một, bạn có cách nào làm (select all) sau đó chỉ duyệt những Layer nằm trên cùng một dòng : LUC 223 \ 2345 thỏa  mạn điều kiện khi đó sẽ được tách ra, còn các layer khác sẽ xử lý ở câu lệnh khác được không... đó là những ý kiến của mình không biết có phù hợp không mong bạn xem giúp

 Bạn thử cái này, chỉ dùng cho text  nào có  "/" .

(vl-load-com)
(defun c:tac (/ ss ssc)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun MakeLayer_ ( name colour /)
    (if (null (tblsearch "LAYER" name))
      (entmake  (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
     '(70 . 0) (cons 2 name)  (cons 62 colour)))
    )
  )
  (defun chiachu (st / l vt)
    (setq l nil)
    (while (setq vt (vl-string-search " " st))
      (setq l (append l (list (substr st 1 vt)))
   st (substr st (+ 2 vt))))
    (if (/= st "")  (setq l (append l (list st))))
    (vl-remove "" l)
  )
  
  (defun vtchu (st)
    (vl-list->string  (vl-remove 47 (vl-remove 32 (vl-remove-if '(lambda(x) (<= 48 x 57)) (vl-string->list st)))))
  )
  
  (defun vietchu (v0 tt0 nd lay / eg pt)
    (setq eg (entget v0)
 pt (polar (dxf 10 v0) (dxf 50 v0) (* (vl-string-search nd tt0) (dxf 40 v0) (dxf 41 v0) ))
    )
    (entmake (list '(0 . "TEXT") (cons 10 pt) (cons 11 pt) (cons 8 lay) 
  (assoc 50 eg) (assoc 40 eg) (assoc 41 eg) (assoc 51 eg) (assoc 7 eg) (cons 1 nd)))
  )
  
  (defun tachchu (v / tt tt1 tm chu)
    (if (and (setq tm (vl-string-subst " / " "/" (dxf 1 v))
  chu (vtchu tm)
  tt (chiachu (vl-string-subst (strcat chu " ") chu tm)))
    (>= (length tt) 3))
      (progn
(setq tt1 (apply 'strcat tt))
(vietchu v tt1 (last tt) "DIENTICH") 
(if (not (distof (car tt)))
 (progn (vietchu v tt1 (car tt) "LOAIDAT") (vietchu v tt1 (cadr tt) "SOTHUA"))
 (vietchu v tt1 (car tt) "SOTHUA")
)
(vietchu v tt1 "/" "13")
(entdel v)
      )
    )
  )
  
  (MakeLayer_ "LOAIDAT" 1)
  (MakeLayer_ "SOTHUA" 2)
  (MakeLayer_ "DIENTICH" 3)
  
  (setq ss (ssget '((0 . "TEXT")))
ssc (vl-remove-if-not '(lambda (x) (vl-string-search "/" (dxf 1 x)))
     (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  )
  (mapcar 'tachchu ssc)
)

<<

Filename: 313233_tac.lsp
Tác giả: tuannv
Bài viết gốc: 313272
Tên lệnh: tac
Xin nhờ các Pro trên diễn đàn Tách và gán level cho nhãn thửa đất

Thuật toán xử lý được 100%  dạng LUC 233/1222 kiểu trên một dòng này nhanh và tối ưu đã giải quyết được 90% yêu cầu của công việc biên tập, còn một dạng nữa bạn xem kết quả của mình chạy http://www.cadviet.com/upfiles/3/135423_ketqua2.dwg mong bạn xử lý tiếp dạng còn lại giúp mình với.


 

 Bạn thử cái...

>>

Thuật toán xử lý được 100%  dạng LUC 233/1222 kiểu trên một dòng này nhanh và tối ưu đã giải quyết được 90% yêu cầu của công việc biên tập, còn một dạng nữa bạn xem kết quả của mình chạy http://www.cadviet.com/upfiles/3/135423_ketqua2.dwg mong bạn xử lý tiếp dạng còn lại giúp mình với.


 

 Bạn thử cái này, chỉ dùng cho text  nào có  "/" .

 

(vl-load-com)
(defun c:tac (/ ss ssc)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun MakeLayer_ ( name colour /)
    (if (null (tblsearch "LAYER" name))
      (entmake  (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
     '(70 . 0) (cons 2 name)  (cons 62 colour)))
    )
  )
  (defun chiachu (st / l vt)
    (setq l nil)
    (while (setq vt (vl-string-search " " st))
      (setq l (append l (list (substr st 1 vt)))
   st (substr st (+ 2 vt))))
    (if (/= st "")  (setq l (append l (list st))))
    (vl-remove "" l)
  )
  
  (defun vtchu (st)
    (vl-list->string  (vl-remove 47 (vl-remove 32 (vl-remove-if '(lambda(x) (<= 48 x 57)) (vl-string->list st)))))
  )
  
  (defun vietchu (v0 tt0 nd lay / eg pt)
    (setq eg (entget v0)
 pt (polar (dxf 10 v0) (dxf 50 v0) (* (vl-string-search nd tt0) (dxf 40 v0) (dxf 41 v0) ))
    )
    (entmake (list '(0 . "TEXT") (cons 10 pt) (cons 11 pt) (cons 8 lay) 
  (assoc 50 eg) (assoc 40 eg) (assoc 41 eg) (assoc 51 eg) (assoc 7 eg) (cons 1 nd)))
  )
  
  (defun tachchu (v / tt tt1 tm chu)
    (if (and (setq tm (vl-string-subst " / " "/" (dxf 1 v))
  chu (vtchu tm)
  tt (chiachu (vl-string-subst (strcat chu " ") chu tm)))
    (>= (length tt) 3))
      (progn
(setq tt1 (apply 'strcat tt))
(vietchu v tt1 (last tt) "DIENTICH") 
(if (not (distof (car tt)))
 (progn (vietchu v tt1 (car tt) "LOAIDAT") (vietchu v tt1 (cadr tt) "SOTHUA"))
 (vietchu v tt1 (car tt) "SOTHUA")
)
(vietchu v tt1 "/" "13")
(entdel v)
      )
    )
  )
  
  (MakeLayer_ "LOAIDAT" 1)
  (MakeLayer_ "SOTHUA" 2)
  (MakeLayer_ "DIENTICH" 3)
  
  (setq ss (ssget '((0 . "TEXT")))
ssc (vl-remove-if-not '(lambda (x) (vl-string-search "/" (dxf 1 x)))
     (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  )
  (mapcar 'tachchu ssc)
)

<<

Filename: 313272_tac.lsp
Tác giả: Tot77
Bài viết gốc: 313443
Tên lệnh: tac
Xin nhờ các Pro trên diễn đàn Tách và gán level cho nhãn thửa đất

Gửi bạn cái lsp "3 trong 1". Bạn check lại xem.

(vl-load-com)
(defun c:tac (/ ss ssc)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun MakeLayer_ ( name colour /)
    (if (null (tblsearch "LAYER" name))
      (entmake  (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
     '(70 . 0) (cons 2 name)  (cons 62 colour)))
    )
  )
  (defun chiachu (st / l vt)
    (setq l...
>>

Gửi bạn cái lsp "3 trong 1". Bạn check lại xem.

(vl-load-com)
(defun c:tac (/ ss ssc)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun MakeLayer_ ( name colour /)
    (if (null (tblsearch "LAYER" name))
      (entmake  (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
     '(70 . 0) (cons 2 name)  (cons 62 colour)))
    )
  )
  (defun chiachu (st / l vt)
    (setq l nil)
    (while (setq vt (vl-string-search " " st))
      (setq l (append l (list (substr st 1 vt)))
   st (substr st (+ 2 vt))))
    (if (/= st "")  (setq l (append l (list st))))
    (vl-remove "" l)
  )
  
  (defun vtchu (st)
    (vl-list->string  (vl-remove 47 (vl-remove 32 (vl-remove-if '(lambda(x) (<= 48 x 57)) (vl-string->list st)))))
  )
  
  (defun vietchu (v0 tt0 nd lay / eg pt)
    (setq eg (entget v0)
 pt (polar (dxf 10 v0) (dxf 50 v0) (* (vl-string-search nd tt0) (dxf 40 v0) (dxf 41 v0) ))
    )
    (entmake (list '(0 . "TEXT") (cons 10 pt) (cons 11 pt) (cons 8 lay) 
  (assoc 50 eg) (assoc 40 eg) (assoc 41 eg) (assoc 51 eg) (assoc 7 eg) (cons 1 nd)))
  )
  
  (defun tachchu (v / tt tt1 tm chu)
    (if (and (setq tm (vl-string-subst " / " "/" (dxf 1 v))
  chu (vtchu tm)
  tt (chiachu (vl-string-subst (strcat chu " ") chu tm)))
    (>= (length tt) 3))
      (progn
(setq tt1 (apply 'strcat tt))
(vietchu v tt1 (last tt) "DIENTICH") 
(if (not (distof (car tt)))
 (progn (vietchu v tt1 (car tt) "LOAIDAT") (vietchu v tt1 (cadr tt) "SOTHUA"))
 (vietchu v tt1 (car tt) "SOTHUA")
)
(vietchu v tt1 "/" "13")
(entdel v)
      )
    )
  )
  
  (defun entmodl (v l)
    (mapcar '(lambda (x) (entmod (subst (cons (car x) (last x))
(assoc (car x) (entget v)) (entget v)))) l)
  )
  
  (defun tachblock (v / el l en ld)
    (setq el (entlast) l nil)
    (vla-Explode (vlax-ename->vla-object v) )
    (while (setq en (entnext el))
      (if (= (dxf 0 en) "TEXT")
(setq l (cons en l)))
      (setq  el en)
    )
    (cond ((= (length l) 1) (entmodl (car l) (list '(8 "SOTHUA") '(62 256))))
          ((= (length l) 3)
   (setq ld (car (vl-remove-if '(lambda (x) (distof (dxf 1 x))) l))
 l (vl-sort (vl-remove ld l) '(lambda (x y) (> (cadr (dxf 10 x)) (cadr (dxf 10 y))))))
   (entmodl ld (list '(8 "LOAIDAT") '(62 256)))
   (entmodl (car l) (list '(8 "SOTHUA") '(62 256)))
   (entmodl (last l) (list '(8 "DIENTICH") '(62 256)))
   )
    )
  )
  
  (defun locchu (ll lt / l l1 l2)
    (while ll
      (setq l (car ll)
   ll (cdr ll)
   lt1 (vl-sort (vl-remove-if-not '(lambda (x) (< (distance (dxf 10 x) (vlax-curve-getclosestPointTo l (dxf 10 x))) (* 3 cao))) lt)
'(lambda (x y) (< (distance (dxf 10 x) (vlax-curve-getclosestPointTo l (dxf 10 x)))
  (distance (dxf 10 y) (vlax-curve-getclosestPointTo l (dxf 10 y))))))
      )
      (if (>= (length lt1) 2)
(progn
 (setq l1 (car lt1)
l2 (cadr lt1)
lt (vl-remove l2 (vl-remove l1 lt)))
 (entmodl l1 (list '(8 "SOTHUA") '(62 256)))
          (entmodl l2 (list '(8 "DIENTICH") '(62 256)))
        )
      )
    )
  )
  
  (MakeLayer_ "LOAIDAT" 1)
  (MakeLayer_ "SOTHUA" 2)
  (MakeLayer_ "DIENTICH" 3)
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "TEXT,INSERT,LINE"))))))
ssl (vl-remove-if-not '(lambda (x) (and (= "LINE" (dxf 0 x)) (= "13" (dxf 8 x)))) ss) 
ssb (vl-remove-if-not '(lambda (x) (= "INSERT" (dxf 0 x))) ss)
sst (vl-remove-if-not '(lambda (x) (= "TEXT" (dxf 0 x))) ss)
 
ssc (vl-remove-if-not '(lambda (x) (vl-string-search "/" (dxf 1 x))) sst)
ss  (vl-remove-if '(lambda (x) (member x ssc)) sst)
ssd (vl-remove-if '(lambda (x) (distof (dxf 1 x))) ss)
ss  (vl-remove-if '(lambda (x) (member x ssd)) ss)
  )
  (mapcar 'tachchu ssc)
  (mapcar 'tachblock ssb)
  (mapcar '(lambda(x) (entmodl x (list '(8 "LOAIDAT") '(62 256)))) ssd)
  (setq cao (dxf 40 (car ss)))
  (locchu ssl ss)
  (princ)
)

<<

Filename: 313443_tac.lsp
Tác giả: hiepttr
Bài viết gốc: 313400
Tên lệnh: circlebox grc cb2 grc2
Chương 10.3 : Grdraw, Grvecs, Grtext

Mấy hôm nay "ngáp" :D :D :D

Giờ mới trả bài đc đây !

Chờ đá ^ ^

 

;Bai tap chuong 10.3
;;Bai 1:
(defun c:CIRCLEBOX( / ss i ename info cen r BL BR TL TR)
(prompt "\nChon duong tron: ")
(setq ss (ssget '((0 . "CIRCLE"))))
(if ss
	(progn
		(or #offset (setq #offset 0.0))
		(setq #offset 
			(cond
				((getreal (strcat "\nKhoang offset <" (rtos #offset) ">:")))
				(#offset)
			)
		)
		(or #col (setq #col 1))
		(setq...
>>

Mấy hôm nay "ngáp" :D :D :D

Giờ mới trả bài đc đây !

Chờ đá ^ ^

 

;Bai tap chuong 10.3
;;Bai 1:
(defun c:CIRCLEBOX( / ss i ename info cen r BL BR TL TR)
(prompt "\nChon duong tron: ")
(setq ss (ssget '((0 . "CIRCLE"))))
(if ss
	(progn
		(or #offset (setq #offset 0.0))
		(setq #offset 
			(cond
				((getreal (strcat "\nKhoang offset <" (rtos #offset) ">:")))
				(#offset)
			)
		)
		(or #col (setq #col 1))
		(setq #col 
			(cond
				((getint (strcat "\nMau bounding box <" (itoa #col) ">:")))
				(#col)
			)
		)
		(setq i -1)
		(repeat (sslength ss)
			(setq ename (ssname ss (setq i (1+ i)))
				  info (entget ename)
				  cen (cdr (assoc 10 info))
				  r (cdr (assoc 40 info))
				  BL (list (- (car cen) r #offset) (- (cadr cen) r #offset))
				  BR (list (+ (car cen) r #offset) (- (cadr cen) r #offset))
				  TL (list (- (car cen) r #offset) (+ (cadr cen) r #offset))
				  TR (list (+ (car cen) r #offset) (+ (cadr cen) r #offset))
			)
			(grdraw BL BR #col 1)
			(grdraw BL TL #col 1)
			(grdraw TR TL #col 1)
			(grdraw TR BR #col 1)
		)	;repeat
	)
)
(princ)
)
;==========================================================================================
;;Bai 2:
(defun c:GRC( / cen r i j pt lst_pt pt1 pt2)
(setq
	cen (getpoint "\nChon tam: ")
	r (getdist "\nNhap ban kinh: ")
	)
(if (and cen r)
	(progn
		(setq au (getvar "AUNITS"))
		(setvar "AUNITS" 0)
		(setq i 0)
		(repeat 361
			(setq pt (polar cen i r)
				  lst_pt (cons pt lst_pt)
				  i (1+ i)
			)
		)	;repeat
		(setq j 0)
		(repeat 360
			(setq pt1 (nth j lst_pt)
				  pt2 (nth (setq j (1+ j)) lst_pt)
			)
			(grdraw pt1 pt2 200 1)
		)
	)
)
)
;==============================================================================================
;;Bai 3:
;3_1:
(defun c:CB2( / ss i ename info cen r BL BR TL TR)
(prompt "\nChon duong tron: ")
(setq ss (ssget '((0 . "CIRCLE"))))
(if ss
	(progn
		(or #offset (setq #offset 0.0))
		(setq #offset 
			(cond
				((getreal (strcat "\nKhoang offset <" (rtos #offset) ">:")))
				(#offset)
			)
		)
		(or #col (setq #col 2))
		(setq #col 
			(cond
				((getint (strcat "\nMau bounding box <" (itoa #col) ">:")))
				(#col)
			)
		)
		(setq i -1)
		(repeat (sslength ss)
			(setq ename (ssname ss (setq i (1+ i)))
				  info (entget ename)
				  cen (cdr (assoc 10 info))
				  r (cdr (assoc 40 info))
				  BL (list (- (car cen) r #offset) (- (cadr cen) r #offset))
				  BR (list (+ (car cen) r #offset) (- (cadr cen) r #offset))
				  TL (list (- (car cen) r #offset) (+ (cadr cen) r #offset))
				  TR (list (+ (car cen) r #offset) (+ (cadr cen) r #offset))
			)
			(grvecs (list #col BL BR BR TR TR TL TL BL))
		)	;repeat
	)
)
(princ)
)
;==============================
;3_2:
(defun c:GRC2( / cen r i pt lst_pt lst)
(setq
	cen (getpoint "\nChon tam: ")
	r (getdist "\nNhap ban kinh: ")
	)
(if (and cen r)
	(progn
		(setq au (getvar "AUNITS"))
		(setvar "AUNITS" 0)
		(setq i 0)
		(repeat 361
			(setq pt (polar cen i r)
				  lst_pt (cons pt lst_pt)
				  i (1+ i)
			)
		)	;repeat
		(setq lst (cdr (reverse (cdr (apply 'append (mapcar '(lambda (x) (cons x (list x))) lst_pt))))))
		(grvecs (cons 3 lst))
	)
)
)
;=========================================================================================================
;;Bai 4:
(grtext -1 (strcat "Hello " (getvar 'loginname) " !"))

<<

Filename: 313400_circlebox_grc_cb2_grc2.lsp
Tác giả: hiepttr
Bài viết gốc: 312714
Tên lệnh: 3ddd
Lisp thao tác trong 3D

@ Tue_NV:

Nghe lời "xúi dại" của bác, em làm công cụ thay cho 3dalign ^^

Quả thật 2d thì còn dễ ngốn chứ quả 3d này đã làm em mất ngày chủ nhật đó :D :D :D

 

Tạm xong, em đưa lên đây xin đá ^^ :D :D :D

Đến khi ổn thì em cho vào code !

 

p/s:

1) Hạn chế của nó là "em đã phát hiện có sai số trong các phép toán của lisp" 

Tuy ko lớn >>> nhưng...

>>

@ Tue_NV:

Nghe lời "xúi dại" của bác, em làm công cụ thay cho 3dalign ^^

Quả thật 2d thì còn dễ ngốn chứ quả 3d này đã làm em mất ngày chủ nhật đó :D :D :D

 

Tạm xong, em đưa lên đây xin đá ^^ :D :D :D

Đến khi ổn thì em cho vào code !

 

p/s:

1) Hạn chế của nó là "em đã phát hiện có sai số trong các phép toán của lisp" 

Tuy ko lớn >>> nhưng chỉ sợ nếu ứng dụng vào bài toán của haanh thì ko sao mà dùng trong các trường hợp khác để xđịnh giao cắt ... thì có thể "dính đòn"

 

Mong đc chỉ giáo thêm !

 

2) Đang để dạng thủ tục để các bác dễ đường test !

 

3) Chưa xét đến tỉ lệ scale

 

;lisp thay the lenh 3dalign tuy chon "Copy"
;pt_a, pt_b, pt_c la 3 diem chuan
;pt_1, pt_2, pt_3 la 3 diem dich
; ss co the la 1 ename hoac mot tap chon ss
;ti le (length pt_1 pt_2) / (length pt_a pt_b) la ti le scale
(defun c:3DDD(/ )
;ss pt_a pt_b pt_c pt_1 pt_2 pt_3 
;lst_var old lst_point_w moc new pre pt_phu pt_phu_w base ang anh pt_phu_2d pt_phu_3d pt_phu_w_3d
(setq pt_a (getpoint "\nchon a:") 
	  pt_b (getpoint "\nchon b:")
	  pt_c (getpoint "\nchon c:")
	  pt_1 (getpoint "\nchon d:")
	  pt_2 (getpoint "\nchon e:")
	  pt_3 (getpoint "\nchon f:")
	  ss (car(entsel "\nChon vat: ")))
(setq lst_va '("osmode" "cmdecho" "AUNITS" "ANGDIR"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 3 0))
(setq lst_point_w (mapcar '(lambda (x) (trans x 1 0)) (list pt_a pt_b pt_c pt_1 pt_2 pt_3)))
(command "ucs" "na" "s" "save_ucs")
(command "-view" "s" "save_v")
(setq moc (entlast) 
	  new (ssadd))
(command "_.copy" ss "" pt_a pt_1)
(while (setq pre (entnext moc))
	(setq new (ssadd pre new)
		  moc pre)
)	;while
(setq pt_phu (mapcar '+ pt_1 (mapcar '- pt_b pt_a))
	  pt_phu_w (trans pt_phu 1 0))
(command "ucs" "3p" pt_1 pt_2 pt_phu)
(command "plan" "c")
(command "rotate" new "" 
	(setq base (trans (nth 3 lst_point_w) 0 1)) 
	(setq ang (* -1 (angle base (trans pt_phu_w 0 1))))
	)
(setq pt_phu_2d 
				(polar 
					base 
					(+ ang (angle base (setq anh (mapcar '+ base (mapcar '- (trans (nth 2  lst_point_w) 0 1) (trans (nth 0  lst_point_w) 0 1)))))) 
					(distance (list (car base) (cadr base)) (list (car anh) (cadr anh))))
	  pt_phu_3d (list (car pt_phu_2d) (cadr pt_phu_2d) (last anh))
	  pt_phu_w_3d (trans pt_phu_3d 1 0))
(command "ucs" "3p" base (trans (nth 5 lst_point_w) 0 1) pt_phu_3d)
(command "plan" "c")
(command "rotate" new "" 
	(setq base (trans (nth 3 lst_point_w) 0 1)) 
	(* -1 (angle base (trans pt_phu_w_3d 0 1)))
	)
(command "ucs" "na" "r" "save_ucs")
(command "ucs" "na" "d" "save_ucs")
(command "-view" "r" "save_v")
(command "-view" "d" "save_v")
(mapcar 'setvar lst_va old)
)

<<

Filename: 312714_3ddd.lsp
Tác giả: hiepttr
Bài viết gốc: 313604
Tên lệnh: ve
Lisp thao tác trong 3D

Chắc là haanh đã thử lisp trong bài này:

 

 


@ Tue_NV:

Nghe lời "xúi dại" của bác, em làm công cụ thay cho 3dalign ^^

Quả thật 2d thì còn dễ ngốn chứ quả 3d này đã làm em mất ngày chủ nhật đó :D :D :D

 

Tạm xong, em đưa lên đây xin đá ^^ :D :D :D

Đến khi ổn thì em cho vào code !

.............................

Lỗi tại ko đọc kĩ hdsd trước khi...

>>

Chắc là haanh đã thử lisp trong bài này:

 

 


@ Tue_NV:

Nghe lời "xúi dại" của bác, em làm công cụ thay cho 3dalign ^^

Quả thật 2d thì còn dễ ngốn chứ quả 3d này đã làm em mất ngày chủ nhật đó :D :D :D

 

Tạm xong, em đưa lên đây xin đá ^^ :D :D :D

Đến khi ổn thì em cho vào code !

.............................

Lỗi tại ko đọc kĩ hdsd trước khi dùng ^^

 

Giờ thì có cái để thử rồi đây !

Hơi dài, do chưa tìm đc cách rút ngắn code

 

Mèo đen, mèo trắng miễn là bắt đc chuột :D :D :D

 

p/s: Lệnh là VE nghe haanh ^^

 

 

;lisp ve duong ong 3d
(defun c:VE(/ lst_va old D ss lst_TC_DUC cao_tam_cut R path cut base_w lst_ver lst_w obj i ss_ong ss_cut n len dau cuoi)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
;=================
(setq D (getdist "\nNhap duong kinh ong: ")
	  lst_TC_DUC '((12 . 26.0) (13 . 26.0) (18 . 35.0) (19 . 35.0) (22 . 40.0) (23 . 40.0) (28 . 
50.0) (29 . 50.0) (35 . 55.0) (34 . 55.0) (40 . 60.0) (52 . 70.0) (53 . 70.0) 
(70 . 80.0) (69 . 80.0) (85 . 90.0) (84 . 90.0) (104 . 100.0) (129 . 187.5) 
(154 . 225.0) (204 . 300.0) (254 . 375.0))
	  cao_tam_cut (cdr (assoc D lst_TC_DUC))
	  )	;setq
;=================
(prompt "\nChon 3DPOLY: ")
(setq ss (ssget "+.:E:S" '((0 . "POLYLINE"))))
(if (and
		D
		(member D (mapcar 'car lst_TC_DUC))
		ss)
	(progn
		(or #lan_ve (setq #lan_ve 0))
		(setq #lan_ve (1+ #lan_ve))
		;ve cut mau:
		(command "arc" "c" '(0 0 0) (list cao_tam_cut 0 0) (list 0 cao_tam_cut 0))
		(setq path (entlast))
		(command "circle" '(0 0 0) (setq R (/ D 2.0)))
		(command "sweep" (entlast) "" path)
		(setq cut (entlast))
		(setq base_w (mapcar '(lambda (x) (trans x 1 0)) (list (list cao_tam_cut 0 0) (list cao_tam_cut cao_tam_cut 0) (list 0 cao_tam_cut 0))))
		;== xong cut mau ==
		;Luu UCS:
		(command "ucs" "na" "s" "save1_ucs")
		;(command "-view" "s" "save_v")
		;*******************************
		(setq lst_ver (acet-geom-vertex-list (setq ename (ssname ss 0)))
			  lst_w (mapcar '(lambda (x) (trans x 1 0)) lst_ver)
			  obj (vlax-ename->vla-object ename))
		(setq i 0
			  ss_ong (ssadd)
			  ss_cut (ssadd)
			  )
		(repeat (setq n (1- (length lst_w)))
			(setq len (distance (setq dau (nth i lst_w)) (setq cuoi (nth (1+ i) lst_w))))
			(command "UCS" "za" (trans dau 0 1) (trans cuoi 0 1))
			(cond
				((= i 0) (command "CYLINDER" (trans dau 0 1) R (- len cao_tam_cut))	;ve ong
					(setq ss_ong (ssadd (entlast) ss_ong))
					(3DDD cut  
						(trans (car base_w) 0 1) 
						(trans (cadr base_w) 0 1) 
						(trans (last base_w) 0 1) 
						(trans (vlax-curve-getPointAtDist obj (- (vlax-curve-getDistAtParam obj 1) cao_tam_cut)) 0 1) 
						(trans (vlax-curve-getPointAtParam obj 1) 0 1) 
						(trans (vlax-curve-getPointAtDist obj (+ (vlax-curve-getDistAtParam obj 1) cao_tam_cut)) 0 1))	;align_copy cut
					(setq ss_cut (ssadd (entlast) ss_cut))
				)
				((= i (1- n)) (command "CYLINDER" (mapcar '+ (list 0 0 cao_tam_cut) (trans dau 0 1)) R (- len cao_tam_cut))	;ve ong
					(setq ss_ong (ssadd (entlast) ss_ong))
				)	
				(t (command "CYLINDER" (mapcar '+ (list 0 0 cao_tam_cut) (trans dau 0 1)) R (- len (* 2 cao_tam_cut)))	;ve ong
					(setq ss_ong (ssadd (entlast) ss_ong))
					(3DDD cut 
						(trans (car base_w) 0 1) 
						(trans (cadr base_w) 0 1) 
						(trans (last base_w) 0 1) 
						(trans (vlax-curve-getPointAtDist obj (- (vlax-curve-getDistAtParam obj (1+ i)) cao_tam_cut)) 0 1) 
						(trans (vlax-curve-getPointAtParam obj (1+ i)) 0 1) 
						(trans (vlax-curve-getPointAtDist obj (+ (vlax-curve-getDistAtParam obj (1+ i)) cao_tam_cut)) 0 1))		;align_copy cut
					(setq ss_cut (ssadd (entlast) ss_cut))
				)
			)
			(setq i (1+ i))
		)	;repeat
		;(command "-block" (strcat "Ong_" (rtos (getvar 'cdate) 2 4)) (trans (nth 0 lst_w) 0 1) ss_ong "")
		;(command "-block" (strcat "Cut_" (rtos (getvar 'cdate) 2 4)) (trans (nth 0 lst_w) 0 1) ss_cut "")
		(command "group" "c" (strcat "Ong_" (rtos (getvar 'cdate) 2 0) (itoa #lan_ve)) "Group_ong" ss_ong "")
		(command "group" "c" (strcat "Cut_" (rtos (getvar 'cdate) 2 0) (itoa #lan_ve)) "Group_cut" ss_cut "")
		;(mapcar 'entdel (list cut path))       ;Cai nay chay tren cad2014 thay co loi ko xoa path nen thay bang command
		(command ".ERASE" cut "")
		(command ".ERASE" path "")
		(command "ucs" "na" "r" "save1_ucs")
		(command "ucs" "na" "d" "save1_ucs")
		;(command "-view" "r" "save_v")
		;(command "-view" "d" "save_v")
		(mapcar 'setvar lst_va old)
		(princ)
	)
	(alert "***** Nhap du lieu chua dung ! *****")
)
)
(vl-load-com)
;*****************************************************************************************************************************
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=============================================================================================================================
(defun 3DDD(ss pt_a pt_b pt_c pt_1 pt_2 pt_3 / lst_va old lst_point_w moc new pre
huong_12_xoy huong_13_xoy huong_ab_xoy huong_ac_xoy 
huong_12_yoz huong_13_yoz huong_ab_yoz huong_ac_yoz 
huong_12_xoz huong_13_xoz huong_ab_xoz huong_ac_xoz 
pt_phu pt_phu_w pt_phu2 pt_phu2_w base truc truc_w ang anh anh_c anh_w pt_phu2_2d pt_phu2_w_3d pt_phu_2d pt_phu_3d pt_phu_w_3d)
;Ham 3dalign khong scale Voi 3 diem chon phai "bang nhau" ve kich thuoc hinh dang
(setq lst_va '("osmode" "cmdecho" "AUNITS" "ANGDIR"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 3 0))
(setq lst_point_w (mapcar '(lambda (x) (trans x 1 0)) (list pt_a pt_b pt_c pt_1 pt_2 pt_3)))
(command "ucs" "na" "s" "save_ucs")
;(command "-view" "s" "save_v")
(setq moc (entlast) 
	  new (ssadd))
(command "_.copy" ss "" pt_a pt_1)
(while (setq pre (entnext moc))
	(setq new (ssadd pre new)
		  moc pre)
)	;while
;======================================================================
;Kiem tra trung phuong, chieu
(command "ucs" "za" '(0 0 0) '(2.357 1.312 4.235))
(setq huong_12_xoy (angle (nth 3 lst_point_w) (nth 4 lst_point_w))
	  huong_13_xoy (angle (nth 3 lst_point_w) (nth 5 lst_point_w))
	  huong_ab_xoy (angle (nth 0 lst_point_w) (nth 1 lst_point_w))
	  huong_ac_xoy (angle (nth 0 lst_point_w) (nth 2 lst_point_w))
	  )
(command "ucs" "za" '(0 0 0) '(1 0 0))
(setq huong_12_yoz (angle (trans (nth 3 lst_point_w) 0 1) (trans (nth 4 lst_point_w) 0 1))
	  huong_13_yoz (angle (trans (nth 3 lst_point_w) 0 1) (trans (nth 5 lst_point_w) 0 1))
	  huong_ab_yoz (angle (trans (nth 0 lst_point_w) 0 1) (trans (nth 1 lst_point_w) 0 1))
	  huong_ac_yoz (angle (trans (nth 0 lst_point_w) 0 1) (trans (nth 2 lst_point_w) 0 1))
	  )
(command "ucs" "za" '(0 0 0) '(1 0 0))
(setq huong_12_xoz (angle (trans (nth 3 lst_point_w) 0 1) (trans (nth 4 lst_point_w) 0 1))
	  huong_13_xoz (angle (trans (nth 3 lst_point_w) 0 1) (trans (nth 5 lst_point_w) 0 1))
	  huong_ab_xoz (angle (trans (nth 0 lst_point_w) 0 1) (trans (nth 1 lst_point_w) 0 1))
	  huong_ac_xoz (angle (trans (nth 0 lst_point_w) 0 1) (trans (nth 2 lst_point_w) 0 1))
	  )
(command "ucs" "na" "r" "save_ucs")
;=====================================================================
(cond
	((and 
		(equal huong_12_xoy huong_ab_xoy 1e-5) 
		(equal huong_12_yoz huong_ab_yoz 1e-5)
		(equal huong_12_xoz huong_ab_xoz 1e-5)
		)
		(cond
			((and 
				(equal huong_13_xoy huong_ac_xoy 1e-5) 
				(equal huong_13_yoz huong_ac_yoz 1e-5)
				(equal huong_13_xoz huong_ac_xoz 1e-5)
				)
				(princ "\nAlign = Copy ! ")
				(princ)
			)
			(t 
				(setq pt_phu (mapcar '+ pt_1 (mapcar '- pt_c pt_a))
					  pt_phu_w (trans pt_phu 1 0))
				(command "ucs" "za" pt_1 pt_2)
				(command "rotate" new "" 
					(setq base (trans (nth 3 lst_point_w) 0 1))
					(- (angle base (trans (nth 5 lst_point_w) 0 1)) (angle base (trans pt_phu_w 0 1)))
					)
			)
		)
	)
	;========================================================
	((and 
		(or (equal (+ huong_12_xoy pi) huong_ab_xoy 1e-5) (equal (- huong_12_xoy pi) huong_ab_xoy 1e-5))
		(or (equal (+ huong_12_yoz pi) huong_ab_yoz 1e-5) (equal (- huong_12_yoz pi) huong_ab_yoz 1e-5))
		(or (equal (+ huong_12_xoz pi) huong_ab_xoz 1e-5) (equal (- huong_12_xoz pi) huong_ab_xoz 1e-5))
		)
			(setq truc (mapcar '+ pt_1 (mapcar '- pt_c pt_a))
				  truc_w (trans truc 1 0))
			(setq anh (mapcar '+ pt_1 (mapcar '- pt_b pt_a))
				  anh_w (trans anh 1 0))
			(command "ucs" "za" pt_1 truc)
			(command "rotate" new "" (setq base (trans (nth 3 lst_point_w) 0 1)) pi)
			(setq pt_phu2_2d
				(polar 
						base 
						(+ pi (angle base (setq anh_c (trans anh_w 0 1)))) 
						(distance base (list (car anh_c) (cadr anh_c)))
						)
				pt_phu2_w_3d (trans (list (car pt_phu2_2d) (cadr pt_phu2_2d) (last anh_c)) 1 0)
				)
			(cond
				((and 
					(equal huong_13_xoy huong_ac_xoy 1e-5) 
					(equal huong_13_yoz huong_ac_yoz 1e-5)
					(equal huong_13_xoz huong_ac_xoz 1e-5)
					)
					(princ)
				)
				((and 
					(or (equal (+ huong_13_xoy pi) huong_ac_xoy 1e-5) (equal (- huong_13_xoy pi) huong_ac_xoy 1e-5))
					(or (equal (+ huong_13_yoz pi) huong_ac_yoz 1e-5) (equal (- huong_13_yoz pi) huong_ac_yoz 1e-5))
					(or (equal (+ huong_13_xoz pi) huong_ac_xoz 1e-5) (equal (- huong_13_xoz pi) huong_ac_xoz 1e-5))
					)
					(command "ucs" "za" base (mapcar '(lambda (x) (* 0.5 x)) (mapcar '+ (trans pt_phu2_w_3d 0 1) (trans (nth 4 lst_point_w) 0 1))))
					(command "rotate" new "" (trans (nth 3 lst_point_w) 0 1) pi)
				)
				(t 
					(command "ucs" "3p" base (trans (nth 5 lst_point_w) 0 1) (trans truc_w 0 1))
					(command "rotate" new ""
						(setq base (trans (nth 3 lst_point_w) 0 1))
						(* -1 (angle base (trans truc_w 0 1)))
					)
				)
			)
	)
	;==================================================================
	(t 
		(cond
			((and 
					(equal huong_13_xoy huong_ac_xoy 1e-5) 
					(equal huong_13_yoz huong_ac_yoz 1e-5)
					(equal huong_13_xoz huong_ac_xoz 1e-5)
					)
					(setq pt_phu (mapcar '+ pt_1 (mapcar '- pt_b pt_a))
						  pt_phu_w (trans pt_phu 1 0))
					(command "ucs" "za" pt_1 pt_3)
					(command "rotate" new "" 
						(setq base (trans (nth 3 lst_point_w) 0 1))
						(- (angle base (trans (nth 4 lst_point_w) 0 1)) (angle base (trans pt_phu_w 0 1)))
					)
			)
			((and 
					(or (equal (+ huong_13_xoy pi) huong_ac_xoy 1e-5) (equal (- huong_13_xoy pi) huong_ac_xoy 1e-5))
					(or (equal (+ huong_13_yoz pi) huong_ac_yoz 1e-5) (equal (- huong_13_yoz pi) huong_ac_yoz 1e-5))
					(or (equal (+ huong_13_xoz pi) huong_ac_xoz 1e-5) (equal (- huong_13_xoz pi) huong_ac_xoz 1e-5))
					)
					(setq truc (mapcar '+ pt_1 (mapcar '- pt_b pt_a))
						  truc_w (trans truc 1 0))
					(setq anh (mapcar '+ pt_1 (mapcar '- pt_c pt_a))
						  anh_w (trans anh 1 0))
					(command "ucs" "za" pt_1 truc)
					(command "rotate" new "" (setq base (trans (nth 3 lst_point_w) 0 1)) pi)
					(command "ucs" "3p" base (trans (nth 4 lst_point_w) 0 1) (trans truc_w 0 1))
					(command "rotate" new ""
						(setq base (trans (nth 3 lst_point_w) 0 1))
						(* -1 (angle base (trans truc_w 0 1)))
					)
			)
			(t
				(setq pt_phu (mapcar '+ pt_1 (mapcar '- pt_b pt_a))
					  pt_phu_w (trans pt_phu 1 0)
					  pt_phu2 (mapcar '+ pt_1 (mapcar '- pt_c pt_a))
					  pt_phu2_w (trans pt_phu2 1 0))
				(command "ucs" "3p" pt_1 pt_2 pt_phu)
				(command "rotate" new "" 
					(setq base (trans (nth 3 lst_point_w) 0 1)) 
					(setq ang (* -1 (angle base (trans pt_phu_w 0 1))))
				)
				(setq pt_phu_2d 
						(polar 
							base 
							(+ ang (angle base (setq anh_c (trans pt_phu2_w 0 1)))) 
							(distance (list (car base) (cadr base)) (list (car anh_c) (cadr anh_c))))
					  pt_phu_3d (list (car pt_phu_2d) (cadr pt_phu_2d) (last anh_c))
					  pt_phu_w_3d (trans pt_phu_3d 1 0))
				(command "ucs" "za" (trans (nth 3  lst_point_w) 0 1) (trans (nth 4  lst_point_w) 0 1))
				(command "rotate" new "" 
					(setq base (trans (nth 3 lst_point_w) 0 1))
					(- (angle base (trans (nth 5 lst_point_w) 0 1)) (angle base (trans pt_phu_w_3d 0 1)))
				)
			)
		)
	)
)
(command "ucs" "na" "r" "save_ucs")
(command "ucs" "na" "d" "save_ucs")
;(command "-view" "r" "save_v")
;(command "-view" "d" "save_v")
(mapcar 'setvar lst_va old)
(princ)
)

<<

Filename: 313604_ve.lsp
Tác giả: Tot77
Bài viết gốc: 313646
Tên lệnh: lm
Cần layiso theo màu của layer

Lisp này nhấp vào màu nào thì nó hiện tất cả các đt cùng màu đó. Muốn hiện lên hết thì khi nó hỏi thì enter.

(defun c:lm(/ v mau ss ss1 tm)
  (vl-load-com)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun laymau(e / m)  (if (not (setq m (dxf 62 e))) (cdr (assoc 62 (tblsearch "LAYER" (dxf 8 e)))) m))
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
  (mapcar '(lambda(x)...
>>

Lisp này nhấp vào màu nào thì nó hiện tất cả các đt cùng màu đó. Muốn hiện lên hết thì khi nó hỏi thì enter.

(defun c:lm(/ v mau ss ss1 tm)
  (vl-load-com)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun laymau(e / m)  (if (not (setq m (dxf 62 e))) (cdr (assoc 62 (tblsearch "LAYER" (dxf 8 e)))) m))
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
  (mapcar '(lambda(x) (vla-put-Visible (vlax-ename->vla-object x) actrue)) ss)
  
  (if (setq v (car (entsel "\nChon hien mau:")))
    (setq mau (laymau v) 
 ss1 (vl-remove-if-not '(lambda (x) (= mau (laymau x))) ss)
 tm (mapcar '(lambda(x) (vla-put-Visible (vlax-ename->vla-object x) acfalse)) ss)
 tm (mapcar '(lambda(x) (vla-put-Visible (vlax-ename->vla-object x) actrue)) ss1))
  )
  (princ)  
)

<<

Filename: 313646_lm.lsp
Tác giả: nhoclangbat
Bài viết gốc: 313681
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

nhoc có 1 lsp mót chỉnh sữa lại 1 tí theo ý bạn, bạn xem sao ^^

;;;Dung de tinh tong cac so
(defun C:tbcc()
  (setq ss (ssget '((0 . "TEXT"))))
  (setq c 0 tong 0)
  (if (/= ss nil)
    (while (< c (sslength ss))
      (setq oldob (entget (ssname ss c)))
      (setq txtstr (assoc 1 oldob))
	  (setq realk (assoc 40 oldob))
	(if (/= txtstr nil)
        (progn
		  (setq ctext (cdr realk))
          (setq num (cdr txtstr))
          (setq...
>>

nhoc có 1 lsp mót chỉnh sữa lại 1 tí theo ý bạn, bạn xem sao ^^

;;;Dung de tinh tong cac so
(defun C:tbcc()
  (setq ss (ssget '((0 . "TEXT"))))
  (setq c 0 tong 0)
  (if (/= ss nil)
    (while (< c (sslength ss))
      (setq oldob (entget (ssname ss c)))
      (setq txtstr (assoc 1 oldob))
	  (setq realk (assoc 40 oldob))
	(if (/= txtstr nil)
        (progn
		  (setq ctext (cdr realk))
          (setq num (cdr txtstr))
          (setq tam (atof num))
          (setq tong (+ tong tam))
		  (setq tbc (/ tong (sslength ss)))
        );progn
      );if
      (setq c (1+ c))
    );while
  );if
  (while (/= tong 0)
    (setq p (getpoint "\nNhap vi tri xuat ket qua: "))
    (command "TEXT" p ctext 0 (rtos tbc 2 3) "")
    (setq tong 0)
  );while
)
(prompt "ten lenh : tbcc")


<<

Filename: 313681_tbcc.lsp
Tác giả: thanhduan2407
Bài viết gốc: 313784
Tên lệnh: 00
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

À mà em giải quyết được rồi ạ!

(defun C:00 ( /  )
(setq ObjPline1 (car (entsel "\nChon Pline can tim diem giao cat gan nhat: ")))
(setq ObjPoint (car (entsel "\nChon diem can tim giao ")))
(setq P1 (acet-dxf 10 (entget ObjPoint)))
(setq  P2 (mapcar '- Pnt P1))
(MakeXline P1 P2)
(setq EnameXline (entlast))
)

(defun MakeXline (pt vec)
  (entmakex (list (cons 0 "XLINE")
                  (cons 100 "AcDbEntity")
                  (cons 100...
>>

À mà em giải quyết được rồi ạ!

(defun C:00 ( /  )
(setq ObjPline1 (car (entsel "\nChon Pline can tim diem giao cat gan nhat: ")))
(setq ObjPoint (car (entsel "\nChon diem can tim giao ")))
(setq P1 (acet-dxf 10 (entget ObjPoint)))
(setq  P2 (mapcar '- Pnt P1))
(MakeXline P1 P2)
(setq EnameXline (entlast))
)

(defun MakeXline (pt vec)
  (entmakex (list (cons 0 "XLINE")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDbXline")
                  (cons 10 pt)
                  (cons 11 vec)
	    )
  )
)

<<

Filename: 313784_00.lsp

Trang 173/330

173