Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
Người theo dõi 0
huunhantvxdts

[Nhờ sữa lisp] xuất khối lượng qua excell

Bởi huunhantvxdts , trong AutoLisp

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

huunhantvxdts    195

huunhantvxdts
Đã đăng

Đây là lisp mình sửa lại để phục vụ cho công việc của mình

nhưng đang bị lỗi không xuất được những trắc ngang cuối cùng khoảng 7-8 trắc ngang chi đó

nhờ mọi người giúp đỡ

đây là lisp

 (defun c:Nhan (/ lstkm point kcach point1 pointtim diemtam)
 (defun sosanh (e1 e2 / p1 p2)
	(setq p1 (car e1)
		p2 (car e2)
	)
	(if (equal (cadr p1) (cadr p2) fuzz)
		(< (car p1) (car p2))
		(> (cadr p1) (cadr p2))
	)
	)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (prompt "\nChon doi tuong coc hoac ly trinh lam lop chuan.")  
  (setq dtltc (car (entsel)))
  (setq lop1 (cdr (assoc 8 (entget dtltc))))
  (prompt "\nChon doi tuong ghi dien tich lam lop chuan.")
  (setq lop2 (car (entsel)))
  (setq lop2 (cdr (assoc 8 (entget lop2))))
  ;(setq cot (getint "\nSo cot can xuat ra Excel:"))
(setq danhsachkm (acet-ss-to-list (ssget (list (cons 8 lop1) (cons 1 "K*")))))
(setq lstkm (mapcar '(lambda (e) (cons (cdr (assoc 11 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
(setq lstkm (vl-sort lstkm '(lambda(x y / tmx tmy) (setq tmx (timlt x) tmy (timlt y))
               (or (< (car tmx) (car tmy))
   (and (= (car tmx) (car tmy)) (< (last tmx) (last tmy)))))))
(setq ss (acet-ss-to-list (ssget "X" '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq fn (getfiled "Chon file de save" "" "csv" 1))
(setq fid (open fn "w"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(foreach ent lstkm
(setq point (car ent))
(setq kcach (distance point (cdr (assoc 11 (entget (nth 0 ss))))))
(foreach enxt ss
(setq point1 (cdr (assoc 11 (entget enxt))))
(setq toay (cadr point1))
(if (and (< (distance point1 point) kcach) (< toay (cadr point)) (equal (car point1) (car point) 1))
(progn
(setq pointtim (cdr (assoc 11 (entget enxt))))
(setq kcach (distance pointtim point))
)
)
)
(setq diemtam (polar pointtim (/ pi 2) (/ kcach 2)))
(command "ZOOM" "c" diemtam (+ kcach 5))
(setq dd (acet-ss-to-list (ssget "C" (polar pointtim (/ pi 4) 0.1 ) (polar pointtim (/ pi -4) 0.1 ) '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
(setq diemdau (cdr (assoc 10 (entget (car dd)))))
(setq diemcuoi (cdr (assoc 11 (entget (car dd)))))
(setq diemtren (polar point (/ pi 2) 3))
(command ".RECTANGLE" diemdau diemtren)
(setq text (ssget "C" diemdau diemtren (list (cons 0 "text"))))
(setq lst0 (ss2ent text lop1))
(setq lst0 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst0))
(setq lst2 (ss2ent text lop2))
(setq lst2 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst2))
(setq
	caotext (cdr (assoc 40 (entget (ssname text 0))))
	fuzz (* caotext 1.0)
	lst0 (vl-sort lst0 'sosanh)
	lst2 (vl-sort lst2 'sosanh)
	index 1
	oldy nil
)
(setq xuongdong 1)
	(foreach em lst0
	(if (= dong 0)
	(progn
	   (princ (cdr em) fid)
	   (princ "\n" fid)
	)
	(progn
	(if (= xuongdong 1)
	   (progn
	   (princ "\n" fid)
	   (princ (cdr em) fid)
	   (princ "\n" fid)
	   (setq xuongdong 2)
	   )
	(princ (cdr em) fid)
	)
	)
	)
	)
(setq dong 1)
	(foreach en lst2
	(if (equal oldy (cadr (car en)) fuzz)
  		(progn
     			(if (< index 4)
  			(progn
        		(princ "," fid)
        		(setq index (1+ index))
  			)
       		(progn
       		(setq index 1)
       		(princ "\n" fid)
       		)
      		)
  		)
 		(progn
  		(if hangdau
            		(progn
            		(setq index 1)
            		(princ "\n" fid)
           	 )
   		(setq hangdau t)
   		)
 		)
	)
	(princ (cdr en) fid)
	(setq oldy (cadr (car en)))
	)
(command ".RECTANGLE" diemcuoi diemtren)
(setq text1 (ssget "C" diemcuoi diemtren (list (cons 0 "text"))))
(setq lst3 (ss2ent text1 lop2))
(setq lst3 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst3))
(setq
	lst3 (vl-sort lst3 'sosanh)
	index 1
	oldy nil
)
(setq dong 1)
	(foreach en lst3
	(if (equal oldy (cadr (car en)) fuzz)
  		(progn
     			(if (< index 4)
  			(progn
        		(princ "," fid)
        		(setq index (1+ index))
  			)
       		(progn
       		(setq index 1)
       		(princ "\n" fid)
       		)
      		)
  		)
 		(progn
  		(if hangdau
            		(progn
            		(setq index 1)
            		(princ "\n" fid)
           	 )
   		(setq hangdau t)
   		)
 		)
	)
	(princ (cdr en) fid)
	(setq oldy (cadr (car en)))
	)
)
)

(defun timlt (st / tm)
  (setq tm (vl-string->list (substr (strcase (cdr st)) (+ 3 (vl-string-search "KM" (strcase (cdr st)))))))
  (read (strcat "(" (vl-list->string (subst 32 43 (subst 32 58 tm))) ")"))
)
(defun ss2ent (ss lop / sodt index lstent)
(setq
sodt (if ss
(sslength ss)
0
)
index 0
)
(repeat sodt
(setq ent (ssname ss index))
(setq index (1+ index))
(if (= (cdr (assoc 8 (entget ent))) lop)
(setq lstent (cons ent lstent))
)
)
(reverse lstent)

)

đây là file thực hiện

http://www.cadviet.com/upfiles/3/66960_tn_khong_dc_dia_chat.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

Tot77    508

Tot77
Đã đăng

Không biết cái này có được không, test thì vẫn đưa ra đủ.

Tôi phải sửa cho nó gọn lại cho dễ nhìn.

 

 (defun c:Nhan (/ lstkm point kcach point1 pointtim diemtam)
   (defun sosanh (e1 e2 / p1 p2)
(setq p1 (car e1)
p2 (car e2)
)
(if (equal (cadr p1) (cadr p2) fuzz)
(< (car p1) (car p2))
(> (cadr p1) (cadr p2))
)
   )
   
   (defun inra(lst)
    (setq index 1
 oldy nil)
    (foreach en lst
      (if (equal oldy (cadr (car en)) fuzz)
(progn (if (< index 4)
 (progn (princ "," fid) (setq index (1+ index)))
 (progn (setq index 1) (princ "\n" fid) )
       )
    )
(progn  (if hangdau
 (progn (setq index 1) (princ "\n" fid))
 (setq hangdau t))
  )
      )
      (princ (cdr en) fid)
      (setq oldy (cadr (car en)))
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (prompt "\nChon doi tuong coc hoac ly trinh lam lop chuan.")  
  (setq dtltc (car (entsel)))
  (setq lop1 (cdr (assoc 8 (entget dtltc))))
  (prompt "\nChon doi tuong ghi dien tich lam lop chuan.")
  (setq lop2 (car (entsel)))
  (setq lop2 (cdr (assoc 8 (entget lop2))))
  ;(setq cot (getint "\nSo cot can xuat ra Excel:"))
  (setq danhsachkm (acet-ss-to-list (ssget (list (cons 8 lop1) (cons 1 "K*")))))
  (setq lstkm (mapcar '(lambda (e) (cons (cdr (assoc 11 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
  (setq lstkm (vl-sort lstkm '(lambda(x y / tmx tmy) (setq tmx (timlt x) tmy (timlt y))
                 (or (< (car tmx) (car tmy))
    (and (= (car tmx) (car tmy)) (< (last tmx) (last tmy)))))))
  (setq ss (acet-ss-to-list (ssget "X" '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq fn (getfiled "Chon file de save" "" "csv" 1))
  (setq fid (open fn "w"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (foreach ent lstkm
    (setq point (car ent))
    (setq kcach (distance point (cdr (assoc 11 (entget (nth 0 ss))))))
    (foreach enxt ss
      (setq point1 (cdr (assoc 11 (entget enxt))))
      (setq toay (cadr point1))
      (if (and (< (distance point1 point) kcach) (< toay (cadr point)) (equal (car point1) (car point) 1))
(progn
 (setq pointtim (cdr (assoc 11 (entget enxt))))
 (setq kcach (distance pointtim point))
)
      )
    )
    (setq diemtam (polar pointtim (/ pi 2) (/ kcach 2)))
    (command "ZOOM" "c" diemtam (+ kcach 5))
    (setq dd (acet-ss-to-list (ssget "C" (polar pointtim (/ pi 4) 0.1 ) (polar pointtim (/ pi -4) 0.1 ) '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
    (setq diemdau (cdr (assoc 10 (entget (car dd)))))
    (setq diemcuoi (cdr (assoc 11 (entget (car dd)))))
    (setq diemtren (polar point (/ pi 2) 3))
    
    (command ".RECTANGLE" diemdau diemtren)
    (setq text (ssget "C" diemdau diemtren (list (cons 0 "text"))))
    (setq lst0 (ss2ent text lop1))
    (setq lst0 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst0))
    (setq lst2 (ss2ent text lop2))
    (setq lst2 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst2))
    (setq
caotext (cdr (assoc 40 (entget (ssname text 0))))
fuzz (* caotext 1.0)
lst0 (vl-sort lst0 'sosanh)
lst2 (vl-sort lst2 'sosanh)
    )
    (setq xuongdong 1)
    (foreach em lst0
(if (= dong 0)
 (progn (princ (cdr em) fid) (princ "\n" fid))
 (if (= xuongdong 1)
   (progn (princ "\n" fid) (princ (cdr em) fid) (princ "\n" fid) (setq xuongdong 2))
   (princ (cdr em) fid)
)
      )
    ) 
    (inra lst2)
 
    (command ".RECTANGLE" diemcuoi diemtren)
    (setq text1 (ssget "C" diemcuoi diemtren (list (cons 0 "text"))))
    (setq lst3 (ss2ent text1 lop2))
    (setq lst3 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst3))
    (setq lst3 (vl-sort lst3 'sosanh))
    (inra lst3)
  )
  (if fid (close fid))
)
 
(defun timlt (st / tm)
  (setq tm (vl-string->list (substr (strcase (cdr st)) (+ 3 (vl-string-search "KM" (strcase (cdr st)))))))
  (read (strcat "(" (vl-list->string (subst 32 43 (subst 32 58 tm))) ")"))
)
 
(defun ss2ent (ss lop / sodt index lstent)
  (setq sodt (if ss (sslength ss) 0)
index 0)
  (repeat sodt
    (setq ent (ssname ss index))
    (setq index (1+ index))
    (if (= (cdr (assoc 8 (entget ent))) lop)
      (setq lstent (cons ent lstent))
    )
  )
  (reverse lstent)
)
 
  • Vote tăng 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

huunhantvxdts    195

huunhantvxdts
Đã đăng

 

Không biết cái này có được không, test thì vẫn đưa ra đủ.

Tôi phải sửa cho nó gọn lại cho dễ nhìn.

 

 (defun c:Nhan (/ lstkm point kcach point1 pointtim diemtam)
   (defun sosanh (e1 e2 / p1 p2)
(setq p1 (car e1)
p2 (car e2)
)
(if (equal (cadr p1) (cadr p2) fuzz)
(< (car p1) (car p2))
(> (cadr p1) (cadr p2))
)
   )
   
   (defun inra(lst)
    (setq index 1
 oldy nil)
    (foreach en lst
      (if (equal oldy (cadr (car en)) fuzz)
(progn (if (< index 4)
 (progn (princ "," fid) (setq index (1+ index)))
 (progn (setq index 1) (princ "\n" fid) )
       )
    )
(progn  (if hangdau
 (progn (setq index 1) (princ "\n" fid))
 (setq hangdau t))
  )
      )
      (princ (cdr en) fid)
      (setq oldy (cadr (car en)))
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (prompt "\nChon doi tuong coc hoac ly trinh lam lop chuan.")  
  (setq dtltc (car (entsel)))
  (setq lop1 (cdr (assoc 8 (entget dtltc))))
  (prompt "\nChon doi tuong ghi dien tich lam lop chuan.")
  (setq lop2 (car (entsel)))
  (setq lop2 (cdr (assoc 8 (entget lop2))))
  ;(setq cot (getint "\nSo cot can xuat ra Excel:"))
  (setq danhsachkm (acet-ss-to-list (ssget (list (cons 8 lop1) (cons 1 "K*")))))
  (setq lstkm (mapcar '(lambda (e) (cons (cdr (assoc 11 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
  (setq lstkm (vl-sort lstkm '(lambda(x y / tmx tmy) (setq tmx (timlt x) tmy (timlt y))
                 (or (< (car tmx) (car tmy))
    (and (= (car tmx) (car tmy)) (< (last tmx) (last tmy)))))))
  (setq ss (acet-ss-to-list (ssget "X" '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq fn (getfiled "Chon file de save" "" "csv" 1))
  (setq fid (open fn "w"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (foreach ent lstkm
    (setq point (car ent))
    (setq kcach (distance point (cdr (assoc 11 (entget (nth 0 ss))))))
    (foreach enxt ss
      (setq point1 (cdr (assoc 11 (entget enxt))))
      (setq toay (cadr point1))
      (if (and (< (distance point1 point) kcach) (< toay (cadr point)) (equal (car point1) (car point) 1))
(progn
 (setq pointtim (cdr (assoc 11 (entget enxt))))
 (setq kcach (distance pointtim point))
)
      )
    )
    (setq diemtam (polar pointtim (/ pi 2) (/ kcach 2)))
    (command "ZOOM" "c" diemtam (+ kcach 5))
    (setq dd (acet-ss-to-list (ssget "C" (polar pointtim (/ pi 4) 0.1 ) (polar pointtim (/ pi -4) 0.1 ) '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
    (setq diemdau (cdr (assoc 10 (entget (car dd)))))
    (setq diemcuoi (cdr (assoc 11 (entget (car dd)))))
    (setq diemtren (polar point (/ pi 2) 3))
    
    (command ".RECTANGLE" diemdau diemtren)
    (setq text (ssget "C" diemdau diemtren (list (cons 0 "text"))))
    (setq lst0 (ss2ent text lop1))
    (setq lst0 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst0))
    (setq lst2 (ss2ent text lop2))
    (setq lst2 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst2))
    (setq
caotext (cdr (assoc 40 (entget (ssname text 0))))
fuzz (* caotext 1.0)
lst0 (vl-sort lst0 'sosanh)
lst2 (vl-sort lst2 'sosanh)
    )
    (setq xuongdong 1)
    (foreach em lst0
(if (= dong 0)
 (progn (princ (cdr em) fid) (princ "\n" fid))
 (if (= xuongdong 1)
   (progn (princ "\n" fid) (princ (cdr em) fid) (princ "\n" fid) (setq xuongdong 2))
   (princ (cdr em) fid)
)
      )
    ) 
    (inra lst2)
 
    (command ".RECTANGLE" diemcuoi diemtren)
    (setq text1 (ssget "C" diemcuoi diemtren (list (cons 0 "text"))))
    (setq lst3 (ss2ent text1 lop2))
    (setq lst3 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst3))
    (setq lst3 (vl-sort lst3 'sosanh))
    (inra lst3)
  )
  (if fid (close fid))
)
 
(defun timlt (st / tm)
  (setq tm (vl-string->list (substr (strcase (cdr st)) (+ 3 (vl-string-search "KM" (strcase (cdr st)))))))
  (read (strcat "(" (vl-list->string (subst 32 43 (subst 32 58 tm))) ")"))
)
 
(defun ss2ent (ss lop / sodt index lstent)
  (setq sodt (if ss (sslength ss) 0)
index 0)
  (repeat sodt
    (setq ent (ssname ss index))
    (setq index (1+ index))
    (if (= (cdr (assoc 8 (entget ent))) lop)
      (setq lstent (cons ent lstent))
    )
  )
  (reverse lstent)
)
 

Đúng như bạn nói chỉ chỉnh lại cho gọn thôi mà bây giờ nó lại xuất ra đúng

Vậy cái lúc đầu sai ở đâu???

Bạn thử  sử dụng cái lisp đầu cho ý kiến

1 lần nữa cám ơn bạn 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

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
Đăng nhập để thực hiện theo  
Người theo dõi 0
Về Đầu Trang AutoLisp
×