Jump to content
InfoFile
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ả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 tượng của phần mềm TK đường VNROAD nên không làm thay đổi ENTNAME của nó để sau VNR vẫn nhận ra mà không bị 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
)
)

<<

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é

test.gif

(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é

test.gif

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

<<

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

<<

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

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


<<

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)

<<

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:

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

http://www.cadviet.com/upfiles/3/64997_test_hatchkin.dwg64997_screenshot_82.png

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

<<

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

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 "screensize")))))
 (setq pllur (vpcords))
 (command "undo" "be")
 (princ "\nChon cac DIM da bi Override de Convert...")
 (if (setq ss (ssget '((0 . "DIMENSION") (1 . "~"))))
  (progn
   (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (initget "All  Individually")
   (setq key (getkword "\nSelect type <All>: "))
   (if (not key) (setq key "All"))
   (cond
    ((= key "All")
     (foreach ent lst
      (entmod (subst (cons 1 "") (assoc 1 (entget ent)) (entget ent)))))
    ((= key "Individually")
     (foreach ent lst
      (command "zoom" "c" "non" (cdr (assoc 11 (entget ent))) 5)
   (command "ddedit" ent pause))))))
 (command "zoom" "w" "non" (car pllur) "non" (cadr pllur))
 (command "undo" "e")
 (princ))
 


<<

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

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 (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 "screensize")))))
 (setq pllur (vpcords))
 (command "undo" "be")
 (princ "\nChon cac DIM da bi Override de Convert...")
 (if (setq ss (ssget '((0 . "DIMENSION") (1 . "~"))))
  (progn
   (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (initget "All  Individually")
   (setq key (getkword "\nSelect type for convert <All>: "))
   (if (not key) (setq key "All"))
   (cond
    ((= key "All")
     (foreach ent lst
      (entmod (subst (cons 1 "") (assoc 1 (entget ent)) (entget ent)))))
    ((= key "Individually")
     (foreach ent lst
      (vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
 (setq p1 (safearray-value ll) p2 (safearray-value ur))
 (setq p11 (polar p1 (angle p2 p1) (/ (distance p1 p2) 2)) p22 (polar p2 (angle p1 p2) (/ (distance p1 p2) 2)))
      (command "zoom" "w" "non" p11 "non" p22)
   (command "ddedit" ent pause))))))
 (command "zoom" "w" "non" (car pllur) "non" (cadr pllur))
 (command "undo" "e")
 (princ))
;; Doan Van Ha - CadViet.com - 17/01/2014
;; Lisp thay doi Dim Override gan giong Find and Replace trong Word. Mac dinh chi co 1 option: Individually
(defun C:HA1( / VPCords pllur lst key p1 p2 p11 p22)
 (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 "screensize")))))
 (setq pllur (vpcords))
 (command "undo" "be")
 (princ "\nChon cac DIM da bi Override de Convert tung Dim...")
 (if (setq ss (ssget '((0 . "DIMENSION") (1 . "~"))))
  (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
   (vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
   (setq p1 (safearray-value ll) p2 (safearray-value ur))
   (setq p11 (polar p1 (angle p2 p1) (/ (distance p1 p2) 2)) p22 (polar p2 (angle p1 p2) (/ (distance p1 p2) 2)))
   (command "zoom" "w" "non" p11 "non" p22)
   (command "ddedit" ent pause)))
 (command "zoom" "w" "non" (car pllur) "non" (cadr pllur))
 (command "undo" "e")
 (princ))
 


<<

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à...

>>

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à đổi chiều pline và nó không đúng với ý bạn là điểm startpoint phải gần gốc tọa độ nhất được.

http://www.cadviet.com/upfiles/3/5194_changestartpointofpline.lsp

 

(Defun c:csp (/ oldos oldcol ent plst plst1 plst2 n i lst1 lst2)

(vl-load-com)

(setq oldos (getvar "osmode"))

(setvar "osmode" 0)

(setq oldcol (getvar "cecolor"))

(setvar "cecolor" "1")

(command "undo" "be")

(setq ent (car (entsel "\n Chon Polyline can doi")))

(if (= (cdr (assoc 70 (entget ent))) 1)

    (setq plst (cdr (acet-geom-vertex-list ent)))

)

(setq  plst1 (vl-sort plst '(lambda (x y) (< (distance '(0 0 0) x) (distance '(0 0 0) y)))))

(setq n (vl-position (car plst1) plst))

(setq lst1 (member (car plst1) plst))

(setq i 0 lst2 (list))

(while (< i n)

        (setq  lst2 (append lst2 (list (nth i plst)))

                  i (1+ i) )

)

(setq plst2 (append lst1 lst2))

(command "pline")

(foreach p plst2

       (command p)

)

(command "c" "")

(command "erase" ent "")

(command "undo" "e")

(setvar "cecolor" oldcol)

(setvar "osmode" oldos)

(princ)

)

(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq oldcol (getvar "cecolor"))
(setvar "cecolor" "1")
(command "undo" "be")
(setq ent (car (entsel "\n Chon Polyline can doi")))
(if (= (cdr (assoc 70 (entget ent))) 1)
    (setq plst (cdr (acet-geom-vertex-list ent)))
)

<<

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.

@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.

http://www.cadviet.com/upfiles/3/5194_reconstlwpline.lsp

 

 

(Defun c:csp (/ oldos oldcol ent plst plst1 plst2 n i k p1 p2 lst1 lst2)

(vl-load-com)

(setq oldos (getvar "osmode"))

(setvar "osmode" 0)

(setq oldcol (getvar "cecolor"))

(setvar "cecolor" "1")

(command "undo" "be")

(setq ent (car (entsel "\n Chon Polyline can doi")))

(if (= (cdr (assoc 70 (entget ent))) 1)

    (setq plst  (acet-geom-vertex-list ent))

    (progn

           (alert "\n doi tuong khong phai Lwpolyline kin")

           (exit)

    )

)

(setvar "osmode" 1)

(setq p1 (getpoint "\n Chon diem startpoint moi")

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

)

(setq i (vl-position p1 plst)

          k (vl-position p2 plst)

)

(if (/= i (1- k))

    (setq plst (reverse plst))

)

(setq plst (reverse (cdr (reverse plst))))

(setq n (vl-position p1 plst))

(setq lst1 (member p1 plst))

(setq i 0 lst2 (list))

(while (< i n)

        (setq  lst2 (append lst2 (list (nth i plst)))

                  i (1+ i) )

)

(setq plst2 (append lst1 lst2))

(setvar "osmode" 0)

(command "pline")

(foreach p plst2

       (command p)

)

(command "c" "")

(command "erase" ent "")

(command "undo" "e")

(setvar "cecolor" oldcol)

(setvar "osmode" oldos)

(princ)

)

 


<<

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

test2.gif


<<

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
;;...
>>


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
;; A
cao (getreal "\nCao cot: ")
;; B
rongnhat (getreal "\nDuong Kinh to nhat: ")
;; C
diemchuan (getpoint "\nDiem chuan: ")




Câu 2: Mình muốn cho đoạn p6,p7,p8,p9,p10 chuyển thành SPLINE thay cho LINE thì phải dùng lệnh SPLINE như thế nào
. Vì khi muốn dừng lệnh SPLINE phải ấn Space 3 lần mới đẹp. (Chuyển 4 đoạn thẳng nối p6,p7,p8,p9,p10 thành 1 SPLINE tạo bởi 5 điểm p6,p7,p8,p9,p10)
http://i72.photobucket.com/albums/i195/nguyentuyen86/untitled-2.jpg



CẢm ơn bạn rất nhiều.
<<

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

<<

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 ...
>>
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 “We’ll have some affirmation of what’s being put in the ground,” Womack said. “You can deny the trade secret status. You can deny the use of that material in North Carolina.”
manforce tablet 50 mg side effects Years in NFL: 1987-1996Years Behind Bars: 2001, 2004, presentThe Giants took the former Michigan State star with a first-round pick in the 1987 draft and Ingram made an iconic catch to help Big Blue win Super Bowl XXV. The wideout now sits behind bars for the third time in eight years after ignoring a judge"s order to start a 92-month prison term for a money-laundering scheme. The first two stints in jail were for theft and counterfeiting.
zyrexin customer reviews "I didn"t want to get in that position," editor Alan Rusbridger said in a video interview posted to the Guardian"s website. "Once it was obvious that they would be going to law, I would rather destroy the copy than hand it back to them or allow the courts to freeze our reporting."
udenafil 2013 Kids who reportedly drank no soda scored 56 on the aggression scale, on average. That compared to 57 among kids who drank one serving per day, 58 among those who drank two servings, 59 among those who drank three servings and 62 for four soda servings or more per day.
source naturals tongkat ali review Yahoo Inc., one of the Internet"s oldest and best-known companies, also has been on the comeback trail. After it was stuck below $20 for more than four years, Yahoo"s stock has more than doubled since last September. While the company"s July 2012 hiring of Marissa Mayer as its CEO played a role in the stock"s run-up, the biggest factor was a fortuitous investment in rapidly growing Chinese Internet company Alibaba Group.
testofuel vs battle fuel Nearly half of the money raised in the new campaign will support teaching and research, while a quarter will go forfinancial aid and related programs. The rest will go towardcapital improvements and a flexible fund, according to Harvard, recently ranked America"s No. 2 university behind Princeton byU.S. News & World Report.
can you buy male enhancement pills gnc Last week Stockton released a draft plan for adjusting its debt that disclosed a deal with National over about $45 million in outstanding lease revenue bonds for the city"s arena whose payments will be cut by 3 percent. Other bonds insured by National and related to parking garages will be cut by 12 percent, while a third bond for a city building will be paid in full.
tabletki intimax 100 Doesn’t sound like they were “drawn in” to anything. Sounds more like they chose to do it for the heck of it. Of course, stupid is as stupid does as they only hurt themselves. But then, maybe if we wait long enough these idiots will all just kill themselves out and we won’t have to worry about them anymore.
activator rx buy Controversial issues such as potential primary school closures and the sale of Toward Castle and Ardentinny outdoor education centres have been divisive and have "damaged trust" between councillors as well as between some councillors and senior officers, the report found.
cheap alpha male xl On this week"s edition of the Daily News Fifth Yankees Podcast, Mark Feinsand sits down with Robinson Cano to discuss next week"s All-Star Game, his participation - and hopeful redemption - in the Home Run Derby, as well as what the Yankees have to do in the second half to reach October. ... plus much more!
delgra 200mg wirkung "The CFDT is aware of the seriousness of the situation and deplores this," it said in a statement. "But once again it is the staff that are paying the price ... We will fight this plan and make proposals to change it."
tazalis online ADDIS ABABA, Aug 18 (Reuters) - Ethiopia signed an $800million deal with China"s ZTE on Sunday to expandmobile phone infrastructure and introduce a high-speed 4Gbroadband network in the capital Addis Ababa and a 3G servicethroughout the rest of the country.

<<

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

<<

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

>>

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 mà sai được.

Hỏi: có lúc nào nó sai không nhỉ? Cho 1 ví dụ.

P/S: để đơn giản chỉ cần nhập các số nho nhỏ thôi, và cũng chỉ cần 1 số lẻ thôi.

Đêm giao thừa mời các bạn đón xem 1 câu đố khác nhé!

(defun C:HA()
 (setq a (getreal "\nNhap so thu 1: "))
 (setq b (getreal "\nNhap so thu 2: "))
 (setq c (getreal "\nNhap tong so: "))
 (if (= (+ a b) c)
  (alert "Ket qua nay la dung!")
  (alert "Ket qua nay la sai!")))
 


<<

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

<<

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

<<

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

<<

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

>>

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
s_big.gif


<<

Filename: 274522_anlay.lsp

Trang 150/303

150