Jump to content
InfoFile
Tác giả: ut_cung
Bài viết gốc: 96085
Tên lệnh: xkl
Viết lisp theo yêu cầu [phần 2]
Vừa hay, mới vừa viết xong Code cho Út. Tuy nhiên, không hiểu sao Lisp chạy lần đầu tiên thì không có kết quả. Chạy lần thứ hai trở đi thì OK

Út hãy thử với Code này :...

>>
Vừa hay, mới vừa viết xong Code cho Út. Tuy nhiên, không hiểu sao Lisp chạy lần đầu tiên thì không có kết quả. Chạy lần thứ hai trở đi thì OK

Út hãy thử với Code này :

(defun c:xkl(/ doc ss Lptext Lpxtext Ltt sset st fname i team)
 (setq doc (vla-get-activedocument (vlax-get-acad-object))
sset (vla-get-activeselectionset doc)
st (getint "\n So Text tren 1 hang :"))
 (setq ss (ssget '((0 . "TEXT"))) Lptext '() Lpxtext '() Ltt '() i 0)
 (vlax-for x sset
   (setq Lptext (cons (cons  (vlax-get x 'InsertionPoint)
			 (vlax-get x 'Textstring)
		) Lptext))
 )
 (setq Lptext (vl-sort Lptext '(lambda (x y) (> (cadar x) (cadar y)))))
 (Repeat (fix  (/ (length Lptext) st))
   	   (setq Ltt (removeL (* st i) (1- (* st (1+ i))) Lptext))
  (setq Lpxtext (append Lpxtext (list Ltt)))
  (setq i (1+ i))
   )
 (if (setq fName (getfiled "Chon file" (getvar "dwgprefix") "txt" 1))
   (progn
     (setq fName (open fName "a"))
     (foreach x Lpxtext
(setq team "")
(foreach y x
    (setq team (strcat team "  " (cdr y)))
)
(write-line team fName)
      )
     )
     (close fName))
 (vla-delete sset)	
 (princ)
 )
;;;;;;;;;;
(defun removeL(d c L)
(reverse
 (member (nth c L)
 	(reverse (member (nth d L) L))
 )
)
)

Chào thanhliemvqh : file kết quả của bạn upload có vấn đề : không load về được.

Trước đây thanhliem có gửi 1 yêu cầu như yêu cầu này, Tue_NV thấy kết quả bạn nội suy, theo Tue_NV được biết thì nội suy tuyến tính (theo tam giác đồng dạng) nhưng sao kết quả mình tính sao không thấy giống????

-> Bạn thử minh hoạ 1 cái cốt hố ga mà bạn cần đánh (công thức tính) nội suy, kết quả xuất qua file .dwg 1 cách cụ thể nhé.

 

thanks bác Tuệ nhiều nhiều, ut đã chạy thử thấy rất tốt. một lần nữa cảm ơn Bác nha!


<<

Filename: 96085_xkl.lsp
Tác giả: hdt4151
Bài viết gốc: 96262
Tên lệnh: cs
Viết lisp theo yêu cầu [phần 2]
Viết lại cho bạn nè :

(defun c:cs(/ ss sx lis1 lis2 n i nn mm li li1)
(vl-load-com)
(setq ss (ssget '((0 . "TEXT"))))
(setq sx (ssget '((0 . "TEXT"))))
(setq lis1 (vl-remove-if...
>>
Viết lại cho bạn nè :

(defun c:cs(/ ss sx lis1 lis2 n i nn mm li li1)
(vl-load-com)
(setq ss (ssget '((0 . "TEXT"))))
(setq sx (ssget '((0 . "TEXT"))))
(setq lis1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lis2 (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx))))
(setq lis1 (vl-sort lis1 '(lambda (x y) 
		(< (cadr (assoc 10 (entget x)))
		   (cadr (assoc 10 (entget y)))
		)
	     )
    )
)
(setq lis2 (vl-sort lis2 '(lambda (x y) 
		(< (cadr (assoc 10 (entget x)))
		   (cadr (assoc 10 (entget y)))
		)
	     )
    )
)	
(setq n (sslength ss) i 0)

(if (= (length lis1) (length lis2))
(progn
  (while (< i (length lis1))

(setq nn (entget (nth i lis1)))
(setq mm (entget (nth i lis2)))

(setq li (cdr (assoc 1 nn)))

(setq li1 (cdr (assoc 1 mm)))
(setq nn (subst (cons 1 li1) (assoc 1 nn) nn))
(setq mm (subst (cons 1 li) (assoc 1 mm) mm))

(entmod mm)
(entmod nn)
(setq i (+ i 1))

)
)
(alert "\n Hai chuoi khong bang nhau. Lisp khong thuc hien duoc")
)

(princ)

)

Trong code Lisp có kiểm tra sự bằng nhau của 2 chuỗi Text

 

Lisp đổi giá trị của 2 chuỗi text cho nhau.

Mình nhờ bạn đổi lại chút đc k, thay vì sắp xếp các chuỗi text theo X thì bây h đổi lại sắp xếp theo Y :rolleyes:


<<

Filename: 96262_cs.lsp
Tác giả: hoangkimoanh
Bài viết gốc: 402146
Tên lệnh: qqq%C2%A0
Lisp hatch nhanh.

 

=>​

(defun c:qqq  ()
 (command "lweight" 0.09)
 (command "-layer" "m" "Hatch" "c" "8" ""...
>>

 

=>​

(defun c:qqq  ()
 (command "lweight" 0.09)
 (command "-layer" "m" "Hatch" "c" "8" "" "")
 (command "-bhatch" "p" "ansi31" "5" "" pause "")
 (command "lweight" "Bylayer")
 (command "-layer" "s" "0" "")
 (princ))

cảm ơn anh, vậy mà em loay hoay chỗ lày mãi. 


<<

Filename: 402146_qqq%C2%A0.lsp
Tác giả: eng-hiep
Bài viết gốc: 81367
Tên lệnh: po
Viết lisp theo yêu cầu [phần 2]
Bạn cung cấp dữ liệu đầu vào đơn giản quá.

Đây là Lisp xuất ra tọa độ của các point dưới dạng bảng (table) ở dạng đơn giản.

(defun c:po(/...
>>
Bạn cung cấp dữ liệu đầu vào đơn giản quá.

Đây là Lisp xuất ra tọa độ của các point dưới dạng bảng (table) ở dạng đơn giản.

(defun c:po(/ coor doc pt siz);point out
 (vl-load-com)
 (setq doc (vla-get-ActiveDocument(vlax-get-Acad-Object)))
 (print "\nChon Point: ")
 (if (ssget '((0 . "POINT")))
   (progn
     (setq pt (getpoint "\nDiem dat Bang :" )
    siz (* (getvar "dimtxt")(getvar "dimscale")) )
     (vlax-for e (vla-get-ActiveselectionSet doc)	
(setq Coor (vl-princ-to-string (vlax-safearray->list (variant-value (vla-get-Coordinates e))))  )
(vla-addtext (vla-get-modelspace doc) Coor (vlax-3d-point pt) siz)	
(setq pt (polar pt (/ pi -2) (* 2.0 siz)))
);for
     )
   )
 (princ))

Thx bác đã quan tâm :cheers:

 

Em đã dùng thử lisp của bác rồi -rất hay .Nhưng vẫn chưa được như mong muốn : Ý em là khi ta pick vào 1 point thì chương trình sẽ kêu ta đặt tên cho point đó , sau khi chọn xong tất cả các point cần xuất tọa độ thì chương trình sẽ xuất các dữ liệu ấy ( Tên point , Tọa độ X ,Tọa độ Y ) dưới dạng bảng table (lisp của bác chỉ cho ra dưới dạng dấu ngoặc) .


<<

Filename: 81367_po.lsp
Tác giả: tnmtpc
Bài viết gốc: 81383
Tên lệnh: mpt
Viết lisp theo yêu cầu [phần 2]

Chào thiep

Nếu thiep sử dụng từ "san bằng" thì bài toán trở nên đúng đắn. Còn nếu không sử dụng từ "san bằng" thì point rất dễ nhận cao...

>>
Chào thiep

Nếu thiep sử dụng từ "san bằng" thì bài toán trở nên đúng đắn. Còn nếu không sử dụng từ "san bằng" thì point rất dễ nhận cao độ Z là Text của thằng "hàng xóm". Lisp TIMGAN của bác Hoành không thể áp dụng đúng trong trường hợp của bài toán không gian 3D trong trường hợp này. Phải nhờ tới điều kiện "san bằng để giải quyết.

Tuy nhiên, nếu mà "san bằng" như vậy thì không thể Move các point về cao độ của điểm chèn Text được vì cao độ của điểm chèn Text và điểm chèn Point được đưa về mặt phẳng 0.0 rồi

 

Đây là Lisp mà Tue_NV viết theo ý của thiep :

1. "San bằng" độ cao của tất cả text cao độ và point về mặt phẳng 0.0

2. Sử dụng hàm TIMGAN để tìm Text gần point nhất (vì có thể giữa point và Text có khoảng hở nhất định nào đó)

3. Dựa vào nội dung của Text số : đây là độ cao -> theo ý của thiep : nâng cả text độ cao và point lên độ cao của nội dung text số

Cảm ơn thiep đã gợi ý cho Tue_NV hoàn thành code này. Nếu có gì chưa đúng lắm các bạn có thể góp ý để mình chỉnh sửa lại. Thanks

 

@ tnmtpc : Theo Tue_NV suy luận thì trước khi sử dụng Lisp mà Tue_NV đã viết thì bạn đã sử dụng cái Lisp di chuyển các text sao cho điểm chèn text trùng các point tương ứng rồi, để cho các point và Text trùng nhau rồi, phải không bạn tnmtpc? -> Cái Lisp đó cũng chính là bản chất của Lisp TIMGAN đấy.

 

Đây là code mà Tue_NV đã viết lại theo ý kiến của bạn thiep

(defun c:MPT(/ ss ss2 i j lis p p2 textgan entextgan Ztextgan ent entp 
	lay_point lay_txt)
;copyright by Tue_NV
(command "undo" "be")

(if (= (cdr (assoc 0 (entget 
(setq ename (car (entsel "\nChon Point de lay Layer chua POINT : ")))
	      ))) "POINT")
(setq lay_Point (cdr(assoc 8 (entget ename))))
)

(if (= (cdr (assoc 0 (entget 
(setq ename (car (entsel "\nChon TEXT de lay Layer chua TEXT : ")))
	      ))) "TEXT")
(setq lay_Txt (cdr(assoc 8 (entget ename))))
)

(setq ss (ssget "X" (list (cons 0 "TEXT") (cons 8 lay_txt))) 
i 0 j 0 lis (list) )
(setq ss2 (ssget "X" (list (cons 0 "POINT") (cons 8 lay_Point))) )
(ZO ss) (ZO ss2)

(while (< i (sslength ss))
(setq entp (entget (ssname ss i)) )
(setq p (cdr(assoc 10 entp)))
(setq lis (append lis (list p) )
)

(setq i (1+ i))
)

(while (< j (sslength ss2))
(setq ent (ssname ss2 j))
(setq p2 (cdr(assoc 10 (entget ent))))
(setq textgan (ssget "X" 
		(list 
		(cons 0 "TEXT") 
		(cons 8 lay_txt)
		 (cons 10 (timgan p2 lis)) 
		))) 
(setq entextgan (ssname textgan 0))
(if (distof 
	(cdr(assoc 1 (entget entextgan) )) 2)
	(setq Ztextgan 
	   (distof (cdr(assoc 1 (entget entextgan) )) 2)
	)
	(setq Ztextgan 0.0)
)
	(command "move" ent entextgan "" (list 0 0 (caddr p2)) 
				(list 0 0 Ztextgan)
	)
(setq j (1+ j))
)
(command "undo" "end")
)
;
(defun round(so tp)
(setvar "dimzin" 0)
(atof (rtos so 2 tp))
)
;
(defun ZO(ss / i ent po)
(setq i 0)
(while (< i (sslength ss))
	(setq ent (entget(ssname ss i)))
	(setq po (cdr(assoc 10 ent)))
	(entmod (subst (list 10 (car po) (cadr po) 0.0) 
			(assoc 10 ent) ent
		)
	)
	(setq i (1+ i))
)
)
;
(defun timgan	(p lst / dmin ppluu)
      (foreach pp lst
        (setq d (distance p pp))
        (if (or (not dmin) (> dmin d))
  	(setq dmin d
  	      ppluu pp
  	)
        )
      )
     ppluu
)

Mình download lisp về chạy thấy báo lỗi, hơn nữa có bất tiện là nếu di chuyển cho dấu chấm thập phân của text trùng point thì thì point bị "đè" dưới text không chọn được. Mình thấy lisp trước tuy thêm một bước tùy chọn ZT< ZC nhưng cũng có cái hay của nó


<<

Filename: 81383_mpt.lsp
Tác giả: conghoan1003
Bài viết gốc: 72396
Tên lệnh: gtd
Viết lisp theo yêu cầu [phần 2]

Chào CongHoan, Thiep muốn tìm lại lisp gtd.lsp mà Hoan load được là của tác giả nào mà không thấy. Hoan chỉ giùm nhé

Bây giờ Thiep chỉnh lại lisp ấy đây:

>>
Chào CongHoan, Thiep muốn tìm lại lisp gtd.lsp mà Hoan load được là của tác giả nào mà không thấy. Hoan chỉ giùm nhé

Bây giờ Thiep chỉnh lại lisp ấy đây:

(defun c:gtd (/ ST fn f x1 y1)
 (setq fn (getfiled "Chon file ghi toa do: " "D:/" "tdo" 8))
 (setq f (open fn "a"))
 (setq ST 1)
 (while (setq pt (getpoint "Toa do diem : "))
   (setq x1 (rtos (car pt) 2 4)
  y1 (rtos (cadr pt) 2 4))
   (write-line (strcat (itoa ST) "\t" x1 "\t" y1) f)
   (setq ST (1+ ST))
   (terpri)
 )
 (close f)
 (print)
)

Chào Thiêp! cảm ơn vì một lần nữa đã giúp mình.

Cái này mình sưu tầm được hình như không phải ở cadviet.

Lisp Thiep sửa chạy tốt lắm nhưng mình thấy khi bắt đầu là mở mốt file .tdo. Mình nghĩ để cho nó lưu file thì sẽ hay hơn , vì mối lần làm như thế mình cần một file mới mình nghĩ lưu một file sẽ hay hơn mở một file đã có.

Chúc thiep sức khoẻ!


<<

Filename: 72396_gtd.lsp
Tác giả: gia_bach
Bài viết gốc: 96106
Tên lệnh: xkl
Viết lisp theo yêu cầu [phần 2]
...................

Tuy nhiên, không hiểu sao Lisp chạy lần đầu tiên thì không có kết quả. Chạy lần thứ hai trở đi thì OK

(defun c:xkl(/ doc ss...
>>
...................

Tuy nhiên, không hiểu sao Lisp chạy lần đầu tiên thì không có kết quả. Chạy lần thứ hai trở đi thì OK

(defun c:xkl(/ doc ss Lptext Lpxtext Ltt sset st fname i team)
 (setq doc (vla-get-activedocument (vlax-get-acad-object))
sset (vla-get-activeselectionset doc)
st (getint "\n So Text tren 1 hang :"))
 (setq ss (ssget '((0 . "TEXT"))) Lptext '() Lpxtext '() Ltt '() i 0)
 (vlax-for x sset
.............................

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

Bạn đưa dòng vla-get-activeselectionset ra phía sau ssget :

(defun c:xkl(/ doc ss Lptext Lpxtext Ltt sset st fname i team)

(setq doc (vla-get-activedocument (vlax-get-acad-object))

st (getint "\n So Text tren 1 hang :"))

(setq ss (ssget '((0 . "TEXT"))) Lptext '() Lpxtext '() Ltt '() i 0

sset (vla-get-activeselectionset doc)

)

(vlax-for x sset

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

 

 

Vậy thì xuất lqua Excel luôn. Phiphi hãy thử code này :

........

Bạn tham khảo hàm ghi 1 danh sách (list) ra file Excel.

http://www.cadviet.com/forum/index.php?sho...ost&p=90451


<<

Filename: 96106_xkl.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 350112
Tên lệnh: tinh
Nhờ sữa lisp tính tổng text

Hi vọng đúng ý bạn

 

(defun c:tinh (/ ent i ss sum sum1 t1 t2 txt x)

(command "undo"...

>>

Hi vọng đúng ý bạn

 

(defun c:tinh (/ ent i ss sum sum1 t1 t2 txt x)

(command "undo" "be")

(setvar "cmdecho" 0)

(prompt "\n Chon cac Text de cong:")

(setq ss (ssget '((0 . "TEXT"))))

 

(setq i 0

sum 0

sum1 0)

(while (< i (sslength ss))

(setq ent (entget(ssname ss i))

txt (cdr(assoc 1 ent)))

 

(if (= (substr txt 1 1) "@")

(setq x (vl-string-search "x" txt 1)

t1 (substr txt 2 (1- x))

t2 (substr txt (+ 2 x))

sum1 (* (atof t1) (atof t2)))

(setq sum1 (atof txt))

)

(setq sum (+ sum sum1))

(setq i (1+ i))

)

 

(command "text" (getpoint"\nChon Diem dat Text:") 250 0 (rtos sum 2 1));;;Muon chieu cao chu bao nhieu thi thay doi 250 thanh so khac

(setvar "cmdecho" 1)

(command "undo" "end")

(princ)

)

 

Hi vọng đúng ý bạn

 

(defun c:tinh (/ ent i ss sum sum1 t1 t2 txt x)

(command "undo" "be")

(setvar "cmdecho" 0)

(prompt "\n Chon cac Text de cong:")

(setq ss (ssget '((0 . "TEXT"))))

 

(setq i 0

sum 0

sum1 0)

(while (< i (sslength ss))

(setq ent (entget(ssname ss i))

txt (cdr(assoc 1 ent)))

 

(if (= (substr txt 1 1) "@")

(setq x (vl-string-search "x" txt 1)

t1 (substr txt 2 (1- x))

t2 (substr txt (+ 2 x))

sum1 (* (atof t1) (atof t2)))

(setq sum1 (atof txt))

)

(setq sum (+ sum sum1))

(setq i (1+ i))

)

 

(command "text" (getpoint"\nChon Diem dat Text:") 250 0 (rtos sum 2 1));;;Muon chieu cao chu bao nhieu thi thay doi 250 thanh so khac

(setvar "cmdecho" 1)

(command "undo" "end")

(princ)

)

Hề hề hề,

Hình như chưa đúng với yêu cầu của chủ thớt.


<<

Filename: 350112_tinh.lsp
Tác giả: shikou
Bài viết gốc: 350143
Tên lệnh: tinh
Nhờ sữa lisp tính tổng text

Hi vọng đúng ý bạn

 

(defun c:tinh (/ ent i ss sum sum1 t1 t2 txt x)

(command "undo"...

>>

Hi vọng đúng ý bạn

 

(defun c:tinh (/ ent i ss sum sum1 t1 t2 txt x)

(command "undo" "be")

(setvar "cmdecho" 0)

(prompt "\n Chon cac Text de cong:")

(setq ss (ssget '((0 . "TEXT"))))

 

(setq i 0

sum 0

sum1 0)

(while (< i (sslength ss))

(setq ent (entget(ssname ss i))

txt (cdr(assoc 1 ent)))

 

(if (= (substr txt 1 1) "@")

(setq x (vl-string-search "x" txt 1)

t1 (substr txt 2 (1- x))

t2 (substr txt (+ 2 x))

sum1 (* (atof t1) (atof t2)))

(setq sum1 (atof txt))

)

(setq sum (+ sum sum1))

(setq i (1+ i))

)

 

(command "text" (getpoint"\nChon Diem dat Text:") 250 0 (rtos sum 2 1));;;Muon chieu cao chu bao nhieu thi thay doi 250 thanh so khac

(setvar "cmdecho" 1)

(command "undo" "end")

(princ)

)

Không được bạn ơi! vẫn báo lỗi không tính được!


<<

Filename: 350143_tinh.lsp
Tác giả: vbao
Bài viết gốc: 2305
Tên lệnh: check
Thống kê tấm ốp.
Viết từ hôm trước mà quên chưa up lên cho Vbao.

Lệnh CHECK, sẽ tìm kiếm những cặp text lân cận nhau (khoảng cách bé hơn Lmax) và có độ dốc lớn hơn cho phép...

>>
Viết từ hôm trước mà quên chưa up lên cho Vbao.

Lệnh CHECK, sẽ tìm kiếm những cặp text lân cận nhau (khoảng cách bé hơn Lmax) và có độ dốc lớn hơn cho phép (imax) rồi hiển thị nó trên màn hình bằng các nét màu đỏ.

 

(defun c:check ()
 (defun ss2ent(ss / sodt index lstent)
 (setq
   sodt (cond
   (ss (sslength ss))
   (t 0)
 )
   index 0
 )
 (repeat sodt
   (setq ent (ssname ss index)
  index (1+ index)
  lstent (cons ent lstent)
   )
 )
 (reverse lstent)
)
 (defun ent2p (ent)
   (setq tt (entget ent)
  p  (cdr (assoc 10 tt))
  z  (atof (cdr (assoc 1 tt)))

   )
   (list ent p z)
 )
 (defun getpgoc (/ pp xmax ymax xmin ymin)
   (foreach pp	lsttext
     (setq p (cadr pp)
    x (car p)
    y (cadr p)
     )
     (if (or
    (not xmax)
    (< xmax x)
  )
(setq xmax x)
     )
     (if (or
    (not xmin)
    (> xmin x)
  )
(setq xmin x)
     )
     (if (or
    (not ymax)
    (< ymax y)
  )
(setq ymax y)
     )
     (if (or
    (not ymin)
    (> ymin y)
  )
(setq ymin y)
     )
   )
   (cons (list xmax ymax 0.0) (list xmin ymin 0.0))
 )
 (setq	sstext	(ssget '((0 . "TEXT")))
Lmax	(getdist "\nVao khoang cach Lmax: ")
imax	(getreal "\nVao do doc max imax (%): ")
imax    (/ imax 100.0)
lsttext	(ss2ent sstext)
lsttext (mapcar 'ent2p lsttext)
sotext	(length lsttext)
i	-1
pgoc	(getpgoc)
pmax	(car pgoc)
pmin	(cdr pgoc)
 )
 (defun quadoc	(pp1 pp2 / l)
   (and
     (<= (setq l (distance (cadr pp1) (cadr pp2))) lmax)
     (> l 0.0)
     (>= (/ (abs (- (caddr pp1) (caddr pp2))) l) imax)
   )
 )
 (command ".zoom" pmax pmin)
 (repeat sotext
   (setq j	    -1
  i	    (1+ i)
  pp1	    (nth i lsttext)
  sotextcon (- sotext j 2)
   )
   (repeat sotextcon
     (setq j	(1+ j)
    pp2	(nth j lsttext)
     )
     (if (quadoc pp1 pp2)
(grdraw (cadr pp1) (cadr pp2) 1)
     )
   )
 )
 (princ)
)

 

Một lần nữa xin cảm ơn anh Nguyen Hoanh đã nhiệt tình giúp tôi giải quyết vấn đề trên.


<<

Filename: 2305_check.lsp
Tác giả: kinhcan9988
Bài viết gốc: 291510
Tên lệnh: erc
lisp xóa tất cả các đối tượng trong 1 vùng kín

Mọi người ơi cho mình hỏi cái, mình load được các lisp erc, erc2, eob nhưng đến khi bấm lệnh thì lại không nhận. Mình đã đọc và thử hết các cách sửa nhưng vẫn không được. 

>>

Mọi người ơi cho mình hỏi cái, mình load được các lisp erc, erc2, eob nhưng đến khi bấm lệnh thì lại không nhận. Mình đã đọc và thử hết các cách sửa nhưng vẫn không được. 

 

Đây là lisp bạn cần:

;;;-------------------------------------------------------------(defun c:erC (/ sc cur p0 P1 L1 d L n ssgDEL glength)  (princ "\nFree lisp from www.cadviet.com")  (command "undo" "be")  (setvar "osmode" 0)  (setq	sc	2009	cur	(car (entsel "\nchon duong: "))	glength	(lambda (e) (command ".lengthen" e "") (getvar "perimeter"))	d	(/ (glength cur) sc)	l1	0.0	p0	(vlax-curve-getStartPoint cur)	L	(list p0)  )  (redraw cur 4)  (repeat sc    (setq      l1 (+ l1 d)      p1 (vlax-curve-getPointAtDist cur l1)    )    (setq L (append L (List p1)))  )  (setq ssgDEL (ssget "WP" L))  (setq n 0)  (repeat (sslength ssgDEL)    (entdel (ssname ssgDEL n))    (setq n (1+ n))  )  (command "undo" "end")  (princ "\nChuc cac ban may man va thanh cong - Thiep 0918841230")  (princ))(vl-load-com)
Không phải xóa thủ công nữa nhé.

<<

Filename: 291510_erc.lsp
Tác giả: tien2005
Bài viết gốc: 426660
Tên lệnh: rd2
Lipcad dim + label room. Xin giúp đỡ

Bạn thử xem được không

(DEFUN C:RD2 (/ P1 P2 delta a b)
  (SETQ
    P1	     (GETPOINT "\nPICK 1st CORNER :") ; get the first corner
    P2	     (GETPOINT "\nPICK 2nd CORNER :" p1) ; get the second corner
    delta    (mapcar '- P1 P2)		; function to calculate the length
    dimz     (getvar 'dimzin)		; save current dimzin value
    oldlayer (getvar "CLAYER")		; save current layer
    FLayer  ...
>>

Bạn thử xem được không

(DEFUN C:RD2 (/ P1 P2 delta a b)
  (SETQ
    P1	     (GETPOINT "\nPICK 1st CORNER :") ; get the first corner
    P2	     (GETPOINT "\nPICK 2nd CORNER :" p1) ; get the second corner
    delta    (mapcar '- P1 P2)		; function to calculate the length
    dimz     (getvar 'dimzin)		; save current dimzin value
    oldlayer (getvar "CLAYER")		; save current layer
    FLayer   (tblsearch "LAYER" "DIM TEXT") ; Found "DIM TEXT" layer?
    FStyle   (tblsearch "STYLE" "Text Style")
					; Found "Text Style" Text Style?
    XLength  (rtos (fix (abs (car delta)))) ; horizontal length
    YLength  (rtos (fix (abs (cadr delta)))) ; vertical length

  )					; setq

  (if (and FLayer FStyle)
    ;; if "DIM TEXT" layer and  "Text Style" Text Style are in the drawing, do this
    (progn
      (setvar "CLAYER" "DIM TEXT")	;set layer to "DIM TEXT"
      (setvar 'dimzin 3)
      (if (> XLength Ylength)
	(progn
	  (command
	    "_.Mtext"
	    (mapcar '/ (mapcar '+ P1 P2) '(2 2 2))
	    "_style"
	    "text style"		;
	    "_j"
	    "_mc"
	    "_R"
	    0
	    "_W"
	    65
	    (strcat
	      (rtos (setq a (fix (abs (car delta)))) 4)
	      " x "
	      (rtos (setq b (fix (abs (cadr delta)))) 4)
	      "\n"
	      (rtos (cvunit a "inch" "mm") 2 1)
	      " x "
	      (rtos (cvunit b "inch" "mm") 2 1)
	      " MM"
	    )
	    ""				; content
	  )				; command			  
	)

	(progn
	  (command
	    "_.Mtext"
	    (mapcar '/ (mapcar '+ P1 P2) '(2 2 2))
	    "_style"
	    "text style"		;
	    "_j"
	    "_mc"
	    "_R"
	    0
	    "_W"
	    65
	    (strcat
	      (rtos (setq a (fix (abs (cadr delta)))) 4)
	      " x "
	      (rtos (setq b (fix (abs (car delta)))) 4)
	      "\n"
	      (rtos (cvunit a "inch" "mm") 2 1)
	      " x "
	      (rtos (cvunit b "inch" "mm") 2 1)
	      " MM"
	    )
	    ""				; content
	  )				; command

	)
      )					; end of if
      (setvar "CLAYER" oldlayer)
    )					;progn 

    (progn
      (setvar 'dimzin 3)
      (if (> XLength Ylength)
	(progn
	  (command
	    "_.Mtext"
	    (mapcar '/ (mapcar '+ P1 P2) '(2 2 2))
	    "_j"
	    "_mc"
	    "_R"
	    0
	    "_W"
	    65
	    (strcat
	      (rtos (setq a (fix (abs (car delta)))) 4)
	      " x "
	      (rtos (setq b (fix (abs (cadr delta)))) 4)

	      "\n"
	      (rtos (cvunit a "inch" "mm") 2 1)
	      " x "
	      (rtos (cvunit b "inch" "mm") 2 1)
	      " MM"
	    )
	    ""				; content
	  )				; command			  
	)

	(progn
	  (command
	    "_.Mtext"
	    (mapcar '/ (mapcar '+ P1 P2) '(2 2 2))
	    "_j"
	    "_mc"
	    "_R"
	    0
	    "_W"
	    65
	    (strcat
	      (rtos (setq a (fix (abs (cadr delta)))) 4)
	      " x "
	      (rtos (setq b (fix (abs (car delta)))) 4)
	      "\n"
	      (rtos (cvunit a "inch" "mm") 2 1)
	      " x "
	      (rtos (cvunit b "inch" "mm") 2 1)
	      " MM"
	    )
	    ""				; content
	  )				; command

	)
      )					; end of if     
    )					;progn
  )					;enf of if 
  (setvar 'dimzin dimz)
  (princ)
)					; end of RD

 


<<

Filename: 426660_rd2.lsp
Tác giả: thanhhoa.36
Bài viết gốc: 111379
Tên lệnh: cte
chuyển số liệu text từ cad sang excell
Bạn chạy thử Code này nhé :

(defun c:CTE(/ ss ent sht dtich cthua gchu lst i fname)
;copyright by Tue_NV
(IF (ACET-UTIL-VER)
(PROGN
(iF (setq ss (ssget '((0 . "*POLYLINE") (70 ....
>>
Bạn chạy thử Code này nhé :

(defun c:CTE(/ ss ent sht dtich cthua gchu lst i fname)
;copyright by Tue_NV
(IF (ACET-UTIL-VER)
(PROGN
(iF (setq ss (ssget '((0 . "*POLYLINE") (70 . 1))))
(pROGN (setq i -1 lst '())
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq L (acet-geom-vertex-list ent))
   (if (and (setq sht (ssget "CP" L '((0 . "*TEXT") (8 . "Sothua") (1 . "~**"))))  
   	     (setq dtich (ssget "CP" L '((0 . "*TEXT") (8 . "Dientich") (1 . "*#.#*,*#,#*"))))
   	     (setq cthua (ssget "CP" L '((0 . "*TEXT") (8 . "Text") (1 . "*@*"))))
   	     (setq gchu (ssget "CP" L '((0 . "*TEXT") (8 . "Dientich") (1 . "@@@"))))
)
      (setq lst (vl-sort 
           (append lst
   		     (list
	 	 (mapcar '(lambda(x)
		   		(acet-dxf 1 (entget x))
			   )
    			(apply 'append
		       		(mapcar 'acet-ss-to-list
			       			(list sht sht cthua dtich gchu)
		       		)
			)
   		   	)
	     )
          );append
	 '(lambda (x1 x2) (< (atoi (car x1)) (atoi (car x2))))
	);vl-sort
   	)
    )
 );while
 ;;;;;;;;;;;;;;
(if (setq fName (getfiled "Ten file xuat " (getvar "dwgprefix") "xls" 1))
  (progn
(setq fName (open fName "w"))
(write-line "STT\tSO HIEU THUA\tCHU THUA\tDIEN TICH\tGHI CHU" fname)
(foreach pt lst
   (write-line (strcat (nth 0 pt) "\t" (nth 1 pt) "\t" (nth 2 pt) "\t"
		       (nth 3 pt) "\t" (nth 4 pt)) fName)
)
      (close fName)
  )
)
 ))));PROGN_IF
(setvar "modemacro" "Chuc ban lam viec hieu qua - tue_nvcc@yahoo.com")
(princ)
)

 

Anh ơi sau khi Load Lisp của anh em chạy, khi quét các đối tượng nó hiện lên thông báo

 

Select objects: ; error: no function definition: ACET-GEOM-VERTEX-LIST

 

Đây là lỗi gì vậy anh, em chưa biết về Lisp lắm.

Anh xem hộ em cái nhé !

Xin cảm ơn anh nhiều !


<<

Filename: 111379_cte.lsp
Tác giả: danhgapro
Bài viết gốc: 159943
Tên lệnh: shbv
Lisp đánh số thứ tự bản vẽ tự động?

OK, mình update giúp bạn đây, hy vọng bạn vừa ý

;; free lisp from cadviet.com : ketxu update from @Tue_NV
(defun c:shbv(/ dau...
>>

OK, mình update giúp bạn đây, hy vọng bạn vừa ý

;; free lisp from cadviet.com : ketxu update from @Tue_NV
(defun c:shbv(/ dau tong po po1 ent i pre sotong)
(prompt "\n Danh so hieu ban ve dang n/m ")
(setvar "cmdecho" 0)
(setq pre "< KC, CN KT>: ")
(wtxt pre '(0 0 0))
(command "ddedit" (entlast) "") 
(setq pre (cdr(assoc 1 (entget(entlast)))))
;(setq pre (strcat pre ": "))
(entdel (entlast))
(setq dau (getint "\n Danh so bat dau (n):"))
(setq tong (getint "\n Danh so tong (m):") i 1)
(if (< tong 10) (setq sotong (strcat "0" (itoa tong))) (setq sotong (itoa tong))) 
(setq po (getpoint 
(strcat "\n Cho diem chen cua so: " (if (< dau 10) (strcat pre "0" (itoa dau)) (itoa dau)) "/" sotong)))
(wtxt (strcat (if (< dau 10) (strcat pre "0" (itoa dau)) (itoa dau)) "/" sotong) po)

(Repeat (- tong dau)
(setq po1 (getpoint po 
(strcat "\n Cho diem chen cua so: " (if (< (+ dau i) 10) (strcat pre "0" (itoa (+ dau i))) (itoa (+ dau i))) "/" sotong)))

(command "copy" "L" "" po po1) 
(setq ent (entget(entlast)))
(setq ent 
(subst 
(cons 1 (strcat (if (< (+ dau i) 10) (strcat pre "0" (itoa (+ dau i))) (itoa (+ dau i))) "/" sotong)) (assoc 1 ent) ent))
(entmod ent)
(setq i (1+ i))
(setq po po1)
)
(princ)
)
;
(defun wtxt(txt p / sty d h1 h2 wf h) ;;;Write txt on graphic screen at p
(setq    sty (getvar "textstyle")    
d (tblsearch "style" sty)    
h1 (cdr (assoc 40 d))    
h2 (cdr (assoc 42 d))    
wf (cdr (assoc 41 d)))
(if (> h1 0) (setq h h1) (setq h h2))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 40 h) (cons 41 wf)(cons 72 4)(cons 11 p) (cons 1 txt) (cons 10 p))))

 

 

Lisp rất hay, nhưng đến phần " cho điểm chèn của số" mình muốn click thay số vào text có sẵn được không??.Nhờ bác sửa dùm. Thanks cả nhà.


<<

Filename: 159943_shbv.lsp
Tác giả: danhgapro
Bài viết gốc: 161668
Tên lệnh: shbv
Lisp đánh số thứ tự bản vẽ tự động?

Hề hề hề,

Phải chăng bạn ấy muốn cái như thế này:

;; free lisp from cadviet.com : ketxu update...
>>

Hề hề hề,

Phải chăng bạn ấy muốn cái như thế này:

;; free lisp from cadviet.com : ketxu update from @Tue_NV
(defun c:shbv(/ dau tong po po1 ent i pre sotong en en1)
(command "undo" "be")
(prompt "\n Danh so hieu ban ve dang n/m ")
(setvar "cmdecho" 0)
(setq pre "< KC, CN KT>: ")
(wtxt pre '(0 0 0))
(command "ddedit" (entlast) "") 
(setq pre (cdr(assoc 1 (entget(entlast)))))
;(setq pre (strcat pre ": "))
(entdel (entlast))
(setq dau (getint "\n Danh so bat dau (n):"))
(setq tong (getint "\n Danh so tong (m):") i 1)
(if (< tong 10) (setq sotong (strcat "0" (itoa tong))) (setq sotong (itoa tong))) 
(setq po (cdr (assoc 11 (entget (car (setq en (entsel 
        (strcat "\n Hay chon text can thay the boi " pre (if (< dau 10) (strcat "0" (itoa dau)) (itoa dau)) "/" sotong))))))))
;;;;(getpoint (strcat "\n Cho diem chen cua so: " (if (< dau 10) (strcat pre "0" (itoa dau)) (itoa dau)) "/" sotong)))
(command "erase" en "")
(wtxt (strcat pre (if (< dau 10) (strcat "0" (itoa dau)) (itoa dau)) "/" sotong) po)

(Repeat (- tong dau)
(setq po1 (cdr (assoc 11 (entget (car (setq en1 (entsel 
          (strcat "\n Hay chon text can thay the boi " pre (if (< (+ dau i) 10) (strcat "0" (itoa (+ dau i))) (itoa (+ dau i))) "/" sotong))))))))
;;;(getpoint po (strcat "\n Cho diem chen cua so: " (if (< (+ dau i) 10) (strcat pre "0" (itoa (+ dau i))) (itoa (+ dau i))) "/" sotong)))
(command "erase" en1 "")
(command "copy" "L" "" po po1) 
(setq ent (entget(entlast)))
(setq ent 
(subst 
(cons 1 (strcat pre (if (< (+ dau i) 10) (strcat "0" (itoa (+ dau i))) (itoa (+ dau i))) "/" sotong)) (assoc 1 ent) ent))
(entmod ent)
(setq i (1+ i))
(setq po po1)
)
(command "undo" "e")
(princ)
)
;
(defun wtxt(txt p / sty d h1 h2 wf h) ;;;Write txt on graphic screen at p
(setq    sty (getvar "textstyle")    
d (tblsearch "style" sty)    
h1 (cdr (assoc 40 d))    
h2 (cdr (assoc 42 d))    
wf (cdr (assoc 41 d)))
(if (> h1 0) (setq h h1) (setq h h2))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 40 h) (cons 41 wf)(cons 72 4)(cons 11 p) (cons 1 txt) (cons 10 p))))

 

@Bác Tue_NV và Ketxu: Mạn phép sửa lại tí chút cái lisp của các bác cái chổ :

(wtxt (strcat (if (< dau 10) (strcat pre "0" (itoa dau)) (itoa dau)) "/" sotong) po)

Có nhẽ phải là:

(wtxt (strcat pre (if (< dau 10) (strcat "0" (itoa dau)) (itoa dau)) "/" sotong) po)

mới đúng ạ.

 

 

Rất cảm ơn 2 bạn đã hiểu đúng ý mình :D.

Không biết có phải tại máy mình không???, khi kick vào text có sẵn thì text mới bị nhảy lung tung và dồn lại 1 cục...

Nhờ bạn kiểm tra lại dùm.

Cảm ơn nhiều nhiều.


<<

Filename: 161668_shbv.lsp
Tác giả: glorious_9x
Bài viết gốc: 392203
Tên lệnh: gpad+%C2%A0
Cách Chuyển Cao Độ Dạng Text (Chữ Số)

 

Hề hề hề,

Bạn cho hỏi rằng cái text cao độ của bạn thể hiện cao độ theo đơn vị là m hay là...

>>

 

Hề hề hề,

Bạn cho hỏi rằng cái text cao độ của bạn thể hiện cao độ theo đơn vị là m hay là mm?

Nếu là mm thì bạn có thể dùng lisp sau đây để chèn một point vào điểm đặt của text với cao độ là giá trị của text và trả về một list các point này. Từ đó bạn muốn làm chi với nó thì tùy nhé.

http://www.cadviet.com/upfiles/5/5194_chendiem.lsp

(defun c:gpad  ( / sslt pls cd pd p )
(vl-load-com)
(setq sslt (acet-ss-to-list (ssget (list (cons 0 "text") (cons 8 "docaoct")))))
(setq pls (list))
(foreach tp sslt
       (setq cd (atof (cdr (assoc 1 (entget tp))))
                 pd (cdr (assoc 10 (entget tp)))
                 p (list (car pd) (cadr pd) cd)  )
      (command "point" p )
      (setq pls (append pls (list p)))
)
)

Vâng, em làm được rồi. cảm ơn bác nhé!!


<<

Filename: 392203_gpad+%C2%A0.lsp
Tác giả: prouce
Bài viết gốc: 300645
Tên lệnh: tmp
Hỏi cách link từ file excel vào khung tên trong autocad

 

Việc này cũng có thể giải quyết bằng lisp. Tôi không rành lắm về lệnh của cad, có thể có lệnh nào đó giải quyết vấn đề...

>>

 

Việc này cũng có thể giải quyết bằng lisp. Tôi không rành lắm về lệnh của cad, có thể có lệnh nào đó giải quyết vấn đề này nhưng tạm thời bạn dùng cái lisp dưới đây.

Tuy nhiên có vài vấn đề cần đặt ra là :

1. Trong ô ngày tháng (02/07/2014) và scale của bản vẽ (1:20) trong file excel bạn phải cho format của nó là text (thêm dấu ' đằng trước) , nếu không cad sẽ hiểu đó là số chứ không phải text.

2. File dwg và xls ở cùng thư mục và file excel tên là Link.xlsx. Nếu bạn làm 100 cái khung thì nên copy 100 cái khung đó trong cùng bản vẽ, đồng thời ghi 100 dòng trong file excel tương ứng. Tức là khi làm việc chỉ có 1 file cad và 1 excel thôi.

3. Còn 1 vấn đề tôi chưa giải quyết được là font chữ, tức là chữ tiếng việt có dấu không hiển thị được, cái này tính sau.

 

Lisp sẽ hỏi số dòng trong file excel (ở ví dụ này là 2), sau đó nhấp vào cái Attribute Block, nó sẽ điền thông tin từ excel vào cad.

 

Cái này có thể làm hàng loạt nếu trong Dynamic Block của bạn có thêm 1 cái att ghi số dòng (từ 2 -> 101 chẳng hạn), hoặc bạn dùng att có sẵn sửa số cũng được.

(defun c:tmp()
 (setq l0 (list "$DWGNAME1" "$R_DAY0" "$R_DESCR0" "$R_DWR0" "$R_CHK0" "$R_APP0"  "$SCALES"  "$FORMAT"
"$R_DAY0_1" "$TITLE_1" "$TITLE_2" "$TITLE_3"  "$TITLE_4" "$DWGNAME1" "$NR1")
       row (getint "\nChon dong trong file Excel:")
       col 0)
 
 (setq excel (vlax-create-object "Excel.Application")  
       currworkbook (vlax-invoke-method (vlax-get-property excel 'Workbooks)
'Open (strcat (getvar 'dwgprefix) "Link.xlsx"))
       cells (vlax-get-property (vlax-get-property excel 'ActiveSheet) 'Cells))
 (setq l1 (mapcar '(lambda(x) (cons x
(vlax-variant-value (vlax-get-property (vlax-variant-value (vlax-get-property cells 'ITem row (setq col (1+ col)))) 'Value)))) l0))
 
 (setq en (car (entsel "\nChon dynamic Block:")))
 (while (and (setq en (entnext en))
    (/= (cdr (assoc 0 (entget en))) "SEQEND"))
    (if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object en)) 'TagString)
    (setq tm (assoc (vla-get-TagString obj) l1)))
      (vla-put-TextString obj (cdr tm)))
 )
)
 
 

Cảm ơn bác nhiều nhé, bác viết lisp này cao siêu quá, chắc em fai nghiên cứu từ từ,hehe  :D


<<

Filename: 300645_tmp.lsp
Tác giả: minhphuong_humg
Bài viết gốc: 185488
Tên lệnh: ch2w
Làm sao để thay thế (đối tượng bằng wipeout) ?

Hề hề hề,

Đúng như bạn Chiron đã nói, mình có thể xử lý việc này bằng lisp được, nhưng trước hết bạn hãy mở...

>>

Hề hề hề,

Đúng như bạn Chiron đã nói, mình có thể xử lý việc này bằng lisp được, nhưng trước hết bạn hãy mở topic này bên lisp box đã nhé. Như vậy đúng với quy định của diễn đàn và sẽ thuận lợi hơn cho những người khác theo dõi và quan tâm tới vấn đề này. Hãy chịu khó một chút vì quyền lợi chung của mọi người tham gia diễn đàn bạn nhé. Có thể khi bạn post xong topic thì đã có bài trả lời rồi đó.

Hề hề hề,

Đất chả chịu giời thì giời chịu đất vậy. Mình giúp bạn lần này chuyển bài viết về box mới và sửa tiêu đề topic cho đúng với quy định của diễn đàn, mong rằng lần sau bạn sẽ tự thực hiện đúng với quy định nhé.

Hãy dùng thử cái lisp này xem có đúng cái bạn cần không nhé. Lưu ý rằng các vòng tròn của bạn sau khi dùng lisp này sẽ không còn là circle nữa mà là các wipeout tương tự như cái mẫu trong bản vẽ của bạn post. Vì thế chớ có ngạc nhiên khi thấy nó không được tròn vành vạnh nhé.

Trong lisp này mình có nhón một khúc lisp của bác SSG về để xào nấu lại. Vì thế hãy cám ơn bác ấy nhé. Không có bác ấy thì cái lisp này sẽ chả dùng được đâu.

Hề hề hề


(defun c:ch2w (/ ent pt la oldlay oldos d0 d1 ent1 ent2 plst ss1 sscl)
(vl-load-com)
(command "undo" "be")
(setq ent (car (entsel "\n Hay chon mot hinh tron mau muon thay the de tao wipeout "))
         pt (cdr (assoc 10 (setq els (entget ent))))
         la (cdr (assoc 8 els))
)
(setq oldlay (getvar "clayer"))
(setvar "clayer" la)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(if (not d0) (setq d0 0.5));;;Init dividual distance, global variable
(setq d1 (getreal (strcat "\nLength of 1 segment <" (rtos d0) ">:")));;;Input distance
(if d1 (setq d0 d1) (setq d1 d0));;;Reset or get distance
(makepl ent d1)
(setq ent1 (entlast))
(command "wipeout" "p" ent1 "n")
(setq ent2 (entlast)
         plst (acet-geom-vertex-list ent1)
         ss1 (ssget "cp" plst (list (cons 0 "line") (cons 8 "Duong"))) )
  	(command "draworder" ent2 "" "b")
  	(command "draworder" ss1 "" "b")
  	(command "erase" ent "")
(alert "\n Chon tat ca cac vong tron can thay the")
(setq sscl (acet-ss-to-list (ssget (list (cons 0 "circle") (cons 8 la)))))
(foreach crl sscl
  	(setq p1 (cdr (assoc 10 (entget crl))))
  	(command "move" ent1 "" pt p1)
  	(command "copy" ent2 "" pt p1)
  	(setq ent2 (entlast)
        		plst (acet-geom-vertex-list ent1)
        		ss1 (ssget "cp" plst (list (cons 0 "line") (cons 8 "Duong"))) )
  	(command "draworder" ent2 "" "b")
  	(command "draworder" ss1 "" "b")
  	(command "erase" crl "")
  	(setq pt p1 p1 nil)
)
(command "erase" ent1 "")
(setvar "clayer" oldlay)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)

;;;-------------------------------------------------------------
(defun makepl ( e d1 / ps pe d d2 p2);;;Make pline along curve e. Length of 1 segment = d1
(vl-load-com);;;Load Visual LISP extensions before use vlax-xxxx functions
(setq
ps (vlax-curve-getStartPoint e);;;Start point
pe (vlax-curve-getEndPoint e);;;End point
d (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e));;;Length of curve e
d2 d1;;;Init variable distance
)
(command "pline");;;Call pline command
(command ps);;;Start point
(while (<= d2 d);;;While not over end point pe
(setq p2 (vlax-curve-getPointAtDist e d2));;;Variable point at d2 = length along curve
(command p2);;;Continue pline command from current point to p2
(setq d2 (+ d2 d1));;;Increase distance d2 by d1
);;;End while
(if (not (equal pe ps 0.01))
(command pe "");;;Pline to pe and finish command
(command "c" )
)
)
;;;-------------------------------------------------------------

Hề hề hề,

Chúc bạn vui

 

Thành thật em cảm ơn anh rất nhiều, sáng mai đi làm em sẽ làm ngay theo cách anh mách. Lý do em em post ở đây là vì: em nghĩ rằng vấn đề này có thể Copy rồi Dán hoặc Lọc theo kiểu gì đó---->liên quan tới Kỹ thuật Autocad; nên em viết bài này ở đây. Rất mong mọi người bỏ quá cho em. Cảm ơn anh và các bạn đã quan tâm rất nhiều. Chúc mọi người có sức khỏe!


<<

Filename: 185488_ch2w.lsp
Tác giả: duy782006
Bài viết gốc: 426822
Tên lệnh: nb
Vẽ Line, Pline theo Text

Nối theo thứ tự lung tung.

(defun c:nb ()
(princ "\nChon cac block can noi")
(setq dchon (ssget (list (cons 0 "INSERT"))))

(setq LAYLST nil)
(setq i 0)
(setq N (sslength dchon))
(while (< i N)
(setq bltktchon (ssname dchon i)) 
(setq LAY (cdr (assoc 2 (entget bltktchon))) )
(if (not (member LAY LAYLST))
(setq LAYLST (cons LAY LAYLST))
)

(setq i (1+ i))
)

(foreach LAYc LAYLST
(command...
>>

Nối theo thứ tự lung tung.

(defun c:nb ()
(princ "\nChon cac block can noi")
(setq dchon (ssget (list (cons 0 "INSERT"))))

(setq LAYLST nil)
(setq i 0)
(setq N (sslength dchon))
(while (< i N)
(setq bltktchon (ssname dchon i)) 
(setq LAY (cdr (assoc 2 (entget bltktchon))) )
(if (not (member LAY LAYLST))
(setq LAYLST (cons LAY LAYLST))
)

(setq i (1+ i))
)

(foreach LAYc LAYLST
(command ".pline")
(setq stt 0)
(setq sdt (sslength dchon))
(while (< stt sdt)
(setq chondt (ssname dchon stt))
(setq LAYss (cdr (assoc 2 (entget chondt))) )

(cond
((= LAYss LAYc) (setq diem (cdr (assoc 10 (entget chondt)))) (command "_non" diem) )
)

(setq stt (+ stt 1))
)
(command "")

);foreach


(princ LAYLST))

 


<<

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

Anh chỉnh cho em độ dốc được viết vào bản vẽ dưới dạng text và là % được không? VD trong file em đính kèm, độ dốc sẽ được viết vào là 1.41%.

Anh giúp em độ dốc viết vào có 3 số sau dấu phảy, như trên là 1.411% chẳng hạn.

Em cảm ơn ạ!

>>

Anh chỉnh cho em độ dốc được viết vào bản vẽ dưới dạng text và là % được không? VD trong file em đính kèm, độ dốc sẽ được viết vào là 1.41%.

Anh giúp em độ dốc viết vào có 3 số sau dấu phảy, như trên là 1.411% chẳng hạn.

Em cảm ơn ạ!

 

Bạn thử cái này.

 

(defun c:dd(/ t1 t2 pl dai)
  (setq t1 (car (entsel "\nChon text cao do 1:"))
t2 (car (entsel "\nChon text cao do 2:"))
pl (car (entsel "\nChon polyline:"))
dai (vlax-curve-getDistAtParam pl (vlax-curve-getEndParam pl)))
  (princ (strcat "\nDo doc : " (rtos(/ (- (atof (cdr (assoc 1 (entget t1))))
                            (atof (cdr (assoc 1 (entget t2))))) dai))))
  (princ)
)

<<

Filename: 312489_dd.lsp

Trang 268/330

268