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

[Duong Nhat Duy 301]

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á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:

 

 

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

 

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

 

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

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

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

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,…

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

 

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

 

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

File lisp:

Tinh dien tich v1.00.lsp (03/03/2023)

Tinh dien tich v1.01.lsp (03/04/2023): Thêm option tạo đường bao

Tinh chieu dai, dien tich v1.00.lsp (01/11/2023): Thêm tính năng tính chiều dài

Tinh chieu dai, dien tich v1.01.lsp (01/02/2024): 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

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

[tanbqtb03 9]

Cám ơn a

 

[doanquanghuy 0]

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.
 

[7o7 79]

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

[Duong Nhat Duy 301]

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 ?

[7o7 79]

 

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.

 

[NTHAHT 78]

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

[Duong Nhat Duy 301]

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

[Duong Nhat Duy 301]

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ỗ đó :))

[tannguyen291 127]

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)

 

[7o7 79]

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

 

 

[Duong Nhat Duy 301]

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

 

[7o7 79]

Bác thay (command (getpoint)) bằng (command "pause") thử xem. Bởi vì (getpoint) là hàm chứ kp lệnh.

[Duong Nhat Duy 301]

7 phút trước, 7o7 đã nói:

Bác thay (command (getpoint)) bằng (command "pause") thử xem. Bởi vì (getpoint) là hàm chứ kp lệnh.

oke đc r nè, mình cảm ơn nhé !

[Duong Nhat Duy 301]

Pline, Hacth đều tính đc bạn nhé, trong hình minh họa mình cũng đưa vào cho dễ hiểu r !

[tannguyen291 127]

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

 

[huunhantvxdts 195]

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? 

[tannguyen291 127]

1 phút trước, huunhantvxdts đã nói:

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

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

[huunhantvxdts 195]

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.

[tannguyen291 127]

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

[huunhantvxdts 195]

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ả

[tannguyen291 127]

Ý 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. :))

[Duong Nhat Duy 301]

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 !

[tannguyen291 127]

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

 

[Duong Nhat Duy 301]

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