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

[bachngoctung 11]

Bạn thử code mới này xem sao nhé

(defun c:dtcd ()
 (vl-load-com)
 (setq dd (entsel "\nChon vung can tinh dien tich")
       dth (car dd)
ll (entsel "\nChon pline can tinh chieu dai")
pl (car ll)
ob1 (vlax-ename->vla-object dth)
ob2 (vlax-ename->vla-object pl)
dientich (vla-get-area ob1)
chieudai (vla-get-length ob2)
pblock (getpoint "\nChon diem chen block")
oldos (getvar "osmode")
)
 (setvar "osmode" 0)
 (if (= (cdr (assoc 0 (entget pl))) "LINE")
   (setq ang (/ (* (vla-get-angle ob2) 180) pi))
   (progn
     (setq lis (acet-geom-vertex-list pl))
     (setq ang (/ (* (angle (car (reverse lis)) (cadr (reverse lis))) 180) pi))
   )
 )
 (vl-cmdf "insert" "BG" pblock "" "" ang (rtos dientich 2 2) (rtos chieudai 2 2))
 (setq pp (polar pblock (/ (* ang pi) 180) 7.7636))
 (vl-cmdf "move" (entlast) "" pblock pp)
 (vl-cmdf "line" (car (cdr dd)) pblock "")
 (vl-cmdf "line" (car (cdr ll)) pblock "")
 (setvar "osmode" oldos)
 )

- Cám ơn Tu nhé mình đã thử lisp bạn mới chỉnh giúp mình , nhưng thấy chưa được thỏa mãn, chắc là do mình diễn tả chưa rõ . Mình up file ảnh lên cho bạn tiện xem:

+ Một là kết quả sau khi sử dụng lisp thì mũi tên chưa có Tu à , đồng thời block sau khi chèn ra nó lại tự đảo ngược vị trí của diện tích và chiều dài

- Tu xem khắc phục giúp mình nhé. Mình cũng up luôn cả file cad lên http://www.cadviet.com/upfiles/3/cadvietcom_4.dwg

[phamthanhbinh 3.146]

Chào bạn thangbkpro. Bạn sử dụng thử cái này :

 

 

@Bác Bình : Kết quả chạy rất tốt. Đúng với ý đồ của Tue_NV với cách xây dựng code có khác :)

Tuy nhiên, kết quả xuất Text không đúng khi Text xoay nghiêng 1 góc a khác 0. Cái này có lẽ User không cần thiết, nhưng mình nên bổ sung thêm cho đầy đủ, bác ạ

 

Hề hề hề, bác Bình mót nhiều quá, đến nỗi bây chừ là không nhớ tên của tác giả của Lisp WritetoExCel nữa :D

Tác giả đã trả lời bác, tặng bác Lisp đó mà bác quên, đó là cái lỗi đó bác ạ :D Hề hề, cái này đáng phạt nha

Tác giả của của Lisp WritetoExCel không phải của bác SSG ạ. Tên của tác giả và Lisp WritetoExCel ở đây, bác ạ :

Bai viet so 160 - Lisp WritetoExCel

Cảm ơn tác giả của Lisp WritetoExCel nhiều lắm :)

 

@khaosat : Tue_NV có đọc yêu cầu của bạn. Nhưng có vài chổ chưa rõ lắm. Phiền bạn upload file .dwg và nói rõ hơn nhé.

 

@tamkt, nguyentuyen : Cái này thiết nghĩ không dùng Lisp. sử dụng CAD là được. Với lại, Lisp mà bạn nguyentuyen viết ra với điểm gốc Rotate ứng với điểm đầu Line. Nhìn vào CAD, nào đâu có biết điểm đầu hay là điểm cuối LINE cơ chứ??

Nếu User muốn xoay với điểm cuối Line thì sao, hoặc là điểm xoay nằm trên hoặc là không nằm trên LINE thì sao??

Lại còn áp dụng các đối tượng khác như bạn tamkt yêu cầu nữa : là LEADER và PLINE thẳng 1 phân đoạn nữa.

 

Lăn tăn chi bạn?? Áp dụng lệnh Rotate ới lựa chọn Reference và chế độ bắt điểm Parallel. Còn nếu thấy chế độ bắt điểm Parallel khó quá thì sử dụng lệnh Copy và sau đó là lệnh ROTATE hoặc là ALIGN

 

Tue_NV về quê có 1 ngày mà topic này rôm rả ghê. Chúc các bạn ngày cuối tuần vui vẻ. :bigsmile:

Hề hề hề,

Lỗi lớn , lỗi lớn, xin cám ơn bác Tue_NV đã nhắc nhở.

Xin lỗi bác Giabach vì sự nhầm lẫn.

Chịu phạt ạ, các bác cứ ra án lệnh rồi mình sẽ thi hành ngay ạ.

Hề hề hề.....

[ceddtu 6]

Hề hề hề,

Khỏi nhờ, nó đây, bạn dùng thử coi sao

bác phamthanhbinh oi, bac lam on sua gium em cai lisp tchu 1 tí đc ko ạ, em chỉ muốn đổi layer phần số thôi, còn phần đơn vị vẫn giữ nguyên (trong lisp đã đổi lun phần dơn vị cùng layer voi phần số rồi)

cám ơn bác nhiều lăm, may mà có bác với bác tue_nv chứ ko em no đòn

[thangbkpro 0]

Chào bạn thangbkpro. Bạn sử dụng thử cái này :

(defun c:ntt(/ ss i p h L ssc ent entt)
 (IF (setq ss (ssget (list(cons 0 "text") (cons 1 "*#ka,#kA"))))
   (PROGN
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq p (cdr(assoc 10 (entget ent))) ssc nil)
   (setq h (cdr(assoc 40 (entget ent))))
   (setq L (list (+ (car p) (* 2.5 h)) (+ (cadr p) (* 6 h)) 0.0))
   (setq ssc (ssget "c" p L))
   (if (setq ssc (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssc)))
	       '(lambda (x y) (> (caddr(assoc 10 (entget x)))
				 (caddr(assoc 10 (entget y)))
			      )
		)
           )
   )
   (PROGN
   (setq entt (entget (car ssc)))
   (setq entt (subst (cons 1 (apply 'strcat (mapcar '(lambda(x) (strcat (cdr(assoc 1 (entget x))) " ")) ssc)))
   		(assoc 1 entt) entt))
   (entmod entt)
   (mapcar 'entdel (vl-remove (car ssc) ssc))
   ))
)
 ))
 )

Cảm ơn bạn Tue_NV

Tuy nhiên khi dùng lip có một vài text của thiết bị này vẫn dính với text của thiết bị khác. Bạn có cách nào tối ưu hơn giúp mình không? Bạn có thể sửa lip theo đuôi *#CB không. Tại vì bên điện thì CB(aptomat) xuất hiện nhiều nhất(ACB, MCB, MCCB) và nó là chủ thể đi kèm với các thông số khác.

[Tue_NV 3.912]

Cảm ơn bạn Tue_NV

Tuy nhiên khi dùng lip có một vài text của thiết bị này vẫn dính với text của thiết bị khác. Bạn có cách nào tối ưu hơn giúp mình không? Bạn có thể sửa lip theo đuôi *#CB không. Tại vì bên điện thì CB(aptomat) xuất hiện nhiều nhất(ACB, MCB, MCCB) và nó là chủ thể đi kèm với các thông số khác.

Gửi bạn cái này. Bạn chú ý : Chọn 1 loạt luôn nhé.

Bạn chạy thử xem đã trúng ý chưa nhé :

(defun c:ntt(/ ss i p h L ssc ent entt)
 (IF (setq ss (ssget (list(cons 0 "text") (cons 1 "*cb,*CB"))))
   (PROGN
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq h (cdr(assoc 40 (entget ent))))
   (setq p (cdr(assoc 10 (entget ent))) )
   (setq p (list (car p) (+ (cadr p) (/ h 2)) 0.0))
   (setq L (list (+ (car p) (* 2.0 h)) (- (cadr p) (* 6 h)) 0.0)
  ssc nil)
   (setq ssc (ssget "c" p L))
   (if (setq ssc (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssc)))
	       '(lambda (x y) (> (caddr(assoc 10 (entget x)))
				 (caddr(assoc 10 (entget y)))
			      )
		)
           )
   )
   (PROGN
   (setq entt (entget (car ssc)))
   (setq entt (subst (cons 1 (apply 'strcat (mapcar '(lambda(x) (strcat (cdr(assoc 1 (entget x))) " ")) ssc)))
   		(assoc 1 entt) entt))
   (entmod entt)
   (mapcar 'entdel (vl-remove (car ssc) ssc))
   ))
)
 ))
 )

[quan08 0]

Nhờ các bác viết giùm e lisp đánh số thứ tự như file e gửi sau.Chân thành cảm ơn các bác trước.

http://www.cadviet.com/upfiles/3/drawing1_29.dwg

[tuannt991 0]

Cho em xin lisp thống kê đường ống. trong bản vẽ pccc. Em muốn thống kê các loại ống. VD: DN32 dài bn mét. DN40, DN50,DN80... tổng cộng mỗi loại ống dài bn mét. em làm thủ công rất mất thời gian và hay bị nhầm. mong các anh giúp em.

 

http://www.cadviet.com/upfiles/3/0748fsp301.dwg đây là 1 trong nhung file em cần thống kế

[nguyentuyen6 130]

Nhờ các bác viết giùm e lisp đánh số thứ tự như file e gửi sau.Chân thành cảm ơn các bác trước.

http://www.cadviet.com/upfiles/3/drawing1_29.dwg

Mình mới làm xong cái làm từ phải sang trái, ban dùng thử nhé:

 

Bạn lưu ý là điểm đặt của text phải thẳng hàng nhé, lệch 1 tí là nó ghi sai luôn, hehe

 

(defun c:dstt (/ i n ss lst thay stt)
;====
;nguyentuyen6 @ CadViet
(setq ss (ssget '((0 . "TEXT")))
lst (ss2ent ss)
lst (vl-sort lst
'(lambda (e1 e2)
(<
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
;====
(setq i 0
n 1
)
(while (< i (sslength ss))
   (setq
thay (itoa n)
stt (nth i lst)
)
(moddxf 1 thay stt)
(setq i (1+ i))
(setq n (1+ n))
)
)
(defun moddxf (dxf chdxf ss) (entmod (subst (cons dxf chdxf) (assoc dxf (entget ss)) (entget ss))))
(defun ss2ent (ss / sodt index lstent)
(setq
sodt (if ss (sslength ss) 0)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
;(reverse lstent)
)

 

Còn cái từ trái sang phải bạn thay dòng này là đc:

 

Thay:

(lambda (e1 e2)

(<

(cadr (assoc 10 (entget e1)))

(cadr (assoc 10 (entget e2)))

 

Thành :

(lambda (e1 e2)

(>

(cadr (assoc 10 (entget e1)))

(cadr (assoc 10 (entget e2)))

 

Bác nào giúp e gộp thành 1 líp với, hjx

[vtd_xd 5]

Chào các bạn

Bạn nào có thể sửa giúp mình lisp "linkT" dùng được cho cả đối tượng Attribute Block.

Xin cảm ơn bác bạn trước nhé

 

 

Đây là file ví dụ của mình: http://www.cadviet.com/upfiles/3/cadviet_3.dwg

 

Chờ đợi mấy hôm mà chưa thấy tín hiện gì, bạn nào ra tay giúp mình với, cám ơn nhiều

[phamngoctukts 714]

Mình mới làm xong cái làm từ phải sang trái, ban dùng thử nhé:

 

Bạn lưu ý là điểm đặt của text phải thẳng hàng nhé, lệch 1 tí là nó ghi sai luôn, hehe

 

(defun c:dstt (/ i n ss lst thay stt)
;====
;nguyentuyen6 @ CadViet
(setq ss (ssget '((0 . "TEXT")))
lst (ss2ent ss)
lst (vl-sort lst
'(lambda (e1 e2)
(<
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
;====
(setq i 0
n 1
)
(while (< i (sslength ss))
   (setq
thay (itoa n)
stt (nth i lst)
)
(moddxf 1 thay stt)
(setq i (1+ i))
(setq n (1+ n))
)
)
(defun moddxf (dxf chdxf ss) (entmod (subst (cons dxf chdxf) (assoc dxf (entget ss)) (entget ss))))
(defun ss2ent (ss / sodt index lstent)
(setq
sodt (if ss (sslength ss) 0)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
;(reverse lstent)
)

 

Còn cái từ trái sang phải bạn thay dòng này là đc:

 

Thay:

(lambda (e1 e2)

(<

(cadr (assoc 10 (entget e1)))

(cadr (assoc 10 (entget e2)))

 

Thành :

(lambda (e1 e2)

(>

(cadr (assoc 10 (entget e1)))

(cadr (assoc 10 (entget e2)))

 

Bác nào giúp e gộp thành 1 líp với, hjx

Mình gộp và rút ngắn cho bạn đây.

(defun c:dstt ()
(vl-load-com)
(setq ss (ssget '((0 . "TEXT")))
tp (getstring "\nBat dau tu: Trai/Phai: ")
lst (acet-ss-to-list ss)
lst (reverse lst)
lst (vl-sort lst
'(lambda (e1 e2)
(if (= (strcase tp) "T")
(<
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
(if (= (strcase tp) "P")
(>
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
)
(setq i 0 n 1)
(while (< i (sslength ss))
   (setq
thay (itoa n)
stt (nth i lst)
)
(moddxf 1 thay stt)
(setq i (1+ i))
(setq n (1+ n))
)
)

(defun moddxf (dxf chdxf ss /) 
(entmod (subst (cons dxf chdxf) (assoc dxf (entget ss)) (entget ss)))
)

[phamthanhbinh 3.146]

bác phamthanhbinh oi, bac lam on sua gium em cai lisp tchu 1 tí đc ko ạ, em chỉ muốn đổi layer phần số thôi, còn phần đơn vị vẫn giữ nguyên (trong lisp đã đổi lun phần dơn vị cùng layer voi phần số rồi)

cám ơn bác nhiều lăm, may mà có bác với bác tue_nv chứ ko em no đòn

Chào bạn ceddtu,

Thực tế mình không đổi layer của thằng nào cả mà là cái text được tạo ra trên layer hiện hành của bản vẽ. Với bản vẽ của bạn post thì layẻ đó là layer có tên DMM, mà thôi.

Việc bạn muốn cái text chỉ đơn vị vẫn nằm ở lớp cũ của nó là layer XVOL thì có ngay, song nếu bạn muốn cái số nó nằm ở layer nào thì mình chưa rõ. Vậy nên mình vẫn để nó nằm trên layer hiện hành. Nếu bạn muồn nó nằm ở layer nào thì hãy bổ sung đoạn code sau ( cons 8 Tenlayer) vào trong cái list của hàm entmake nhé.

Mình cũng bổ sung trường hợp khi text của bạn bị xiên góc bạn nhé mặc dù có thể bạn không cần. Hề hề hề...

Đây là cái đã sửa:

(defun c:tchu(/ L pat ents i2 i3 i str str2 C1 C2 C3)
(setq pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "." ","))
(setq ents (acet-ss-to-list (ssget '((0 . "TEXT") (1 . "* = #*"))))
L '() i2 nil)

(foreach y ents
(setq x (cdr (assoc 1 (entget y))))
(setq i 1 L1 "" L2 "")
(while ((setq str (substr x (setq i (1+ i)) 3))
(if (= str " = ") (progn
(setq i2 (+ i 2))
(while ((if (vl-position (setq str2 (substr x (setq i2 (1+ i2)) 1)) pat)
(setq L1 (strcat L1 str2) i3 i2)
(setq i2 (strlen x))
)
)
) )
)
(setq C1 (substr x 1 (- i3 (strlen L1)))
C2 (substr x (1+ (strlen C1)) (strlen L1))
C3 (substr x (1+ i3) (- i2 i3))
)
;;;;;(alert (strcat C1 "\n" C2 "\n" C3))
(setq ltxt (list (substr C1 1 (- (strlen C1) 3 )) C2 C3))
(setq els (entget y)
b (cdr (assoc 41 els))
p1 (cdr (assoc 10 els))
h (cdr (assoc 40 els))
la (cdr (assoc 8 els))
g (cdr (assoc 50 els))
;;;;p2 (list (+ (car p1) (* b h 0.85 (1+ (strlen C1)))) (cadr p1))
;;;;p3 (list (+ (car p2) (* b h 0.85 (1+ (strlen L1)))) (cadr p2))
st (cdr (assoc 7 els))
els (subst (cons 1 C1) (assoc 1 els) els)
;;;ent (cdr (assoc 0 els))
)
(entmod els)
(if (/= g 0)
(command "rotate" y "" p1 (- (* g (/ 180 pi))))
)
(setq pls (textbox els)
dis1 (- (caadr pls) (caar pls))
p2 (list (+ (car p1) dis1 (* b h )) (cadr p1))
)
(entmake
(list (cons 0 "text") (cons 10 p2) (cons 1 C2) (cons 62 3) (cons 7 st) (cons 40 h) (cons 41 b ))
)
(setq ent (entlast)
pls1 (acet-ent-geomextents ent)
dis2 (- (caadr pls1) (caar pls1))
p3 (list (+ (car p2) dis2 (* b h )) (cadr p2))
)
(entmake
(list (cons 0 "text") (cons 10 p3) (cons 1 C3) (cons 62 256) (cons 7 st) (cons 40 h) (cons 41 b ) (cons 8 la))
)
(setq ent1 (entlast))
(if (/= g 0)
(command "rotate" y ent ent1 "" p1 (* g (/ 180 pi)))
)
(setq L (append L (list ltxt)))

)
(writetoExcel L)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;
(defun WriteToExcel (lst_data / col row x xlApp xlCells)
(setq xlApp (vlax-get-or-create-object "Excel.Application")
xlCells (vlax-get-property
(vlax-get-property
(vlax-get-property
(vlax-invoke-method
(vlax-get-property xlApp "Workbooks")
"Add")
"Sheets")
"Item" 1)
"Cells"))
(setq row 3)
(foreach pt lst_data
(setq col 2)
(foreach coor pt
(vlax-put-property xlCells 'Item row col coor)
(setq col (1+ col)))
(setq row (1+ row)) )
(vla-put-visible xlApp :vlax-true)
(mapcar
(function (lambda (x)
(vl-catch-all-apply
(function (lambda ()(if x (vlax-release-object x)))))))
(list xlCells xlApp))
(gc) (gc) ) 

[phamthanhbinh 3.146]

Cho em xin lisp thống kê đường ống. trong bản vẽ pccc. Em muốn thống kê các loại ống. VD: DN32 dài bn mét. DN40, DN50,DN80... tổng cộng mỗi loại ống dài bn mét. em làm thủ công rất mất thời gian và hay bị nhầm. mong các anh giúp em.

 

http://www.cadviet.com/upfiles/3/0748fsp301.dwg đây là 1 trong nhung file em cần thống kế

Chào bạn tuannt991,

Để có thể làm bảng thống kê như bạn yêu cầu thì việc tổ chức bản vẽ của bạn phải thống nhất một số nguyên tắc nào đó. Xem bản vẽ của bạn thì trên cùng một tuyến ống bạn chỉ phân biệt kích thước ống bằng các text đơn giản như vậy, rất khó để tách các đoạn ống trên cùng một tuyến để tính chiều dài.

Theo mình thiển nghĩ, bạn nên cấu tạo lại bản vẽ , tỷ như mỗi loại đường kính ống bạn sử dụng một màu khác nhau chẳng hạn, hoặc giả kết hợp với linetype để thể hiện cũng như sử dụng các pline với chiều dày khác nhau.

Dùng cách nào tùy bạn lựa chọn nhưng cần phải thống nhất trên tất cả các bản vẽ, có vậy việc thống kê mới có thể dễ dàng và thuận lợi cho bạn được. Nhất là khi bạn lại phải vẽ hàng ty tỷ bản vẽ kiểu này.

Với bản vẽ hiện tại như vầy, quả thật việc thống kê không hề dễ dàng. Rất mong bạn lưu tâm cải thiện công việc của bạn....

[tuannt991 0]

Chào bạn tuannt991,

Để có thể làm bảng thống kê như bạn yêu cầu thì việc tổ chức bản vẽ của bạn phải thống nhất một số nguyên tắc nào đó. Xem bản vẽ của bạn thì trên cùng một tuyến ống bạn chỉ phân biệt kích thước ống bằng các text đơn giản như vậy, rất khó để tách các đoạn ống trên cùng một tuyến để tính chiều dài.

Theo mình thiển nghĩ, bạn nên cấu tạo lại bản vẽ , tỷ như mỗi loại đường kính ống bạn sử dụng một màu khác nhau chẳng hạn, hoặc giả kết hợp với linetype để thể hiện cũng như sử dụng các pline với chiều dày khác nhau.

Dùng cách nào tùy bạn lựa chọn nhưng cần phải thống nhất trên tất cả các bản vẽ, có vậy việc thống kê mới có thể dễ dàng và thuận lợi cho bạn được. Nhất là khi bạn lại phải vẽ hàng ty tỷ bản vẽ kiểu này.

Với bản vẽ hiện tại như vầy, quả thật việc thống kê không hề dễ dàng. Rất mong bạn lưu tâm cải thiện công việc của bạn....

anh ơi đây là bản vẽ của chủ đầu tư cấp cho, mình là bên bỏ thầu. Nên em nhận bản vẽ này về để tính toán số liệu để dự thầu, dự toán chi phí.... Chứ không phải do em vẽ :-s đó mới là cái khó anh àh.

[quan08 0]

Mình gộp và rút ngắn cho bạn đây.

(defun c:dstt ()
(vl-load-com)
(setq ss (ssget '((0 . "TEXT")))
tp (getstring "\nBat dau tu: Trai/Phai: ")
lst (acet-ss-to-list ss)
lst (reverse lst)
lst (vl-sort lst
'(lambda (e1 e2)
(if (= (strcase tp) "T")
(<
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
(if (= (strcase tp) "P")
(>
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
)
(setq i 0 n 1)
(while (< i (sslength ss))
   (setq
thay (itoa n)
stt (nth i lst)
)
(moddxf 1 thay stt)
(setq i (1+ i))
(setq n (1+ n))
)
)

(defun moddxf (dxf chdxf ss /) 
(entmod (subst (cons dxf chdxf) (assoc dxf (entget ss)) (entget ss)))
)

Nhưng vẫn chưa đánh đúng bạn ah.mình gửi lại file.Mong bạn sửa giùm.thanks

http://www.cadviet.com/upfiles/3/drawing1_29_1.dwg

[gia_bach 1.549]

Chào các bạn

Bạn nào có thể sửa giúp mình lisp "linkT" dùng được cho cả đối tượng Attribute Block.

Xin cảm ơn bác bạn trước nhé

 

 

Đây là file ví dụ của mình: http://www.cadviet.com/upfiles/3/cadviet_3.dwg

Lisp "link" cho đối tượng Block thuộc tính.

(link tất cả thuộc tính của Block)

(defun c:linkBA (/ e i obj obj1 ss1 ss2 vallst val); link Block Attribute
 (vl-load-com)
 (if (and
(princ "\nChon Block nguon :")
(setq ss1 (ssget "+.:S:N" (list (cons 0 "INSERT") (cons 66 1))))
(setq obj1 (vlax-Ename->Vla-Object (ssname ss1 0)))
(princ "\nChon Block dich :")
(setq ss2 (ssget "_:L" (list (cons 0 "INSERT") (cons 2 (vla-get-name obj1))))))
   (progn
     (foreach att (vlax-invoke obj1 'GetAttributes)
(setq valLst (cons (cons (vla-get-TagString Att)
			 (vla-get-ObjectId Att)) valLst)) )
     (setq i -1)
     (while (setq e (ssname ss2 (setq i (1+ i))))
(setq obj (vlax-Ename->Vla-Object e))
(foreach att (vlax-invoke obj 'GetAttributes)
  (if (setq val (assoc (vla-get-TagString att) valLst))
    (vla-put-TextString Att (strcat
			      "%<\\AcObjProp Object(%<\\_ObjId "
			      (vl-princ-to-string (cdr val))
			      ">%).TextString >%")) ))	)  ) )
 (princ))

[phamngoctukts 714]

Nhưng vẫn chưa đánh đúng bạn ah.mình gửi lại file.Mong bạn sửa giùm.thanks

http://www.cadviet.com/upfiles/3/drawing1_29_1.dwg

Hôm qua mình mới gộp lại cho bạn nguyentuyen nên chưa test thử. Mình sửa lại cho bạn đây.

;; free lisp from cadviet.com

(defun c:dstt ()
(vl-load-com)
(setq ss (ssget '((0 . "TEXT")))
tp (getstring "\nBat dau tu: Trai/Phai: ")
lst (acet-ss-to-list ss)
lst (reverse lst))
(if (= (strcase tp) "T")
(setq lst (vl-sort lst
'(lambda (e1 e2)
(<
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
)
(if (= (strcase tp) "P")
(setq lst (vl-sort lst
'(lambda (e1 e2)
(>
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
)
(setq i 0)
(while (< i (length lst))
   (setq
thay (itoa (1+ i))
stt (nth i lst)
)
(entmod (subst (cons 1 thay) (assoc 1 (entget stt)) (entget stt)))
(setq i (1+ i))
)
)

[thangbkpro 0]

Gửi bạn cái này. Bạn chú ý : Chọn 1 loạt luôn nhé.

Bạn chạy thử xem đã trúng ý chưa nhé :

(defun c:ntt(/ ss i p h L ssc ent entt)
 (IF (setq ss (ssget (list(cons 0 "text") (cons 1 "*cb,*CB"))))
   (PROGN
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq h (cdr(assoc 40 (entget ent))))
   (setq p (cdr(assoc 10 (entget ent))) )
   (setq p (list (car p) (+ (cadr p) (/ h 2)) 0.0))
   (setq L (list (+ (car p) (* 2.0 h)) (- (cadr p) (* 6 h)) 0.0)
  ssc nil)
   (setq ssc (ssget "c" p L))
   (if (setq ssc (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssc)))
	       '(lambda (x y) (> (caddr(assoc 10 (entget x)))
				 (caddr(assoc 10 (entget y)))
			      )
		)
           )
   )
   (PROGN
   (setq entt (entget (car ssc)))
   (setq entt (subst (cons 1 (apply 'strcat (mapcar '(lambda(x) (strcat (cdr(assoc 1 (entget x))) " ")) ssc)))
   		(assoc 1 entt) entt))
   (entmod entt)
   (mapcar 'entdel (vl-remove (car ssc) ssc))
   ))
)
 ))
 )

Cảm ơn Tue_NV!

Bạn thêm cho mình khả năng nối với text "*CB" với các text ở phía trên nó nhé. Vì đôi khi bạn vẽ khác mình nhận được thì họ lại để "CB" ở dưới cùng sau text 10A 3p 25kA mà dùng lip quét thì select được nhưng không nối được.

Thanks!

[quan08 0]

Hôm qua mình mới gộp lại cho bạn nguyentuyen nên chưa test thử. Mình sửa lại cho bạn đây.

;; free lisp from cadviet.com

(defun c:dstt ()
(vl-load-com)
(setq ss (ssget '((0 . "TEXT")))
tp (getstring "\nBat dau tu: Trai/Phai: ")
lst (acet-ss-to-list ss)
lst (reverse lst))
(if (= (strcase tp) "T")
(setq lst (vl-sort lst
'(lambda (e1 e2)
(<
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
)
(if (= (strcase tp) "P")
(setq lst (vl-sort lst
'(lambda (e1 e2)
(>
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
)
(setq i 0)
(while (< i (length lst))
   (setq
thay (itoa (1+ i))
stt (nth i lst)
)
(entmod (subst (cons 1 thay) (assoc 1 (entget stt)) (entget stt)))
(setq i (1+ i))
)
)

Cảm ơn sự giúp đỡ của bạn nhưng nó vẫn chưa đúng

thí dụ mình có:

1 1 1 1 1

1 1 1 1 1

lisp bạn viết thí dụ cho trường hợp đánh từ trái qua phải thì:

1 3 5 7 9

2 4 6 8 10

ý mình muốn là như thế này:

1 4 6 8 10

2 3 5 7 9

Mong bạn sửa giùm mình.

[phamngoctukts 714]

Cảm ơn sự giúp đỡ của bạn nhưng nó vẫn chưa đúng

thí dụ mình có:

1 1 1 1 1

1 1 1 1 1

lisp bạn viết thí dụ cho trường hợp đánh từ trái qua phải thì:

1 3 5 7 9

2 4 6 8 10

ý mình muốn là như thế này:

1 4 6 8 10

2 3 5 7 9

Mong bạn sửa giùm mình.

Bạn bị như vậy là do text của bạn không thẳng hàng. Như bạn nguyentuyen đã nói ở trên các text này phải thẳng hàng thì mới chạy đúng. Thẳng cả hàng dọc lẫn hàng ngang.

[duyhung 9]

Bạn bị như vậy là do text của bạn không thẳng hàng. Như bạn nguyentuyen đã nói ở trên các text này phải thẳng hàng thì mới chạy đúng. Thẳng cả hàng dọc lẫn hàng ngang.

Bạn tú có rỗi ko check cho mình một chút ở lisp dden với.

[Tue_NV 3.912]

Cảm ơn Tue_NV!

Bạn thêm cho mình khả năng nối với text "*CB" với các text ở phía trên nó nhé. Vì đôi khi bạn vẽ khác mình nhận được thì họ lại để "CB" ở dưới cùng sau text 10A 3p 25kA mà dùng lip quét thì select được nhưng không nối được.

Thanks!

Bạn thử với cái này xem vừa ý không nhé :

Tick Thanks thay cho bài viết cảm ơn

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

(defun c:ntt(/ ss i p h L ssc ent entt)
 (IF (setq ss (ssget (list(cons 0 "text") (cons 1 "*cb,*CB"))))
   (PROGN
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq h (cdr(assoc 40 (entget ent))))
   (setq p1 (cdr(assoc 10 (entget ent))) )
   (setq p (list (car p1) (+ (cadr p1) (/ h 2)) 0.0))
   (setq L (list (+ (car p) (* 2.0 h)) (- (cadr p) (* 6 h)) 0.0))
   (setq ssc nil)
   (setq ssc (ssget "c" p L (list(cons 0 "text"))   ))
   (if (and ssc (> (sslength ssc) 1))
     (PROGN
   	(setq ssc (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssc)))
	       '(lambda (x y) (> (caddr(assoc 10 (entget x)))
				 (caddr(assoc 10 (entget y)))
			      )
		)
           )
       )
     );PROGN
     (PROGN
   	(setq L (list (+ (car p1) (* 2.0 h)) (+ (cadr p1) (* 6 h)) 0.0))
  	(setq ssc (ssget "c" p L (list(cons 0 "text"))   ))
   	(setq ssc (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssc)))
	       '(lambda (x y) (					 (caddr(assoc 10 (entget y)))
			      )
		)
           )
       )
     );PROGN
   )
(setq entt (entget (car ssc)))
   	(setq entt (subst (cons 1 (apply 'strcat (mapcar '(lambda(x) (strcat (cdr(assoc 1 (entget x))) " ")) ssc)))
   			(assoc 1 entt) entt))
   	(entmod entt)

(mapcar 'entdel (vl-remove (car ssc) ssc))
)
 ))
(princ)
 )

[vtd_xd 5]

Lisp "link" cho đối tượng Block thuộc tính.

(link tất cả thuộc tính của Block)

(defun c:linkBA (/ e i obj obj1 ss1 ss2 vallst val); link Block Attribute
 (vl-load-com)
 (if (and
(princ "\nChon Block nguon :")
(setq ss1 (ssget "+.:S:N" (list (cons 0 "INSERT") (cons 66 1))))
(setq obj1 (vlax-Ename->Vla-Object (ssname ss1 0)))
(princ "\nChon Block dich :")
(setq ss2 (ssget "_:L" (list (cons 0 "INSERT") (cons 2 (vla-get-name obj1))))))
   (progn
     (foreach att (vlax-invoke obj1 'GetAttributes)
(setq valLst (cons (cons (vla-get-TagString Att)
			 (vla-get-ObjectId Att)) valLst)) )
     (setq i -1)
     (while (setq e (ssname ss2 (setq i (1+ i))))
(setq obj (vlax-Ename->Vla-Object e))
(foreach att (vlax-invoke obj 'GetAttributes)
  (if (setq val (assoc (vla-get-TagString att) valLst))
    (vla-put-TextString Att (strcat
			      "%<\\AcObjProp Object(%<\\_ObjId "
			      (vl-princ-to-string (cdr val))
			      ">%).TextString >%")) ))	)  ) )
 (princ))

 

 

Cám ơn bạn Gia Bach nhiều, lisp chạy rất ổn

[hugo75 4]

thí dụ mình có:

1 1 1 1 1

1 1 1 1 1

lisp bạn viết thí dụ cho trường hợp đánh từ trái qua phải thì:

1 3 5 7 9

2 4 6 8 10

ý mình muốn là như thế này:

1 4 6 8 10

2 3 5 7 9

Mong bạn sửa giùm mình.

Bạn phamngoctukts có thể thêm chức năng ví dụ như:

1 4 6 8 10

2 3 5 7 9

khi đánh lệnh dstt thì nó hỏi số bắt đầu thì nếu nhập 22 rồi chọn số 2 ngay vị trí phía dưới và số gia là 1 thì :

23 25 27 29 31

22 24 26 28 30

Cảm ơn bạn trước.

[phamngoctukts 714]

Bạn phamngoctukts có thể thêm chức năng ví dụ như:

1 4 6 8 10

2 3 5 7 9

khi đánh lệnh dstt thì nó hỏi số bắt đầu thì nếu nhập 22 rồi chọn số 2 ngay vị trí phía dưới và số gia là 1 thì :

23 25 27 29 31

22 24 26 28 30

Cảm ơn bạn trước.

Của bạn đây. Bạn xem đúng ý chưa nhé.

;; free lisp from cadviet.com

(defun c:dstt ()
(vl-load-com)
(setq ss (ssget '((0 . "TEXT")))
tp (getstring "\nBat dau tu: Trai/Phai: ")
lst (acet-ss-to-list ss)
lst (reverse lst))
(if (= (strcase tp) "T")
(setq lst (vl-sort lst
'(lambda (e1 e2)
(<
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
)
(if (= (strcase tp) "P")
(setq lst (vl-sort lst
'(lambda (e1 e2)
(>
(cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
)
(setq i 0)
(setq sbd (getint "\nVao so bat dau: "))
(while (< i (length lst))
   (setq
thay (itoa (+ i sbd))
stt (nth i lst)
)
(entmod (subst (cons 1 thay) (assoc 1 (entget stt)) (entget stt)))
(setq i (1+ i))
)
)

[thangbkpro 0]

Chào các bạn

Giúp mình nối 2 lip đếm text dưới đây thành một được không

1. Lip đếm text của bác gia_bach. sau khi đếm in ra table trong cad 1 cột loại text 1 cột là số lượng và 1 cột là số thứ tự

(defun c:tkt(/ ent h height i len0 lst msp pt row ss str str0 str_len tblobj width0 width1); thong ke text
;; By : Gia Bach, Copyrightｩ December 2010;;
;; Contact : gia_bach @ www.CadViet.com;;
(defun TxtWidth (val msp / txt minp maxp)
(vla-getBoundingBox (setq txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) 1)) 'minp 'maxp)
(vla-Erase txt)
(-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp))) )
;main
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.0)
(progn
(vl-load-com)
(princ "\nChon cac Text de thong ke :")
(if (setq ss (ssget(list (cons 0 "TEXT"))))
(progn
(setq i -1 len0 8)
(while (setq ent (ssname ss (setq i (1+ i))))
(setq str(cdr(assoc 1 (entget ent ))))
(if (> (setq str_len (strlen str)) len0)
(setq str0 str len0 str_len) )
(if (not (assoc str lst))
(setq lst (cons (cons str 1) lst))
(setq lst (subst (cons str (1+ (cdr (assoc str lst))))
(assoc str lst) lst))) )
(setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(or *h* (setq *h* 175))
(initget 6)
(setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))
(if h (setq *h* h) (setq h *h*) )
(setq width0 (* 3 h(TxtWidth "STT" msp))
height (* 2 h))
(if str0
(setq width1 (* 1.2 h(TxtWidth (strcase str0) msp)))
(setq width1 (* 2 h(TxtWidth "Gia tri" msp))))
(if (> h 3)
(setq width0 (* (fix (/ width0 10))10)
width1 (* (fix (/ width1 10))10)
height (* (fix (/ height 5))5)))
(setq pt (getpoint "\nDiem dat Bang :")
TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst) 2) 3 height width1))
(vla-put-regeneratetablesuppressed TblObj :vlax-true)
(vla-put-vertcellmargin TblObj (* 0.25 h))
(vla-put-horzcellmargin TblObj (* 0.75 h))
(vla-SetColumnWidth TblObj 0 width0)
(vla-SetColumnWidth TblObj 2 (* 2 h(TxtWidth "So luong" msp)))
(mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
(list acTitleRow acHeaderRow acDataRow) )
(mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
(list acTitleRow acHeaderRow acDataRow))
(vl-catch-all-error-p (vl-catch-all-apply (function(lambda () (vla-MergeCells TblObj 0 0 0 2)) )))
(vla-setText TblObj 0 0 "Bang thong ke")
(vla-setText TblObj 1 0 "STT")
(vla-setText TblObj 1 1 "Gia tri")
(vla-setText TblObj 1 2 "So luong")
(setq i 1 row 2 )
(foreach e lst
(vla-setText TblObj row 0 (itoa i))
(vla-setText TblObj row 1 (car e))
(vla-setText TblObj row 2 (cdr e))
(vla-SetCellAlignment TblObj row 1 7)
(vla-SetCellAlignment TblObj row 2 9)
(setq row (1+ row) i (1+ i)) )
(vla-put-regeneratetablesuppressed TblObj :vlax-false)
(vlax-release-object TblObj) )
(alert "Khong chon duoc Text.") )
(princ) )
(alert "\nPhien ban Cad cua ban khong ho tro tao Bang (TABLE)") ) )

2. Lip đếm text của SSG và ainhandilac sau khi đếm xuất ra tất cả các text đã select ra file exel

(defun C:VT2( / fn f ss e t1)
(if (setq fn (getfiled "Select file" "" "xls" 1))
(progn
(setq f (open fn "a"))
(setq ss (ssget '((0 . "TEXT"))))
(while (setq e (ssname ss 0))
(setq t1 (cdr (assoc 1 (entget e))))
(write-line t1 f)
(ssdel e ss)
)
(close f)
)
(alert "No file selected!")
)
)

Giờ mình muốn nối thành một lip với thực hiện lệnh như sau:

 

select text và in ra file exel với 1 cột số thứ tự 1 cột loại text và 1 cột số lượng loại đó.

 

Ngoài ra mình còn muốn thống kê text vào file excel có sẵn trên ổ đĩa. Vì với một bản vẽ điện thì có rất nhiều tủ. Mình làm thống kê theo từng tủ nên tạo ra rất nhiều file exel. Nếu vẫn thống kê theo cách trên mà chỉ điền vào một file cell duy nhất tức là file exel đó đang làm đến row 17 sẽ điền tiếp vào row 18 thì tuyệt!

Many thanks!