Đến nội dung


Hình ảnh
* * * - - 8 Bình chọn

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


  • Chủ đề bị khóa Chủ đề bị khóa
3783 replies to this topic

#2441 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 01 November 2010 - 08:32 AM

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.c...awing1_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))
)
)

  • 2
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2442 thangbkpro

thangbkpro

    biết zoom

  • Members
  • Pip
  • 12 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 01 November 2010 - 08:54 AM

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!
  • 0

#2443 quan08

quan08

    biết vẽ pline

  • Members
  • PipPip
  • 67 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 01 November 2010 - 09:01 AM

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

#2444 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 01 November 2010 - 09:09 AM

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.
  • 1
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2445 duyhung

duyhung

    biết vẽ rectang

  • Members
  • PipPip
  • 88 Bài viết
Điểm đánh giá: 9 (bình thường)

Đã gửi 01 November 2010 - 09:39 AM

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.
  • 0
Song va chien dau!

#2446 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 01 November 2010 - 09:46 AM

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

  • 2

#2447 vtd_xd

vtd_xd

    biết vẽ circle

  • Members
  • PipPip
  • 38 Bài viết
Điểm đánh giá: 5 (bình thường)

Đã gửi 01 November 2010 - 10:28 AM

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
  • 0
Chuc vui ve

#2448 hugo75

hugo75

    biết vẽ polygon

  • Members
  • PipPip
  • 72 Bài viết
Điểm đánh giá: -4 (bình thường)

Đã gửi 01 November 2010 - 10:50 AM

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

#2449 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 01 November 2010 - 11:03 AM

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

  • 2
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2450 thangbkpro

thangbkpro

    biết zoom

  • Members
  • Pip
  • 12 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 01 November 2010 - 11:21 AM

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!
  • 0

#2451 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 01 November 2010 - 01:01 PM

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

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!

Khi đã tạo được Table rồi thì xuất qua Excel chỉ là chuyện nhỏ.
Tue_NV mạn phép anh gia_bach bổ sung thêm vào tính năng thêm data vào bảng TABLE đã có :
Bạn thangbkpro test thử nhé :

(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)))
(initget "T TH")
(setq ans (getkword "Ban Tao bang moi hay THem du lieu vao bang da co :"))
(IF (= ans "T") (PROGN
(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 )
)
(PROGN
(setq tblobj (vlax-ename->vla-object (car(entsel "\n Chon bang can them du lieu vao :"))))
(setq row (1+ (vla-get-rows Tblobj)) i (- row 2))
(vla-insertrows Tblobj (1- row) h (1+ (length lst)))
)
)
(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)") ) )

Chức năng DownLoad của Diễn đàn có thể bị lỗi. Bạn có thể chạy với file này :
http://www.cadviet.c...files/3/tkt.lsp
  • 3

#2452 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 01 November 2010 - 01:31 PM

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

Chào bác Phamngoctukts,
Lisp của bác chạy đúng trong trường hợp các text được nhập đúng với trình tự hàng lối.
Bác nên bổ sung thêm vào hàm so sánh lambda trường hợp các text tuy có cùng tọa độ x của điểm chèn nhưng tọa độ y thay đổi không theo quy luật bác ạ.
Bác có thể tahm khảo lisp sắp xếp đối tượng của bác Hoành sẽ rõ.
Chúc bác vui.
  • 3
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2453 thangbkpro

thangbkpro

    biết zoom

  • Members
  • Pip
  • 12 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 01 November 2010 - 01:46 PM

Chức năng download của diễn đàn bị lỗi thật. File phía trên vẫn tải về được thực hiện lệnh nhưng ko ra kết quả Phải tải file phía dưới mới dùng đuợc!
Lip quá tuyệt kaka:)). Thank bác Tue_NV và bác gia_bach
  • 0

#2454 nguyentuyen6

nguyentuyen6

    biết lệnh chamfer

  • Advance Member
  • PipPipPipPip
  • 213 Bài viết
Điểm đánh giá: 124 (tàm tạm)

Đã gửi 01 November 2010 - 02:08 PM

Chào bác Phamngoctukts,
Lisp của bác chạy đúng trong trường hợp các text được nhập đúng với trình tự hàng lối.
Bác nên bổ sung thêm vào hàm so sánh lambda trường hợp các text tuy có cùng tọa độ x của điểm chèn nhưng tọa độ y thay đổi không theo quy luật bác ạ.
Bác có thể tahm khảo lisp sắp xếp đối tượng của bác Hoành sẽ rõ.
Chúc bác vui.

Bác nói đúng chỗ ngứa của em. Lúc đầu em cũng định làm gộp cả toạ độ x và y mà loay hoay 1 lúc với lambda vẫn không ra. Bác cho e cái link kia với. E tim không thấy, hêh
  • 0

Lisp In bản vẽ hàng loạt:
http://www.cadviet.c...ndpost&p=139860


#2455 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 01 November 2010 - 02:57 PM

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.

Hề hề hề,
Vậy là việc đầu tiên bạn cần làm là cải tạo lại cái bản vẽ này theo các quy ước của bạn đã. Sau đó mới nói chuyện làm lisp được. Vì người mà thua thì lisp nó cũng sẽ thua là cái chắc....
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2456 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 01 November 2010 - 02:59 PM

Bác nói đúng chỗ ngứa của em. Lúc đầu em cũng định làm gộp cả toạ độ x và y mà loay hoay 1 lúc với lambda vẫn không ra. Bác cho e cái link kia với. E tim không thấy, hêh

Bạn xem cái này vậy vì mình cũng chả nhớ rõ nó nằm ở đâu. Có nhẽ cũng trong mục viết lisp theo yêu cầu thôi nhưng mà nó dài quá......

(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)
(if (= (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))) )
(< (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2))) )
(< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))) )
)
)
)
)
)

(if (= (strcase tp) "P")
(setq lst (vl-sort lst
'(lambda (e1 e2)
(if (= (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))) )
(< (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2))) )
(> (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))) )
)
)
)
)
)
(setq S (getint "\n Nhap gia tri so bat dau danh thu tu"))
(setq i 0 n 1)
(while (< i (sslength ss))
(setq
thay (itoa (+ n S))
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)))
)


  • 2
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2457 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 01 November 2010 - 03:04 PM

Các bạn viết dùm lisp xuất dữ liệu dạng text từ cad sang excel (xuất theo thứ tự các lớp trong một thửa khép kính tương ứng một lớp là một cột ) có file mẩu
http://www.cadviet.c...iles/3/vd_8.rar

Chào bạn thanhvienmoi1981
Có lẽ bạn nên tạo mỗi thửa đất là 1 Polyline kín -> Sau đó, trên cơ sở các PLINE kín đó -> Lisp sẽ xuất ra toàn bộ như bạn mong muốn. Bạn có thể xem các bài viết của Tue_NV trong topic này :

chuyển số liệu text từ cad sang excell


  • 0

#2458 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1432 Bài viết
Điểm đánh giá: 1425 (rất tốt)

Đã gửi 01 November 2010 - 03:28 PM

Bác nói đúng chỗ ngứa của em. Lúc đầu em cũng định làm gộp cả toạ độ x và y mà loay hoay 1 lúc với lambda vẫn không ra. Bác cho e cái link kia với. E tim không thấy, hêh

Bạn tham khảo Lisp đánh số thứ tự này :
(defun c:dstt (/ doc i ins lst)
(vl-load-com)
(defun sort_lst (lst dk)
(if (= dk "Left")
(vl-sort lst '(lambda (x y)
(or (< (car (cadr x)) (car (cadr y)))
(and (= (car (cadr x)) (car (cadr y)))
(< (cadr (cadr x)) (cadr (cadr y))) )) ))
(vl-sort lst '(lambda (x y)
(or (> (car (cadr x)) (car (cadr y)))
(and (= (car (cadr x)) (car (cadr y)))
(< (cadr (cadr x)) (cadr (cadr y))) )) ))) )

(if (ssget '((0 . "TEXT")))
(progn
(initget 0 "Left Right")
(setq tp (cond ((getkword (strcat "\nBat dau tu: [Left/Right] <"
(cond (tp) ((setq tp "Right")) )
">: " ) ) )
(tp) ) )
(setq sbd (cond ((getint (strcat "\nVao so bat dau <"
(itoa (cond (sbd) ((setq sbd 1)) ) )
">: " ) ) )
(sbd) ) )
(setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vlax-for e (vla-get-ActiveSelectionSet doc)
(if (= (vla-get-Alignment e) 0)
(setq ins (vlax-get e 'InsertionPoint))
(setq ins (vlax-get e 'TextAlignmentPoint)) )
(setq lst (cons (list e ins )lst)))
(setq i (1- sbd)
lst (sort_lst lst tp )
lst (append (mapcar 'car lst) ) )
(foreach e lst
(vla-put-TextString e (itoa(setq i (1+ i)))) ) ))
(princ))

  • 2

#2459 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 01 November 2010 - 04:40 PM

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.

Chào bạn tuannt991,
Thấy bạn làm việc vất vả quá, 2 giờ sáng còn ngồi máy tính và post bài.
Mình đã tranh thủ sửa file bạn gửi được một phần, tách các đường ống DN40 ra khỏi các ống DN32 và DN50.
Với lisp sau, bạn có thể lấy được tổng chiều dài của các đường ống DN32 nằm trên layer "sprinkler" và các đường ống DN40 nằm trên layer DN40 mà mình mới tạo. Tương tự cách làm của mình, nếu bạn chịu khó ngồi tách các loại ống thành các lớp riêng thì bạn có thể sử dụng cái lisp mình viết để làm thống kê rất tốt.
Mong bạn thành công trong công việc và cuộc sống.

(defun c:tko (/ ss n i L la en obj)
(vl-load-com)
(setq la (getstring T "\n Nhap ten lop cua loai ong: "))
(setq ss (ssget "x" (list (cons 0 "lwpolyline") (cons 8 la)))
n (sslength ss)
i 0
L 0)
(while (< i n)
(setq en (ssname ss i)
obj (vlax-ename->vla-object en)
len (vlax-curve-getdistatparam obj (vlax-curve-getEndparam obj))
L (+ L len)
i (1+ i))
)
(alert (strcat "\n Tong chieu dai ong tren lop " la " la " (rtos L 2 2)))
)


Mình gửi kèm ở đây bản vẽ mình đả cải tạo để bạn tham khảo.
http://www.cadviet.c...748fsp301_1.dwg
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2460 hdt4151

hdt4151

    biết vẽ pline

  • Members
  • PipPip
  • 69 Bài viết
Điểm đánh giá: -1 (bình thường)

Đã gửi 02 November 2010 - 09:57 AM

Nhờ các bạn viết giúp mình lisp này nhé:

- Hoán đổi giá trị 2 nhóm text A và B

Điều kiện:

- Số text trong nhóm A và B bằng nhau
- Mỗi nhóm text A và B được sắp xếp ở dạng table gồm m hàng và n cột
- Xem như các text trong cùng 1 hàng có tọa độ x bằng nhau, trong 1 cột có y bằng nhau.
- File mẫu:
http://www.mediafire...1e7xz982g2vc7yr

- Còn đây là lisp có sẵn đã từng viết trước đó để các bạn tham khảo (đổi giá trị text của 2 cột)

(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)
(< (caddr (assoc 10 (entget x)))
(caddr (assoc 10 (entget y)))
)
)
)
)
(setq lis2 (vl-sort lis2 '(lambda (x y)
(< (caddr (assoc 10 (entget x)))
(caddr (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)

)

  • 0