Chuyển đến nội dung
Diễn đàn CADViet
Duong Nhat Duy

Lisp tính chiều dài, diện tích hàng loạt

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

Gửi đến các bạn 1 lisp tính chiều dài, diện tích all-in-one, đơn giản, dễ dùng, và có thể tính được theo nhiều yêu cầu đề bài.

 

Công dụng:
- Tính chiều dài, diện tích nhiều đối tượng (Line, Pline, Spline, Arc, Circle, Hatch, Region, ...), có thể tính riêng lẻ hoặc cộng gộp.
- Kết quả có thể xuất ra text mới, block att, hoặc cập nhật vào text cũ, block att cũ.

- Kết quả có thể ghi dưới dạng Field, tự động cập nhật khi đối tượng thay đổi.


Cách dùng:
- Load lisp, nhập lệnh TL để thiếp lập các thông số như đơn vị, cao chữ,… Chỉ cần khai báo 1 lần (có thể bỏ qua lệnh này).
- Các lệnh tính chiều dài, diện tích bao gồm các lệnh riêng biệt như sau:

 

image.thumb.png.da632837ef1c089054123479e4594b1b.png

 

CD1: Tính chiều dài các đối tượng riêng lẻ

CD1.gif.fbeeea099df1aca63a118f8a355c575b.gif

 

CD2: Tính TỔNG chiều dài các đối tượng

CD2.gif.11a878073a651fadabe8947b3f91957c.gif

 

CD3: Tính chiều dài 1 đoạn bất kỳ nằm trên đối tượng

CD3.gif.faced0f7801489da1b3eb72970b767fb.gif


DT1: Tính diện tích 1 vùng (pick điểm, bấm đâu tính đó)

DT1.gif.0e8980740c70a5ddd2656f4d270f0c36.gif


DT2: Tính TỔNG diện tích các vùng chọn bằng các pick điểm (text kết quả có thể tạo mới bằng cách bấm vào khoảng trắng hoặc sửa text, att bằng cách bấm chọn 1 text, att đã có sẵn trên bản vẽ)

DT2.gif.7bc8a5799714878d784c014c2aec9add.gif


DT3: Tính diện tích các đối tượng riêng lẻ, có thể chọn được nhiều đối tượng cùng lúc, nhiều kiểu đối tượng ví dụ: Pline, Spline, Hatch, Region,…

DT3.gif.288e8af23418a96767972db83a074da5.gif


DT4: Tính TỔNG diện tích nhiều đối tượng (text kết quả có thể tạo mới bằng cách bấm vào khoảng trắng hoặc sửa text, att bằng cách bấm chọn 1 text, att đã có sẵn trên bản vẽ)

DT4.gif.84afc18dbcd2ef285ce343d15c94849f.gif

 

- Bonus: kết quả xuất ra có thể là Block do người dùng định nghĩa (ví dụ Block tem đất), khai báo trong lệnh TL

DT-Block.gif.c1cd06ace4f97536c33dbedf1522e438.gif

 

- Bonus: kết quả xuất ra có thể là Field (giá trị tự động cập nhật khi đối tượng thay đổi), khai báo trong lệnh TL

DT-Field.gif.e0f4aa55e9c0cde83565bdd109136aea.gif

 

Một số tính năng khác:

- Có thể thay đổi cài đặt mặc định mỗi khi dùng lisp bằng cách sửa trực tiếp file lisp (bằng Notepad hoặc các phần mềm tương tự), chỉ áp dụng với bản "Tinh chieu dai, dien tich v1.01" trở lên

1777660578_Suathongsomacdinh.png.fa266f2fed096589ca32af966b78fa80.png


File lisp:

- 01/11/2023: Tinh chieu dai, dien tich v1.00.lsp => Phiên bản đầu tiên

- 01/02/2024: Tinh chieu dai, dien tich v1.01.lsp => Người dùng có thể sửa file lisp theo cài đặt mặc định mong muốn + Sửa lỗi lệnh DT2 trên CAD2007

- 13/06/2024: Tinh chieu dai, dien tich v1.02.lsp => Thêm tính năng tạo Field (chiều dài, diện tích tự cập nhật khi đối tượng thay đổi)

 

Link Google Drive (dự phòng):

https://drive.google.com/drive/folders/1i9s1v8KgnD4weWO6ZpPOB1IOqqgxbEPd


Chúc các bạn thành công :)))

  • Like 23
  • Vote tăng 5

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

Thank bạn!
Mình gặp phải lỗi DT1 too many agruments thì làm sao sửa được ạ?
Mình dùng AutoCAD Architecture 2020.
 

Chắc bị lỗi khi HATCH do khác version cad thôi mà, tức là do lỗi dòng (command "-HATCH" "P" "S" pt ""). Có thể CAD architect có lệnh HATCH khác với version cad trước. Bạn thử xem lệnh hatch của bạn có bao nhiêu thông số.

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, 7o7 đã nói:

Chắc bị lỗi khi HATCH do khác version cad thôi mà, tức là do lỗi dòng (command "-HATCH" "P" "S" pt ""). Có thể CAD architect có lệnh HATCH khác với version cad trước. Bạn thử xem lệnh hatch của bạn có bao nhiêu thông số.

Uh có lẽ vậy, tại mình gà nên chỗ nãy phải dùng command chứ ko làm khác đc :v, nhưng mà command nó cũng có highlight nên khá tiện.

Mà giả sử vẫn là dùng command thì bạn có cách nào cải thiện lisp nó thích nghi với các đời cad khác nhau ko ?

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, Duong Nhat Duy đã nói:

Uh có lẽ vậy, tại mình gà nên chỗ nãy phải dùng command chứ ko làm khác đc :v, nhưng mà command nó cũng có highlight nên khá tiện.

Mà giả sử vẫn là dùng command thì bạn có cách nào cải thiện lisp nó thích nghi với các đời cad khác nhau ko ?

  Tôi dùng 2015 thì lisp của bác ok không bị lỗi gì, nhưng câu hỏi của bác phải để người nào cài nhiều cad mới biết mà trả lời, chứ tôi thì không thể.

  Nói chung viết lisp mà có dòng command thì không thể dùng với mọi loại cad, chỉ có người dùng tự biết mà chỉnh sửa thôi.

  Hay bác thử dùng (vla-AddHatch (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object))) acHatchPatternTypePreDefined "ANSI31" :vlax-True)) xem sao.

 

  • 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
44 phút trước, 7o7 đã nói:

  Tôi dùng 2015 thì lisp của bác ok không bị lỗi gì, nhưng câu hỏi của bác phải để người nào cài nhiều cad mới biết mà trả lời, chứ tôi thì không thể.

  Nói chung viết lisp mà có dòng command thì không thể dùng với mọi loại cad, chỉ có người dùng tự biết mà chỉnh sửa thôi.

  Hay bác thử dùng (vla-AddHatch (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object))) acHatchPatternTypePreDefined "ANSI31" :vlax-True)) xem sao.

 

Sau khi đọc qua đống code vla để tạo hatch mình nghĩ chắc mình vẫn để command thôi :))

 

14 giờ trước, doanquanghuy đã nói:

Thank bạn!
Mình gặp phải lỗi DT1 too many agruments thì làm sao sửa được ạ?
Mình dùng AutoCAD Architecture 2020.
 

Mình chưa hình dung ra lệnh Hatch trong AutoCAD Architecture 2020 nó ntn, bạn thử gõ -HATCH (có dấu trừ nhé) xong chụp màn hình mình xem

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
10 phút trước, NTHAHT đã nói:

Mình tham gia 1 cái, tất cả trong 1 lệnh: DTS.

(Các lựa chọn nằm ở dòng nhắc)

DTS.rar

Lisp bạn khá hay, nhưng nó bị ntn, nó ko trừ đi diện tích cục bên trong. Lisp mình tuy ngu ngơ dùng command nhưng đc cái nó lại đỡ đc chỗ đó :))

image.png.3f432e3a882320f14915f57724eb0f51.png

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

(vla-AddHatch (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object))) acHatchPatternTypePreDefined "ANSI31" :vlax-True))

Lệnh này sẽ không chạy được giống như DT1 của bác Duong Nhat Duy. Vì phải có đối tượng để dùng vla-appendouterloop

Có thể thay thế lệnh hatch bằng  (bpoly  point ) tạo ra pline

Nếu tạo ra nhiều hơn 1 đối tượng thì tính diện tích pline lớn nhất trừ đi các diện tích nhỏ hơn. 

(mình không thích lệnh bpoly nhưng đây là sự lựa chọn đơn giản nhất)

 

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
Vào lúc 23/12/2022 tại 01:41, doanquanghuy đã nói:

Thank bạn!
Mình gặp phải lỗi DT1 too many agruments thì làm sao sửa được ạ?
Mình dùng AutoCAD Architecture 2020.
 

   Suy nghĩ kỹ thì thấy dòng báo lỗi "too many agruments" hơi bị vô lý, vì dòng đó chỉ xuất hiện khi hàm (Function) có nhiều thông số hơn so với định nghĩa (defun). Mà trong lisp bác Duy thì hoàn toàn ko có lỗi này. Còn nếu bảo do dòng (command ..) thì cũng ko đúng, vì nếu do command nó sẽ báo lỗi kiểu khác chứ kp "too many agruments".

   Do đó chắc bác @doanquanghuy có nhầm lẫn gì đó chăng mà không thấy bác ấy đưa hình chụp dòng command lên.

   Vậy cho nên bác Duy có thể yên tâm là lisp của bác không có lỗi gì hết. Hoặc bác thay lệnh hatch bằng "-Boundary" cũng hay. Lệnh hatch hơi bị khó chịu, và entmake hatch cũng không dễ dàng gì.

 

 

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
Vào lúc 24/12/2022 tại 21:54, 7o7 đã nói:

   Suy nghĩ kỹ thì thấy dòng báo lỗi "too many agruments" hơi bị vô lý, vì dòng đó chỉ xuất hiện khi hàm (Function) có nhiều thông số hơn so với định nghĩa (defun). Mà trong lisp bác Duy thì hoàn toàn ko có lỗi này. Còn nếu bảo do dòng (command ..) thì cũng ko đúng, vì nếu do command nó sẽ báo lỗi kiểu khác chứ kp "too many agruments".

   Do đó chắc bác @doanquanghuy có nhầm lẫn gì đó chăng mà không thấy bác ấy đưa hình chụp dòng command lên.

   Vậy cho nên bác Duy có thể yên tâm là lisp của bác không có lỗi gì hết. Hoặc bác thay lệnh hatch bằng "-Boundary" cũng hay. Lệnh hatch hơi bị khó chịu, và entmake hatch cũng không dễ dàng gì.

Chắc là mình giữ nguyên lệnh Hatch thôi, vì Bpoly nó có thể ra nhiều đối tượng (pick nhiều điểm cùng 1 lúc), S tổng có thể là tổng hoặc hiệu, chắc phải cần thêm 1 thuật toán phức tạp mới tính nổi S chỗ này nên thôi mình chọn cách đơn giản :))

 

Nhân tiện mình hỏi sao lệnh này khi kết thúc lại ko tạo ra Hatch nhỉ ?

(command "-HATCH" "Properties" "Solid")
(while (> (getvar "CMDACTIVE") 0)
 (command (getpoint))
 )

 

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

@Duong Nhat Duy

bạn thử dùng hàm này của mình xem sao thay cho hatch.

(defun BoundaryAreaPoint ( pt / ent lst area)
  (setq ent (entlast))
  (vl-cmdf "_.boundary" "A" "I" "Y" "O" "P" "X" pt "")
  (while (setq ent (entnext ent))
    (setq lst (cons (vlax-ename->vla-object ent) lst))
  )
  (setq 
    lst (vl-sort lst '(lambda (a b) (> (vla-get-area a) (vla-get-area b))))
    area (abs (apply '- (mapcar 'vla-get-area lst)))
  )
  (cons area lst)
)

 

  • 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, tannguyen291 đã nói:

@Duong Nhat Duy

bạn thử dùng hàm này của mình xem sao thay cho hatch.


(defun BoundaryAreaPoint ( pt / ent lst area)
  (setq ent (entlast))
  (vl-cmdf "_.boundary" "A" "I" "Y" "O" "P" "X" pt "")
  (while (setq ent (entnext ent))
    (setq lst (cons (vlax-ename->vla-object ent) lst))
  )
  (setq 
    lst (vl-sort lst '(lambda (a b) (> (vla-get-area a) (vla-get-area b))))
    area (abs (apply '- (mapcar 'vla-get-area lst)))
  )
  (cons area lst)
)

 

Nếu Polyline thì khó xét vùng giao nhau? 

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 phút trước, tannguyen291 đã nói:

Boundary mà bạn. làm sao mà giao nhau??

Nhầm ý mình có người nói Thay Hatch bằng Polyline. mà như trường hợp trên có 2 polyline chồng nhau nên khó làm thôi.

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
13 phút trước, huunhantvxdts đã nói:

Nhầm ý mình có người nói Thay Hatch bằng Polyline. mà như trường hợp trên có 2 polyline chồng nhau nên khó làm thôi.

mình không hiểu ý bạn. 

(defun c:testdt1 (/ pt1 sb str)
  (setq 
    pt1 (getpoint )
    sb (BoundaryAreaPoint pt1)
    str (rtos (car sb) 2 2)
  )
  (mapcar 'vla-delete (cdr sb))
  (entmake (list(cons 0 "TEXT")(cons 100 "AcDbEntity")(cons 100 "AcDbText")(cons 1 str)(cons 10 pt1)(cons 40 2)(cons 41 1)(cons 50 0)))
  (princ)
)

bạn thử đoạn test này của mình xem lỗi ở đâu

  • 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
Vừa xong, tannguyen291 đã nói:

mình không hiểu ý bạn. 


(defun c:testdt1 (/ pt1 sb str)
  (setq 
    pt1 (getpoint )
    sb (BoundaryAreaPoint pt1)
    str (rtos (car sb) 2 2)
  )
  (mapcar 'vla-delete (cdr sb))
  (entmake (list(cons 0 "TEXT")(cons 100 "AcDbEntity")(cons 100 "AcDbText")(cons 1 str)(cons 10 pt1)(cons 40 2)(cons 41 1)(cons 50 0)))
  (princ)
)

bạn thử đoạn test này của mình xem lỗi ở đâu

cái mày pick điểm nên nó không vấn đề gì cả

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

Ý của bạn là dt4 của bác duy đó hả.

cái đó thì còn dễ hơn.

dùng vla-addregion xong rồi vla-boolean -  acunion lại toàn bộ là xong. không cần dùng đến command luô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
2 giờ trước, tannguyen291 đã nói:

@Duong Nhat Duy

bạn thử dùng hàm này của mình xem sao thay cho hatch.


(defun BoundaryAreaPoint ( pt / ent lst area)
  (setq ent (entlast))
  (vl-cmdf "_.boundary" "A" "I" "Y" "O" "P" "X" pt "")
  (while (setq ent (entnext ent))
    (setq lst (cons (vlax-ename->vla-object ent) lst))
  )
  (setq 
    lst (vl-sort lst '(lambda (a b) (> (vla-get-area a) (vla-get-area b))))
    area (abs (apply '- (mapcar 'vla-get-area lst)))
  )
  (cons area lst)
)

 

Mình mới đọc qua thôi chưa test, mà tóm lại ntn: các lệnh DT3, 4 để tính S đối tượng thì dễ r khỏi bàn; lệnh DT1 thì có thể viết = nhiều cách; nhưng lệnh DT2 chủ ý của mình là pick được nhiều điểm cùng lúc, pick đâu highlight đến đó, như vậy bạn cải tiến nó lên để ko dùng command nữa đc ko, mình cảm ơ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
49 phút trước, Duong Nhat Duy đã nói:

Mình mới đọc qua thôi chưa test, mà tóm lại ntn: các lệnh DT3, 4 để tính S đối tượng thì dễ r khỏi bàn; lệnh DT1 thì có thể viết = nhiều cách; nhưng lệnh DT2 chủ ý của mình là pick được nhiều điểm cùng lúc, pick đâu highlight đến đó, như vậy bạn cải tiến nó lên để ko dùng command nữa đc ko, mình cảm ơn !

Để tạo ra boundary không dùng command  thì mình có 1 hàm như vậy.

thuật toán rất dài và chạy cũng k nhanh hơn command boundary.

Cảm thấy như là dùng dao mổ trâu để giết con gà vậy.

Vì command hatch chạy khá ì ạch nên mọi người cho rằng boundary sẽ nhanh hơn.

Hàm phía trên của mình có thể áp dụng cho DT2 của bạn được đấy.

(defun c:testdt2 (/ areaall ptx ss1 lst)
  (setq areaall 0)
  (while (setq ptx (getpoint))
    (setq 
      ss1 (BoundaryAreaPoint ptx)
      areaall (+ areaall (car ss1))
      lst (append lst (cdr ss1) )
    )
    (mapcar '(lambda (x) (redraw (vlax-vla-object->ename x) 3)) (cdr ss1))
  )
  (setq ptx (getpoint))
  (mapcar 'vla-delete lst)
  (entmake (list(cons 0 "TEXT")(cons 100 "AcDbEntity")(cons 100 "AcDbText")
                (cons 1 (rtos areaall 2 2))(cons 10 ptx)(cons 40 2)(cons 41 1)(cons 50 0)))
  (princ)
)

 

  • 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
9 phút trước, tannguyen291 đã nói:

Để tạo ra boundary không dùng command  thì mình có 1 hàm như vậy.

thuật toán rất dài và chạy cũng k nhanh hơn command boundary.

Cảm thấy như là dùng dao mổ trâu để giết con gà vậy.

Vì command hatch chạy khá ì ạch nên mọi người cho rằng boundary sẽ nhanh hơn.

Hàm phía trên của mình có thể áp dụng cho DT2 của bạn được đấy.


(defun c:testdt2 (/ areaall ptx ss1 lst)
  (setq areaall 0)
  (while (setq ptx (getpoint))
    (setq 
      ss1 (BoundaryAreaPoint ptx)
      areaall (+ areaall (car ss1))
      lst (append lst (cdr ss1) )
    )
    (mapcar '(lambda (x) (redraw (vlax-vla-object->ename x) 3)) (cdr ss1))
  )
  (setq ptx (getpoint))
  (mapcar 'vla-delete lst)
  (entmake (list(cons 0 "TEXT")(cons 100 "AcDbEntity")(cons 100 "AcDbText")
                (cons 1 (rtos areaall 2 2))(cons 10 ptx)(cons 40 2)(cons 41 1)(cons 50 0)))
  (princ)
)

 

Hê hê cảm ơn bạn nhé, để mình chỉnh sửa lại lisp cho ngon 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

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

×