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

[Nhờ Chỉnh Sửa] Lisp Tính Diện Tích Trên Nhiều Trắc Ngang

Bởi huunhantvxdts , trong AutoLisp

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

huunhantvxdts    195

huunhantvxdts
Đã đăng

Đây là lisp mình viết đang còn hạn chế về tính tự động(chỉ tính từng hạng mục một).Bây giờ muốn phát triển thêm tính nhiều hạng mục

chỉ 1 lần chạy:

ý tưởng thì có nhưng viết lại không được mới khổ chứ:

1. Sẽ định nghĩa đối tượng tương ứng với hạng mục

Hạng mục 1

 1.1 chọn đối tượng

 1.2 chọn text hạng mục có sẳn (nếu ghi thì tôt hơn)

 1.3 chọn đơn vị m or m2

Hạng mục 2

 1.1 chọn đối tượng

 1.2 chọn text hạng mục có sẳn (nếu ghi thì tôt hơn)

 1.3 chọn đơn vị m or m2

..........

Sau khi định nghĩa xong các hạng mục Enter thì lisp điền diện tích luôn.

Và đây là lisp:

(defun c:DTTN (/ NDTS dem1 lstkm point kcach point1 pointtim diemtam xuongdong kt diemtren1)
(setvar "CMDECHO" 0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq lop1 "entdauco")
  (prompt "\nChon Pline hoac Hatch mau tinh dien tich.")
  (setq fltr (ssx_fe))
  (prompt "\nChon Text ghi dien tich.")
  (setq DTS (car (entsel)))
  (setq DTS (entget DTS))
  (setq NDTS (cdr (assoc 1 DTS)))
  (command "-layer" "new" "Tinh dien tich TN" "color" "2" "Tinh dien tich TN" "")
  (command "-layer" "set" "Tinh dien tich TN" "")
(if (null cdtxt)
 (caidat)
)
 (setq th (getvar "textsize"))
 (setq dentay (- dentay (* 1.5 th)))
  ;(prompt "\nChon trac ngang.")
  (setq danhsachkm (acet-ss-to-list (ssget "X" (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 dem1 1)
(setq sodt (length danhsachkm)
ta 
            (chr 8)
stxoa (strcat ta ta ta ta ta ta ta ta ta ta ta ta ta ta 
            ta ta ta ta ta ta)
stxuly "Xu ly duoc: "
ptcu nil
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
    (vla-ZoomCenter (vlax-get-acad-object) (vlax-3D-point diemtam) (+ kcach 50))
    (setq dd (acet-ss-to-list (ssget "C" (polar pointtim 0 0.1 ) (polar pointtim 0 0.15 ) '((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) 10))
	(setq diemtren1 (list (car diemcuoi) (cadr diemtren) 0))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq SSS (ssget "C" diemdau diemtren1 fltr)) 
(if (/= sss nil)
(progn
(setq i 0)
(setq s 0)
(setq N (sslength sss))
  (while (< i N)
  ;(luuos)
  (setvar "osmode" 0)
  (setq DT (ssname sss i))	
  (setq j 0)
  (setq ent1 (ssname data 0))
  (setq diemchuan (cdr (assoc 10 (entget ent1))))
  (Command "area" "o" DT)
  (if (= (getvar "area") 0)
  (progn
  (setq s (+ s (getvar "PERIMETER")))
  (setq i (1+ i))
  (setq donvi "m")
  )
  (progn
  (setq s (+ s (getvar "AREA")))
  (setq i (1+ i))
  (setq donvi "m2")
  )
  ))
  (setq diemghi (polar diemchuan 0 dentax))
  (setq diemghi (polar diemghi (/ pi 2) dentay))
  (setq txt NDTS)
  (command "TEXT" diemghi th 0 txt)
  (setq pointt11 (polar diemghi 0 cdtxt))
  (command "TEXT" pointt11 th 0 ":")
  (setq pointt1 (polar pointt11 0 cdsokl))
  (command "TEXT" "J" "R" pointt1 th 0 (rtos s 2 2))
  (setq point2 (polar pointt1 0 0.2))
  (command "TEXT" point2 th 0 donvi)
  ;(traos)
  )
  (progn
  (setq data (ssget "C" diemdau diemtren1 '((0 . "INSERT") (8 . "entdauco"))))
  (setq ent1 (ssname data 0))
  ;(luuos)
  (setvar "osmode" 0)
  (setq diemchuan (cdr (assoc 10 (entget ent1))))
  (setq diemghi (polar diemchuan 0 dentax))
  (setq diemghi (polar diemghi (/ pi 2) dentay))
  (setq txt NDTS)
  (command "TEXT" diemghi th 0 txt)
  (setq pointt11 (polar diemghi 0 cdtxt))
  (command "TEXT" pointt11 th 0 ":")
  (setq pointt1 (polar pointt11 0 cdsokl))
  (command "TEXT" "J" "R" pointt1 th 0 "0.00")
  (setq point2 (polar pointt1 0 0.2))
  (command "TEXT" point2 th 0 donvi)
  ;(traos)
  )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; xu ly phan tram chay o duoi
(setq pt (* (/ (* dem1 1.0) sodt) 100.0)
dem1 (+ dem1 1)
)
(if (/= pt ptcu)
(progn
(princ (strcat stxoa stxuly (rtos pt 2 0) "%"))
(setq ptcu pt)
)
)
;(princ "\nDang xu ly")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "MODEMACRO" "DANG CHUYEN DU LIEU CHO TRONG GIAY LAT")  
)
(setvar "CMDECHO" 1)
;(thoi)
)
(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 Caidat (/ htxt httxt ltxt lsokl)
 (if (null dentax)
 (progn
 (setq dentax 10)
 (setq dentay 10)
 ))
 (setq x (getstring (strcat "\nKhoang cach dien phuong x <"(rtos dentax)"> :")))
 (setq y (getstring (strcat "\nKhoang cach dien phuong y <"(rtos dentay)"> :")))
 (if (/= x "") (setq dentax (atof x)))
 (if (/= y "") (setq dentay (atof y)))
(setq htxt 0.2)
(setq httxt (getstring (strcat "\nNhap chieu cao chu <"(rtos htxt)"> :")))
(if (/= httxt "") (setq htxt (atof httxt)))
(setvar "textsize" htxt)
(setq cdtxt 4.5)
(setq ltxt (getstring (strcat "\nNhap chieu dai chuoi <"(rtos cdtxt)"> :")))
(if (/= ltxt "") (setq cdtxt (atof ltxt)))
(setq cdsokl 0.75)
(setq lsokl (getstring (strcat "\nNhap chieu dai chu so khoi luong <"(rtos cdsokl)"> :")))
(if (/= lsokl "") (setq cdsokl (atof lsokl)))
)
(defun C:Caidatlai (/ htxt httxt ltxt lsokl)
(if (null dentax)
 (progn
 (setq dentax 10)
 (setq dentay 10)
 ))
 (setq x (getstring (strcat "\nKhoang cach dien phuong x <"(rtos dentax)"> :")))
 (setq y (getstring (strcat "\nKhoang cach dien phuong y <"(rtos dentay)"> :")))
 (if (/= x "") (setq dentax (atof x)))
 (if (/= y "") (setq dentay (atof y)))
(setq htxt 0.2)
(setq httxt (getstring (strcat "\nNhap chieu cao chu <"(rtos htxt)"> :")))
(if (/= httxt "") (setq htxt (atof httxt)))
(setvar "textsize" htxt)
(setq cdtxt 4.5)
(setq ltxt (getstring (strcat "\nNhap chieu dai chuoi <"(rtos cdtxt)"> :")))
(if (/= ltxt "") (setq cdtxt (atof ltxt)))
(setq cdsokl 0.75)
(setq lsokl (getstring (strcat "\nNhap chieu dai chu so khoi luong <"(rtos cdsokl)"> :")))
(if (/= lsokl "") (setq cdsokl (atof lsokl)))
) 

Đây là file test:

http://www.cadviet.com/upfiles/5/66960_vi_du.dwg

  • 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

NguyenNgocSon    43

NguyenNgocSon
Đã đăng

Bài toán của bạn khá hay

Nhưng theo mình cách tính diện tích nên theo hướng khác, vì nếu đã tạo được Polyline thì vấn đề đơn giản rồi

Thuật toán xây dựng nên như Nova, dựa vào đường trắc ngang tự nhiên để xác định các loại diện tích.

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

Nó xuất phát từ thực tế bạn à. Với lại mình không đủ khả năng để xây dựng các thuật toán như Nova với các mã diện tích với các phép toán cộng trừ. ở đây mình đơn giản hơn nhiều. chỉ là các Polyline và các Hatch đã tạo ra sẳn từ 1 ứng dụng khác. Cám ơn bạn đã quan tâm

  • 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

NguyenNgocSon    43

NguyenNgocSon
Đã đăng

Mình cũng đang quan tâm đến chủ đề này. Nhưng về VBA mình có thể làm được cái bạn đang cần

Theo hướng này, bạn nên đi vào giao diện thì hay hơn
Sẽ tạo ra 1 list box gồm các layer đối tượng cần ghi trên từng trắc ngang
Sau đó, lệnh sẽ lấy diện tích hoặc chiều dài của đối tượng này ghi vào bản vẽ

Nhưng mình thiên theo hướng giống như Nova hơn, đang tìm hiểu và xây dựng bằng VBA

Bạn có ý tưởng gì có thể chia sẻ giúp

Trân trọng!

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

Cái giao diện thì mình đã nghĩ tới rồi nhưng khả năng viết thì chưa làm được. Lisp của mình ở đây lọc theo hàm ssx chứ ko phải layer. Mình nghĩ sẽ tao 1list các điều kiện lọc, sau đó sẽ chạy qua từng điều kiện để lấy kết quả không biết có được ko nữa.

Còn về VBA thì lúc đầu định đi theo nhưng lên diễn đàn thấy mọi người ko quan tâm nhiều nên bỏ.

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

buithengan1    1

buithengan1
Đã đăng

mình thấy trện youtube có 1 cái lisp tính diện tích khá hay nhưng không tải được. bạn có thể liên hệ với tác giả xem chớ mình thấy lisp của bạn phải mất thêm công đoạn bo polyline hoặc tô vật liệu khá mất thời gian

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

Cái này của Bác Hưng bạn vào trang của Bác ấy mà down nếu không thì để lại mail mình gửi cho. Cái này thì mình chưa dùng nhưng mình đã down về. Những cái Hatch và poly đã xuất ra từ 1 phần mềm khác, nên cũng nhanh thôi. mình đưa lên cho ai cần thôi mà

  • Vote tăng 2

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

leoteo1988    2

leoteo1988
Đã đăng

Mình là dân ngoại đạo biết rất ít nhưng lisp bạn viết cũng khá hay, mình tải về dùng thử thì bị lỗi, nếu được xin phép bạn gửi cho mình cái lisp này dùng thử, và cái bác hưng nữa. Cảm ơn bạn đã góp cho diễn đàn rất bổ ích, mail của mình là leohuy1988@gmail.com, một lần nữa cảm ơn bạn rất 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

chuotxd    0

chuotxd
Đã đăng

e là thành viên mới .. đấy là vấn đê e tìm rất lâu rồi . bác có thể cho e xin lip của bác Hưng đc k ạ. vì clip bác ấy up lên mạng e đã thấy nhưng k dowload đc về .. nếu đc gủi cho e vào gmail.. xuandoaixd92@gmail.com.. tk bác huunhantvxdts

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

trangnhung    3

trangnhung
Đã đăng

chào bác huunhantvxdts cho mình hỏi một chút, mình đã xem clips, mình có một thắc mắc là nếu như vậy thì mình phải bôi hacth cho toàn bộ các mặt cắt à vì địa hình luôn thay đổi làm như vậy rất mất thời gian. Mong hồi âm

ps: bác cho e xin lisp của bác duyhung được ko: mail:vlc.vnn@gmail.com

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

chào bác huunhantvxdts cho mình hỏi một chút, mình đã xem clips, mình có một thắc mắc là nếu như vậy thì mình phải bôi hacth cho toàn bộ các mặt cắt à vì địa hình luôn thay đổi làm như vậy rất mất thời gian. Mong hồi âm

ps: bác cho e xin lisp của bác duyhung được ko: mail:vlc.vnn@gmail.co

Cái này Hatch cũng được Polyline cũng được, đang nghiên cứu để tự động hơn

  • 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

Superlong    9

Superlong
Đã đăng

phần mềm này hay quá bạn cho mail cho mình với được không mình đang làm hoàn công phân lớp thủ công oải quá 
longnguyen4563@gmail.com
thanks bạn 

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
Về Đầu Trang AutoLisp
×