- page 150

Info

File

Tác giả: VoHoan
Bài viết gốc: 276965
Tên lệnh: keo

?Be sure to clean your hands using an anti-bacterial soap.

Cảm ơm quansla đã có ý kiến giúp mình. Nhưng bạn chưa hiểu rõ ý mình muốn diễn đạt. Ở đây mình muốn kéo điểm B về điểm C (trong đó AB đã có, điểm C đã xác định được) mà vẫn giữ nguyên đối tượng là đoạn thẳng AB, chứ không phải tạo ra AB bằng lệnh "LINE" nữa. Mục đích vì AB là đối...

Cái mình vướng ở đây là thao tác "KÉO" điểm B về điểm C. Thao tác trên Cad là chọn đoạn thẳng AB sau đó pick vào điểm B kéo nó về C. Việc này viết trên lisp mình không thực hiện được.

Mình có 2 giải pháp nhưng không khả thi lắm như sau:

1. Dùng lệnh "STRETCH" để kéo, nhưng nhựơc điểm là nếu trên bản vẽ chỉ có đoạn AB thì dễ làm được, còn có nhiều đối tượng nằm gần AB thì không được vì ảnh hướng đến nhiều đối tượng khác.

2. Dùng hàm "ENTMOD" để thay đổi mã DXF của giá trị (10 X Y) của (ENTGET AB) thì làm được với điều kiện AB chỉ có >=2 đỉnh thì được. Nếu nhiều hơn 2 đỉnh thì trong (ENTGET AB) có nhiều giá trị (10 X Y) khó tìm để thay đổi được.

MÌnh đã viết được lisp sửa trắc ngang dùng theo cách thứ 2 nhưng chưa ưng ý. Ai có cách gì hay hơn chỉ ra giúp mình nhé:

(defun C:keo ( / SS P P2 P3 PTL Pmep TR1 TR2 PH1 PH2 SSM SSL SSTL SSTN SSR S1 S2 S3 S4 S5
                 i KT SR ent layer P10 XP10 YP10 K11 P11 ob1 ob2 kq g)
(setvar "CMDECHO" 0)
(setvar "osmode" 0) 
(princ "\nChon trac ngang")
(setq	SS (ssget '((0 . "LWPOLYLINE") (8 . "Lop2")) ))
(setq	S (ssname SS 0)
	P2 (vlax-curve-getPointAtParam S 1)
	P3 (vlax-curve-getPointAtParam S 3)
)
(setq	TR1 (polar P2 (/ pi 4) 3.5)
	TR2 (polar P2 (/ pi 4) -3.5)
	PH1 (polar P3 (/ pi 4) 3.5)
	PH2 (polar P3 (/ pi 4) -3.5)
)
(matduong TR1 TR2 P2)
(matduong PH1 PH2 P3)
)


;**************Xu ly tung mat duong*********************
(defun Matduong (W1 W2 Mep)
(setq	SSM (ssget "C" W1 W2 '( (8 . "Mat duong 1")) )
	SSL (ssget "C" W1 W2 '( (8 . "Le KGC")) )
	SSTL (ssget "C" W1 W2 '( (8 . "Taluy")) )
	SSTN (ssget "C" W1 W2 '( (8 . "plinetntn")) )
	SSR (ssget "C" W1 W2)
)
(setq	S1 (ssname SSM 0)
	P (vlax-curve-getPointAtParam S1 1)
)
(setq	S2 (ssname SSL 0)
	S3 (ssname SSTL 0)
	S4 (ssname SSTN 0)
	i 0
	Kt 0
)
(repeat (sslength SSR)
  (setq	SR (ssname SSR i)
	ent (assoc 8 (entget SR))
	layer (cdr ent)
	i (+ i 1)
  )
  (if	(= layer "Ranh") 
	(progn
		(setq KT 1)
		(Setq S5 SR)
	)
  )
)

(if (= Kt 1) (command "MOVE" S2 S3 S5 "" P Mep) (command "MOVE" S2 S3 "" P Mep))

;Xu ly list duong mat duong
(Keodiem S1 Mep)

;Xu ly list duong taluy
(setq PTL (car (GiaoDT S3 S4)))
(keodiem S3 PTL)

)

;********************Keo diem doan thang**********************
(defun Keodiem (SDT PDT)
(setq	ent (entget SDT)
	P10 (assoc 10 ent)
	XP10 (cadr P10)
	YP10 (caddr P10)
	K11 (list 11 XP10 YP10)
	P11 (list 10 XP10 YP10)
	ent (subst K11 P10 ent)

)
(setq	P10 (assoc 10 ent)
	XP10 (car PDT)
	YP10 (cadr PDT)
	K10 (list 10 XP10 YP10)
	ent (subst K10 P10 ent)
	K11 (assoc 11 ent)
	ent (subst P11 K11 ent)
)
(entmod ent)
)

;********************Tim giao diem*******************
(defun GiaoDT (ent1 ent2)
(setq	ob1 (vlax-ename->vla-object ent1)
	ob2 (vlax-ename->vla-object ent2)
)
(setq	g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)) )
(if	(/= (vlax-safearray-get-u-bound g 1) -1)
	(setq g (vlax-safearray->list g))
	(setq g nil)
)
(if	g
	(progn
		(setq	kq nil 
			sd (fix (/ (length g) 3))
		)
		(repeat sd
			(setq	kq (append kq (list (list (car g) (cadr g) (caddr g))))
				g (cdddr g)
			)
		)
		kq
	)
		nil
)
)

Download lisp

Filename: 276965_keo.lsp

Tác giả: doanduyhung
Bài viết gốc: 277121
Tên lệnh: taovungpolylinekin

Nhờ viết Lisp Hatch vùng kín của các đối tượng giao nhau.

Mọi người test nhé

(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))
      ...
>>

Mọi người test nhé

(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:SubstNth ( a n l / i )
    (setq i -1)
    (mapcar '(lambda ( x ) (if (= (setq i (1+ i)) n) a x)) l)
)
(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 entmakex-hatchvatlieu (Lsp layer mau kihieuhatch)  
 (entmakex
  (apply 'append
   (list (list '(0 . "HATCH")
	       '(100 . "AcDbEntity")
	       '(410 . "Model")
	       '(100 . "AcDbHatch")
	       '(10 0.0 0.0 0.0)
	       '(210 0.0 0.0 1.0)
	       (cons 2 kihieuhatch)
	       '(70 . 1)
	       '(71 . 0)
	       (cons 91 (length Lsp))
	       (cons 8 layer)
	       (cons 62 mau)
	       )
	 (apply 'append
		(mapcar '(lambda (a)
			   (apply 'append
				  (list (list '(92 . 7) '(72 . 0) '(73 . 1) (cons 93 (length a)))
					(mapcar '(lambda (b) (cons 10 b)) a)
					'((97 . 0))))) Lsp))
	 '((75 . 0)
	   (76 . 1)
	   (47 . 1.)
	   (98 . 2)
	   (10 0. 0. 0.0)
	   (10 0. 0. 0.0)
	   (451 . 0)
	   (460 . 0.0)
	   (461 . 0.0)
	   (452 . 1)
	   (462 . 1.0)
	   (453 . 2)
	   (463 . 0.0)
	   (463 . 1.0)
	   (470 . "LINEAR")
	   )
	 )
	 )
  )
)
(defun create_layer (Layer  Color)
  (if (not (tblsearch "Layer" Layer))
    (entmakex
      (list
	(cons 0 "LAYER")
	(cons 100 "AcDbSymbolTableRecord")
	(cons 100 "AcDbLayerTableRecord")
	(cons 70 0)
	(cons 2 Layer)
	(cons 62 Color)
	)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:taovungpolylinekin(/)
  (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
      (create_layer "PoLyline Tao Vung Kin" 3)      
      (setq lsplinepolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(setq lsplinepolyline (append lsplinepolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i) 1e-3))))	
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonlinepolyline))
      (setq i 0)
      (foreach lsptungline lsplinepolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsptungline (DDH:pointtolsppoint diemgiao lsptungline))
	  )
	(setq lsplinepolyline (LM:SubstNth lsptungline i lsplinepolyline))
	(setq i (+ i 1))
	)
      (setq lsptongline nil)
      (foreach lsptunglinepolyline lsplinepolyline
	(setq i 0)
	(repeat (- (length lsptunglinepolyline) 1)
	  (entmakex (list  '(0 . "LINE")
			   (cons 10 (list (car (nth i lsptunglinepolyline)) (cadr (nth i lsptunglinepolyline))))
			   (cons 11 (list (car (nth (+ i 1) lsptunglinepolyline)) (cadr (nth (+ i 1) lsptunglinepolyline))))
			   ))
	  (setq lsptongline (append lsptongline (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 lsptongline))
	(progn
	  (foreach lsptungline lsptongline
	    (entdel (vlax-vla-object->ename lsptungline))
	    )
	  (setq lsppolylinetong nil)
	  (foreach tungregion lsptongregion
	    (command "explode" (vlax-vla-object->ename tungregion) "")
	    (command "PEDIT" "m" (ssget "p") "" "y" "j" "0.00001" "")
	    (setq lspdoi (entget (entlast)))
	    (entmod (subst (cons 8 "PoLyline Tao Vung Kin") (assoc 8 lspdoi) lspdoi))
	    (setq lsppolylinetong (append lsppolylinetong (list (list (entlast) (vlax-curve-getarea (entlast))))))
	    )
	  (setq lsppolylinetong (vl-sort lsppolylinetong (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lsppolylinetong)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lsppolylinetong)) dientichtong)) 0.0001)
	    (entdel (car (car lsppolylinetong)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lsppolylinetong)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (entmakex-hatchvatlieu (list (cdr (ACET-GEOM-OBJECT-POINT-LIST (car xetpl) 1e-3))) "PoLyline Tao Vung Kin" mau "SLOID")
	    (setq mau (+ mau 12))
	    )
	  
	  )
	)
      )
    )
  )

Download lisp

Filename: 277121_taovungpolylinekin.lsp

Tác giả: hiepttr
Bài viết gốc: 277207
Tên lệnh: ib viet

Chương 6 : Bài Tập

Ôi gần tết xây dựng mình bận quá.

- Về khả năng code có lẽ hiepttr đã dư sức qua lớp Cơ bản này rồi. Vì bạn chịu khó tham gia các topic liên quan, vượt xa Ket rồi ^^

- Các bài nói chung khá ổn, mình chỉ nêu 1 số điều để bạn hiepttr tham khảo :

1 : Giai thừa : n > 17 ?

2,3,4 :...
>>

Ôi gần tết xây dựng mình bận quá.

- Về khả năng code có lẽ hiepttr đã dư sức qua lớp Cơ bản này rồi. Vì bạn chịu khó tham gia các topic liên quan, vượt xa Ket rồi ^^

- Các bài nói chung khá ổn, mình chỉ nêu 1 số điều để bạn hiepttr tham khảo :

1 : Giai thừa : n > 17 ?

2,3,4 : tốt

Các bài còn lại : hàm lấy giá trị mặc định có thể viết 1 lần. Theo yêu cầu của bài toán thì nên viết 1 hàm con, và hàm này chỉ nên dùng cho các trường hợp Get mà bài toán trong BT đưa ra

- Dùng command với Tẽxt ngoài chú ý về Osmode còn cần chú ý về Chiều cao textstyle khác 0 hay không, từ đó mà gán vào dòng command cho phù hợp.

- Do đang học chương vòng lặp, nhưng bạn cũng hoàn toàn có quyền kiến nghị các cách khác để hoàn thành đầu bài (nếu bạn có hứng thú, ví dụ array, đệ quy ...)

- Đã fix lỗi n!

- update cho BT5 thêm tính năng chọn block

- Đã viết hàm con (nhan_gia_tri)

- Đã sửa sai về cách dùng command đối với text khi h=;/= 0

- Đã thử sửa bài 7;8 theo hướng Array ---> vướng: Hàm command: -ARRAY mình ko biết cách đặt tùy chọn Angle of array ở chổ nào ?!

- Thuật toán đệ quy, mình chỉ hiểu sơ sơ, vẫn chưa biết ứng dụng vào code ntn ?!

Mong đc chỉ bảo thêm !

Bài đc sửa lại:

;;;Bai1: Ham tinh n!
(defun gt(n / gt)
	(cond 
		((> n 0)
		(setq gt (* n 1.0))
		(while (> n 1)
			(setq gt (* gt (- n 1))
				n (- n 1)
			)
		)
		gt
		)
		(t (setq gt 1))
	)
)
;;;---------------------------------------------------------
;;;Bai2: Ham in lan luot cac ky tu cua mot chuoi ra man hinh, moi ky tu mot dong:
;DA XONG
;;;----------------------------------------------------------
;;;Bai3: Ham tach chuoi thanh list cac ky tu: "ABC" ---> '("A" "B" "C")
;DA XONG
;;;----------------------------------------------------------
;;;Bai4: Viet lai bai 5.5 (chuong5) bang vong lap
;DA XONG
;;;--------------------------------------------------------------------------------------------------
;;;Bai5:Chen mot block lien tiep tai cac vi tri nguoi dung pick chuot.
;;; ti le, goc nghieng da dc chi dinh truoc do & luu lai cho lan sau:
(defun c:ib( / lst_va old b_name ent key)
;insert block
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE" "AUNITS"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 0 0 0))
(initget 1 "Nhapten pickChonblock _A B")
(setq key (getkword "\nTuy chon < Nhapten	pickChonblock >: "))
(cond 
	((= key "A")
		(if (and (setq b_name (getstring "\nNhap ten block se chen: " T))
				(tblsearch "block" b_name)
			)
			(progn
				;;ti le:
				(setq #scale (nhan_gia_tri #scale 1.0 getreal "Nhap ti le scale block"))
				;;end_ ti le
				;;goc nghieng:
				(setq #ang (nhan_gia_tri #ang 0.0 getreal "Nhap goc nghieng block (degree)"))
				;;end_ goc nghieng
				(while (setq pt (getpoint "\nPick: "))
					(command "-insert" b_name pt #scale "" #ang)
				) ;end_while
			)
			(princ (strcat "\n*** Block " b_name " khong ton tai ***"))
		)
	)
	((= key "B")
		(prompt "\nChon block: ")
		(while (or (null ent) (/= (cdr (assoc 0 (entget ent))) "INSERT")) (setq ent (car (entsel))))
		(setq b_name (cdr (assoc 2 (entget ent))))
		(progn
			;;ti le:
			(setq #scale (nhan_gia_tri #scale 1.0 getreal "Nhap ti le scale block"))
			;;goc nghieng:
			(setq #ang (nhan_gia_tri #ang 0.0 getreal "Nhap goc nghieng block (degree)"))
			(while (setq pt (getpoint "\nPick: "))
				(command "-insert" b_name pt #scale "" #ang)
			) ;while
		)
	)
)
(mapcar 'setvar lst_va old)
(princ)
)
;;;----------------------------------------------------------------------------------------------------
;;;Bai6: Viet len man hinh chuoi cac so tang dan
;cac chi so: so bat dau, so luong, gia so, goc nghieng, chieu cao chu, khoang cach dc luu lai cho lan sau:
(defun c:VIET( / pt lst_va old info start1 old_hg)
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE" "AUNITS"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 0 0 0))
(if (setq pt (getpoint "\nPick diem chen: "))
	(progn
		;;so bat dau:
		(setq #start (nhan_gia_tri #start 2.0 getreal "Nhap so bat dau") start1 #start)
		;;so luong:
		(setq #num (nhan_gia_tri #num 4 getint "Nhap so luong"))
		;;gia so:
		(setq #d (nhan_gia_tri #d 2.0 getreal "Nhap gia so"))
		;;goc nghieng:
		(setq #ang1 (nhan_gia_tri #ang1 0 getreal "Nhap goc nghieng"))
		;;chieu cao chu:
		(setq #h (nhan_gia_tri #h 2.0 getreal "Nhap cao chu"))
		;;khoang cach:
		(setq #dist (nhan_gia_tri #dist 2.0 getreal "Nhap khoang cach"))
		;;;;;;;;;;;;;;;
		;;;;;;;;;;;;;;;
		(if (= 0 (cdr (assoc 40 (setq info (entget (tblobjname "Style" (getvar 'TEXTSTYLE)))))))
			(repeat #num
				(command ".text" pt #h 0 (rtos start1 2 1))
				(setq pt (polar pt (/ (* pi #ang1) 180) #dist)
					start1 (+ #d start1))
			)
			(progn
				(entmod (subst (cons 40 #h) (setq old_hg (assoc 40 info)) info))
				(repeat #num
					(command ".text" pt 0 (rtos start1 2 1))
					(setq pt (polar pt (/ (* pi #ang1) 180) #dist)
						start1 (+ #d start1))
				)
				(entmod (subst old_hg (assoc 40 info) info))
			)
		)
	)
)
(mapcar 'setvar lst_va old)
(princ)
)
;;======================================
(defun NHAN_GIA_TRI(a mac_dinh ham str_nhac / modul)
(or a (setq a mac_dinh))
(setq a (cond
    ((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
    (modul)
    (a)
    )
    )
)
;;;;;;;;;;;;;;;

Download lisp

Filename: 277207_ib_viet.lsp

Tác giả: doanduyhung
Bài viết gốc: 277211
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 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...
>>

mình up lại đây

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))
	    )
	  
	  )
	)
      )
    )
  )

Download lisp

Filename: 277211_hatchkin.lsp

Tác giả: namnhim
Bài viết gốc: 277266
Tên lệnh: dimarc

Hỏi cách DIM nhanh!

bạn dùng thử cái này xem có được không

(defun C:DIMARC ( / pt1 pt2 cen a1 a2 D1 D2 p r oldOs)
 (setq oldOs (getvar "OSMODE"))
 (prompt "Pick 2 points on an arc - ")
 (setvar "OSMODE" 512)
 (while (not cen)
  (setq   pt1 (getpoint "1st pt: ")
   cen (osnap pt1 "_CEN")
  )
  (if (not cen) (alert "Doesn't lie on an arc, retry")
      (setq pt2 (getpoint cen " 2nd pt: ")))
 );while

 (setvar "OSMODE" 0)
 (setq a1 (angle cen pt1) a2 (angle cen...
>>

bạn dùng thử cái này xem có được không

(defun C:DIMARC ( / pt1 pt2 cen a1 a2 D1 D2 p r oldOs)
 (setq oldOs (getvar "OSMODE"))
 (prompt "Pick 2 points on an arc - ")
 (setvar "OSMODE" 512)
 (while (not cen)
  (setq   pt1 (getpoint "1st pt: ")
   cen (osnap pt1 "_CEN")
  )
  (if (not cen) (alert "Doesn't lie on an arc, retry")
      (setq pt2 (getpoint cen " 2nd pt: ")))
 );while

 (setvar "OSMODE" 0)
 (setq a1 (angle cen pt1) a2 (angle cen pt2) ad (abs (- a2 a1))
   r (distance pt1 cen)
   D1 (* r ad)
   D2 (* r (- (* 2 pi) ad))
 )
 (prompt (strcat "\nArc length: " (rtos D1) ",   complementar arc: " (rtos D2))) 

 (command "_DIMANGULAR" "" cen pt1 pt2 "_T" (rtos D1) pause)

 (setvar "OSMODE" oldOs)
 (prin1)
)

(princ "\nDIMARC command loaded.")
(princ)

Download lisp

Filename: 277266_dimarc.lsp

Tác giả: doanduyhung
Bài viết gốc: 277410
Tên lệnh: hatchkin

Nhờ viết Lisp Hatch vùng kín của các đối tượng giao nhau.

Hi bạn:

Em dùng lisp trên với bản Cad sau lại ko được bác DoanDuyHung ah. Em rất hay phải hatch với những đối tượng giao với đường mặt đất tự nhiên màu tím như trong hình sau. Mặc dù em đã Extend hết để cho các đối tượng giao cắt với nhau mà vẫn ko thể Hatch được. Mong bác và diễn đàn tìm cách giúp đỡ em với nhé. Em xin chân thành cảm ơn ạ :)

Hi bạn:

http://www.cadviet.com/upfiles/3/64997_test_hatchkin.dwg

hi bạn

- 2 cái hình trong khung lần 1 đối tượng màu đỏ không giao với đường đứng màu vàng nên chỉ hatch được các phần còn lại

- 2 cái hình trong khung lần 2 thì hatch được hết.

(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 LM:Uniqueline ( l )
  (if l (cons (car l)
	      (LM:Uniqueline
		(vl-remove-if '(lambda (x) (or (and (equal (car x) (car (car l)))
						    (equal (cadr x) (cadr (car l))))
					       (and (equal (car x) (cadr (car l)))
						    (equal (cadr x) (car (car l))))
					       )
				 ) (cdr l))
		))))
(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)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
	  (setq i (+ i 1))
	  )
	)
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
	(entmakex (list '(0 . "LINE")
			(cons 10 (car line))
			(cons 11 (cadr line))
			))
	(ssadd (entlast) chonline)
	(setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	)
      (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))
	    )
	  
	  )
	)
      )
    )
  )

Download lisp

Filename: 277410_hatchkin.lsp

Tác giả: Doan Van Ha
Bài viết gốc: 277499
Tên lệnh: ha

Nhờ viết lisp phát hiện kích thước đã bị thay đổi

Lisp thay đổi Dim Overrive theo kiểu Find and Replace "gần giống" trong Word đây.

(defun C:HA( / VPCords pllur lst key)

(defun VPCords()

((lambda (offset) ((lambda (viewctr) (list (mapcar '- viewctr offset) (mapcar '+ viewctr offset))) (getvar "viewctr")))

((lambda (halfHeight aspectRatio) (list (* halfHeight aspectRatio) halfHeight))

(* 0.5 (getvar "viewsize"))

(apply '/ (getvar...

Download lisp

Filename: 277499_ha.lsp

Tác giả: Doan Van Ha
Bài viết gốc: 277539
Tên lệnh: ha ha1

Nhờ viết lisp phát hiện kích thước đã bị thay đổi

1). Sửa lisp để zoom 2 lần bounding box entity cho dễ nhìn.

2). Bổ sung thêm lệnh HA1 chỉ để dùng cho việc convert từng dim (vì không hiểu tại sao lại lỗi).

;; Doan Van Ha - CadViet.com - 16/01/2014

;; Lisp thay doi Dim Override gan giong Find and Replace trong Word. Co 2 option: All or Individually

(defun C:HA( / VPCords pllur lst key p1 p2 p11 p22)

(defun VPCords()

((lambda...

Download lisp

Filename: 277539_ha_ha1.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 273707
Tên lệnh: csp

Thay đổi StartPoint của polyline

Uhm. Để mình xem lại thế nào. Thank bạn.

Hề hề hề,

Đây là cái lisp mình viết nháp, chưa hiệu chỉnh kỹ. Bạn có thể tham khảo cách đổi startpoint trong lisp để chuyển sang vb.net cho phù hợp. Lisp này chỉ làm việc với polyline kín vì nều polyline hở thì việc đổi điểm startpoint chỉ là...

Download lisp

Filename: 273707_csp.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 277811
Tên lệnh: csp

Thay đổi StartPoint của polyline

@phamthanhbinh

Bác chỉnh giúp e lisp chọn điểm start point của polyline bằng cách pick điểm nhé

E đang cần lấy toạ độ đỉnh của polyline mà thứ tự kết quả ko được như ý muốn, thanks

Hề hề hề,

Hãy dùng thủ cái ni coi đã ưng ý chưa nghen.

Download lisp

Filename: 277811_csp.lsp

Tác giả: doanduyhung
Bài viết gốc: 277827
Tên lệnh: fixline hatchkin

Nhờ viết Lisp Hatch vùng kín của các đối tượng giao nhau.

Em sửa được rồi. Tuyệt quá. Ko biết bác có cách nào để khắc phục vấn đề những chỗ hở 1 chút thì ko hatch được ko ah?
Vì hình như khi Hatch cũng có tùy chọn để ta hatch những hình bị hở đúng ko nhỉ? Nếu giải quyết thêm được vấn đề này thì tuyệt quá.

Không biết phải làm sao để cám ơn các...
>>

Em sửa được rồi. Tuyệt quá. Ko biết bác có cách nào để khắc phục vấn đề những chỗ hở 1 chút thì ko hatch được ko ah?
Vì hình như khi Hatch cũng có tùy chọn để ta hatch những hình bị hở đúng ko nhỉ? Nếu giải quyết thêm được vấn đề này thì tuyệt quá.

Không biết phải làm sao để cám ơn các bác trên diễn đàn. Em xin gửi lời cám ơn chân thành tới các bá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 LM:IntersectionsInSetboth ( 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 acextendboth) 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 LM:Uniqueline ( l )
  (if l (cons (car l)
	      (LM:Uniqueline
		(vl-remove-if '(lambda (x) (or (and (equal (car x) (car (car l)))
						    (equal (cadr x) (cadr (car l))))
					       (and (equal (car x) (cadr (car l)))
						    (equal (cadr x) (car (car l))))
					       )
				 ) (cdr l))
		))))
(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:fixline(/)
  (setq khoangfix (getreal "\nNhap Khang Cach Max De Xet Fix Doi Tuong <1.00>:"))
  (if (= khoangfix nil)
    (setq khoangfix 1.00)
    )		       
  (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 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 i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSetboth chonpolyline))
      (setq i 0)
      (repeat (sslength chonpolyline)
	(setq toado (ACET-GEOM-OBJECT-POINT-LIST (ssname chonpolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonpolyline i) (vlax-curve-getendparam (ssname chonpolyline i)))
			  10000)))      
	(foreach diemgiao lspgiaodiem
	  (if (and (<= (distance (car toado) diemgiao) khoangfix)
		   (> (distance (car toado) diemgiao) 0.001))
	    (entmakex (list '(0 . "LINE")
			(cons 10 (car toado))
			(cons 11 diemgiao)
			))
	    )
	  )
	(foreach diemgiao lspgiaodiem
	  (if (and (<= (distance (last toado) diemgiao) khoangfix)
		   (> (distance (last toado) diemgiao) 0.001))
	    (entmakex (list '(0 . "LINE")
			(cons 10 (last toado))
			(cons 11 diemgiao)
			))
	    )
	  )
	(entdel (ssname chonpolyline i))
	(setq i (+ i 1))
	)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
	  (setq i (+ i 1))
	  )
	)
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
	(entmakex (list '(0 . "LINE")
			(cons 10 (car line))
			(cons 11 (cadr line))
			))
	(ssadd (entlast) chonline)
	(setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	)
      (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) "")
	    (entdel (car xetpl))
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )	  
	  )
	)
      )
    )
  )

thực hiện lệnh fixline để đóng những khoảng hở trước

Download lisp

Filename: 277827_fixline_hatchkin.lsp

Tác giả: nguyentuyen6
Bài viết gốc: 105232
Tên lệnh: vecot

Viết lisp theo yêu cầu [phần 2]

Cảm ơn bạn nhe. Mình đã sửa được rồi.

Mình cũng sửa lại lisp như sau (có thêm 1 tý ):

cho mình hỏi thêm là:

Ca^u 1:

Khi viết:

(defun VeCot ( A B C / p2 p3 p4 p5 p6 p7 p8 p9 p10 p61 p71 p81 p91 p101 OldOs)

Thi` A B C nó tự nhận lần lượt 3 tham số của đoạn này ah:

(defun NhapSoLieu()

(setq
;;...

Download lisp

Filename: 105232_vecot.lsp

Tác giả: ndtnv
Bài viết gốc: 278050
Tên lệnh: hatchkin

Nhờ viết Lisp Hatch vùng kín của các đối tượng giao nhau.

Vì không có nhiều thời gian nên tôi viết tạm phần xử lý REGION tổng. Chương trình chạy hơi chậm vì xử lý các REGION

- Thêm hàm FiltReg : Lọc REGION tổng

- Sửa lại c:hatchkin

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

Vì không có nhiều thời gian nên tôi viết tạm phần xử lý REGION tổng. Chương trình chạy hơi chậm vì xử lý các REGION

- Thêm hàm FiltReg : Lọc REGION tổng

- Sửa lại c:hatchkin

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

(defun FiltReg (rg / el i j n r rt ss)
    (setq i -1 n (1- (length rg)) el (entlast))
    (repeat n
        (setq i (1+ i) j n r nil)
        (while (and (not r) (> j i))
            (setq ss (ssadd))
            (vla-copy (vlax-ename->vla-object(car(nth i rg))))
            (setq ss (ssadd (entlast) ss))
            (vla-copy (vlax-ename->vla-object(car(nth j rg))))
            (setq ss (ssadd (entlast) ss))
            (vl-cmdf "INTERSECT" ss "")
            (if (not (eq el (entlast)))
                (progn
                    (setq r (nth i rg))
                    (setq rt (append rt (list r)))
                    (entdel (entlast)))
            )
            (setq j (1- j))
        )
    )
    rt
)

(defun c:hatchkin(/)
  (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)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
    (foreach diemgiao lspgiaodiem
      (setq lsp (DDH:pointtolsppoint diemgiao lsp))
      )
    (setq i 0)
    (repeat (- (length lsp) 1)
      (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
      (setq i (+ i 1))
      )
    )
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
    (entmakex (list '(0 . "LINE")
            (cons 10 (car line))
            (cons 11 (cadr line))
            ))
    (ssadd (entlast) chonline)
    (setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
    )
      (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 rt (FiltReg lspxetbien))
      (foreach r rt
            (setq lspxetbien (vl-remove r lspxetbien))
        (entdel (car r))
      )
;;;      (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 0)
      (foreach xetpl lspxetbien
            (setq mau (1+ (rem mau 255)))
        (command "hatch" "" "" "" (car xetpl) "")
        (entdel (car xetpl))
        (command "change" (entlast) "" "p" "c" mau "")
        )
      )
    )
      )
    )
  )

Download lisp

Filename: 278050_hatchkin.lsp

Tác giả: namnhim
Bài viết gốc: 278095
Tên lệnh: gbv

INSERT ĐỐI TƯỢNG TRONG THƯ VIỆN

ogoplex dangers Sloan, an engineer for Titan Salvage, said experts would have one chance to pull the ship upright and float it away to the mainland for demolition. The attempt will probably take place in mid-September. If it fails, he said, there won"t be a second chance.
promescent over the counter ...

Download lisp

Filename: 278095_gbv.lsp

Tác giả: gia_bach
Bài viết gốc: 278126
Tên lệnh: edittext

Thay đổi Text trong Block (Text không phải thuộc tính)

Hi anh em,

Mình có một Block có chứa một chuỗi Text (Text này không phải là Attribute nhé). Vậy có lisp nào có thể thay đổi nội dụng của Text này hay ko nhỉ? (Cách làm tay thì mình đã biết, nhưng do số lượng bản vẽ chứa Block n ày n hiều nên mình muốn tự động công việc này)

Nếu được xin ội người...
>>

Hi anh em,

Mình có một Block có chứa một chuỗi Text (Text này không phải là Attribute nhé). Vậy có lisp nào có thể thay đổi nội dụng của Text này hay ko nhỉ? (Cách làm tay thì mình đã biết, nhưng do số lượng bản vẽ chứa Block n ày n hiều nên mình muốn tự động công việc này)

Nếu được xin ội người giúp đỡ nhé.

Thanks so much!

Lisp EditText sử dụng cho :

- Text và MText

- Text trong Dim

- Text trong block (thay đổi tất cả Text của block có trong bản vẽ)

- Text trong block attribute

(defun c:EditText ( / doc e obj str)
  ;; By : Gia_Bach 2014  
  (vl-load-com) 
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (while (setq e (car (nentsel)))
    (if (and
	  (wcmatch (vla-get-ObjectName (setq obj(vlax-ename->vla-object e))) "*Text,*Attribute")
	  (setq str (getstring (strcat "Input new value <" (vla-get-TextString obj) "> : "))))
      (progn
	(vla-StartUndoMark doc)
	(vla-put-TextString obj str)
	(vla-regen (vla-get-ActiveDocument (vlax-get-acad-object)) acAllViewports)
	(vla-EndUndoMark doc)  )))
  (princ))

Download lisp

Filename: 278126_edittext.lsp

Tác giả: Doan Van Ha
Bài viết gốc: 278154
Tên lệnh: ha

Đố vui với LISP

Trước khi chuẩn bị nghỉ Tết, mời các bạn tham gia câu đố này cho vui.

Xem lisp dưới đây, dùng để tính tổng của 2 số.

Ví dụ:

Nhap so thu 1: >> bạn nhập là 1.2

Nhap so thu 2: >> bạn nhập là 3.4

Nhap tong so: >> bạn phải nhập là 4.6 - vì 4.6 là tổng của 1.2 và 3.4

Khi đó sẽ có thông báo "Ket qua nay la dung!" - Điều này ai mà không biết - Và làm sao...

Download lisp

Filename: 278154_ha.lsp

Tác giả: gia_bach
Bài viết gốc: 278204
Tên lệnh: merla

Auto merge layer

Thanks bác Tue_NV

Mình chưa nghĩ đến cái vụ linetype của layer. Mình chỉnh lại yêu cầu một chút

- Bước 1: Lisp yêu cầu người dùng chọn layer gốc

>>

Thanks bác Tue_NV

Mình chưa nghĩ đến cái vụ linetype của layer. Mình chỉnh lại yêu cầu một chút

- Bước 1: Lisp yêu cầu người dùng chọn layer gốc

- Bước 2: Lisp tự động merge những layer nào có cùng color (cả với đối tượng layer (A) nhưng có màu ( B)), cùng linetype với layer gốc lại thành 1 layer (trong quá trình tìm màu layer thì bỏ qua layer DEFPOINTS và layer bị khóa in)

vì linetype của layer bị đổi tên khi mình bind file xref nên chắc sẽ phải chỉnh thủ công những layer này, lisp làm được việc merge như trên đã tốt với mình lắm rồi. Thanks Tue

Sài thử Lisp này nha :

(defun C:merLa( / lay_lst)
  ;; By : Gia_Bach 2014    
  (if (setq e (entsel "chon doi tuong :"))
    (progn
      (setq doc (vla-get-activedocument (vlax-get-acad-object))
	    layName (vla-get-Layer (setq obj (vlax-ename->vla-object (car e))))
	    layCol (vla-get-Color (setq obj (vlax-ename->vla-object (tblobjname "layer" layName))))
	    layLty (vla-get-LineTypes obj) )
      (vlax-for each (vla-get-layers doc)	
	(if (and (/= (strcase (setq LayerName (vla-get-name each))) "DEFPOINTS");(/= LayerName "0")
		 (= (vla-get-Color each) layCol)(= (vla-get-LineTypes each) layLty)
		 (/= (vla-get-lock each) :vlax-true))
	  (setq lay_lst (append lay_lst (list LayerName)))	))
      (vlax-for lay (vla-get-layouts doc)
	(vlax-for obj (vla-get-block lay)
	  (if (vl-position (vla-get-layer obj) lay_lst)
	    (vla-put-layer obj layName))))
      (foreach lay (vl-remove layName lay_lst)
	(vl-catch-all-apply (function vla-delete)
	  (list (vlax-ename->vla-object (tblobjname "layer" lay))))) ) )
  (princ))

Download lisp

Filename: 278204_merla.lsp

Tác giả: Tue_NV
Bài viết gốc: 278244
Tên lệnh: mla

Auto merge layer

Bạn conghoa sử dụng thử Lisp sau:

(defun c:mla()
 (setq lst-mrg nil laygoc nil lay nil lst-lay nil i nil)
  (princ "Chon doi tuong goc :")
  (setq ss (ssget) i -1)
  (while (setq ename (ssname ss (setq i (1+ i))))
    (if (and (null (member (setq lay (cdr(assoc 8 (entget ename)))) laygoc))
                 (/= (strcase lay) "DEFPOINTS")
            )
            (setq laygoc (append laygoc...
>>

Bạn conghoa sử dụng thử Lisp sau:

(defun c:mla()
 (setq lst-mrg nil laygoc nil lay nil lst-lay nil i nil)
  (princ "Chon doi tuong goc :")
  (setq ss (ssget) i -1)
  (while (setq ename (ssname ss (setq i (1+ i))))
    (if (and (null (member (setq lay (cdr(assoc 8 (entget ename)))) laygoc))
                 (/= (strcase lay) "DEFPOINTS")
            )
            (setq laygoc (append laygoc (list lay))))
  )
  (setq lay (tblnext "layer" t))
  (setq lst-lay (append lst-lay (list (cdr(assoc 2 lay)))))
  (while (setq lay (tblnext "layer"))
    (if (and (null (member (cdr(assoc 2 lay)) laygoc)) (/= (cdr(assoc 70 lay)) 4) (/= (strcase (cdr(assoc 2 lay))) "DEFPOINTS") )
      (setq lst-lay (append lst-lay (list (cdr(assoc 2 lay)))))
    )
  )
  (foreach x laygoc
     (setq mau (cdr(assoc 62 (tblsearch "layer" x))))
     (foreach y lst-lay
                  (if (= (cdr(assoc 62 (tblsearch "layer" y))) mau)
                          (setq lst-mrg (append lst-mrg (list (cdr(assoc 2 (tblsearch "layer" y))))))
                  )
      )
            (command "._laymrg")(foreach z lst-mrg (command "N" z))
            (command "")
            (command "N" x "y")
   (setq lst-mrg nil)
  )
)

Download lisp

Filename: 278244_mla.lsp

Tác giả: namnhim
Bài viết gốc: 278326
Tên lệnh: lc

INSERT ĐỐI TƯỢNG TRONG THƯ VIỆN

cái này chỉ để gọi cho 1 bve do bạn đặt tên trong Thư Viện,

(command "-insert"

cái này chỉ để gọi cho 1 bve do bạn đặt tên trong Thư Viện,

(command "-insert" "C:\\Program Files\\AutoCAD 2004\\Thu Vien\\TENBVE.DWG" x ms ms "0")

Nếu bạn muốn gọi từng chi tiết bằng bảng điều khiển thì hình như trên diễn đàn đã có rồi, bạn có thể tìm nó tối ưu hơn.

hoặc bạn có thể dùng theo kiểu cùi bắp này là tạo những file chi tiết riêng rồi vất vào trong thư viện, sau đó sử dụng Lisp hiển thị bảng lệnh do anh anh Ketxu viết và gõ LC là hiện ra bảng có tên chi tiết cần gọi rồi chon chi tiết đó và nhấn OK là ra cái chi tiết đó.

(defun c:lc(/ LM:ListBox str lstData ST:SendKeys)
(setq lstData
    (acad_strlsort (list
;Viet tiep cac lenh vao duoi dong nay theo mau "Ten lenh Noi dung"
    "MCA MatcatAA.dwg"
    "MCB MatcatBB.dwg"
    "MCC MatcatCC.dwg"
    "CO Copy th\U+00F4ng minh"    
    ))
)
(defun ST:SendKeys (keys / ws)
  (vlax-invoke-method (setq ws (vlax-create-object "WScript.Shell"))  'sendkeys keys)
  (vlax-release-object ws)
  (princ)
)
(defun LM:ListBox ( title data multiple / file tmp dch return )
  (cond
	(
  	(not
    	(and (setq file (open (setq tmp (vl-filename-mktemp nil nil ".dcl")) "w"))
      	(write-line
        	(strcat "listbox : dialog { label = \"" title
          "\"; spacer; : list_box { key = \"list\"; multiple_select = "
          	(if multiple "true" "false") "; } spacer; ok_cancel;}"
        	)
        	file
      	)
      	(not (close file)) (< 0 (setq dch (load_dialog tmp))) (new_dialog "listbox" dch)
    	)
  	)
	)
	(
  	t    
  	(start_list "list")
  	(mapcar 'add_list data) (end_list)
 
  	(setq return (set_tile "list" "0"))
  	(action_tile "list" "(setq return $value)")
 
  	(setq return
    	(if (= 1 (start_dialog))
      	(mapcar '(lambda ( x ) (nth x data)) (read (strcat "(" return ")")))
    	)
  	)          
	)
  )
  (if (< 0 dch) (unload_dialog dch))
  (if (setq tmp (findfile tmp)) (vl-file-delete tmp))
  return
)
(cond (
        (setq str (LM:ListBox "Ghi ch\U+00FA l\U+1EC7nh - lisp CAD - @ketxu - 2/6/2012 :" lstData nil))
        (setq str (car str))
        (ST:SendKeys (strcat (substr str 1 (vl-string-position 32 str)) "\n"))
        )
)
(princ)
)

Download lisp

Filename: 278326_lc.lsp

Tác giả: huaductiep
Bài viết gốc: 274522
Tên lệnh: anlay

Thắc mắc về Layoff, layiso?

sao em dùng thì lisp ko chạy? toàn báo là Unknown Load Lísp. Bác sửa giúp em với nha

Bạn có đọc kỹ yêu cầu của bài này không?
Lệnh Layoff : tắt layer trên toàn bộ bản vẽ
Còn đây là lisp mà Tue_NV viết để tắt Layer trên 1 vùng chọn của bản vẽ? Bạn hiểu không?
Lisp này kết hợp Lisp của bác Bemove và của Tue_NV có tính năng ẩn các Layer được user chọn và lần này Tue_NV bổ sung thêm tính năng ẩn Layer trên toàn bộ bản vẽ (tính năng này tương đương với lệnh Layoff của Express). Các bạn chạy thử xem và để hiện lại layer thì dùng Lisp VIS của bác Bemove

;copyright by Tue_NV and Bemove(defun c:anlay(/ vung lstlay n dt ent enti ss ss1 i ans)(setq lstlay nil)(prompt "\n chon vung :")(initget "V A")(setq ans (getstring "\n Ban muon an Layer theo Vung chon hay an Layer tren toAn ban ve <V/A> :"))(if (or (= ans "V") (= ans "v"))(setq vung (ssget))(setq vung (ssget "A")))(setq n (sslength vung) ss (ssadd) i 0)(setq dt (entsel"\n Pick chon Layer :"))(if dt(progn(while dt (setq ent (car dt))(setq lay (cdr(assoc 8 (entget ent))))(if (= (member lay lstlay) nil)(setq lstlay (append lstlay (list lay)))(ALERT "Da chon layer nay roi. Moi ban chon doi tuong thuoc Layer khac :"))(setq dt (entsel"\n Pick chon Layer :")))))(while (< i n)(setq enti (ssname vung i))(setq elay (cdr(assoc 8 (entget enti))))(if (/= (member elay lstlay) nil)(setq ss (ssadd enti ss)))(setq i (1+ i)))(INVIS ss)(princ));;(defun InVis (SSet / Count Elem)(defun Dxf (Id Obj)(cdr (assoc Id (entget Obj))));end Dxf(cond((repeat (setq Count (sslength SSet))(setq Count (1- COunt)Elem (ssname SSet Count))(if (/= 4 (logand 4 (Dxf 70 (tblobjname "layer" (Dxf 8 Elem)))))(if (Dxf 60 Elem)(entmod (subst '(60 . 1) (assoc 60 (entget Elem)) (entget Elem)))(entmod (append (entget Elem) (list '(60 . 1)))))(prompt "\nEntity on a locked layer. Cannot hide this entity. "));end if);end repeat) );end cond(princ));end c:InVis

Bạn sử dụng Lisp của Tue_NV xem :
Ban muon an Layer theo Vung chon hay an Layer tren toAn ban ve <V/A> :
Ở dòng này nếu bạn chọn V : thì ẩn Lâyer theo vùng chọn
Còn nếu bạn chọn là : A thì chức năng này tương đương với lệnh Layoff
-> để hiện lại layer thì dùng Lisp VIS của bác Bemove