Jump to content
InfoFile
Tác giả: phung_gtvt
Bài viết gốc: 213999
Tên lệnh: dscoc
Rải và đánh số thứ tự cọc

Cái này viết thêm cho bạn nè

(defun c:dscoc(/ ss i Tue-dxf Tue-ss-list)
(defun Tue-dxf (dxf ename)(cdr(assoc dxf (entget...
>>

Cái này viết thêm cho bạn nè

(defun c:dscoc(/ ss i Tue-dxf Tue-ss-list)
(defun Tue-dxf (dxf ename)(cdr(assoc dxf (entget ename))))
(defun Tue-ss-list (L-ss-vlaobj / n L Lst ssg vlaobj)
 (mapcar 'set '(ssg vlaobj) L-ss-vlaobj)
 (setq L (sslength ssg))
 (Repeat L
   	(setq ename (ssname ssg (setq L (1- L))))
   (setq Lst (cons (if vlaobj (vlax-ename->vla-object ename) ename) Lst))
 )
)
 (setq i 0)
 (princ "\n Chon cac coc nho can danh so : ")
 (if (setq ss (ssget '((0 . "CIRCLE") (40 . 0.25))))
     (foreach x (reverse (Tue-ss-list  (list ss)))
  	(entmake (list (cons 0 "TEXT") (cons 1 (itoa (setq i (1+ i)))) (cons 40 0.30)
  	       (cons 10 (mapcar '+ (Tue-dxf 10 x) '(0.0 0.5 0.0)))
  	       (cons 11 (mapcar '+ (Tue-dxf 10 x) '(0.0 0.5 0.0)))
  	))
   )
 )
)

-> Lisp lọc chọn các cọc nhỏ và đánh số thứ tự như file kèm theo

 

Cám ơn sự giúp đỡ của anh em.

Lisp "dscoc" đánh số rất hay nhưng vẫn chưa thỏa mãn với câu hỏi của mình.

Ví dụ, mình nhận được bản vẽ thiết kế với 200 cọc (bản vẽ pdf hoặc bản vẽ giấy), sau đó mình vẽ lại bản vẽ đó, tính được tọa độ các cọc lưu thành file excel rồi, nếu lấy lisp "dscoc" áp dụng vào thì tên cọc không theo thứ tự với bản vẽ thiết kế (không khớp với thứ tự cọc theo list tọa độ).

Anh em nào có lisp mà gắn được mối liên quan giữa tọa độ vào tên cọc, sau đó vẽ luôn ra bản vẽ cọc kèm theo tên cọc luôn.

Mình không biết về lập trình hay viết lisp gì cả nên nhờ anh em giúp.

Mình gửi anh em file excel tọa độ làm ví dụ

http://www.cadviet.com/upfiles/3/113288_file_toa_do.rar


<<

Filename: 213999_dscoc.lsp
Tác giả: vanhoatnguyen
Bài viết gốc: 202940
Tên lệnh: bt 10
Lisp ghi bước thép với khoảng cách thép đều nhau

Thêm 1 phương án :

(defun C:bt(/ ctc ss)
 (or *ctc* (setq *ctc* 200))
 (initget 6)
 (setq ctc (getint (strcat"\nNhap buoc thep...
>>

Thêm 1 phương án :

(defun C:bt(/ ctc ss)
 (or *ctc* (setq *ctc* 200))
 (initget 6)
 (setq ctc (getint (strcat"\nNhap buoc thep <" (itoa *ctc*) ">:")) )
 (if ctc (setq *ctc* ctc))
 (if (setq ss (ssget"_:L" (list (cons 0 "DIMENSION")) ))
(progn
 	(command "_.undo" "_begin")    
 	(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(vla-put-TextOverride (vlax-ename->vla-object ent)
  (strcat (itoa (fix(/ (cdr (assoc 42 (entget ent))) *ctc*)))
"x" (itoa *ctc*) "=<>"))	)
 	(command "_.undo" "_end") (princ)  )))
(defun C:10(/ num ss)
 (if (setq ss (ssget"_:L"))
(progn
 	(command "_.undo" "_begin")
 	(or *num* (setq *num* 15))
 	(initget 4)
 	(setq num (getint (strcat"\nNhap color <" (itoa *num*) ">:")) )
 	(while (not (if num (<= num 256)T) )
(princ "\nGia tri <=256.")
(setq num (getint (strcat"\nNhap color <" (itoa *num*) ">:")) ))
 	(if num (setq *num* num))
 	(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(vla-put-Color (vlax-ename->vla-object ent)*num* )	)
 	(command "_.undo" "_end") (princ)  )))

 

Đoạn lisp chuyển màu của bác gia_bach như thế là đúng ý em rồi.

Đoạn lisp BT của bác gia_bach em thử thì cũng bị giống như đoạn lisp BT của bác Tue_NV trước khi sửa thì phải, bác gia_bach xem lại có phải thế không giúp em nhé. Đoạn lisp BT của bác Tue_NV sau khi sửa em thấy ổn rồi ạ. nhưng nếu có thể bác sửa giúp em thêm thành:

- Lưu giá trị của bước thép lần lệnh trước để nếu lần sau vẫn là bước đó mình đỡ phải gõ lại.

- Khi click vào đường kích thước thì sẽ tự chuyển sang dạng "5x500=2500" luôn chứ không cần Enter lần nữa

Cảm ơn tất cả các bác đã quan tâm giúp đỡ.


<<

Filename: 202940_bt_10.lsp
Tác giả: dauquangminh
Bài viết gốc: 162843
Tên lệnh: vc
Lisp lấy tọa độ của các đỉnh của 1 polyline của bác ssg

À, mình thì yên tâm rồi nhưng CAD nhiều lúc nó chẳng yên tâm, giải quyết bài toán thường tốt hơn nếu làm tổng quát :) Ví dụ, như hình...

>>

À, mình thì yên tâm rồi nhưng CAD nhiều lúc nó chẳng yên tâm, giải quyết bài toán thường tốt hơn nếu làm tổng quát :) Ví dụ, như hình trên, việc giải quyết cũng không đơn giản lắm. Theo mình hiểu, việc so sánh thuận nghịch trong ý bạn chỉ là so sánh vị trí point đầu và cuối Pline ?

Nếu đúng thì code có thể giống thế này :

(Chú ý : cách chọn hướng mình gợi ý bạn pick chọn 2 điểm, như thế thao tác sẽ dùng thuần chuột, nhanh hơn là pick, pick , tay trái chọn Y/N, tay phải nhấn Space )

;; by ssg, ketxu update
;; Danh so Pline

;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR(x) (/ (* x pi) 180) ) ;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1) ;;;Line polar: point, degree angle, radius
   (setq p1 (polar p0 (dtr a) r))
   (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x)) ;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y)) ;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
   (setq L (append L (list (vlax-curve-getPointAtParam e i))))
   (setq i (1+ i))
)
L
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h) ;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0  "TEXT") (cons 7 (getvar "textstyle"))(cons 8 (if (tblsearch "Layer" "Defpoints") "Defpoints" (getvar "clayer")))
   (cons 1 txt) (cons 10 p) (cons 11 p) (cons 40 h) (cons 72 1) (cons 73  2)))
)
;;;-------------------------------------------------------------------------------
(defun Collect(e / e2 SS) ;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil) (setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
   p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
   p2 (polar p1 0 (* 6 h))
   p3 (polar p2 0 (* 8 h))
   p4 (polar p3 0 (* 8 h))
   pL (list p1 p2 p3 p4)
   i 0
)
(repeat 3
   (wtxtMC (nth i txtL) (nth i pL) h)
   (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun mesh1() ;;;Make 1 mesh unit
(linepy p0 (* -3 h))
(command "copy" "L" "" p0 (list (+ (car p0) (* 4 h)) (cadr p0)))
(command "array" "L" "" "r" 1 3 (* 8 h))
(linepx (polar p0 (* 1.5 pi) (* 3 h)) (* 20 h))
)
;;;-------------------------------------------------------------------------------


;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC( / h p et p0 p00 pvL oldos j pv num txtL ss bn p1 p2 pvlT)
;;;Vertex Co-ordinate

;;;GET TEXT HEIGHT
(if (not h0) (setq h0 1))
(setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
(if (not h) (setq h h0) (setq h0 h))
(setvar "osmode" 0)

;;;PICK & BASE POINT

(setq et (car (entsel)))

(setq
p1 (getpoint "\n Huong danh so")
p2 (getpoint p1 "\n Huong danh so")
   p00 (getpoint "\nDiem chuan bang toa do (phia tren ben trai):")
   p0 p00
   pvLt (getvert et)
pvL
(cond ((>(setq dau (*(-(car (car pvLt))(car (last pvlT)))(- (car p1)(car p2)))) 0) pvLt)
	((< dau 0) (reverse pvlT)))
   oldos (getvar "osmode")
)

;;;HEADER
(linepx p0 (* 20 h))
(mesh1)
(txt1 (list "TT" "X" "Y"))
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
(setq j 0)
(repeat (1- (length pvL))
   (mesh1)
   (setq
       pv (nth j pvL)
       num (itoa (1+ j))
       txtL (list num (rtos (car pv)) (rtos (cadr pv)) )
   )
   (txt1 txtL)
   ;(wtxtMC num (polar pv 0 h) h)
   (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
   (setq j (1+ j))
)

;;;MAKE BLOCK
(setq ss (collect1 et))

(setq bn "1")
(while (tblsearch "block" bn) (setq bn (itoa (1+ (atoi bn)))))
(command "block" bn p00 ss "")
(command "insert" bn p00 "" "" "")

;;;WRITE POINT NAME
(setq j 0)
(repeat  (length pvL)
   (setq
       pv (nth j pvL)
       num (itoa (1+ j))
   )
   (wtxtMC num (polar pv 0 h) h)
   (setq j (1+ j))
)

;;;FINISH
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------

Mình không thấy lisp lấy tọa độ của điểm cuối cùng, ví dụ polyline có 4 đỉnh thì lisp chỉ lấy tọa độ từ đỉnh 1 đến đỉnh 3 thôi, lạ quá ketxu à. Một điểm nữa là mỗi khi dùng lisp thì tất cả Object snap bị tắt hết, mình phải bấm F3 rồi chọn select all thì mới pick điểm cho hướng đánh số được. :blink:

8-4-20118-15-55AM.jpg

8-4-20118-15-13AM.jpg


<<

Filename: 162843_vc.lsp
Tác giả: pawuta
Bài viết gốc: 345422
Tên lệnh: thkl
Nhờ viết lisp thông kê giá trị trong block ATT

 

Dùng thử Lisp này xem sao : 15454_thongkechdai.png

>>

 

Dùng thử Lisp này xem sao : 15454_thongkechdai.png

(defun c:ThKl (/ doc)
  (vl-load-com)
  (princ "\nChon Block can tong hop :")
  (if (ssget (list (cons 0 "INSERT")(cons 66 1)))
    (tkatt (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))))
	   (vla-get-modelspace doc) "DK" "TCD" "TKL" )
    (princ "\nKhong chon duoc Block thuoc tinh."))
  (princ))
(defun tkatt (ssets msp idTag val1tag val2tag / asoc h i id lst pt row tblobj val1 val2 width)
    ;;  By : Gia_Bach, www.CadViet.com 2015 ;;
  (vlax-for obj ssets
    (setq id nil val1 nil val2 nil)
    (foreach att (vlax-invoke obj 'GetAttributes)
      (cond
	( (= (vla-get-TagString att) idTag)
	  (setq id (vla-get-TextString att)) )
	( (= (vla-get-TagString att) val1Tag)
	  (setq val1 (vla-get-TextString att)) )
	( (= (vla-get-TagString att) val2Tag)
	  (setq val2 (vla-get-TextString att)) ) ))
    (if (and id (distof id 2) val1 val2(setq val1 (distof val1 2))(setq val2 (distof val2 2)))
      (if (setq asoc (assoc id lst))
	(setq lst (subst (cons id (list (+ val1 (car(cdr asoc))) (+ val2 (cadr(cdr asoc))))) asoc lst))
	(setq lst (append lst (list (cons id (list val1 val2)))) )) ))
  (cond
    ( (not lst )
      (princ "\nKhong tim duoc so lieu.") )
    ( (> (atof (substr (getvar "ACADVER") 1 4)) 16.0)
      (if (setq pt (getpoint "\nDiem dat Bang tong hop:"))
	(progn
	  (setq h 1.8 width (* 6 h)
		TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst) 2) 4 (* 2 h) width))
	  (vla-put-regeneratetablesuppressed TblObj :vlax-true)
	  (vla-put-vertcellmargin TblObj (* 0.75 h))
	  (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
		  (list acTitleRow acHeaderRow acDataRow) )
	  (mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
		  (list acTitleRow acHeaderRow acDataRow))
	  (vl-catch-all-error-p (vl-catch-all-apply (function(lambda () (vla-MergeCells TblObj 0 0 0 3)) )))
	  (vla-setText TblObj 0 0 "Bang tong hop")
	  (vla-setText TblObj 1 0 "STT")
	  (vla-setText TblObj 1 1 idTag)
	  (vla-setText TblObj 1 2 val1Tag)
	  (vla-setText TblObj 1 3 val2Tag)
	  (setq row 2 i 1)
	  (foreach pt (vl-sort lst '(lambda (x y) (< (car x) (car y))))
	    (vla-setText TblObj row 0 (itoa i))
	    (vla-setText TblObj row 1 (car pt))
	    (vla-setText TblObj row 2 (rtos(car(cdr pt))2 2))
	    (vla-setText TblObj row 3 (rtos(cadr(cdr pt))2 2))
	    (setq row (1+ row) i (1+ i))	)
	  (vla-put-regeneratetablesuppressed TblObj :vlax-false)
	  (vlax-release-object TblObj)  	  )))
    ( t
      (foreach it (vl-sort lst '(lambda (x y) (< (car x) (car y))))
	(princ (strcat "\n"(car it) " : " (rtos(car(cdr it))2 2) " : " (rtos(cadr(cdr it))2 2))))  ) )
  )

Cảm ơn bạn rất nhiều! Lisp chạy rất oke, nhưng mình có thêm chút ý kiến bạn sửa lại giúp mình một chút nữa nha!

- Mình muốn thay đổi các Text như sau: Bang tong hop -> TỔNG HỢP KHỐI LƯỢNG; DK -> ĐƯỜNG KÍNH; TCD -> TỔNG CHIỀU DÀI; TKL -> TỔNG KHỐI LƯỢNG (font: vni-helve; (cao chữ: 3.5)

- Các số thống kê bên dưới (font: vni-helve; (cao chữ: 2.5) và tự động thay đổi giá trị theo khi thay đổi các giá trị các block att.


<<

Filename: 345422_thkl.lsp
Tác giả: hhhhgggg
Bài viết gốc: 44253
Tên lệnh: xscale xsc
Lisp scale theo 1 trục hay bị lỗi, nhờ sửa giúp !!!!
Líp của bạn không có lỗi gì cả. Tuy nhiên, có chỉnh sửa đôi chút để Lisp chạy tốt hơn

;================ Scale theo 1 truc ============
;Scale the mot...
>>
Líp của bạn không có lỗi gì cả. Tuy nhiên, có chỉnh sửa đôi chút để Lisp chạy tốt hơn

;================ Scale theo 1 truc ============
;Scale the mot chieu
(DEFUN EXCUTE()
(setq oldvalue (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(princ "\nChon doi tuong can scale: ")
(setq ss (ssget))
(setq P0 (getpoint "\nChon diem goc: "))
(initget 1 "X Y X S")
(setq C (getkword "\nScale theo ? :"))
(setq hs (getreal "\nCho biet he so scale: "))
(DELBLOCK "vkc_temp")
(CREATEBLOCK ss P0) 
(Command "-Insert" "vkc_temp" C hs P0 "") 
(setq dt (entlast))
(Command "Explode" dt)
(setvar "CMDECHO" oldvalue)
(princ)
)
(DEFUN CREATEBLOCK(ss P)
(command "-Block" "vkc_temp" P ss "")
)

(DEFUN DELBLOCK (bname)
(if (IsExistBlock bname)
(Command "-Purge" "B" bname "Y" "Y") 
)
)
(DEFUN IsExistBlock(bname / kq)
(setq kq Nil)
(setq n (length LiBlk))
(setq i 0)
(while (< i n)
(if (= bname (nth i LiBlk))
(progn
(setq i n)
(setq kq T)
) 
)
(setq i (1+ i))
)
kq
)
(DEFUN CREALIBLK (/ NL)
(setq LiBlk (List))
(setq NL (tblnext "BLOCK" T)) 
(while NL 
(setq LiBlk (append LiBlk (list (cdr (assoc 2 NL)))))
(setq NL (tblnext "BLOCK"))
)
(setq LiBlk (Acad_strlsort LiBlk))
)
(DEFUN C:XSCALE()
(CREALIBLK)
(EXCUTE)
)
(DEFUN C:XSC()
(CREALIBLK)
(EXCUTE)
)

:cheers:

Nó vẫn báo lỗi như vậy bác Tuệ à ! Cái này nó còn do File CAD nữa. Nhưng rất hay bị lỗi như vậy. Mong bác nào sửa giúp em với !


<<

Filename: 44253_xscale_xsc.lsp
Tác giả: thanhdatkts
Bài viết gốc: 181672
Tên lệnh: tdt tcd
lisp tính tổng diện tích và chu vi các hình

Mình thấy theo cách chọn vùng để tính chu vi và diện tích bằng cách pick điểm thì ko ổn, vì nếu bạn muốn pick vào nhiều vùng khác nhau...

>>

Mình thấy theo cách chọn vùng để tính chu vi và diện tích bằng cách pick điểm thì ko ổn, vì nếu bạn muốn pick vào nhiều vùng khác nhau thì phải zoom toàn bộ vùng đó giống như trong lệnh Hatch. vì vậy nếu muốn dùng tốt lisp tính diện tích cũng như chu vi cho nhiều hình thì chọn các hình bằng cách chọn đối tượng là khả thi hơn!

Trên diễn đàn có rất nhiều lisp tính diện tích chu vi. Mình gửi bạn cái của mình đang xài. Bạn có thể tham khảo!

(defun c:tdt(/ dt sdt gt tgt id pt1)
 (setq dt (ssget)
sdt (sslength dt)
id 0
tgt 0)
 (repeat sdt
(setq ent (ssname dt id)
  id (1+ id)
  )
(command "area" "o" ent "")
(setq gt (getvar "area"))
(setq tgt (+ tgt gt))
(princ)
)
(setq pt1 (getpoint "\nchon diem ghi chu:"))
 (command "text" "j" "mc" pt1 "250" "0" (strcat(rtos (/ tgt 1000000) 2 1) "m2"))
 (princ)
 )
;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:tcd(/ DT SDT TCD PT1)
 (setq dt (ssget '((-4 . "<OR")
  (0 . "CIRCLE")
  (0 . "ELLIPSE")
  (0 . "SPLINE")
  (0 . "ARC")
  (0 . "LINE")
  (0 . "*POLYLINE")
  (-4 . "OR>")
	))
)
 (setq sdt (sslength dt))
 (setq
 	index 0
 	tcd 0
 	)
 (repeat sdt
(setq
 	ent (ssname dt index)
 	index (1+ index)    
 	)    
(command "lengthen" ent "")
(setq cd (getvar "perimeter"))
(setq tcd (+ tcd cd))
)
 (setq pt1 (getpoint "\nchon diem ghi chu:"))
 (command "text" "j" "mc" pt1 "250" "0" (strcat(rtos (/ tcd 1000) 2 1) "m"))
 (princ)
 )

lisp này thì đúng rồi như khi muốn phóng to text ra thì phải scan không tiện lắm bằng lisp trên vì cái pick điểm kéo ra thì nó cũng tự scan roài....bác sửa lại giúp đc không

 

cái lisp trên tính tổng chu vi thì đúng nhưng tổng diện tích các pline vùng kín >2 vùng thì sai.....

 

http://www.mediafire.com/?b11emefhg184uyy


<<

Filename: 181672_tdt_tcd.lsp
Tác giả: huaductiep
Bài viết gốc: 277305
Tên lệnh: hatchkin
Nhờ viết Lisp Hatch vùng kín của các đối tượng giao nhau.

mình up lại đây

lisp nay mình test rồi nó ổn khi các đối tượng phải giao nhau hết (không tính được như hình mẫu ở trên...

>>

mình up lại đây

lisp nay mình test rồi nó ổn khi các đối tượng phải giao nhau hết (không tính được như hình mẫu ở trên trường hợp line và spline nó không giao nhau còn các hình còn lại thì ok)

File mẫu phải khai báo lại tỉ lệ hatch mặc định lớn lên vd=10 nếu không nó không có hatch được

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)
(defun LM:IntersectionsInSet ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendnone) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )
(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:hatchkin(/)
  (vl-load-com)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
						      (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
							 10000)))))
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (entmakex (list '(0 . "LINE")
			    (cons 10 (nth i lsp))
			    (cons 11 (nth (+ i 1) lsp))
			    ))
	  (ssadd (entlast) chonline)
	  (setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	  (setq i (+ i 1))
	  )
	)     
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (command "ERASE" chonline "")
	  (command "ERASE" chonpolyline "")
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lspxetbien)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	    (entdel (car (car lspxetbien)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (command "hatch" "" "" "" (car xetpl) "")
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )
	  
	  )
	)
      )
    )
  )

test.gif

Em còn gặp lỗi là nếu ta quét chọn nhiều hình cùng lúc (như file em gửi là em quét chọn cả 6 khối hình 1 lúc) thì sau khi Hatchkin có một số vùng Hatch được tạo ra bao toàn bộ tất cả các hình. Mà em chỉ muốn nó ra kết quả Hatch ở mỗi vùng riêng biệt thôi. Và Bác có thể chỉnh cho em cái phần sau khi hatch xong thì nó mất cái phần Region được tạo ra đó ko ah? 

Nói chung Lisp đã rất tuyệt rồi. Bác chỉnh giúp em mấy cái này nữa nhá. Em cám ơn các Bác nhiều lắm  :) http://www.cadviet.com/upfiles/3/64997_test_hatch_2.dwg64997_screenshot_81.png


<<

Filename: 277305_hatchkin.lsp
Tác giả: bach1212
Bài viết gốc: 365910
Tên lệnh: edt vld
Đổi Màu Text Kết Quả Của Lisp Tính Diện Tích

 

Của bạn đây.

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

 

Của bạn đây.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/141684-nha-cha-nh-sa-a-a-i-ma-u-text-ka-t-qua-ca-a-lisp-ta-nh-dia-n-ta-ch/
(defun c:edt( / DTCON DTL ELST ET OSLAST PT1 SS VSIZE ObjText)
(setvar "DIMZIN" 0)
  (if (= tl nil) (progn
    (setq tl (getreal "\nDrawing scale<1> : "))
    (setq ntl tl)
    (setq tl2 (* ntl ntl))
    )
  )
  (setq dtl 0)
  (setq ss (ssadd))
  (setq oslast (getvar "OSMODE"))
  (command "osnap" "")
  (print)
  (print)
  (setq pt1 (getpoint "\nChon mot diem trong vung dien tich can tinh: "))
  (while (/= pt1 nil)
    (command "-boundary" pt1 "")
    (setq et (entlast))
    (ssadd et ss)
    (command "area" "e" "last")
    (setq vsize ( /(getvar "VIEWSIZE") 3 ))
    (command "hatch" "ANSI31" vsize "0" "last" "")
    (setq et (entlast))
    (ssadd et ss)
    (setq dtcon (getvar "AREA"))
    (setq dtl (+ dtcon dtl))
    (print)
    (print)
    (setq pt1 (getpoint "\nChon mot diem trong vung dien tich tiep theo : "))
  )
  (command "setvar" "OSMODE" oslast)
  (command "erase" ss "")
  (setq ss nil)
  (command "redraw" )
  (setq dtl (* dtl tl2))
  (print dtl)
  (setq ObjText  (car (entsel "Thay cho so: ")))
  (setq elst (entget ObjText))
  (setq elst (subst (cons 1 (rtos dtl 2 2)) (assoc 1 elst) elst))
  (entmod elst)
  (vla-put-color
      (vlax-ename->vla-object ObjText)
      6
    )

  
  ;(print)
  (prompt (strcat "\nTong dien tich: " (rtos dtl 2 4)))
  (print)
;  (setq pt2 (getpoint "\nPoint to write: "))
;  (command "text" pt2 (/ vsize 6) "0" (rtos dtl 2 2))
);defun
;(setq caodo (atof (assoc 1 ((entget (car (entsel "Thay cho so: ")))))))
;----------------------------------------------------------------------------
(Defun c:vld( / PT PT1 PT2 S)
  (Setq pt1(getpoint"\nChon diem bat dau ve:"))
  ;(Setq s(getreal"\nCho chieu dai doan ve:"))
  ;(Setq pt(getreal"\nCho do doc cua duong thang<%>:"))
  (While
    (Setq s(getreal"\nCho chieu dai doan ve:"))
  (Setq pt(getreal"\nCho do doc cua duong thang<%>:"))
    (setq pt2(list ))))
	

Được rùi bạn ah. thanks all!  :)


<<

Filename: 365910_edt_vld.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 363252
Tên lệnh: vtl vtl2 dctl
Lisp Dải Taluy

 

Của bạn đây! Mình đang ở vùng biên giới nên ko có mạng internet.

>>

 

Của bạn đây! Mình đang ở vùng biên giới nên ko có mạng internet.

(vl-load-com)
(defun C:VTL( /  ObjPline LtsTaluy LtsLDai LtsLNgan e1 e2 e3 e4 ang1 ang2 ang3 ang4 Pnt10N Pnt10D Pnt11N Pnt11D Chon)
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar "OSMODE"))

(or *CDTLN* (setq *CDTLN* 1))
(setq CDTLN (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch nh\U+1ECF < "
			  (rtos *CDTLN* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDTLN) (setq CDTLN *CDTLN*) (setq *CDTLN* CDTLN))

(or *CDTLD* (setq *CDTLD* 2))
(setq CDTLD (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch d\U+00E0i < "
			  (rtos *CDTLD* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDTLD) (setq CDTLD *CDTLD*) (setq *CDTLD* CDTLD))

  
(or *Sovachngan* (setq *Sovachngan* 2))
(setq Sovachngan (getint (strcat "\nS\U+1ED1 v\U+1EA1ch nh\U+1ECF gi\U+1EEFa 2 v\U+1EA1ch l\U+1EDBn: < "
			  (rtos *Sovachngan* 2 0)
			 " > :"
		  )
	 )
)
(if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))

(while (setq ObjPline (car (entsel "\nCh\U+1ECDn Pline: ")))
  	(setq VlaObjPL (vlax-ename->vla-object ObjPline))
        (setq LtsTaluy (VTLL CDTLN CDTLD Sovachngan ObjPline))
	(setq LtsLDai (car LtsTaluy))
	(setq LtsLNgan (cadr LtsTaluy))
  	 (setq Chon (strcase (getstring "\n(Ghi ch\U+00FA: U - L\U+00E0m l\U+1EA1i, C - \U+0110\U+1ED5i chi\U+1EC1u v\U+1EA1ch, G\U+00F5 b\U+1EA5t k\U+1EF3 \U+0111\U+1EC3 ti\U+1EBFp t\U+1EE5c) ")))
         (cond
           ((= Chon  "U")
	     (progn
	        (foreach e1 LtsLDai
			(entdel e1)
		)
	        (foreach e2 LtsLNgan
			(entdel e2)
		)
	     )
	    )
	   ((= Chon  "C")
	     (progn
	        (foreach e3 LtsLDai
		  	(progn
				(setq Pnt10D (cdr (assoc 10 (entget e3))))
			  	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10D))))
			  	(setq Pnt11D (polar Pnt10D (- ang3 (/ pi 2) )  CDTLD))
		  		(entmod (subst (cons 11 Pnt11D) (assoc 11 (entget e3)) (entget e3) ))
			)
		)
	        (foreach e4 LtsLNgan
		  	(progn
				(setq Pnt10N (cdr (assoc 10 (entget e4))))
			  	(setq ang4 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10N))))
			  	(setq Pnt11N (polar Pnt10N (- ang4 (/ pi 2) ) CDTLN))
		  		(entmod (subst (cons 11 Pnt11N) (assoc 11 (entget e4)) (entget e4) ))
			)
		)
	     )
	    )
	   ((or (/= Chon  "U") (/= Chon  "C"))
	     (setq Chon nil)
	    )
	 )
   )
(setvar "OSMODE" Olmode)
(princ)
)

(defun VTLL (CDTLN CDTLD Sovachngan ObjPline / CDTLD CDDoan n d1 d2 CDaiPLine ang2 Ptd Lts1 Lts2 LtsPntNgan Pnt1  EnameLD )
(MakeLayer_ "TALUY" 7)
(setq CDDoan (* (+ Sovachngan 1) CDTLN ))
(setq VlaObjPline (vlax-ename->vla-object ObjPline))
(setq CDaiPLine (vla-get-length VlaObjPline))
(setq n (fix (/ CDaiPLine CDDoan)))
(setq d1 0)
(setq Lts1 (list))
(setq LtsEnameLD (list))
(setq LtsEnameLN (list))
(while (< d1 CDaiPLine)
	(progn
		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline d1))
		(setq d1 (+ d1 CDDoan))
	  	(setq ang2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Ptd))))
	  	(entmake (list (cons 0 "LINE") (cons 8 "TALUY") (cons 10  Ptd) (cons 11 (polar Ptd (+ ang2 (/ pi 2) ) CDTLD))))
	  	(setq EnameLD (entlast))
	  	(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
	  	(setq Lts1 (append Lts1 (list Ptd)))
	)
)
(setq d2 0)
(setq Lts2 (list))
(setq m (fix (/ CDaiPLine CDTLN)))
(while (< d2 CDaiPLine)
	(progn
		(setq Ptn (vlax-curve-getPointAtDist VlaObjPline d2))
		(setq d2 (+ d2 CDTLN))
	  	(setq Lts2 (append Lts2 (list Ptn)))
	)
)
(setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
(foreach Pnt1 LtsPntNgan
  	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Pnt1))))
  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUY") (cons 11 (polar Pnt1 (+ ang3 (/ pi 2) ) CDTLN))))
  	(setq EnameLN (entlast))
  	(setq LtsEnameLN (append LtsEnameLN (list EnameLN)))
)
(setq DsTaluy (list LtsEnameLD LtsEnameLN))
DsTaluy
)


(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 C:VTL2 (  / Olmode Sovachngan  *Sovachngan* CDVN *CDVN*  CDDoan ObjPline1 ObjPL2 ObjPline2 VlaObjPline1 CDaiPLine1 VlaObjPline2
		   n d1 d2 LtsEnameLD LtsEnameLN Lts1 Lts2 LtsPntNgan   PntInObjPline2 PntInObjPline3 ang_1 ang_2 P3
	       )
(MakeLayer_ "TALUYN" 1)
(MakeLayer_ "TALUYD" 7)
;;;;;;;;;LUU OSNAP KHI BREAK, CANCEL, EXIT
(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 Sovachngan 1)

(or *Sovachngan* (setq *Sovachngan* 1))
(setq Sovachngan (getint (strcat "\nNhap so vach ngan giua 2 vach dai: < "
			  (rtos *Sovachngan* 2 0)
			 " > :"
		    )
	 )
)
(if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))
  
(or *CDVN* (setq *CDVN* 2.5))
(setq CDVN (getreal (strcat "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch gi\U+1EEFa c\U+00E1c v\U+1EA1ch: < "
			  (rtos *CDVN* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDVN) (setq CDVN *CDVN*) (setq *CDVN* CDVN))
(setq CDDoan (* (+ Sovachngan 1) CDVN ))


  
(setq ObjPline1 (car (entsel "\nChon duong thu nhat: ")))
(setq ObjPL2  (entsel "\nChon duong thu hai: "))
(setq ObjPline2 (car ObjPL2))
;;;(setq PickPoint (cdr ObjPL2))

(setq VlaObjPline1 (vlax-ename->vla-object ObjPline1))
(setq CDaiPLine1 (vla-get-length VlaObjPline1))


(setq VlaObjPline2 (vlax-ename->vla-object ObjPline2))
  
(setq n (fix (/ CDaiPLine1 CDDoan)))
(setq d1 0)
(setq Lts1 (list))
(setq LtsEnameLD (list))
(setq LtsEnameLN (list))
(while (< d1 CDaiPLine1)
	(progn
		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline1 d1))
		(setq d1 (+ d1 CDDoan))
	  	(setq ang_1 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Ptd))))
	  	(if (setq PntInObjPline2 (TDKDGN Ptd ObjPline2 (polar Ptd (+ ang_1 (/ pi 2) ) CDVN)))
		    (progn
	  	    	(entmake (list (cons 0 "LINE") (cons 8 "TALUYD") (cons 10  Ptd) (cons 11 PntInObjPline2)))
	  	    	(setq EnameLD (entlast))
	  		(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
	  		(setq Lts1 (append Lts1 (list Ptd)))
		    )
		)
	)
)
(setq d2 0)
(setq Lts2 (list))
(setq m (fix (/ CDaiPLine1 CDVN)))
(while (< d2 CDaiPLine1)
	(progn
		(setq Ptn_N (vlax-curve-getPointAtDist VlaObjPline1 d2))
		(setq d2 (+ d2 CDVN))
	  	(setq Lts2 (append Lts2 (list Ptn_N)))
	)
)
(setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
(foreach Pnt1 LtsPntNgan
  	(setq ang_2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Pnt1))))
  	(if (setq PntInObjPline3 (TDKDGN Pnt1 ObjPline2 (polar Pnt1 (+ ang_2 (/ pi 2) ) CDVN)))
	    (progn
	  	(setq P3 (list (/ (+ (car Pnt1) (car PntInObjPline3)) 2) (/ (+ (cadr Pnt1) (cadr PntInObjPline3)) 2)))
	  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUYN") (cons 11 P3)))
	    )
	)
)
(princ)
)





;;;HAM LAY RA CAC PHAN TU KHAC NHAU TRONG DANH SACH 1 SO VOI DANH SACH 2 (TO - CON) (LEN L1 > LEN L2)
;;;(LM:ListDifference '(1 2 3 4 5) '(2 4 6)  )
(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))
    )
  )
)


;;;;;;;;;;;;;;;acextendnone	Do not extend either object
;;;;;;;;;;;;;;;acextendthisentity	Extend obj1 to meet obj2
;;;;;;;;;;;;;;;acextendotherentity	Extend obj2 to meet obj1
;;;;;;;;;;;;;;;acextendboth	Extend both objects

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)

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

(defun TDKDGN (P1 ObjPline1 Pnt / Vla:ObjPline1   EnameXline Vla:Xline LtsPnt ) ;;;TIM DIEM KEO DAI GAN NHAT
(setq Vla:ObjPline1 (vlax-ename->vla-object ObjPline1))
(setq P2 (mapcar '- Pnt P1))
(MakeXline P1 P2)
(setq EnameXline (entlast))
(setq Vla:Xline (vlax-ename->vla-object EnameXline))
(setq LtsPnt (LM:Intersections Vla:ObjPline1  Vla:Xline acextendboth))
(entdel EnameXline)
(setq PntNear (car (vl-sort LtsPnt '(lambda(x y) (< (distance x P1) (distance y P1))))))
PntNear
)


(defun C:DCTL( / ss LtsEnameLine P1 P2  PVG1 PVG2 CDLine);;;DAO CHIEU TALUY
(setq VLA:ObjPline (vlax-ename->vla-object (car (entsel "\nChon Polyline can dao chieu Taluy:"))))
(Alert "\nQuet chon Line")
(setq ss (ssget (list (cons 0 "LINE"))))
(setq LtsEnameLine (acet-ss-to-list ss))
(setq i 0)
(foreach EnameL LtsEnameLine
	(setq P1 (acet-dxf 10 (entget EnameL)))
	(setq P2 (acet-dxf 11 (entget EnameL)))
	(if (and (setq Pgiao (last (LM:Intersections (vlax-ename->vla-object EnameL) VLA:ObjPline acextendnone ))) (equal (LineVGtPline VLA:ObjPline EnameL) 1 0.0000000001))
	    (progn
	    	(setq CDLine (vla-get-length (vlax-ename->vla-object EnameL)))
	    	(cond ((equal P1 Pgiao 0.00000001)
		      	      (progn
			    	(setq angL10 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
				(setq P2A (polar Pgiao (+ angL10 (* -1.0 (PointLeftRightPline VLA:ObjPline P2)  (/ pi 2))) CDLine))
			      	(entmod (subst (cons 11 P2A) (assoc 11 (entget EnameL)) (entget EnameL) ))
			      )
		      )
		      ((equal P2 Pgiao 0.00000001)
		      	      (progn
			    	(setq angL11 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
				(setq P1A (polar Pgiao (+ angL11 (* -1.0 (PointLeftRightPline VLA:ObjPline P1)  (/ pi 2))) CDLine))
			      	(entmod (subst (cons 10 P1A) (assoc 10 (entget EnameL)) (entget EnameL) ))
			      )
		      )
		    )
		 )
	)
)
(princ)
)


  
(defun LineVGtPline (VLA:ObjPline ObjLine / PVG Pd1 Pd2 GocP1P2  VLA:ObjPline VLA:ObjLine PntGiao );;;;XET LINE VUONG GOC VOI POLYLINE HAY KHONG?
	(setq P1 (acet-dxf 10 (entget ObjLine)))
	(setq P2 (acet-dxf 11 (entget ObjLine)))
  	(setq GocP1P2 (angle P1 P2))
  	(setq GocP2P1 (angle P2 P1))
  	(setq VLA:ObjLine (vlax-ename->vla-object ObjLine))
        (setq PntGiao (last (LM:Intersections VLA:ObjLine VLA:ObjPline acextendnone)))
  	(setq Goctaidiemgiao (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline PntGiao))))
  	(setq KQVG nil)
	(if (or (equal (+ Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001)
	        (equal (+ Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001))
	    (setq KQVG 1)
	    (setq KQVG 0)
        )
  KQVG
)


(defun PointLeftRightPline (ObjPline Pnt / PVG Pd1 Pd2);;;;XET DIEM NAM TRAI HAY PHAI PLINE
    (setq PVG (vlax-curve-getClosestPointTo ObjPline Pnt)
          Pd1 (vlax-curve-getpointAtParam ObjPline (fix (vlax-curve-getparamatPoint ObjPline PVG)))
          Pd2 (vlax-curve-getpointAtParam ObjPline (1+ (fix (vlax-curve-getparamatPoint ObjPline PVG))))
    )
    (setq Kqua nil)
    (if (or (equal (cos (+ (/ pi 2) (angle Pd1 Pd2))) (cos (angle Pnt PVG)) 0.00000001)
   	    (equal (sin (+ (/ pi 2) (angle Pd1 Pd2))) (sin (angle Pnt Pd1)) 0.00000001)
	)
        (setq Kqua -1)
        (setq Kqua 1)
    )
    Kqua
)




Hề hề hề,

Lên biên giới buôn CAD hay buôn lisp vậy bác Duân ơi????


<<

Filename: 363252_vtl_vtl2_dctl.lsp
Tác giả: tranpro
Bài viết gốc: 264655
Tên lệnh: gt
Nhờ viết lisp đo khoảng cách và ghi ra text có sẵn

(defun c:gt (/ p1 p2 txt etxt d str)

(setvar "cmdecho" 0)

(while (and (setq p1 (getpoint "\n Chon diem thu nhat"))

(setq...

>>

(defun c:gt (/ p1 p2 txt etxt d str)

(setvar "cmdecho" 0)

(while (and (setq p1 (getpoint "\n Chon diem thu nhat"))

(setq p2 (getpoint p1 "\n Chon diem thu hai "))

(setq txt (car (entsel "\n Chon text can thay" ))))

(progn

(command "undo" "begin")

(setq d (distance p1 p2) etxt (entget txt))

(setq str (strcat "\n" (cdr(assoc 1 etxt)) " + " (rtos d 2 2) " = " (rtos (+ d (atof(cdr(assoc 1 etxt)))) 2 2)))

(entmod(subst(cons 1 (rtos (+ d (atof (cdr(assoc 1 etxt)))) 2 2)) (assoc 1 etxt) etxt))

(command "change" txt "" "p" "c" 1 "")

(command "undo" "end")

(princ str)

(princ)

)

)

(setvar "cmdecho" 1)

(princ)

)

bạn thử xem đứng ý bạn không

Chỉnh sao cho nó làm trong số thì sửa thông số nào bác nhỉ, em ko dùng hàng thập phân :(


<<

Filename: 264655_gt.lsp
Tác giả: Kieu Tan
Bài viết gốc: 379864
Tên lệnh: cc
Lisp xuất chiều dài Line ra Text có sẵn và có tiền tố, hậu tố

Của anh đây ạ :

(defun c:cc (/ doituong total dtuong1 tdt dt ktext ktratext ktratext1 ktextcu textdt ktextmoi...
>>

Của anh đây ạ :

(defun c:cc (/ doituong total dtuong1 tdt dt ktext ktratext ktratext1 ktextcu textdt ktextmoi newcolor oldcolor)
   (setq doituong (ssget '((0 . "*POLYLINE"))))
   (setq total (sslength doituong))
   (setq tdt 0)
   (repeat total
         (setq total (- total 1))
         (setq dtuong1 (cdr (car (entget (ssname doituong total)))))
         (command "area" "e" dtuong1)
         (setq dt (getvar "Perimeter"))
         (setq tdt (+ tdt dt))
   )
   (setq ktext (car (entsel "chi vµo text cЗn ghi: ")))
   (setq ktratext (entget ktext))
   (setq ktratext1 (cdr (assoc 0 ktratext)))
   (if (= ktratext1 "TEXT")
       (progn
               (setq ktextcu (assoc 1 ktratext))
               (setq textdt (strcat "L= " (rtos (- tdt 0) 2 2) " m"))
               (setq ktextmoi (cons 1 textdt))
               (setq ktratext (subst ktextmoi ktextcu ktratext))
               (entmod ktratext)
               (setq color 4)
               (setq newcolor (cons 62 color))
                  (if (assoc 62 ktratext)
                      (progn
                           (setq oldcolor (assoc 62 ktratext))
                           (setq ktratext (subst newcolor oldcolor ktratext))
                           (entmod ktratext)
                      )
                      (entmod (append ktratext (list (cons 62 color))))
                   )
        )
        (alert "¤i trкi ¬i, chдn nhЗm rеi, ®г kh«ng ph¶i lµ tetx!")
   )
  (textpage)
  (graphscr)
)

Các bạn ai biết thì chỉnh giúp mình sao cho lsp khi xuất ra text luôn là 1 số chẳn(không có .00 ở phía sau). Thanks các bạn


<<

Filename: 379864_cc.lsp
Tác giả: colombus
Bài viết gốc: 338786
Tên lệnh: dtp
xin giúp đỡ lisp dời dimension text...

Thử xem:

(defun c:dtp (/ ss ename obj i txt-po delta-x delta-y sta-po end-po ang-diml xxx yyy new-po-x new-po-y...
>>

Thử xem:

(defun c:dtp (/ ss ename obj i txt-po delta-x delta-y sta-po end-po ang-diml xxx yyy new-po-x new-po-y direct)

(if (setq ss (ssget '((0 . "DIMENSION"))))

(progn (setq i -1

delta-x (getreal "\nKhoang dich Text theo chieu // dimline: ")

delta-y (getreal "\nKhoang dich Text theo chieu Vuong goc dimline: "))

(while (setq ename (ssname ss (setq i (1+ i))))

(setq obj (vlax-ename->vla-object ename))

(if (null delta-x)

(setq delta-x 0))

(if (null delta-y)

(setq delta-y 0))

(setq txt-po (cdr (assoc 11 (entget ename)))

sta-po (cdr (assoc 10 (entget ename)))

end-po (cdr (assoc 14 (entget ename)))

ang-diml (- (angle sta-po end-po) (* pi 0.5)))

(cond ((= ang-diml (* pi 0.5 -1)) (setq direct -1))

((<= ang-diml (* pi 0.5)) (setq direct 1))

((<= ang-diml (* pi 1.0)) (setq direct -1))

((<= ang-diml (* pi 1.5)) (setq direct -1))

((< ang-diml (* pi 2.0)) (setq direct 1)))

(setq xxx (* (cos ang-diml) direct)

yyy (* (sin ang-diml) direct))

(setq new-po-x (list (+ (car txt-po) (* delta-x xxx)) (+ (cadr txt-po) (* delta-x yyy)) 0.0)

new-po-y (list (- (car new-po-x) (* delta-y yyy)) (+ (cadr new-po-x) (* delta-y xxx)) 0.0))

(vla-put-textposition obj (vlax-3d-point new-po-y)))))

(princ))

(vl-load-com)

 

Vâng như thế này là rất tốt rồi bác à. Tôi xin cảm ơn sự giúp đỡ của bác.

 

Như yêu cầu của tôi ban đầu thì cũng không cần khoảng dời theo phương song song dimline . Vì thế nếu như bác bỏ cho tôi cái phần này thì tốt hơn nữa. Không chỉ là bớt đi 1 cú gõ phím "space bar" mà làm như thế sẽ đỡ bị nhầm lẫn trong thao tác vẽ.


<<

Filename: 338786_dtp.lsp
Tác giả: hhhhgggg
Bài viết gốc: 79393
Tên lệnh: hg
Lisp thay thế lệnh Replace all !!!
với text thì bạn dùng cái này

(defun C:HG ()
(vl-load-com)
(setq old_text "Cadviet"	new_text "Forum CADVIET")
(setq adoc (vla-get-activedocument...
>>
với text thì bạn dùng cái này

(defun C:HG ()
(vl-load-com)
(setq old_text "Cadviet"	new_text "Forum CADVIET")
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vlax-for lt (vla-get-layouts adoc)
(vlax-for obj (vla-get-block lt)
 (if (eq "AcDbText" (vla-get-objectname obj))
(while (vl-string-search old_text (vla-get-textstring obj))
		  (vla-put-textstring obj
		  (vl-string-subst new_text old_text (vla-get-textstring obj)))
);while
 );if
)
)
(princ)
);end

Cảm ơn bác Thái nhé . Lisp này thật đúng ý em ? Nhưng ngộ nhỡ cái chữ đó nó là Mtext thì lại ko đổi được ạ ? Bởi vì nó nằm ở nhìu nơi trong bản vẽ, Chạy xong lại mất công đi dò lại xem có thằng nào lạc loài là Mtext thì cũng hơi bất tiện !


<<

Filename: 79393_hg.lsp
Tác giả: pphung183
Bài viết gốc: 338424
Tên lệnh: dopl
Đo đường polyline

 

Nhờ mọi người giúp đỡ nên bây giờ chạy cũng tạm ổn

Đã chạy được theo

>>

 

Nhờ mọi người giúp đỡ nên bây giờ chạy cũng tạm ổn

Đã chạy được theo Dim hiện hành.

đang ngâm cứu để update khi chỉnh sửa Dim.

(defun c:dopl(/ E LA OLDOS P1 P2 PT3)
(setvar "osmode" 0)
(defun angf(d1 d2 ang) 
 (angle d1 (inters d1 (polar d1 ang 1) d2 (polar d2 (+ ang (* pi 0.5)) 1) nil))
)
(setq tyle (getvar "Dimscale"))
(setq sole (getvar "Dimdec"))
(setq kctext (* (getvar "Dimgap") tyle))
(setq keodaiddong (* (getvar "Dimexe") tyle))
(setq hchu (* (getvar "Dimtxt") tyle))
(setq tyleghi (getvar "Dimlfac"))
(setq dolonmuiten (* (* (getvar "Dimasz") tyle) 2.5))
(defun tiep (e p1 p2 pt3 / A1 A2 A3 E1 GOC H LA LEN P3 P4 P5 P6 P7 P8 PA1 PA2 PT1 V1 V2 V3)
(setvar "osmode" 0)
(setq p1 (vlax-curve-getclosestpointto e p1)
p2 (vlax-curve-getclosestpointto e p2)
pa1 (vlax-curve-getparamatpoint e p1)
pa2 (vlax-curve-getparamatpoint e p2)
v1 (vlax-curve-getfirstderiv e pa1)
v2 (vlax-curve-getfirstderiv e pa2)
len (- (vlax-curve-getdistatpoint e p2) (vlax-curve-getdistatpoint e p1))
pt1 (vlax-curve-getClosestPointTo e pt3)
h (distance pt3 pt1)
a1 (atan (/ (cadr v1) (car v1)))
a2 (atan (/ (cadr v2) (car v2)))
p3 (polar p1 (angf pt1 pt3 (+ a1 (/ pi 2))) h)
p4 (polar p2 (angf pt1 pt3 (+ a2 (/ pi 2))) h)
p5 (polar p3 (angle p1 p3) keodaiddong)
p6 (polar p4 (angle p2 p4) keodaiddong)
) 
(command "offset" h e "non" pt3 "")
(setq e1 (entlast)) 
(command "break" e1 (if (> len 0) p4 p3) (vlax-curve-getendpoint e1))
(command "break" e1 (if (> len 0) p3 p4) (vlax-curve-getstartpoint e1))
(command "change" e1 "" "p" "la" la "")
(command "line" "non" p1 "non" p5 "")
(command "line" "non" p2 "non" p6 "")
(command "QLEADER" P3 (polar p3 a1 dolonmuiten) ^C)
(command "QLEADER" P4 (polar p4 (+ a2 pi) dolonmuiten) ^C)
(if (setq p7 (vlax-curve-getpointatdist e1 (/ (abs len) 2)))
(progn
(setq v3 (vlax-curve-getfirstderiv e1 (vlax-curve-getparamatpoint e1 p7))
a3 (atan (/ (cadr v3) (car v3)))
goc (+ a3 (/ pi 2))
p8 (polar p7 goc kctext)
goc1 (- (/ (* 180 (angle p7 p8)) pi) 90)
)
(command "text" "non" "J" "C" p8 hchu goc1 (rtos (* (abs len) tyleghi) 2 sole))
(setvar "osmode" 15359) 
)
)
)
;;;
(setq oldos (getvar "osmode"))
(setvar "osmode" 15359) 
(setvar "cmdecho" 0)
(command "undo" "be")
(setq e (car (entsel "\n Chon polyline can do "))
p1 (getpoint "\n Chon diem bat dau ")
p2 (getpoint "\n Chon diem ket thuc ")
pt3 (getpoint "\n Chon diem dat ")
)
(tiep e p1 p2 pt3) (setq p1 p2)
(while (setq p2 (getpoint "\n Chon diem ket thuc ")) 
(tiep e p1 p2 pt3) (setq p1 p2)
)
(command "undo" "e")
(setvar "osmode" oldos) 
(setvar "cmdecho" 1)
(princ)
)
 

Bạn phải chú ý khi dimscale = 0 nữa, nếu không sẽ lỗi  :) 


<<

Filename: 338424_dopl.lsp
Tác giả: Tue_NV
Bài viết gốc: 57943
Tên lệnh: p
Thêm node vào đường Pline
Chào bạn AGI,

Bạn xài thử cái này coi sao. Líp này chỉ chèn thêm diểm vào pline mà chả làm thêm bất cứ động tác nào. Kín hở gì cũng vậy bạn ạ. Miễn...

>>
Chào bạn AGI,

Bạn xài thử cái này coi sao. Líp này chỉ chèn thêm diểm vào pline mà chả làm thêm bất cứ động tác nào. Kín hở gì cũng vậy bạn ạ. Miễn rằng bạn phải pick điểm chọn đúng trên pline mà thôi.

(defun c:p ()
(setq pdm (getvar "pdmode")
  ols (getvar "osmode"))
(setvar "pdmode" 3)
(setvar "osmode" 0)
(command "point" (getpoint "\n Chon diem can them"))
(setvar "pdmode" pdm) 
(setvar "osmode" ols)
(princ)
)

 

Nếu bạn muốn một lần chạy chọn nhiều điểm thì phải làm thêm một vòng lặp While nữa bạn ạ.

Ý của AGI là thêm đỉnh cho phân đoạn chứ không phải là thêm point cho Polyline bác Bình à.

Bác cứ đọc Code trên của Tue_NV thì thấy rõ ngay.

To AGI : Ý của bạn có phải là Code trên của mình chạy đúng với Polylỉne hở chứ Polyline kín thì không còn đúng nữa phải không?


<<

Filename: 57943_p.lsp
Tác giả: w1nDream
Bài viết gốc: 108247
Tên lệnh: dopl
đo đường polyline

Bạn chạy thử Lisp này xem :

Lisp đo một đoạn của Line, Pline, Arc, Circle, Spline, elipse

(defun c:dopl()
(vl-load-com)
(setq curve (car(entsel"\n Chon Polyline...
>>
Bạn chạy thử Lisp này xem :

Lisp đo một đoạn của Line, Pline, Arc, Circle, Spline, elipse

(defun c:dopl()
(vl-load-com)
(setq curve (car(entsel"\n Chon Polyline :")))
(setq ddau (getpoint"\n Pick diem dau can do :"))
(setq dcuoi (getpoint ddau"\n Pick diem dau can do :"))
(setq d1 (vlax-curve-getDistAtPoint curve ddau))
(setq d2 (vlax-curve-getDistAtPoint curve dcuoi))
(alert (strcat " L = " (rtos (abs (- d1 d2)) 2 0)))
(princ)
)

:bigsmile:

 

Pác à.Em đã dùng thử Lisp DOPL của Pác nhưng nó bị lỗi thế này không biết tại sao:

Command: DOPL

Chon Polyline :

Pick diem dau can do :

Pick diem dau can do :; error: bad argument type: numberp: nil

 

Pác xem lại hộ em vói.TKS Pác! :undecided:


<<

Filename: 108247_dopl.lsp
Tác giả: Huynh Nghia
Bài viết gốc: 407355
Tên lệnh: tt
lisp xoay text theo pline

Viết lại cho bạn:

(defun c:tt (/ FixTextAngle a ang els ent h mid p pte pts spt txt)

(defun FixTextAngle...

>>

Viết lại cho bạn:

(defun c:tt (/ FixTextAngle a ang els ent h mid p pte pts spt txt)

(defun FixTextAngle (ang)

(if (and (> ang (* 0.5 pi)) (<= ang (* 1.5 pi)))

(+ ang pi)

ang))

(while (and (setq txt (car (entsel "\nPick Text")))

(wcmatch (cdr (assoc 0 (entget txt))) "TEXT")

(setq ent (entsel "\nPick LINE, PLINE: "))

(setq els (entget (car ent)))

(wcmatch (cdr (assoc 0 els)) "*LINE"))

(setq spt (osnap (cadr ent) "NEA")

mid (osnap (cadr ent) "MID"))

(if (< (car mid) (car spt))

(setq pts mid

pte spt)

(setq pts spt

pte mid))

(setq ang (FixTextAngle (angle pts pte))

els (entget txt))

(setq h (cdr (assoc 40 els))

p (cons 10 (polar spt (+ ang (* 0.5 pi)) (* 0.5 h)))

a (cons 50 ang))

(setq els (subst a (assoc 50 els) els))

(entmod (subst p (assoc 10 els) els)))

(princ))

P/s: Chọn Text trước, Line or Pline sau:

Lsp có thể uốn cong theo spline dc không bạn ?


<<

Filename: 407355_tt.lsp
Tác giả: Hung_tthanh
Bài viết gốc: 299375
Tên lệnh: mct
Xin lệnh gán thuộc tính contents cho text

 

Bạn thử cái này, lệnh MCT:

 

(defun C:MCT( / et1 t1 et2 d2);;;Matchprop Content of Text
(setq
	et1 (car...
>>

 

Bạn thử cái này, lệnh MCT:

 

(defun C:MCT( / et1 t1 et2 d2);;;Matchprop Content of Text
(setq
	et1 (car (entsel "\nSelect Source text:"))
	t1 (assoc 1 (entget et1))
)
(redraw et1 3)
(while (setq et2 (car (entsel "\nSelect Destination text or <Exit>:")))
	(setq
		d2 (entget et2)
		d2 (subst t1 (assoc 1 d2) d2)
	)
	(entmod d2)
)
(command "regen")
(princ)
)

bạn bổ sung thêm chọn nhiều phần tử thay đổi cùng lúc luôn đi, hiện giờ chỉ pick từng text 1 thôi...


<<

Filename: 299375_mct.lsp
Tác giả: gia_bach
Bài viết gốc: 100353
Tên lệnh: rb
Viết lisp theo yêu cầu [phần 2]
(defun c:RB (/ SS NAME NNAME)
 (setq SS (ssget "I"))
 (if (not SS)
(progn
  (prompt "- Select block for rename")
  (setq SS (ssget '((0 . "insert"))))
  );progn
);if
(setq NAME (cdr...
>>
(defun c:RB (/ SS NAME NNAME)
 (setq SS (ssget "I"))
 (if (not SS)
(progn
  (prompt "- Select block for rename")
  (setq SS (ssget '((0 . "insert"))))
  );progn
);if
(setq NAME (cdr (assoc 2 (entget (ssname SS 0)))))
(setq NNAME(getstring (strcat "\nCurrent block name: " NAME "\nEnter new name:")))
(command "-rename" "B" NAME NNAME)
 (princ)
 );end

Nếu cần ngay thì bạn dùng tạm code này. mình không có thời gian làm hộp thoại cho bạn.

Để tránh t/hợp chọn nhiều Block nhưng chỉ đổi đuợc tên 1 Block (đôi khi không đúng tên Block muốn đổi), bạn thay dòng :

(setq SS (ssget '((0 . "insert"))))

bằng : (while (not(setq ss (ssget "+.:S:N" (list (cons 0 "INSERT"))))))

 

 

Tôi cần 1 LISP đổi tên block với yêu cầu sau:

- chạy LISP

- chọn block cần đổi tên

- nhập tên mới

 

(Trong AutoCAD đã có lệnh REN nhưng không cho mình chọn block muốn đổi tên, mà phải tìm tên của nó trước rồi mới vô đó tìm trong 1 đống tên :cheers:, đối với file có nhiều block tên dạng như A$12345678 thì :blink:bó tay ).

 

Tôi cũng có viết 1 VBA tương tự (nhưng nó load vô phức tạp hơn lisp) nên muốn nhờ cao thủ chuyển sang LISP dùm. Với lại CAD sau này ko tích hợp sẵn VBA như trước nữa mà phải tự cài thêm nên muốn chuyển cho máy khác cũng hơi phê. Thêm phần FORM cho nó nữa thì càng tốt :cheers:. (Mới tập tành viết VBA nên có nhiều lỗi nhưng đc cái thực hiện đúng ý đồ của mình, mong chỉ giáo :D)

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

Gửi bạn Lisp đổi tên Block.blkre.jpg

 

file : download

bao gồm :

- File BlockRename.LSPBlockRename.dcl để "ngâm cứu"

- file BlockRename.vlx (chỉ cần load và run).


<<

Filename: 100353_rb.lsp
Tác giả: hoangnam2017
Bài viết gốc: 418536
Tên lệnh: ha
Vẽ Một Hình Tứ Giác Khi Đã Biết Chiều Dài 4 Cạnh Và Diện Tích.

 

Đây là 1 bài toán đưa đến việc phải giải 1 phương trình bậc cao >> cách giải gần đúng là chấp nhận được...

>>

 

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

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

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

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

Cad đây:

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

Lisp đây:

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

 

Cảm ơn bác, Nhưng hình bác đưa ra không phải hình em cần vẽ ạ. Hình của em giống ở bài #14 ạ


<<

Filename: 418536_ha.lsp

Trang 238/301

238