Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Nguyen Hoanh

Viết Lisp theo yêu cầu

Các bài được khuyến nghị

Em đang cần dùng một cái lisp như sau:

+ B1: offset đối tượng là một hình chữ nhật có sẵn như lệnh offset thường dùng.

+ B2: nối các góc của hình chữ nhật bên trong với góc của hình chữ nhật gốc.

Các pro giúp em viết hộ cái lisp này nhé.

Em đang cần dùng gấp để vẽ mấy cái chi tiết cửa sổ. Vẽ thủ công theo 2 bước trên lâu quá!

Bây giờ nếu mà offset nó nối luôn các góc cho thì nhanh hơn bao nhiêu!

Địa chỉ email:sv_nuce@yahoo.com.vn

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào cả nhà !

Mình thấy ở ngoài có người hỏi nhưng chưa ai trả lời ! Mình cũng đang cần cái này mong cả nhà giúp đỡ !

Mình đang rất cần lisp kiểm tra như sau:

 

+ layer 1 là Pline (mầu xanh cây) bắt snap hai đầu vào layer 2 cũng là Pline (mầu đen)

Nếu hai đầu layer 1 chưa tới hoặc vượt quá layer 2 thì lisp sẽ báo lỗi bằng point hoặc Circle

Mong cả nhà giúp mình với cám ơn nhiều lắm !

 

Ảnh Minh họa :ban_ve_minh_hoa.jpg

 

Bạn có thể nói rõ hơn đc không? Bạn muốn check toàn bản vẽ hay chỉ nhấp chọn đg biên rồi chọn tiếp các pline cần kiểm tra? Nếu check toàn bản vẽ thì phức tạp lắm, nhất là bản vẽ có nhiều pline như bình đồ chẳng hạn.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Bạn có thể nói rõ hơn đc không? Bạn muốn check toàn bản vẽ hay chỉ nhấp chọn đg biên rồi chọn tiếp các pline cần kiểm tra? Nếu check toàn bản vẽ thì phức tạp lắm, nhất là bản vẽ có nhiều pline như bình đồ chẳng hạn.

Chào bạn q288 Mình muốn check toàn bản vẽ nhưng chỉ bật hai layer đó lên để check thôi. Bạn giúp mình đi . Mình phải check rất nhiều mà bằng mắt thwờng thì rất lâu mới được một cái .

File mẫu : http://www.cadviet.com/upfiles/file_mau.dwg

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào bạn duy782006,mình xin giải thích rõ hơn

Nhờ các bạn viết dùm mình đọan code "Chèn block vào trung điểm của các đường thẳng được chọn", trình tự như sau:

- Gõ tên lệnh

- Chương trình sẽ yêu cầu chọn block cần insert (chỉ đường dẫn đến thư mục chứa file block)

- Chương trinh sẽ yêu cầu chọn các đường thẳng trong bản vẽ để insert block

- Thực thi lệnh

- Kết quả là block sẽ chèn và tự động align dọc theo phương của các đường thẳng được chọn

Xin chân thành cảm ơn!

 

Bạn thử dùng code sau đây xem sao nhé. Tên lệnh là ins.

 

(defun c:ins()

(setq bl (getfiled "Open file" (getvar "dwgprefix") "dwg" 4)

ss (ssget '((0 . "LINE")))

n 0)

(setq os (getvar "OSMODE"))

(setvar "OSMODE" 0)

(repeat (sslength ss)

(setq v (ssname ss n)

p1 (cdr (assoc 10 (entget v)))

p2 (cdr (assoc 11 (entget v)))

pm (polar p1 (angle p1 p2) (* 0.5 (distance p1 p2))))

(command "-insert" bl pm "" "" (* 180 (/ (angle p1 p2) pi)))

(setq n (1+ n)))

(setvar "OSMODE" os)

)

  • Vote tăng 2

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Bạn thử dùng code sau đây xem sao nhé. Tên lệnh là ins.

 

(defun c:ins()

(setq bl (getfiled "Open file" (getvar "dwgprefix") "dwg" 4)

ss (ssget '((0 . "LINE")))

n 0)

(setq os (getvar "OSMODE"))

(setvar "OSMODE" 0)

(repeat (sslength ss)

(setq v (ssname ss n)

p1 (cdr (assoc 10 (entget v)))

p2 (cdr (assoc 11 (entget v)))

pm (polar p1 (angle p1 p2) (* 0.5 (distance p1 p2))))

(command "-insert" bl pm "" "" (* 180 (/ (angle p1 p2) pi)))

(setq n (1+ n)))

(setvar "OSMODE" os)

)

Cám ơn bạn rất nhiều, đúng là lisp mình cần

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
cảm ơn sự nhiệt tình của bạn Bình và Bác Tue mình đã chạy thử lisp của bạn Bình và thấy các vấn đề sau :

 

1- với đuờng PLine thì nói chung là đã ok

 

2-với đuờng SPline và đuờng cong thì block nó bị nguợc và thứ tự đánh chữ bị đảo nguợc sau text gốc là T1/L1-1A thì sẽ phải đến T1/L1-2B rồi đến T1/L1-3C rôi đến T1/L1-4A,T1/L1-5B......( mình chủ yếu là dùng đường loại SPline :cry: )

 

3- về text thì mình cần các text sau giống text gốc về khoảng cách với điểm gốc và song song với tiếp tuyến của đường chuẩn như trong file kèm theo mình đã vẽ chi tiếp ( vi khó nói miêu tả :cry: )

 

4- về số ký tự thì text mẫu ban đầu của mình luôn là T1/L1-1A ( không hiểu như vậy có dễ dàng hơn cho các bạn kô )

 

file đính kèm ( mình đã chuyển về CAD 2004 )

http://www.cadviet.com/upfiles/12.dwg

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Em đang cần dùng một cái lisp như sau:

+ B1: offset đối tượng là một hình chữ nhật có sẵn như lệnh offset thường dùng.

+ B2: nối các góc của hình chữ nhật bên trong với góc của hình chữ nhật gốc.

Các pro giúp em viết hộ cái lisp này nhé.

Em đang cần dùng gấp để vẽ mấy cái chi tiết cửa sổ. Vẽ thủ công theo 2 bước trên lâu quá!

Bây giờ nếu mà offset nó nối luôn các góc cho thì nhanh hơn bao nhiêu!

Địa chỉ email:sv_nuce@yahoo.com.vn

Bạn thử dùng đoạn Lisp này xem :

(defun c:bcn(/ hcn kc phia entL entn a b c d e f g h)
(setq hcn (ssget '((0 . "LWPOLYLINE")))
kc (getdist "\n Khoang cach offset :")
phia (getpoint "\n Phia offset :")

)
(setq entL (entget(ssname hcn 0)))
(setq
a (List (cadr(nth 14 entL)) (caddr(nth 14 entL)) 0.0)
b (List (cadr(nth 18 entL)) (caddr(nth 18 entL)) 0.0)
c (List (cadr(nth 22 entL)) (caddr(nth 22 entL)) 0.0)
d (List (cadr(nth 26 entL)) (caddr(nth 26 entL)) 0.0)
)

(command "offset" kc hcn phia "")


(setq entn (entget(entlast)))
(setq
e (List (cadr(nth 14 entn)) (caddr(nth 14 entn)) 0.0)
f (List (cadr(nth 18 entn)) (caddr(nth 18 entn)) 0.0)
g (List (cadr(nth 22 entn)) (caddr(nth 22 entn)) 0.0)
h (List (cadr(nth 26 entn)) (caddr(nth 26 entn)) 0.0)
)
(Command "Line" a e "")
(Command "Line" b f "")
(Command "Line" c g "")
(Command "Line" d h "")
(princ)
)

Hy vọng bạn hài lòng.

Chúc thành công nhé :cry:

  • Vote tăng 2

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào bạn q288 Mình muốn check toàn bản vẽ nhưng chỉ bật hai layer đó lên để check thôi. Bạn giúp mình đi . Mình phải check rất nhiều mà bằng mắt thwờng thì rất lâu mới được một cái .

File mẫu : http://www.cadviet.com/upfiles/file_mau.dwg

 

Mình đã viết thử ct và chạy thử. Tuy nhiên ngoài những điểm bắt đúng theo yêu cầu thì nó còn bắt thêm vài điểm khác. Có lẽ do cách bắt điểm của ACAD. Mình chưa biết cách khắc phục chuyện đó. Tuy vậy bạn có thể dùng tạm ct này, dù sao còn đõ hơn rà cả bản vẽ bằng mắt. Tên lệnh là chk.

 

(defun c:chk()

 

(defun ints (e1 e2 / ob1 ob2 V L1 L2)

;;;Intersections of e1, e2. Return LIST of points

;;;Thank Mr. Hoanh for this function!

(setq

ob1 (vlax-ename->vla-object e1)

ob2 (vlax-ename->vla-object e2)

)

(setq V (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendBoth)))

(if (/= (vlax-safearray-get-u-bound V 1) -1)

(progn

(setq L1 (vlax-safearray->list V) L2 nil)

(while L1

(setq L2 (append L2 (list (list (car L1) (cadr L1) (caddr L1)))))

(repeat 3 (setq L1 (cdr L1)))

)

)

(setq L2 nil)

)

L2

)

 

;;;

 

(setq os (getvar "OSMODE"))

(setvar "OSMODE" 0)

(setvar "CLAYER" "layer 2")

(setvar "CECOLOR" "1")

(command "zoom" "e")

(setq ss (ssget "X" '((8 . "layer 2")))

n 0)

 

(repeat (sslength ss)

(setq v0 (ssname ss n)

v (vlax-ename->vla-object v0)

L nil)

 

(if (= (cdr (assoc 0 (entget v0))) "LWPOLYLINE")

(progn

(setq p1 (vlax-curve-getStartPoint v)

p2 (vlax-curve-getEndPoint v)

ss1 (ssget "f" (list p1 p2)))

(if (= (length p1) 2) (setq p1 (append p1 (list 0.0))))

(if (= (length p2) 2) (setq p2 (append p2 (list 0.0))))

 

(if (= (sslength ss1) 1)

(progn

(command "Point" p1)

(command "Point" p2))

(progn

(if (ssmemb v0 ss1) (setq ss1 (ssdel v0 ss1)))

(while (> (sslength ss1) 0)

(setq L (append L (ints v0 (ssname ss1 0)))

ss1 (ssdel (ssname ss1 0) ss1)))

 

(if (not (member p1 L)) (command "Point" p1))

(if (not (member p2 L)) (command "Point" p2)))

)

))

(setq n (1+ n)

)

)

(setvar "OSMODE" os)

)

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

chào các bác. Em muốn viết một cái lisp để vẽ biên dạng có phương trình:

x=(r1-r2)*sin(a)+r3*sin(a)

y=(r1-r2)*cos(a)-r3*cos(a)

bác nào viết giúp em với. Em làm mãi ma không ra

Cám ơn các bác nhiều

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
chào các bác. Em muốn viết một cái lisp để vẽ biên dạng có phương trình:

x=(r1-r2)*sin(a)+r3*sin(a)

y=(r1-r2)*cos(a)-r3*cos(a)

bác nào viết giúp em với. Em làm mãi ma không ra

Cám ơn các bác nhiều

Đã có bàn ở đây và mình cũng thấy bạn xuất hiện bên đó sao không hỏi luôn cho nó tập trung thuận tiện cho người sau bạn cần tìm.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
cảm ơn sự nhiệt tình của bạn Bình và Bác Tue mình đã chạy thử lisp của bạn Bình và thấy các vấn đề sau :

 

1- với đuờng PLine thì nói chung là đã ok

 

2-với đuờng SPline và đuờng cong thì block nó bị nguợc và thứ tự đánh chữ bị đảo nguợc sau text gốc là T1/L1-1A thì sẽ phải đến T1/L1-2B rồi đến T1/L1-3C rôi đến T1/L1-4A,T1/L1-5B......( mình chủ yếu là dùng đường loại SPline :cheers: )

 

3- về text thì mình cần các text sau giống text gốc về khoảng cách với điểm gốc và song song với tiếp tuyến của đường chuẩn như trong file kèm theo mình đã vẽ chi tiếp ( vi khó nói miêu tả :) )

 

4- về số ký tự thì text mẫu ban đầu của mình luôn là T1/L1-1A ( không hiểu như vậy có dễ dàng hơn cho các bạn kô )

 

file đính kèm ( mình đã chuyển về CAD 2004 )

http://www.cadviet.com/upfiles/12.dwg

Chào bạn nguyenkhoadung98,

Rất xin lỗi vì vẫn chưa làm được theo đúng yêu cầu của bạn. Hiện tại, mặc dầu đã cố gắng nhưng mình vẫn chưa giải quyết được triệt để theo đúng yêu cầu của bạn. Mình mới chỉ giải quyết được việc để cho block chèn không bị chổng tu, và các text nằm song song với tiếp tuyến, sắp xếp theo đúng thứ tự bạn muốn từ trái qua phải không phụ thuộc vào loại đường và cách vẽ. Còn vấn đề vị trí tương đối của text so với block chèn tưởng là ngon mà mình vẫn không giải quyết được. Lý do là việc chèn text vào rất khác với việc chèn block cột. Cái góc xoay của Text không hoàn toàn đồng nhất với cái góc chèn block bạn ạ.

Hơn nữa do text mẫu của bạn đã bị căn chỉnh cả về điểm chèn lẫn font gốc nên mình chưa tìm ra được cách lấy chuẩn để căn text bạn ạ.

Hiện tại mình chấp nhận vị trí đặt text cao hơn điểm chèn 6 và lệch trái so với điểm chèn block 3 bạn nhé.

Một vấn đề nữa là cái lisp này có sự khác biệt với các lisp trước do mình sử dụng gợi ý của bác ndtnv, mình đưa việc chọn điểm chèn bắt đầu vào và các block sẽ được chèn bắt đầu từ điểm này trở đi bạn nhé. Điểm chèn này sẽ được đánh thứ tự là T2/L1-2B bạn ạ và tăng dần. Trong trường hợp bạn muốn điểm bắt đấu này là mút của đường chuẩn thì bạn không được chèn trước block cũng như text vào đó và phải chấp nhận không có block mang số T2/L1-1A. Khi đó cái block và text chuẩn này bạn phải lấy từ một vị trí khác trên bản vẽ. Nếu bạn muốn điểm chèn đâu tiên được đánh số là T2/L1-1A thì cũng đơn giản, chỉ cần sửa lại một chút ở hai đoạn code lấy giá trị t4 và t5 mà thôi bạn ạ.

Hy vọng các bác cao thủ khác trên diễn đàn sẽ góp ý hoàn thiện ơn cái lisp này của mình. Mong bạn thông cảm.

Lisp đây bạn, nhớ lệnh chạy là ido

(defun c:ido ()
(vl-load-com)
(setq dt (car (entsel "\n Chon doi tuong goc"))
  edt (entget dt)
  bn (cdr (assoc 2 edt))
  dg (cdr (assoc 10 edt))
  txt (entsel "\n Chon text chuan")
  etxt (entget (car txt))
  text (cdr (assoc 1 etxt))
  t1 (substr text 1 6)
  t2 (substr text 7 1)
  t3 (substr text 8 1)
  gt (cdr (assoc 50 etxt))
   h (cdr (assoc 40 etxt)) 
  lt (cdr (assoc 8 etxt))
  st (cdr (assoc 7 etxt))
  mt (cdr (assoc 62 etxt))
  pt (cdr (assoc 10 etxt)) 
  dc (car (entsel "\n Chon duong chuan"))
  edc (entget dc)
  p0 (getpoint"\n Chon diem bat dau")
)
(setq a (- (car pt) (car dg))
  b (- (cadr pt) (cadr dg))
)
(if (equal (cdr (assoc 10 edc)) p0)
(setq a1 0)
(setq a1 (vlax-curve-getdistatpoint dc p0))
)
(setq par (vlax-curve-getparamatdist dc a1)
  vtt (vlax-curve-getFirstderiv dc par)
  lth (vlax-curve-getdistatpoint dc (vlax-curve-getendpoint dc))
  dis (getreal "\n Nhap khoang cach giua cac diem : ")
  i 0
)
(if (/= (car vtt) 0)
(setq gr (atan (/ (cadr vtt) (car vtt))))
)
(if (> (car vtt) 0)
(setq gr (+ pi gr))
)
(setq gd (/ (* gr 180) pi))
;;;(command "insert" bn "r" gd p0 "" "" "")
(if (	(progn
	  (while (>= (- a1 (* i dis)) 0)
			 (setq p1 (vlax-curve-getpointatdist dc (- a1 (* i dis)))
				   par (vlax-curve-getparamatpoint dc p1)
				   vtt (vlax-curve-getFirstderiv dc par)
			 )
			 (if (/= (car vtt) 0)
				 (setq gr (atan (/ (cadr vtt) (car vtt))))
			 )
			 (if (> (car vtt) 0)
				 (setq gr (+ pi gr))
			 )
			 (setq gd (/ (* gr 180) pi))
			 (command "insert" bn "r" gd p1 "" "" "")
			 (if (and (> gd 90) (					 (setq gd (+ gd 180))
			 )
			 (if (/= (atoi t2) nil)
				 (setq t4 (+ i (atoi t2) 1))
				 (setq t4 100)
			 )
			 (if (or (> (ascii t3) 67) (					 (setq t5 (chr 65))
				 (setq t5 t3)
			 )
			 (if (= 0 (rem i 3))
				 (setq t5 (chr (+ (ascii t5) 1)))
				 (if (= 1 (rem i 3))
					 (setq t5 (chr (+ (ascii t5) 2)))
				 )
			 )
			 (setq pt1 (list (+ (car p1) a) (+ (cadr p1) b)))
			 (command "layer" "m" lt "" "")
			 (Command "style" st "txt.shx" "0" "1" "0" "n" "n" "n")
			 (command "text" pt1 h gd (strcase (strcat t1 (itoa t4) t5) nil))
			 (setq i (1+ i))

	   )
 )
 (progn
	   (while (				  (setq p1 (vlax-curve-getpointatdist dc (+ a1 (* i dis)))
					par (vlax-curve-getparamatpoint dc p1)
					vtt (vlax-curve-getFirstderiv dc par)
			  )
			  (if (/= (car vtt) 0)
				  (setq gr (atan (/ (cadr vtt) (car vtt))))
			  )
			  (if (					  (setq gr (+ pi gr))
			  )
			  (setq gd (/ (* gr 180) pi))
			  (command "insert" bn "r" gd p1 "" "" "") 
			  (if (and (> gd 90) (					  (setq gd (+ gd 180))
			  )
			  (if (/= (atoi t2) nil)
				  (setq t4 (+ i (atoi t2) 1))
				  (setq t4 100)
			  )
			  (if (or (> (ascii t3) 67) (					  (setq t5 (chr 65))
				  (setq t5 t3)
			  )
			  (if (= 0 (rem i 3))
				  (setq t5 (chr (+ (ascii t5) 1)))
				  (if (= 1 (rem i 3))
					  (setq t5 (chr (+ (ascii t5) 2)))
				  )
			  )
			  (setq pt1 (list (+ (car p1) a) (+ (cadr p1) b)))
			  (command "layer" "m" lt "" "")
			  (Command "style" st "txt.shx" "0" "1" "0" "n" "n" "n")
			  (command "text" pt1 h gd (strcase (strcat t1 (itoa t4) t5) nil))
			  (setq i (1+ i))
	   )
 )
)

)

 

Chúc bạn vui.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào bạn nguyenkhoadung98,

Rất xin lỗi vì vẫn chưa làm được theo đúng yêu cầu của bạn. Hiện tại, mặc dầu đã cố gắng nhưng mình vẫn chưa giải quyết được triệt để theo đúng yêu cầu của bạn. Mình mới chỉ giải quyết được việc để cho block chèn không bị chổng tu, và các text nằm song song với tiếp tuyến, sắp xếp theo đúng thứ tự bạn muốn từ trái qua phải không phụ thuộc vào loại đường và cách vẽ. Còn vấn đề vị trí tương đối của text so với block chèn tưởng là ngon mà mình vẫn không giải quyết được. Lý do là việc chèn text vào rất khác với việc chèn block cột. Cái góc xoay của Text không hoàn toàn đồng nhất với cái góc chèn block bạn ạ.

Hơn nữa do text mẫu của bạn đã bị căn chỉnh cả về điểm chèn lẫn font gốc nên mình chưa tìm ra được cách lấy chuẩn để căn text bạn ạ.

Hiện tại mình chấp nhận vị trí đặt text cao hơn điểm chèn 6 và lệch trái so với điểm chèn block 3 bạn nhé.

Một vấn đề nữa là cái lisp này có sự khác biệt với các lisp trước do mình sử dụng gợi ý của bác ndtnv, mình đưa việc chọn điểm chèn bắt đầu vào và các block sẽ được chèn bắt đầu từ điểm này trở đi bạn nhé. Điểm chèn này sẽ được đánh thứ tự là T2/L1-2B bạn ạ và tăng dần. Trong trường hợp bạn muốn điểm bắt đấu này là mút của đường chuẩn thì bạn không được chèn trước block cũng như text vào đó và phải chấp nhận không có block mang số T2/L1-1A. Khi đó cái block và text chuẩn này bạn phải lấy từ một vị trí khác trên bản vẽ. Nếu bạn muốn điểm chèn đâu tiên được đánh số là T2/L1-1A thì cũng đơn giản, chỉ cần sửa lại một chút ở hai đoạn code lấy giá trị t4 và t5 mà thôi bạn ạ.

Hy vọng các bác cao thủ khác trên diễn đàn sẽ góp ý hoàn thiện ơn cái lisp này của mình. Mong bạn thông cảm.

Lisp đây bạn, nhớ lệnh chạy là ido

(defun c:ido ()
(vl-load-com)
(setq dt (car (entsel "\n Chon doi tuong goc"))
  edt (entget dt)
  bn (cdr (assoc 2 edt))
  dg (cdr (assoc 10 edt))
  txt (entsel "\n Chon text chuan")
  etxt (entget (car txt))
  text (cdr (assoc 1 etxt))
  t1 (substr text 1 6)
  t2 (substr text 7 1)
  t3 (substr text 8 1)
  gt (cdr (assoc 50 etxt))
   h (cdr (assoc 40 etxt)) 
  lt (cdr (assoc 8 etxt))
  st (cdr (assoc 7 etxt))
  mt (cdr (assoc 62 etxt))
  pt (cdr (assoc 10 etxt)) 
  dc (car (entsel "\n Chon duong chuan"))
  edc (entget dc)
  p0 (getpoint"\n Chon diem bat dau")
)
(setq a (- (car pt) (car dg))
  b (- (cadr pt) (cadr dg))
)
(if (equal (cdr (assoc 10 edc)) p0)
(setq a1 0)
(setq a1 (vlax-curve-getdistatpoint dc p0))
)
(setq par (vlax-curve-getparamatdist dc a1)
  vtt (vlax-curve-getFirstderiv dc par)
  lth (vlax-curve-getdistatpoint dc (vlax-curve-getendpoint dc))
  dis (getreal "\n Nhap khoang cach giua cac diem : ")
  i 0
)
(if (/= (car vtt) 0)
(setq gr (atan (/ (cadr vtt) (car vtt))))
)
(if (> (car vtt) 0)
(setq gr (+ pi gr))
)
(setq gd (/ (* gr 180) pi))
;;;(command "insert" bn "r" gd p0 "" "" "")
(if (< (car vtt) 0)
(progn
	  (while (>= (- a1 (* i dis)) 0)
			 (setq p1 (vlax-curve-getpointatdist dc (- a1 (* i dis)))
				   par (vlax-curve-getparamatpoint dc p1)
				   vtt (vlax-curve-getFirstderiv dc par)
			 )
			 (if (/= (car vtt) 0)
				 (setq gr (atan (/ (cadr vtt) (car vtt))))
			 )
			 (if (> (car vtt) 0)
				 (setq gr (+ pi gr))
			 )
			 (setq gd (/ (* gr 180) pi))
			 (command "insert" bn "r" gd p1 "" "" "")
			 (if (and (> gd 90) (< gd 270))
				 (setq gd (+ gd 180))
			 )
			 (if (/= (atoi t2) nil)
				 (setq t4 (+ i (atoi t2) 1))
				 (setq t4 100)
			 )
			 (if (or (> (ascii t3) 67) (< (ascii t3) 65))
				 (setq t5 (chr 65))
				 (setq t5 t3)
			 )
			 (if (= 0 (rem i 3))
				 (setq t5 (chr (+ (ascii t5) 1)))
				 (if (= 1 (rem i 3))
					 (setq t5 (chr (+ (ascii t5) 2)))
				 )
			 )
			 (setq pt1 (list (+ (car p1) a) (+ (cadr p1) b)))
			 (command "layer" "m" lt "" "")
			 (Command "style" st "txt.shx" "0" "1" "0" "n" "n" "n")
			 (command "text" pt1 h gd (strcase (strcat t1 (itoa t4) t5) nil))
			 (setq i (1+ i))

	   )
 )
 (progn
	   (while (<= (+ a1 (* i dis)) lth)
			  (setq p1 (vlax-curve-getpointatdist dc (+ a1 (* i dis)))
					par (vlax-curve-getparamatpoint dc p1)
					vtt (vlax-curve-getFirstderiv dc par)
			  )
			  (if (/= (car vtt) 0)
				  (setq gr (atan (/ (cadr vtt) (car vtt))))
			  )
			  (if (< (car vtt) 0)
				  (setq gr (+ pi gr))
			  )
			  (setq gd (/ (* gr 180) pi))
			  (command "insert" bn "r" gd p1 "" "" "") 
			  (if (and (> gd 90) (< gd 270))
				  (setq gd (+ gd 180))
			  )
			  (if (/= (atoi t2) nil)
				  (setq t4 (+ i (atoi t2) 1))
				  (setq t4 100)
			  )
			  (if (or (> (ascii t3) 67) (< (ascii t3) 65))
				  (setq t5 (chr 65))
				  (setq t5 t3)
			  )
			  (if (= 0 (rem i 3))
				  (setq t5 (chr (+ (ascii t5) 1)))
				  (if (= 1 (rem i 3))
					  (setq t5 (chr (+ (ascii t5) 2)))
				  )
			  )
			  (setq pt1 (list (+ (car p1) a) (+ (cadr p1) b)))
			  (command "layer" "m" lt "" "")
			  (Command "style" st "txt.shx" "0" "1" "0" "n" "n" "n")
			  (command "text" pt1 h gd (strcase (strcat t1 (itoa t4) t5) nil))
			  (setq i (1+ i))
	   )
 )
)

)

 

Chúc bạn vui.

 

 

cảm ơn bạn Bình rất nhiều tớ đã dùng thử, đúng như bạn nói các vấn đề hầu như đã đc giải quyết, chỉ còn vấn đề về text và vụ kô có được cái text T1/L1-1A, hi vọng bạn sớm giải quyết được.1 lần nữa cảm ơn bạn rất nhiều :cheers:

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
cảm ơn bạn Bình rất nhiều tớ đã dùng thử, đúng như bạn nói các vấn đề hầu như đã đc giải quyết, chỉ còn vấn đề về text và vụ kô có được cái text T1/L1-1A, hi vọng bạn sớm giải quyết được.1 lần nữa cảm ơn bạn rất nhiều :)

 

 

ah bạn Bình có thể tách cho mình từ cái lisp IDO ấy ra cho mình 1 cái lisp mà nó chỉ tự động đánh số cột đèn từ T1/L1-1A,T1/L1-2B,T1/L1-3C,T1/L1-4A,T1/L1-5B.....vì các block đã có sẵn từ trước rồi ( đã me block hết rồi chỉ thiếu mỗi text thôi ), thật ngại wa đúng là đc voi đòi tiên :) mình có sẵn 1 lisp tương tự như thế rồi nhưng nó lại bắt mình pick từng điểm cho mỗi 1 text :cheers: nó đây :

 

;;;===================================================================

;;; Danh so cot den:

(defun c:dsc (/ ang x y ent tg tg1tg2 num_r

num_c num_inc dis_r dis_c num top idnum

dx dy bottom inc tgnum attr attr_ent

t_base b_base locat value deci stnum loca1 loca2

tt count inctg inctg1 bpoint mx my nx

ny bx by

)

(setq idnum 0)

(while (/= idnum 1)

(setq ent (entsel "\nHay lua chon so ma ban muon copy : "))

(if ent

(progn

(setq e (car ent))

(setq tg (entget e))

(if (= (cdr (assoc 0 tg)) "TEXT")

(setq idnum 1)

)

)

(princ)

)

)

 

(setq num_inc (getreal "\nHay nhap he so tang giam <1> : "))

(if (= num_inc nil)

(setq num_inc 1)

)

 

(setq bpoint (getpoint "\nChon diem goc de copy : "))

(setq x (car bpoint))

(setq y (car (cdr bpoint)))

 

(if (and (= (cdr (assoc 72 tg)) 0) (= (cdr (assoc 73 tg)) 0))

(progn

(setq bx (car (cdr (assoc 10 tg))))

(setq by (car (cdr (cdr (assoc 10 tg)))))

)

(progn

(setq bx (car (cdr (assoc 11 tg))))

(setq by (car (cdr (cdr (assoc 11 tg)))))

)

)

 

(setq attr (cdr tg))

(setq tg (cdr (assoc 1 tg)))

(setq inc 0)

(setq tg1 "")

(setq t_base "")

(setq b_base "")

(setq idnum 0)

(setq top 0)

(setq bottom 0)

(setq stnum "")

(setq deci 0)

(repeat (strlen tg)

(if

(or (and (> (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))

47

) ;(chr 32)

(< (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))

58

)

)

 

(= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))

32

)

 

(= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))

46

)

)

(progn

(if (= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))

46

)

(setq deci inc)

)

(if (= inc 0)

(progn

(setq idnum 1)

(if

(= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))

46

)

(setq b_base (strcat "." b_base))

)

)

)

(if (= bottom 1)

(progn (setq bottom 0) (setq idnum 1) (setq top 1))

)

(if (and (= idnum 0) (= top 1))

(setq t_base (strcat tgnum t_base))

)

(if (= idnum 1)

(progn

(if (and (= tgnum "0") (> inc 0))

(setq stnum (strcat stnum "0"))

(setq stnum "")

)

(setq tg1 (strcat tgnum tg1))

)

)

)

(if (= inc 0)

(progn

(setq b_base (strcat tgnum b_base))

(setq bottom 1)

)

(if (= bottom 1)

(setq b_base (strcat tgnum b_base))

(progn

(setq top 1)

(setq t_base (strcat tgnum t_base))

(if (= idnum 1)

(setq idnum 0)

)

)

)

)

)

(setq inc (+ inc 1))

)

 

(if (= tg1 "")

(exit)

)

(setq num (atof tg1))

(setq count 1)

 

(while (setq bpoint (getpoint "\nChon diem copy tiep theo : "))

(setq num (+ num num_inc))

(if (>= (strlen b_base) 1)

(cond

((or (= "A"

(strcase (substr b_base (strlen b_base) 1))

)

(= "B"

(strcase (substr b_base (strlen b_base) 1))

)

)

(setq b_base

(strcat

(substr b_base 1 (1- (strlen b_base)))

(chr (1+ (ascii (substr b_base (strlen b_base) 1))))

)

)

)

((= "C" (strcase (substr b_base (strlen b_base) 1)))

(setq

b_base (strcat (substr b_base 1 (1- (strlen b_base))) "A")

)

)

)

 

)

(setq value (strcat t_base (strcat stnum (rtos num 2 deci)) b_base))

(setq nx (car bpoint))

(setq ny (car (cdr bpoint)))

(setq dx (- nx x))

(setq dy (- ny y))

(setq mx (car (getvar "ucsxdir")))

(setq my (car (cdr (getvar "ucsxdir"))))

(setq loca1 (+ bx (* mx dx)))

(setq loca2 (+ by (* my dx)))

(setq mx (car (getvar "ucsydir")))

(setq my (car (cdr (getvar "ucsydir"))))

(setq loca1 (+ loca1 (* mx dy)))

(setq loca2 (+ loca2 (* my dy)))

(setq attr_ent (subst (cons 1 value) (assoc 1 attr) attr))

(if (and (= (cdr (assoc 72 attr_ent)) 0)

(= (cdr (assoc 73 attr_ent)) 0)

)

(setq attr_ent (subst (list 10 loca1 loca2 0)

(assoc 10 attr_ent)

attr_ent

)

)

(setq attr_ent (subst (list 11 loca1 loca2 0)

(assoc 11 attr_ent)

attr_ent

)

)

)

(entmake attr_ent)

(setq count (+ count 1))

) ;end while

(princ)

)

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
chào các bác. Em muốn viết một cái lisp để vẽ biên dạng có phương trình:

x=(r1-r2)*sin(a)+r3*sin(a)

y=(r1-r2)*cos(a)-r3*cos(a)

bác nào viết giúp em với. Em làm mãi ma không ra

Cám ơn các bác nhiều

Chào bạn Cuong_gtvt,

Bạn thử xài cái củ lisp mót này của mình xem nhé. Thú thực là mình mót của bác SSG đó. Sau khi gặm xong, tiêu hóa rồi thì được cái lisp này. Được cái nó cũng hơi dễ tiêu nên mới dám post lên đây. Nếu bạn thấy nặng ụng thì cứ post lên, sẽ có thuốc giải ngay bạn nhé. Chúc bạn vui, khỏe và thành đạt.

Củ ấy đây:

(defun c:vhs ()
(setq Oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq r1 (getreal "\n Nhap gia tri R1 : ")
  r2 (getreal "\n Nhap gia tri R2 : ")
  r3 (getreal "\n Nhap gia tri R3 : ")
  b (getreal "\ Nhap gia tri buoc nhay : ")
  a 0
  i 0
  pt (getpoint "\n Chon diem goc ")
  lstpt (list)
)
(while (	   (setq x (+ (* (- r1 r2) (sin a)) (* (sin a) r3))
		 y (- (* (- r1 r2) (cos a)) (* (cos a) r3))
		 p (list (+ (car pt) x) (+ (cadr pt) y))
		 lstpt (append (list p) lstpt)
		;;; p (command "point" p)
		 i (1+ i)
		 a (* i b)
   )
)
(command "pline") 
(foreach x Lstpt (command x)) 
(command "c")
(setvar "osmode" Oldos)
(princ)
)

Lệnh là VHS, vì ở đây dùng lệnh pline nên đường nối không được nhuyễn lắm. Bạn càng giảm bước nhảy thì nó sẽ càng nhuyễn bạn nhé. Hy vọng nó làm bạn hài lòng.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
ah bạn Bình có thể tách cho mình từ cái lisp IDO ấy ra cho mình 1 cái lisp mà nó chỉ tự động đánh số cột đèn từ T1/L1-1A,T1/L1-2B,T1/L1-3C,T1/L1-4A,T1/L1-5B.....vì các block đã có sẵn từ trước rồi ( đã me block hết rồi chỉ thiếu mỗi text thôi ), thật ngại wa đúng là đc voi đòi tiên :) mình có sẵn 1 lisp tương tự như thế rồi nhưng nó lại bắt mình pick từng điểm cho mỗi 1 text :cheers: nó đây :

Chào bạn nguyenkhoadung98,

Rất vui vì thấy bạn dùng được cái lisp của mình. Về cái vụ vị trí text thì quả thực là mình cũng đang hơi rối, chưa tìm được giải pháp bạn ạ. Còn cái text T2/L1-1A thực ra chỉ khó nếu như bạn đã đặt nó vào đường chuẩn rồi thôi. Nếu như bạn chưa đặt nó vào thì như mình đã viết trong bài trước, chỉ chỉnh tí xíu là OK ngay. Tại mình cứ theo cái hình bạn post lên nên sợ có hai cột cùng số đó mà thôi. Nếu như bạn đặt cái text ấy và cái block d0 ra ngoài đường chuẩn thì mình đã sửa cái lisp rồi. Bạn sửa như sau nhé:

1/- Trong các dòng code (setq t4 (+ i (atoi t2) 1)) bạn xóa béng cái con số 1 đi. Nhớ là chỉ xóa số 1 chứ đừng xóa đi bất cứ dấu ngoặc nào nha.

2/- Trong các dòng code (if (= 0 (rem i 3)) bạn thay số 1 vào vị trí số 0

3/- Trong các dòng code (if (= 1 (rem i 3)) bạn thay số 2 vào vị trí số 1

Lúc này kết quả chạy ra sẽ có các text bắt đầu là T2/L1-1A và tăng dần đến cuối cùng như bạn muốn. Và như vậy bạn có thể chọn điểm bắt đấu từ bất cứ vị trí nào trên đường chuẩn của bạn, các block cột sẽ được bắt đầu chèn từ vị trí đó theo hướng từ trái qua phải bạn ạ.

 

Về cái việc đòi tiên thì ai chả muốn. Mình cũng muốn lắm chớ. Mỗi tội hơi khó kiếm thôi bạn ạ. Cái cô tiên bạn muốn hơi khó tính đấy. Này nhé:

1/- Vì các block đã được chèn sẵn rồi nên việc xác định thứ tự các block này không hề đơn giản bạn ạ. Nhất là khi bản vẽ lại do người khác cung cấp. Đấy cũng chính là lý do mà cái lisp của bạn lại yêu cầu người dùng phải nhập lại thứ tự các điểm chèn để mà đánh số cho đúng trật tự bạn ạ. Bởi vì rất có thể cái block cột thứ 6 lại được insert trước thằng block cột thứ nhất ấy chứ.

2/- Khoảng cách giữa các block có được biết chính xác hay không hay phải mò từng chú một.

3/- Về vị trí đặt text cũng gặp rắc rối y như trường hợp trên bạn ạ.

 

Vậy nên mình thiển nghĩ thế này: Chả có tiên thì ni cô cũng xài tạm vậy, cách xài như sau

Nếu như bạn đã biết chính xác cái khoảng cách giữa các block là như nhau và biết được chính xác cái điểm chèn của block đấu tiên thì bạn hoàn toàn có thể xài cái củ lisp mà mình đã biếu bạn với chút xíu công phu như sau:

1/- Bạn gõ giùm mình ba hay bốn cái dấu ; vào trước các dòng code (command "insert" bn "r" gd p1 "" "" "") để nó trở thành ;;;;(command "insert" bn "r" gd p1 "" "" "") .

2/- Bạn load lisp và chạy nó y sì như các thao tác cũ chỉ lưu ý rằng chọn đúng cái điểm chèn đầu tiên của cái block mà bạn muốn bắt đầu đánh số và nhập đúng cái khoảng cách giữa các block đã được chèn. Vậy là khi chạy lisp nó sẽ "quên béng cái việc insert block cột của bạn mà chỉ nhăm nhăm đánh số thôi bạn ạ. Và nó cũng sẽ đánh số i sì phóoc như bạn muốn

3/- Sau khi xài xong, bạn chịu khó xóa sạch mấy cái dấu ; đi là lisp lại trở về nguyên trạng bạn ạ. Vậy là khỏi phải lo tậu thêm lisp mới cho nặng máy bạn nhé.

 

Hì hì, vì mình chuyên đi mót nên bày bạn cái cách hơi củ chuối này. Bạn đừng giận nếu bạn không muốn xài thế nhé. Cái cách tuy củ chuối nhưng được việc ra phết bạn ạ. Ít ra nó cũng cứu đói được cho mình nhiều phen rồi bạn ạ.

 

Hy vọng bạn sẽ bật cười khi xài cái cách này. Mong bạn thành công

 

PS: bạn nguyenkhoadung ơi, lúc nào bạn ranh rảnh chỉ mình cách xài cái lệnh ME với nhé. Mình xài cad2004 mà chả biết mò cái đó ra sao. Thấy bạn xài tới tới mà ham quá à. Thanks bạn trước nha.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Mình đã viết thử ct và chạy thử. Tuy nhiên ngoài những điểm bắt đúng theo yêu cầu thì nó còn bắt thêm vài điểm khác. Có lẽ do cách bắt điểm của ACAD. Mình chưa biết cách khắc phục chuyện đó. Tuy vậy bạn có thể dùng tạm ct này, dù sao còn đõ hơn rà cả bản vẽ bằng mắt. Tên lệnh là chk.

 

(defun c:chk()

 

(defun ints (e1 e2 / ob1 ob2 V L1 L2)

;;;Intersections of e1, e2. Return LIST of points

;;;Thank Mr. Hoanh for this function!

(setq

ob1 (vlax-ename->vla-object e1)

ob2 (vlax-ename->vla-object e2)

)

(setq V (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendBoth)))

(if (/= (vlax-safearray-get-u-bound V 1) -1)

(progn

(setq L1 (vlax-safearray->list V) L2 nil)

(while L1

(setq L2 (append L2 (list (list (car L1) (cadr L1) (caddr L1)))))

(repeat 3 (setq L1 (cdr L1)))

)

)

(setq L2 nil)

)

L2

)

 

;;;

 

(setq os (getvar "OSMODE"))

(setvar "OSMODE" 0)

(setvar "CLAYER" "layer 2")

(setvar "CECOLOR" "1")

(command "zoom" "e")

(setq ss (ssget "X" '((8 . "layer 2")))

n 0)

 

(repeat (sslength ss)

(setq v0 (ssname ss n)

v (vlax-ename->vla-object v0)

L nil)

 

(if (= (cdr (assoc 0 (entget v0))) "LWPOLYLINE")

(progn

(setq p1 (vlax-curve-getStartPoint v)

p2 (vlax-curve-getEndPoint v)

ss1 (ssget "f" (list p1 p2)))

(if (= (length p1) 2) (setq p1 (append p1 (list 0.0))))

(if (= (length p2) 2) (setq p2 (append p2 (list 0.0))))

 

(if (= (sslength ss1) 1)

(progn

(command "Point" p1)

(command "Point" p2))

(progn

(if (ssmemb v0 ss1) (setq ss1 (ssdel v0 ss1)))

(while (> (sslength ss1) 0)

(setq L (append L (ints v0 (ssname ss1 0)))

ss1 (ssdel (ssname ss1 0) ss1)))

 

(if (not (member p1 L)) (command "Point" p1))

(if (not (member p2 L)) (command "Point" p2)))

)

))

(setq n (1+ n)

)

)

(setvar "OSMODE" os)

)

 

Cám ơn ban q288 nhiệt tình giúp đỡ bọn mình . Chương trình chạy rất tuyệt ! Tuy nhiên thì mình cũng phát hiện ra lỗi đó không biết có đúng không bạn xem lại hộ mình nhé. mình thấy ngoài lỗi bắt chính xác ra, những lỗi kia nó bắt là do không tạo điểm point (end point) ở đó. layer 2 nó chỉ snap vào thì cũng được không cần endpoint ...Bạn chỉnh lại cho giúp mình xem có được không nhé ...

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Chào các bác!

Em đang cần Lisp có khả năng như sau:

1_Chọn "n" đối tượng trên bản vẽ.

2_Đổi màu "n" đối tường này (mỗi đối tượng có một màu mới).

Xin chân thành cảm ơn! Em đang rất cần. :cheers:

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào các bác!

Em ðang cần Lisp có khả nãng nhý sau:

1_Chọn "n" ðối týợng trên bản vẽ.

2_Ðổi màu "n" ðối týờng này (mỗi ðối týợng có một màu mới).

Xin chân thành cảm õn! Em ðang rất cần. :cheers:

Ðây, nhýng chỉ ðổi màu các ðối týợng ðõn giản thôi

(defun C:DOIMAUDT( / ss i j name)
 (setq ss (ssget))
 (if ss (progn
(setq i 0 j 1)
(while (< i (sslength ss))
  (setq name (ssname ss i))
  (command "_.change" name "" "p" "c" j "")
  (setq j (1+ j) i (1+ i))
  (if (= j 256) (setq j 1))
)
 ))
)

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào bạn nguyenkhoadung98,

Rất vui vì thấy bạn dùng được cái lisp của mình. Về cái vụ vị trí text thì quả thực là mình cũng đang hơi rối, chưa tìm được giải pháp bạn ạ. Còn cái text T2/L1-1A thực ra chỉ khó nếu như bạn đã đặt nó vào đường chuẩn rồi thôi. Nếu như bạn chưa đặt nó vào thì như mình đã viết trong bài trước, chỉ chỉnh tí xíu là OK ngay. Tại mình cứ theo cái hình bạn post lên nên sợ có hai cột cùng số đó mà thôi. Nếu như bạn đặt cái text ấy và cái block d0 ra ngoài đường chuẩn thì mình đã sửa cái lisp rồi. Bạn sửa như sau nhé:

1/- Trong các dòng code (setq t4 (+ i (atoi t2) 1)) bạn xóa béng cái con số 1 đi. Nhớ là chỉ xóa số 1 chứ đừng xóa đi bất cứ dấu ngoặc nào nha.

2/- Trong các dòng code (if (= 0 (rem i 3)) bạn thay số 1 vào vị trí số 0

3/- Trong các dòng code (if (= 1 (rem i 3)) bạn thay số 2 vào vị trí số 1

Lúc này kết quả chạy ra sẽ có các text bắt đầu là T2/L1-1A và tăng dần đến cuối cùng như bạn muốn. Và như vậy bạn có thể chọn điểm bắt đấu từ bất cứ vị trí nào trên đường chuẩn của bạn, các block cột sẽ được bắt đầu chèn từ vị trí đó theo hướng từ trái qua phải bạn ạ.

 

Về cái việc đòi tiên thì ai chả muốn. Mình cũng muốn lắm chớ. Mỗi tội hơi khó kiếm thôi bạn ạ. Cái cô tiên bạn muốn hơi khó tính đấy. Này nhé:

1/- Vì các block đã được chèn sẵn rồi nên việc xác định thứ tự các block này không hề đơn giản bạn ạ. Nhất là khi bản vẽ lại do người khác cung cấp. Đấy cũng chính là lý do mà cái lisp của bạn lại yêu cầu người dùng phải nhập lại thứ tự các điểm chèn để mà đánh số cho đúng trật tự bạn ạ. Bởi vì rất có thể cái block cột thứ 6 lại được insert trước thằng block cột thứ nhất ấy chứ.

2/- Khoảng cách giữa các block có được biết chính xác hay không hay phải mò từng chú một.

3/- Về vị trí đặt text cũng gặp rắc rối y như trường hợp trên bạn ạ.

 

Vậy nên mình thiển nghĩ thế này: Chả có tiên thì ni cô cũng xài tạm vậy, cách xài như sau

Nếu như bạn đã biết chính xác cái khoảng cách giữa các block là như nhau và biết được chính xác cái điểm chèn của block đấu tiên thì bạn hoàn toàn có thể xài cái củ lisp mà mình đã biếu bạn với chút xíu công phu như sau:

1/- Bạn gõ giùm mình ba hay bốn cái dấu ; vào trước các dòng code (command "insert" bn "r" gd p1 "" "" "") để nó trở thành ;;;;(command "insert" bn "r" gd p1 "" "" "") .

2/- Bạn load lisp và chạy nó y sì như các thao tác cũ chỉ lưu ý rằng chọn đúng cái điểm chèn đầu tiên của cái block mà bạn muốn bắt đầu đánh số và nhập đúng cái khoảng cách giữa các block đã được chèn. Vậy là khi chạy lisp nó sẽ "quên béng cái việc insert block cột của bạn mà chỉ nhăm nhăm đánh số thôi bạn ạ. Và nó cũng sẽ đánh số i sì phóoc như bạn muốn

3/- Sau khi xài xong, bạn chịu khó xóa sạch mấy cái dấu ; đi là lisp lại trở về nguyên trạng bạn ạ. Vậy là khỏi phải lo tậu thêm lisp mới cho nặng máy bạn nhé.

 

Hì hì, vì mình chuyên đi mót nên bày bạn cái cách hơi củ chuối này. Bạn đừng giận nếu bạn không muốn xài thế nhé. Cái cách tuy củ chuối nhưng được việc ra phết bạn ạ. Ít ra nó cũng cứu đói được cho mình nhiều phen rồi bạn ạ.

 

Hy vọng bạn sẽ bật cười khi xài cái cách này. Mong bạn thành công

 

PS: bạn nguyenkhoadung ơi, lúc nào bạn ranh rảnh chỉ mình cách xài cái lệnh ME với nhé. Mình xài cad2004 mà chả biết mò cái đó ra sao. Thấy bạn xài tới tới mà ham quá à. Thanks bạn trước nha.

 

 

cảm ơn bạn Bình rất nhiều.mình đã thử làm và đã làm được theo chỉ dẫn của bạn,nếu có 1000 lần thanks thì cũng đã bấm cho bạn :cheers:. về cái lệnh ME thì mình vẫn dùng như các lệnh khác ( cad 2007) bạn đánh lệnh ME,chọn đối tượng rồi nó hỏi chọn chiều dài đoạn thẳng cần chia hoặc là chọn block ( mình cần rải block nên chọn là B ) sau đó nó hỏi đánh tên Block cần rải,sau đó nó hỏi có làm cho block vuông góc với đường mình chọn hay kô ( y,n), rồi nó bắt mình nhập khoảng cách giữa các block, vậy là xong. kô bit là cad 2004 có kô nữa ( hình như là có ) :) thanks you bạn nhiều

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào bạn,

Theo như bạn viết thì mình hiểu là bạn muốn cộng tất cả chiều dài các đoạn rồi chỉ viết ra tổng chiều dài thôi, phải vậy không? Nếu như vậy thì mình sửa lại như sau:

 

;;;------------------------------------------------------------------------------------

(defun getTw ()

;;;Get current text width factor

(cdr (assoc 41 (tblsearch "style" (getvar "textstyle"))))

)

;;;------------------------------------------------------------------------------------

(defun getTh (/ Th)

;;;Get current textheight or textsize

(if (= (setq

Th (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))

)

0

)

(getvar "textsize")

Th

)

)

;;;------------------------------------------------------------------------------------

(defun emkT (S p)

;;;Write text S at point p by entmake function

;;;Text style, heigh and width factor get from current values

(entmake (list (cons 0 "TEXT")

(cons 10 p)

(cons 40 (getTh))

(cons 41 (getTw))

(cons 1 S)

(cons 7 (getvar "textstyle"))

)

)

)

;;;------------------------------------------------------------------------------------

(defun calcL (e)

;;;Calculate length of Line, Pline, 3dPoly, Spline, Circle, Arc, Polygon

(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))

)

;;;------------------------------------------------------------------------------------

(defun C:CHD (/ Opt S1 S2 e p L)

(vl-load-com)

(if (not preT)

(setq preT "L=")

)

(if (not sufT)

(setq sufT "")

)

(setq S1 preT

S2 sufT

)

(prompt (strcat

"\nMeasure and write length. Current prefix:["

preT

"]\tSuffix:["

sufT

"]"

)

)

(initget "Y N")

(setq Opt (getkword "\nChange prefix and suffix? [Yes/No] :"))

(if (not Opt)

(setq Opt "N")

)

(if (= Opt "Y")

(progn

(setq

S1 (getstring "\nPrefix :")

preT S1

S2 (getstring "\nSuffix :")

sufT S2

)

)

)

(setq ss (ssget)

n 0

total 0

)

 

(repeat (sslength ss)

(setq e (ssname ss n)

L (calcL e)

total (+ total L)

n (1+ n)

)

)

(setq p (getpoint "\nBase point: "))

(emkT S1 p)

(emkT (strcat " " (rtos total) S2) p)

 

(princ)

)

 

Bạn chạy thử xem có đúng ý bạn không, nếu không thì sửa tiếp. Chào bạn

 

Chào q288!

Cái này thì ok rồi nhưng mình muốn hoàn thiện hơn chút xíu bạn giúp mình với nha.

Mình muốn sau khi ghi kích thước thứ nhất thì mình có thể chọn tiếp các đoạn khác để ghi tiếp chứ không cần phải kích lệnh thêm lần nữa, vì mình cần tính chiều dài của nhiều đoạn mà mỗi lần lai đánh lệnh lại từ đầu, rồi nó lại hỏi preix and suffix thấy cũng bất tiện.

Nhân tiện cho mình hỏi thêm nha, hôm trước minh dung thì ok nhung mấy hôm nay dung thì nó ghi kích thước tại vị trí rất xa so với chỗ mình click (điểm cần ghi). Giúp mình với nhé!

Thank!

Chúc sức khoẻ!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Cám ơn ban q288 nhiệt tình giúp đỡ bọn mình . Chương trình chạy rất tuyệt ! Tuy nhiên thì mình cũng phát hiện ra lỗi đó không biết có đúng không bạn xem lại hộ mình nhé. mình thấy ngoài lỗi bắt chính xác ra, những lỗi kia nó bắt là do không tạo điểm point (end point) ở đó. layer 2 nó chỉ snap vào thì cũng được không cần endpoint ...Bạn chỉnh lại cho giúp mình xem có được không nhé ...

 

Mình tìm ra lỗi và sửa rồi. Chạy trong file_mau.dwg thì ok. Bạn thử chạy các file khác xem sao, chọn file lớn hơn và nhiều pline hơn để thử nhiều tình huống. CT sửa như sau:

 

(defun c:chk (/ os ss v0 v L p1 p2 ss1 n)

 

;;;Intersections of e1, e2. Return LIST of points

;;;Thank Mr. Hoanh for this function!

(defun ints (e1 e2 / ob1 ob2 V L1 L2)

(setq ob1 (vlax-ename->vla-object e1)

ob2 (vlax-ename->vla-object e2))

(setq V (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendBoth)))

(if (/= (vlax-safearray-get-u-bound V 1) -1)

(progn

(setq L1 (vlax-safearray->list V)

L2 nil)

(while L1

(setq L2 (append L2 (list (list (car L1) (cadr L1) (caddr L1)))))

(repeat 3 (setq L1 (cdr L1)))) )

(setq L2 nil))

L2

)

 

;;; Bat diem

(defun batd(a1 a2 / ss0 s i)

(setq ss0 (ssget "c" (polar a1 (* -0.25 pi) 0.01)

(polar a1 (* 0.75 pi) 0.01))

i 0

s (ssadd))

(repeat (sslength ss0)

(setq s (ssadd (ssname ss0 i) s)

i (1+ i)))

(setq ss0 (ssget "c" (polar a2 (* -0.25 pi) 0.01)

(polar a2 (* 0.75 pi) 0.01))

i 0)

(repeat (sslength ss0)

(setq s (ssadd (ssname ss0 i) s)

i (1+ i)))

s

)

 

;;; Main function

(setq os (getvar "OSMODE"))

(setvar "OSMODE" 0)

(setvar "CLAYER" "layer 2")

(setvar "CECOLOR" "1")

(command "zoom" "e")

(setq ss (ssget "X" '((8 . "layer 2")))

n 0)

 

(repeat (sslength ss)

(setq v0 (ssname ss n)

v (vlax-ename->vla-object v0)

L nil )

 

(if (= (cdr (assoc 0 (entget v0))) "LWPOLYLINE")

(progn

(setq p1 (vlax-curve-getStartPoint v)

p2 (vlax-curve-getEndPoint v)

ss1 (batd p1 p2))

 

(if (and (= (sslength ss1) 1) (ssmemb v0 ss1))

(progn

(command "Point" p1)

(command "Point" p2))

(progn

(setq ss1 (ssdel v0 ss1))

(while (> (sslength ss1) 0)

(setq L (append L (ints v0 (ssname ss1 0)))

ss1 (ssdel (ssname ss1 0) ss1)))

(if (not (member p1 L)) (command "Point" p1))

(if (not (member p2 L)) (command "Point" p2))))))

(setq n (1+ n))

)

(setvar "OSMODE" os)

)

  • Vote tăng 2

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào q288!

Cái này thì ok rồi nhưng mình muốn hoàn thiện hơn chút xíu bạn giúp mình với nha.

Mình muốn sau khi ghi kích thước thứ nhất thì mình có thể chọn tiếp các đoạn khác để ghi tiếp chứ không cần phải kích lệnh thêm lần nữa, vì mình cần tính chiều dài của nhiều đoạn mà mỗi lần lai đánh lệnh lại từ đầu, rồi nó lại hỏi preix and suffix thấy cũng bất tiện.

Nhân tiện cho mình hỏi thêm nha, hôm trước minh dung thì ok nhung mấy hôm nay dung thì nó ghi kích thước tại vị trí rất xa so với chỗ mình click (điểm cần ghi). Giúp mình với nhé!

Thank!

Chúc sức khoẻ!

 

Bạn muốn dùng vòng lặp thì mình sửa lại như dưới đây. Khi nào bạn muốn thoát ra vòng lặp thì đánh enter. Còn text nằm không đúng vị trí thì chắc do bạn đặt ucs khác với world, mình cũng thêm vào ct một dòng để chỉnh lại ucs.

 

;;;------------------------------------------------------------------------------------

(defun getTw ()

;;;Get current text width factor

(cdr (assoc 41 (tblsearch "style" (getvar "textstyle"))))

)

;;;------------------------------------------------------------------------------------

(defun getTh (/ Th)

;;;Get current textheight or textsize

(if (= (setqTh (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))) 0)

(getvar "textsize")

Th

)

)

;;;------------------------------------------------------------------------------------

(defun emkT (S p)

;;;Write text S at point p by entmake function

;;;Text style, heigh and width factor get from current values

(entmake (list (cons 0 "TEXT")

(cons 10 p)

(cons 40 (getTh))

(cons 41 (getTw))

(cons 1 S)

(cons 7 (getvar "textstyle"))

)

)

)

;;;------------------------------------------------------------------------------------

(defun calcL (e)

;;;Calculate length of Line, Pline, 3dPoly, Spline, Circle, Arc, Polygon

(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))

)

;;;------------------------------------------------------------------------------------

(defun C:CHD (/ Opt S1 S2 e p L)

(vl-load-com)

(command "ucs" "w")

 

(if (not preT) (setq preT "L="))

(if (not sufT) (setq sufT ""))

(setq S1 preT

S2 sufT)

(prompt (strcat "\nMeasure and write length. Current prefix:[" preT "]\tSuffix:[" sufT "]"))

 

(initget "Y N")

(setq Opt (getkword "\nChange prefix and suffix? [Yes/No] :"))

(if (not Opt) (setq Opt "N"))

(if (= Opt "Y")

(setq S1 (getstring "\nPrefix :")

preT S1

S2 (getstring "\nSuffix :")

sufT S2))

 

(setq ss (ssget)

n 0

total 0)

 

(while ss

(repeat (sslength ss)

(setq e (ssname ss n)

L (calcL e)

total (+ total L)

n (1+ n))

)

(setq p (getpoint "\nBase point: "))

(emkT S1 p)

(emkT (strcat " " (rtos total) S2) p)

(setq ss (ssget)

n 0

total 0)

)

(princ)

)

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Mình tìm ra lỗi và sửa rồi. Chạy trong file_mau.dwg thì ok. Bạn thử chạy các file khác xem sao, chọn file lớn hơn và nhiều pline hơn để thử nhiều tình huống. CT sửa như sau:

 

(defun c:chk (/ os ss v0 v L p1 p2 ss1 n)

 

;;;Intersections of e1, e2. Return LIST of points

;;;Thank Mr. Hoanh for this function!

(defun ints (e1 e2 / ob1 ob2 V L1 L2)

(setq ob1 (vlax-ename->vla-object e1)

ob2 (vlax-ename->vla-object e2))

(setq V (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendBoth)))

(if (/= (vlax-safearray-get-u-bound V 1) -1)

(progn

(setq L1 (vlax-safearray->list V)

L2 nil)

(while L1

(setq L2 (append L2 (list (list (car L1) (cadr L1) (caddr L1)))))

(repeat 3 (setq L1 (cdr L1)))) )

(setq L2 nil))

L2

)

 

;;; Bat diem

(defun batd(a1 a2 / ss0 s i)

(setq ss0 (ssget "c" (polar a1 (* -0.25 pi) 0.01)

(polar a1 (* 0.75 pi) 0.01))

i 0

s (ssadd))

(repeat (sslength ss0)

(setq s (ssadd (ssname ss0 i) s)

i (1+ i)))

(setq ss0 (ssget "c" (polar a2 (* -0.25 pi) 0.01)

(polar a2 (* 0.75 pi) 0.01))

i 0)

(repeat (sslength ss0)

(setq s (ssadd (ssname ss0 i) s)

i (1+ i)))

s

)

 

;;; Main function

(setq os (getvar "OSMODE"))

(setvar "OSMODE" 0)

(setvar "CLAYER" "layer 2")

(setvar "CECOLOR" "1")

(command "zoom" "e")

(setq ss (ssget "X" '((8 . "layer 2")))

n 0)

 

(repeat (sslength ss)

(setq v0 (ssname ss n)

v (vlax-ename->vla-object v0)

L nil )

 

(if (= (cdr (assoc 0 (entget v0))) "LWPOLYLINE")

(progn

(setq p1 (vlax-curve-getStartPoint v)

p2 (vlax-curve-getEndPoint v)

ss1 (batd p1 p2))

 

(if (and (= (sslength ss1) 1) (ssmemb v0 ss1))

(progn

(command "Point" p1)

(command "Point" p2))

(progn

(setq ss1 (ssdel v0 ss1))

(while (> (sslength ss1) 0)

(setq L (append L (ints v0 (ssname ss1 0)))

ss1 (ssdel (ssname ss1 0) ss1)))

(if (not (member p1 L)) (command "Point" p1))

(if (not (member p2 L)) (command "Point" p2))))))

(setq n (1+ n))

)

(setvar "OSMODE" os)

)

 

Chào q288 lisp này của bạn bi lỗi khi đánh lệnh nhu sau :

 

Command: chk

zoom

Specify corner of window, enter a scale factor (nX or nXP), or

[All/Center/Dynamic/Extents/Previous/Scale/Window/Object] : e

Command: ; error: no function definition: VLAX-ENAME->VLA-OBJECT

 

Mình chạy trên cad2006 thì ok nhưng sang bên cad 2008 thì nó báo lỗi nhu vậy và sang một số máy cad khác cao hơn 2006 nó cũng báo lỗi nh vậy ...Bạn xem cho mình voi nhé ! Mình cũng đang cần cái nay lắm.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Bạn muốn dùng vòng lặp thì mình sửa lại như dưới đây. Khi nào bạn muốn thoát ra vòng lặp thì đánh enter. Còn text nằm không đúng vị trí thì chắc do bạn đặt ucs khác với world, mình cũng thêm vào ct một dòng để chỉnh lại ucs.

 

;;;------------------------------------------------------------------------------------

(defun getTw ()

;;;Get current text width factor

(cdr (assoc 41 (tblsearch "style" (getvar "textstyle"))))

)

;;;------------------------------------------------------------------------------------

(defun getTh (/ Th)

;;;Get current textheight or textsize

(if (= (setqTh (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))) 0)

(getvar "textsize")

Th

)

)

;;;------------------------------------------------------------------------------------

(defun emkT (S p)

;;;Write text S at point p by entmake function

;;;Text style, heigh and width factor get from current values

(entmake (list (cons 0 "TEXT")

(cons 10 p)

(cons 40 (getTh))

(cons 41 (getTw))

(cons 1 S)

(cons 7 (getvar "textstyle"))

)

)

)

;;;------------------------------------------------------------------------------------

(defun calcL (e)

;;;Calculate length of Line, Pline, 3dPoly, Spline, Circle, Arc, Polygon

(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))

)

;;;------------------------------------------------------------------------------------

(defun C:CHD (/ Opt S1 S2 e p L)

(vl-load-com)

(command "ucs" "w")

 

(if (not preT) (setq preT "L="))

(if (not sufT) (setq sufT ""))

(setq S1 preT

S2 sufT)

(prompt (strcat "\nMeasure and write length. Current prefix:[" preT "]\tSuffix:[" sufT "]"))

 

(initget "Y N")

(setq Opt (getkword "\nChange prefix and suffix? [Yes/No] :"))

(if (not Opt) (setq Opt "N"))

(if (= Opt "Y")

(setq S1 (getstring "\nPrefix :")

preT S1

S2 (getstring "\nSuffix :")

sufT S2))

 

(setq ss (ssget)

n 0

total 0)

 

(while ss

(repeat (sslength ss)

(setq e (ssname ss n)

L (calcL e)

total (+ total L)

n (1+ n))

)

(setq p (getpoint "\nBase point: "))

(emkT S1 p)

(emkT (strcat " " (rtos total) S2) p)

(setq ss (ssget)

n 0

total 0)

)

(princ)

)

Chào q288!

Dùng cái này khi mình kích điểm thì nó lại báo lối thế này: Base point: ; error: no function definition: SETQTH

Giúp mình nhé!

Thank!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào q288 lisp này của bạn bi lỗi khi đánh lệnh nhu sau :

 

Command: chk

zoom

Specify corner of window, enter a scale factor (nX or nXP), or

[All/Center/Dynamic/Extents/Previous/Scale/Window/Object] : e

Command: ; error: no function definition: VLAX-ENAME->VLA-OBJECT

 

Mình chạy trên cad2006 thì ok nhưng sang bên cad 2008 thì nó báo lỗi nhu vậy và sang một số máy cad khác cao hơn 2006 nó cũng báo lỗi nh vậy ...Bạn xem cho mình voi nhé ! Mình cũng đang cần cái nay lắm.

 

Bạn thêm dòng (vl-load-com) ở đầu ct thì sẽ chạy tốt.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Khách
Chủ đề này bây giờ đã bị đóng lại để trả lời thêm.

×