Chuyển đến nội dung
Diễn đàn CADViet
VO HINH

Lisp thông kê danh mục bản vẽ

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

Mình có sưu tầm dc lisp thông kê ATT block,  hiện tại phần STT đang hiển thị tên Block  xin nhờ các cao nhân sửa giúp phần STT theo thứ tự 1-2-3-....

image.png.d6d3a8403d1717fa588f6e32957c4221.png

và chỉnh sửa lại lisp khi quét chuột tạo bảng thổng kế sắp xếp tên và ký hiệu theo thứ tự

lisp :

(Defun c:DM (/ at>att at>item at>set atable cnt cw ena nc nr pt rh)
   (vl-load-com)
   ;; GET_ATTS BY BILL KRAMER
   (defun get_ATTS (EN / EL ATTS)
(setq EL (entget EN))
(setq ENA (cdr (assoc 2 EL))) ; wiz
(if (and (= (cdr (assoc 0 EL)) "INSERT")
     (= (cdr (assoc 66 EL)) 1)
    ) ;_ end and
    (progn
    (setq EN (entnext EN)
          EL (entget EN)
    ) ;_ end setq
    (while (= (cdr (assoc 0 EL)) "ATTRIB")
        (setq ATTS (cons (list
                 (vla-get-ObjectID
                  (vlax-ename->vla-object EN)
                 ) ; wiz
                 (cdr
                     (assoc 2 EL)
                 ) ;_ end_cdr
                 (cdr (assoc 1 EL))
                 ) ;_ end_list
                 ATTS
               ) ;_ end_cons
          EN   (entnext EN)
          EL   (entget EN)
        ) ;_ end setq
    ) ;_ end while
    (list ena (reverse ATTS)) ; wiz
    ) ;_ end progn
) ;_ end if
   ) ;_ end_defun
   (if    (setq at>set (ssget '((0 . "INSERT"))))
(progn
    (setq at>att
         (mapcar 'get_atts
             (vl-remove-if
             'listp
             (mapcar 'cadr (ssnamex at>set))
             ) ;_ end_vl-remove-if
         ) ;_ end_mapcar
    ) ;_ end_setq
    (setq PT (getpoint "\nTable insertion point: ")
      RH (* 2.0 (getvar "TEXTSIZE"))
      CW (* 20.0 (getvar "TEXTSIZE"))
      NR (+ 2 (length at>att))
      NC (1+ (length (cadar at>att)))
    ) ;_ end_setq
    (setq
    aTable (vla-addtable
           (vla-get-modelspace
               (vla-get-activedocument
               (vlax-get-acad-object)
               ) ;_ end_vla-get-activedocument
           ) ;_ end_vla-get-modelspace
           (vlax-3d-point PT)
           NR
           NC
           RH
           CW
           ) ;_ end_vla-addtable
    ) ;_ end_setq
    (vla-setcellvalue aTable 0 0 "DANH MUC BAN VE")
    (vla-setcellvalue aTable 1 0 "STT")
    (vla-setcellvalue aTable 1 1 "TEN BAN VE") 
    (vla-setcellvalue aTable 1 2 "KY HIEU")
    (vla-MergeCells aTable 1 1 2 (length (cadar at>att)))
    (setq CNT 2) ;_ end_setq
    (foreach Item at>att
    (vla-setcellvalue aTable CNT 0 (car Item))
    (setq at>item 1)
    (while (<= at>item (length (cadar at>att)))
        (vl-catch-all-apply
        '(lambda ()
             (vla-settext
             aTable
             CNT
             at>item
             (strcat
                 "%<\\AcObjProp Object(%<\\_ObjId "
                 (itoa (car (nth (1- at>item) (cadr Item))))
                 ">%).TextString>%"
             ) ;_ end_strcat
             ) ;_ end_vla-setcellvalue
         ) ;_ end_lambda
        ) ;_ end_vl-catch-all-apply
        (setq at>item (1+ at>item))
    ) ;_ end_while
    (setq CNT (1+ CNT))
    ;;ready next row
    ) ;_ end_foreach
) ;_ end_progn
   ) ;_ end_if
   (princ)
) ;_ end_Defun

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
2 giờ trước, VO HINH đã nói:

Thank DungNguyen 685, em đã thay đổi nhưng vẫn k dc.

Bạn xem lại thử sửa đúng mình nói và load lại chưa. Chứ sửa thế đúng rồi đó.

  • Like 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

DungNguyen685  có thểm thêm lệnh để lisp hoàn chỉnh đc k?

 tạo bảng thổng kế sắp xếp tên và ký hiệu theo thứ tự  kt 01- kt 02.....

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
17 giờ trước, VO HINH đã nói:

DungNguyen685  có thểm thêm lệnh để lisp hoàn chỉnh đc k?

 tạo bảng thổng kế sắp xếp tên và ký hiệu theo thứ tự  kt 01- kt 02.....

(defun c:DM (/ at>att at>item at>set atable cnt cw ena nc nr pt j list1 list2 list3 L rh) 
   (vl-load-com)
   ;; GET_ATTS BY BILL KRAMER
   (defun get_ATTS (EN / EL ATTS)
(setq EL (entget EN))
(setq ENA (cdr (assoc 2	 EL))) ; wiz
(if (and (= (cdr (assoc 0 EL)) "INSERT")
     (= (cdr (assoc 66 EL)) 1)
    ) ;_ end and
    (progn
    (setq EN (entnext EN)
          EL (entget EN)
    ) ;_ end setq
    (while (= (cdr (assoc 0 EL)) "ATTRIB")
        (setq ATTS (cons (list
                 (vla-get-ObjectID
                  (vlax-ename->vla-object EN)
                 ) ; wiz
                 (cdr
                     (assoc 2 EL)
                 ) ;_ end_cdr
                 (cdr (assoc 1 EL))
                 ) ;_ end_list
                 ATTS
               ) ;_ end_cons
          EN   (entnext EN)
          EL   (entget EN)
        ) ;_ end setq
    ) ;_ end while

    (list ena (reverse ATTS)) ; wiz

    ) ;_ end progn
) ;_ end if
   ) ;_ end_defun
   (if    (setq at>set (ssget '((0 . "INSERT"))))
(progn
    (setq at>att
         (mapcar 'get_atts
             (vl-remove-if
             'listp
             (mapcar 'cadr (ssnamex at>set))
             ) ;_ end_vl-remove-if
         ) ;_ end_mapcar
    ) ;_ end_setq
    (setq PT (getpoint "\nTable insertion point: ")
      RH (* 2.0 (getvar "TEXTSIZE"))
      CW (* 20.0 (getvar "TEXTSIZE"))
      NR (+ 2 (length at>att))
      NC (1+ (length (cadar at>att)))
    ) ;_ end_setq
    (setq
    aTable (vla-addtable
           (vla-get-modelspace
               (vla-get-activedocument
               (vlax-get-acad-object)
               ) ;_ end_vla-get-activedocument
           ) ;_ end_vla-get-modelspace
           (vlax-3d-point PT)
           NR
           NC
           RH
           CW
           ) ;_ end_vla-addtable
    ) ;_ end_setq
    (vla-setcellvalue aTable 0 0 "DANH M\U+1EE4C B\U+1EA2N V\U+1EBC")
    (vla-setcellvalue aTable 1 0 "STT")
    (vla-setcellvalue aTable 1 1 "T\U+00CAN B\U+1EA2N V\U+1EBC") 
    (vla-setcellvalue aTable 1 2 "K\U+00DD HI\U+1EC6U")
    (vla-MergeCells aTable 1 1 2 (length (cadar at>att)))
	;(princ     (cadr at>att))
;;edit by tavantants	
(setq L nil ) 
(setq j 0)
(while (< j (length  at>att) )
	(setq list1 (nth j at>att))
	(setq list2 (nth 2 (cadr (nth 1 list1))))
	(setq list3 (substr list2 (+ 2 (vl-string-search " " list2))))	
	(setq L (append L (list (list  list3 (nth 1 list1)      ))))	
(setq j (1+ j))
)
(setq L (vl-sort L '(lambda (x y) (< (atof(car x)) (atof(car y))))))
;;edit by tavantants
    (setq CNT 2) ;_ end_setq
    (foreach Item L
    (vla-setcellvalue aTable CNT 0 (- CNT 1)) ;Thay  (car Item) thành (- CNT 1)
    (setq at>item 1)
    (while (<= at>item (length (cadar L)))
        (vl-catch-all-apply
        '(lambda ()
             (vla-settext
             aTable
             CNT
             at>item
             (strcat " "
                 "%<\\AcObjProp Object(%<\\_ObjId "
                 (itoa (car (nth (1- at>item) (cadr Item))))
                 ">%).TextString>%"
             ) ;_ end_strcat
             ) ;_ end_vla-setcellvalue
;;edit by tavantants			 
			 (vla-SetCellAlignment aTable CNT 0 5)
			 (vla-SetCellAlignment aTable CNT 1 4)			 
			 (vla-SetCellAlignment aTable CNT 2 5)			 
	(vla-setTextHeight aTable (- CNT 0) (getvar "TEXTSIZE"))			 	 
	(vla-SetColumnWidth aTable 0 (* 6 (getvar "TEXTSIZE")) )    ;(getvar "TEXTSIZE")
	(vla-SetColumnWidth aTable 1 (* 24 (getvar "TEXTSIZE")))			 
	(vla-SetColumnWidth aTable 2 (* 14 (getvar "TEXTSIZE")))	
	(vla-SetRowHeight aTable 0 (* 2 (getvar "TEXTSIZE")))
	(vla-SetRowHeight aTable 1 (* 2 (getvar "TEXTSIZE")))
	(vla-SetRowHeight aTable 2 (* 2 (getvar "TEXTSIZE")))	
	(vla-SetRowHeight aTable (- CNT 0) (* 2 (getvar "TEXTSIZE")))
;;edit by tavantants	
         ) ;_ end_lambda
        ) ;_ end_vl-catch-all-apply
        (setq at>item (1+ at>item))
    ) ;_ end_while
    (setq CNT (1+ CNT))
    ;;ready next row
    ) ;_ end_foreach
) ;_ end_progn
   ) ;_ end_if
   (princ)
) ;_ end_Defun

Bạn thử cái này. Chú ý ký hiệu bản vẽ giữa chữ với số là dấu cách.

VD: KT 01 hoặc KT 1

Còn nếu muốn thay đổi bằng ý tự "-" hay gì đó thì sửa trong 2 dấu " " chỗ này.

(setq list3 (substr list2 (+ 2 (vl-string-search " " list2))))

Mình có edit thêm một số chỗ giãn dòng và cột phụ thuộc vào TEXTSIZE, nên để textstyle Standard font họ arial... để không bị lỗi font.

  • Like 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
1 giờ} trướ}c, DungNguyen685 đã nói:

(defun c:DM (/ at>att at>item at>set atable cnt cw ena nc nr pt j list1 list2 list3 L rh) 
   (vl-load-com)
   ;; GET_ATTS BY BILL KRAMER
   (defun get_ATTS (EN / EL ATTS)
(setq EL (entget EN))
(setq ENA (cdr (assoc 2	 EL))) ; wiz
(if (and (= (cdr (assoc 0 EL)) "INSERT")
     (= (cdr (assoc 66 EL)) 1)
    ) ;_ end and
    (progn
    (setq EN (entnext EN)
          EL (entget EN)
    ) ;_ end setq
    (while (= (cdr (assoc 0 EL)) "ATTRIB")
        (setq ATTS (cons (list
                 (vla-get-ObjectID
                  (vlax-ename->vla-object EN)
                 ) ; wiz
                 (cdr
                     (assoc 2 EL)
                 ) ;_ end_cdr
                 (cdr (assoc 1 EL))
                 ) ;_ end_list
                 ATTS
               ) ;_ end_cons
          EN   (entnext EN)
          EL   (entget EN)
        ) ;_ end setq
    ) ;_ end while

    (list ena (reverse ATTS)) ; wiz

    ) ;_ end progn
) ;_ end if
   ) ;_ end_defun
   (if    (setq at>set (ssget '((0 . "INSERT"))))
(progn
    (setq at>att
         (mapcar 'get_atts
             (vl-remove-if
             'listp
             (mapcar 'cadr (ssnamex at>set))
             ) ;_ end_vl-remove-if
         ) ;_ end_mapcar
    ) ;_ end_setq
    (setq PT (getpoint "\nTable insertion point: ")
      RH (* 2.0 (getvar "TEXTSIZE"))
      CW (* 20.0 (getvar "TEXTSIZE"))
      NR (+ 2 (length at>att))
      NC (1+ (length (cadar at>att)))
    ) ;_ end_setq
    (setq
    aTable (vla-addtable
           (vla-get-modelspace
               (vla-get-activedocument
               (vlax-get-acad-object)
               ) ;_ end_vla-get-activedocument
           ) ;_ end_vla-get-modelspace
           (vlax-3d-point PT)
           NR
           NC
           RH
           CW
           ) ;_ end_vla-addtable
    ) ;_ end_setq
    (vla-setcellvalue aTable 0 0 "DANH M\U+1EE4C B\U+1EA2N V\U+1EBC")
    (vla-setcellvalue aTable 1 0 "STT")
    (vla-setcellvalue aTable 1 1 "T\U+00CAN B\U+1EA2N V\U+1EBC") 
    (vla-setcellvalue aTable 1 2 "K\U+00DD HI\U+1EC6U")
    (vla-MergeCells aTable 1 1 2 (length (cadar at>att)))
;(princ     (cadr at>att))
;edit by tavantants	
(setq L nil ) 
(setq j 0)
(while (< j (length  at>att) )
	(setq list1 (nth j at>att))
	(setq list2 (nth 2 (cadr (nth 1 list1))))
	(setq list3 (substr list2 (+ 2 (vl-string-search " " list2))))	
	(setq L (append L (list (list  list3 (nth 1 list1)      ))))	
(setq j (1+ j))
)
(setq L (vl-sort L '(lambda (x y) (< (atof(car x)) (atof(car y))))))
;;edit by tavantants
    (setq CNT 2) ;_ end_setq
    (foreach Item L
    (vla-setcellvalue aTable CNT 0 (- CNT 1)) ;Thay  (car Item) thành (- CNT 1)
    (setq at>item 1)
    (while (<= at>item (length (cadar L)))
        (vl-catch-all-apply
        '(lambda ()
             (vla-settext
             aTable
             CNT
             at>item
             (strcat " "
                 "%<\\AcObjProp Object(%<\\_ObjId "
                 (itoa (car (nth (1- at>item) (cadr Item))))
                 ">%).TextString>%"
             ) ;_ end_strcat
             ) ;_ end_vla-setcellvalue
;edit by tavantants			 
			 (vla-SetCellAlignment aTable CNT 0 5)
			 (vla-SetCellAlignment aTable CNT 1 4)			 
			 (vla-SetCellAlignment aTable CNT 2 5)			 
	(vla-setTextHeight aTable (- CNT 0) (getvar "TEXTSIZE"))			 	 
	(vla-SetColumnWidth aTable 0 (* 6 (getvar "TEXTSIZE")) )    ;(getvar "TEXTSIZE")
	(vla-SetColumnWidth aTable 1 (* 24 (getvar "TEXTSIZE")))			 
	(vla-SetColumnWidth aTable 2 (* 14 (getvar "TEXTSIZE")))	
	(vla-SetRowHeight aTable 0 (* 2 (getvar "TEXTSIZE")))
	(vla-SetRowHeight aTable 1 (* 2 (getvar "TEXTSIZE")))
	(vla-SetRowHeight aTable 2 (* 2 (getvar "TEXTSIZE")))	
	(vla-SetRowHeight aTable (- CNT 0) (* 2 (getvar "TEXTSIZE")))
;;edit by tavantants	
         ) ;_ end_lambda
        ) ;_ end_vl-catch-all-apply
        (setq at>item (1+ at>item))
    ) ;_ end_while
    (setq CNT (1+ CNT))
    ;;ready next row
    ) ;_ end_foreach
) ;_ end_progn
   ) ;_ end_if
   (princ)
) ;_ end_Defun

Bạn thử cái này. Chú ý ký hiệu bản vẽ giữa chữ với số là dấu cách.

VD: KT 01 hoặc KT 1

Còn nếu muốn thay đổi bằng ý tự "-" hay gì đó thì sửa trong 2 dấu " " chỗ này.

(setq list3 (substr list2 (+ 2 (vl-string-search " " list2))))

Mình có edit thêm một số chỗ giãn dòng và cột phụ thuộc vào TEXTSIZE, nên để textstyle Standard font họ arial hay vni... để không bị lỗi font.

Thank DungNguyen685  nhiều.

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
4 phút trước, kysuketcau đã nói:

Tôi sử dụng lisp của bạn. Nhưng sử dụng chỉ tạo ra khung trống. Không thể thống kê được. Nhờ bạn chỉ giúp

Bạn gửi bản vẽ đó lên đây đi mình hd cho.

  • Like 1

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


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

Mình chỉnh sửa theo yêu cầu này:

Quote

DungNguyen685  có thểm thêm lệnh để lisp hoàn chỉnh đc k?

 tạo bảng thổng kế sắp xếp tên và ký hiệu theo thứ tự  kt 01- kt 02.....

 

test trên file :

Vào lúc 25/7/2021 tại 18:54, VO HINH đã nói:

đây bạn.

test.dwg

 

vvvvvv.gif

  • Like 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
  •  
Quote

Đây bạn ơi. tôi làm thôi của bạn cũng không được. 1 do lỗi phông. 2 là khi đưa ra thì chỉ có bảng trống. Mục tên bản vẽ: Tôi dùng MTEXT ko Block. Và số bản vẽ cũng vậy

5 giờ trước, DungNguyen685 đã nói:

Mình chỉnh sửa theo yêu cầu này:

 

test trên file :

 

vvvvvv.gif

 

 

 

khung bản vẽ.dwg

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


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

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

×