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

Tháng 11 1, 2010

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) (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  :")))
(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.com/upfiles/3/tkt.lsp

Tháng 11 1, 2010

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

Tháng 11 1, 2010

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

Tháng 11 1, 2010

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

Tháng 11 1, 2010

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

Tháng 11 1, 2010

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

(if (= (strcase tp) "P")
(setq lst (vl-sort lst
'(lambda (e1 e2)
(if (= (cadr (assoc 10 (entget e1))) (cadr (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 ((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)))
)

Tháng 11 1, 2010

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.com/upfiles/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

Tháng 11 1, 2010

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

Tháng 11 1, 2010

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 (      (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.com/upfiles/3/0748fsp301_1.dwg

Tháng 11 2, 2010

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.com/?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)

)

Tháng 11 2, 2010

@Tue_NV: lisp trên chạy chưa đúng khi các text trong cùng 1 hàng (cột) khác nhau.

File vd minh họa:

http://www.mediafire.com/?t6baa4ex788567

Tháng 11 2, 2010

Mình gửi lại link file trên :)

http://www.mediafire.com/?o16ukd7xm803l8x

Tháng 11 2, 2010

Mình gửi lại link file trên :)
http://www.mediafire.com/?o16ukd7xm803l8x

Bạn thử lại nhé :


(defun c:cs(/ ss sx lis1 lis2 n i nn mm li li1)
;Copy right by Tue_NV
(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) 
     (if (equal (cadr (assoc 10 (entget x)))
                 (cadr (assoc 10 (entget y)))
                 (cdr  (assoc 40 (entget x)))  )
            (               (caddr (assoc 10 (entget y)))
            )
    (               (cadr (assoc 10 (entget y)))
            )		
             )
        ))
)
(setq lis2 (vl-sort lis2 '(lambda (x y) 
     (if (equal (cadr (assoc 10 (entget x)))
                 (cadr (assoc 10 (entget y)))
                 (cdr  (assoc 40 (entget x)))  )
            (               (caddr (assoc 10 (entget y)))
            )
    (               (cadr (assoc 10 (entget y)))
            )		
             )
        ))
)    
(setq n (sslength ss) i 0)

(if (= (length lis1) (length lis2))
(progn
   (while (
    (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)

)

Tháng 11 2, 2010

Mình gửi lại link file trên :D
http://www.mediafire.com/?o16ukd7xm803l8x

Chào bạn hdt4151,

Gửi bạn cái này coi thử có Ok không nhé.

(defun c:cntxt (/ a b el1 el2 ssl ss1 ss2 els1 els els2)
(setq a (car (entsel "\n Chon text thu nhat"))
       b (car (entsel "\n Chon text thu hai"))
       el1 (entget a )
       el2 (entget b )
       ssl (acet-ss-to-list (ssget "x" (list (cons 0 "text") )))
       ss1 (list)
       ss2 (list)
)
(foreach x ssl
      (if  (equal (cadr (assoc 10 (entget x))) (cadr (assoc 10 el1)) 0.001)
           (setq ss1 (append ss1(list x)))
      )
      (if (equal (cadr (assoc 10 (entget x))) (cadr (assoc 10 el2)) 0.001)
           (setq ss2 (append ss2 (list x)))
      )
)
;;;;(setq ss1 (vl-sort ss1 '(lambda (x y) (        ;;;;ss2 (vl-sort ss2 '(lambda (x y) (;;;:)
(foreach c ss1
       (setq els1 (entget c)
                p (cdr (assoc 10 els1))
       )
       (foreach d ss2
                   (setq els2 (entget d))
                   (if ( equal (caddr (assoc 10 els2)) (caddr (assoc 10 els1)) 0.001)
                      (progn
                           (setq els1 (subst (cons 10 (cdr (assoc 10 els2))) (assoc 10 els1) els1)
                                   els2 (subst (cons 10 p) (assoc 10 els2) els2)
                           )
                           (entmod els1)
                           (entmod els2)
                      )
                   )
        )
)
)

Bạn có thể dựa vào đây để có lisp đổi text theo hàng.

Chú ý là lisp này không yêu cầu số text trong các cột phải bằng nhau, song chỉ có các text trong cột có text cùng tọa độ y ở cột còn lại mới được đổi chỗ mà thôi. Nếu text nào không có text tương ứng ở cột kia sẽ được giữ nguyên giá trị.

Hề hề hề....

Chúc bạn vui.

Tháng 11 2, 2010

Thanks 2 bạn Tue_NV và phamthanhbinh nhiều nhé, lisp chạy rất tốt :)

Tháng 11 2, 2010

- 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

-Bạn phamngoctukts xem giúp mình lisp của bài này nhé http://www.cadviet.com/forum/index.php?s=&...st&p=115000

- Cám ơn nhiều :)

Tháng 11 3, 2010

-Bạn phamngoctukts xem giúp mình lisp của bài này nhé http://www.cadviet.com/forum/index.php?s=&...st&p=115000
- Cám ơn nhiều :)

Chào bạn bachngoctung!

Mấy hôm vưa rồi bận quá mình sửa cho bạn đây.

;; free lisp from cadviet.com

(defun c:dtcd ()
(vl-load-com)
(setq dth (car (entsel "\nChon vung can tinh dien tich"))
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))
)
)
 (if (> ang 90) (setq ang (+ ang 180)))
(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)
(command "qleader" (car (cdr ll)) pblock \e)
(setvar "osmode" oldos)
)

Tháng 11 3, 2010

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) (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  :")))
(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.com/upfiles/3/tkt.lsp

Cám ơn bác Tue và bác gia_bach.Bây giờ từ lisp này,mong các bác có thể giúp em :

- Vẫn lisp này nhưng bỏ cột STT đi.

- 1 lisp mới có chức năng tương tự nhưng chuyển theo dạng hàng ngang như sau(c:tktn)

- Với các lisp này,liệu có thể thay việc tạo table bằng việc kẻ pl như phiên bản TKT đầu tiên bác gia_bach viết k (phiên bản thứ 2 do yêu cầu sắp xếp text,e thấy bác ấy đã chuyển sang tạo table) ? vì vấn đề thao tác sửa Title trong table với e còn rườm rà quá (rườm rà hơn sửa trực tiếp dtext :) )

Tháng 11 3, 2010

Cám ơn bác Tue và bác gia_bach.Bây giờ từ lisp này,mong các bác có thể giúp em :
- Vẫn lisp này nhưng bỏ cột STT đi.

- 1 lisp mới có chức năng tương tự nhưng chuyển theo dạng hàng ngang như sau(c:tktn)

- Với các lisp này,liệu có thể thay việc tạo table bằng việc kẻ pl như phiên bản TKT đầu tiên bác gia_bach viết k (phiên bản thứ 2 do yêu cầu sắp xếp text,e thấy bác ấy đã chuyển sang tạo table) ? vì vấn đề thao tác sửa Title trong table với e còn rườm rà quá (rườm rà hơn sửa trực tiếp dtext :) )

Liệu có thể thay việc tạo table bằng việc kẻ pl

-> Tại sao không tận dụng các tính năng mới của CAD?

Bạn thử lisp mới có chức năng tương tự nhưng chuyển theo dạng hàng ngang

(defun c:tkt(/ ent h height i len0 lst msp pt 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)))  )
 (defun NormalizeNumberInString (str / ch i pat ret count buf);(NormalizeNumberInString "08-01-2009")
   (setq i     0
  pat   '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  ret   ""
  count 4 )
   (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
     (if (vl-position ch pat)
(progn
  (setq buf ch)
  (while (vl-position (setq ch (substr str (setq i (1+ i)) 1)) pat)
    (setq buf (strcat buf ch)))
  (while (< (strlen buf) count) (setq buf (strcat "0" buf)))
  (setq ret (strcat ret buf))) )
     (setq ret (strcat ret ch)) )
   ret)
 ;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 4)
  (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) (< (NormalizeNumberInString(car x))
					   (NormalizeNumberInString(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 "CK" msp))
	height (* 2 h))
  (if str0
    (setq width1 (* 1.2 h(TxtWidth (strcase str0) msp)))
    (setq width1 (* 2 h(TxtWidth "Text" 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) 3(+ (length lst) 1) height width1))	  
  (vla-put-regeneratetablesuppressed TblObj :vlax-true)
  (vla-put-TitleSuppressed TblObj :vlax-true)
  (vla-DeleteRows TblObj 0 1)
  (vla-put-vertcellmargin TblObj (* 0.25 h))
  (vla-put-horzcellmargin TblObj (* 0.75 h))
  (vla-SetColumnWidth TblObj 0 width0)
  (vla-setTextHeight TblObj acDataRow h)
  (vla-setAlignment TblObj acDataRow 8)
  (vla-setText TblObj 0 0 "CK")
  (vla-setText TblObj 1 0 "SL")
  (setq i 1)
  (foreach e lst
    (vla-setText TblObj 0 i (car e))
    (vla-setText TblObj 1 i (cdr e))
    (setq 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)")   )  )

Tháng 11 3, 2010

Diễn đàn đang lỗi nên e chưa lấy code về nghiền được,e cứ thanks bác trước rồi tí vướng ở đâu e xin phép hỏi lại sau.Còn vấn đề table và dtext thì sự thể là e dùng TCVN3,trước khi chạy lisp thì e phải tạo table style trước nên đâm ra cứ thế nào ý.hay các bác chỉ cho e xin các sysvar hoặc hàm thiết lập table style với :"> E tìm chưa thấy ạ.

Rồi mỗi khi muốn sửa 1 chữ trong đấy,thì kích đúp nó hiện bảng edit text rườm rà quá ^^.Hơn nữa,như trong hình em post ý ạ,các đường cell có layer,độ dày nét in,màu mè khác text bên trong.Nếu tạo table rồi thì tấ cả giống nhau hết,e không biết cách khắc phục đâm ra mới mong nó quay về cổ điển.

PS : ý,sau khi post xong thì e cũng down về được xong,code chạy rất mượt bạc ạ ^^

Nhưng e có 1 số thắc mắc sau :

- Text được tạo trước khi kẻ table hay sao ạ ? Mà mình quy định text height ở trong tabstyle rồi mà nó vẫn có thể kẻ bảng theo giá trị nhập vào ^^.Hay là khi tạo table thì nó thay đổi giá trị textheight trong tablestyle ?

- Các text không nằm giữa cell mặc dù mình đã thiết lập Midle Center.

- Nếu text tầm 2 từ (dầm móng),thì cell bị đẩy xuống,nhận thấy rõ là text không nằm đúng giữa cell.Có cách nào khắc phục được không ạ?hay Cad thiết đặt thế?

- Nếu text dài hẳn ra (dầm móng băng) thì nó lại không bị đẩy xuống nữa,mà nằm thẳng hàng.Em mong muốn lúc nào nó cũng như thế này được không ạ?

Đây cũng là 1 số lý do nữa mà e "chưa" ưa table :)

Tháng 11 4, 2010

Diễn đàn đang lỗi nên e chưa lấy code về nghiền được,e cứ thanks bác trước rồi tí vướng ở đâu e xin phép hỏi lại sau.Còn vấn đề table và dtext thì sự thể là e dùng TCVN3,trước khi chạy lisp thì e phải tạo table style trước nên đâm ra cứ thế nào ý.hay các bác chỉ cho e xin các sysvar hoặc hàm thiết lập table style với :"> E tìm chưa thấy ạ.
Rồi mỗi khi muốn sửa 1 chữ trong đấy,thì kích đúp nó hiện bảng edit text rườm rà quá ^^.Hơn nữa,như trong hình em post ý ạ,các đường cell có layer,độ dày nét in,màu mè khác text bên trong.Nếu tạo table rồi thì tấ cả giống nhau hết,e không biết cách khắc phục đâm ra mới mong nó quay về cổ điển.

PS : ý,sau khi post xong thì e cũng down về được xong,code chạy rất mượt bạc ạ ^^

Nhưng e có 1 số thắc mắc sau :

- Text được tạo trước khi kẻ table hay sao ạ ? Mà mình quy định text height ở trong tabstyle rồi mà nó vẫn có thể kẻ bảng theo giá trị nhập vào ^^.Hay là khi tạo table thì nó thay đổi giá trị textheight trong tablestyle ?

- Các text không nằm giữa cell mặc dù mình đã thiết lập Midle Center.

- Nếu text tầm 2 từ (dầm móng),thì cell bị đẩy xuống,nhận thấy rõ là text không nằm đúng giữa cell.Có cách nào khắc phục được không ạ?hay Cad thiết đặt thế?

- Nếu text dài hẳn ra (dầm móng băng) thì nó lại không bị đẩy xuống nữa,mà nằm thẳng hàng.Em mong muốn lúc nào nó cũng như thế này được không ạ?

Đây cũng là 1 số lý do nữa mà e "chưa" ưa table :)

Chào ketxu

Một cách tổng quát, mức độ hổ trợ tiếng Việt của LISP chưa đầy đủ, ví thế (như bạn đã gặp) đôi khi các cell bị đẩy xuống thành 2 dòng. <_<

về các thắc mắc khác, bạn xem code từ đọan :

(setq pt (getpoint "\nDiem dat Bang :")

TblObj (vla-addtable msp (vlax-3d-point pt) 3(+ (length lst) 1) height width1))

... đến

(vlax-release-object TblObj)

các hàm cần quan tâm :

- vla-addtable: tạo đối tượng bảng

- vla-put-vertcellmargin hay vla-put-horzcellmargin : căn lề cho các Cell

- vla-setTextHeight: thiết lập chiều cao Text

- vla-setAlignment: thiết lập căn lề cho Text trong Cell

- vla-setText: gán giá trị cho 1 Cell

Để các text nằm giữa cell (phuơng đứng) thay đổi các tham số trong hàm vla-put-vertcellmargin.

Bạn tham khảo Video hướng dẫn thao tác với đối tượng bảng

Tháng 11 4, 2010

Cám ơn bác đã chỉ dẫn,em sẽ lần mò tiếp ạ ^^

Tháng 11 4, 2010

Bạn thử lại nhé :


(defun c:cs(/ ss sx lis1 lis2 n i nn mm li li1)
;Copy right by Tue_NV
(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) 
     (if (equal (cadr (assoc 10 (entget x)))
                 (cadr (assoc 10 (entget y)))
                 (cdr  (assoc 40 (entget x)))  )
            (< (caddr (assoc 10 (entget x)))
               (caddr (assoc 10 (entget y)))
            )
    (< (cadr (assoc 10 (entget x)))
               (cadr (assoc 10 (entget y)))
            )		
             )
        ))
)
(setq lis2 (vl-sort lis2 '(lambda (x y) 
     (if (equal (cadr (assoc 10 (entget x)))
                 (cadr (assoc 10 (entget y)))
                 (cdr  (assoc 40 (entget x)))  )
            (< (caddr (assoc 10 (entget x)))
               (caddr (assoc 10 (entget 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)

)

Lisp này của bác hay thật! Nhưng giờ em muốn không đổi chỗ 2 chuỗi mà copy nguyên giá trị của chuỗi 1 thay vào chuỗi 2thì làm như nào ạ? Em tìm mãi nhưng không biết thay ở chỗ nào. Cám ơn bác !

Thân !

Tháng 11 4, 2010

Lisp này của bác hay thật! Nhưng giờ em muốn không đổi chỗ 2 chuỗi mà copy nguyên giá trị của chuỗi 1 thay vào chuỗi 2thì làm như nào ạ? Em tìm mãi nhưng không biết thay ở chỗ nào. Cám ơn bác !
Thân !

NgocSon bỏ 2 dong này đi là được

(setq nn (subst (cons 1 li1) (assoc 1 nn) nn))

và

(entmod nn)

hoặc là thêm dấu ; trước 2 dòng đó

;(setq nn (subst (cons 1 li1) (assoc 1 nn) nn))

;(entmod nn)

-> Sau dấu ; thì những đoạn Lisp sau nó (trên dòng đó) hoàn toàn không có nghĩa

Tháng 11 4, 2010

Các bạn giúp mình 1 lisp mà khi đánh lênh break ở 2 đầu của 1 đoạn thẳng thì đoạn ở giữa tự chuyển thành nét đứt. Mong các bạn giúp 1 tay. Chân thành cảm ơn !

Đăng nhập

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

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

Tue_NV 3.912

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thangbkpro 0

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

nguyentuyen6 130

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Tue_NV 3.912

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

gia_bach 1.551

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

hdt4151 1

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

hdt4151 1

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

hdt4151 1

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Tue_NV 3.912

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

hdt4151 1

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

bachngoctung 11

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamngoctukts 714

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

gia_bach 1.551

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

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984