{Nhờ chỉnh sửa} Lisp tính diện tích

[Dzzzung 6]

Em chào các bác, hiện em mới đi làm bên thiết kế giao thông. Em có cái lisp tính diện tích trắc ngang để thay vào số trên bản vẽ thiết kế đường mà công ty vẫn dùng, đáng tiếc là nó còn nhiều cái bất cập. Em đã search khá nhiều nhưng chưa thấy lisp nào được như mong muốn và cũng chưa thể tự sửa cho chính xác được. Vì thế rất mong bác nào cao tay đi ngang sửa giúp em một tý (/vài tý ^^). Cụ thể như sau:

 

1. Đặt cố định tỷ lệ 1000 và số lẻ kích thước là 2, để không phải ấn quá nhiều lần khi đặt lệnh.

 

2. Thêm giúp em cái khôi phục chế độ bắt điểm ban đầu khi gặp lỗi (hàm bẫy lỗi - cụ thể là lỗi ấn esc sau khi chọn vùng cần tính) giống như topic sau (hic, em thêm mãi không được)

http://www.cadviet.c...?showtopic=4049

 

3 Thiết lập việc chọn diện tích sao cho nếu chọn trùng sẽ báo lỗi hoặc không báo nhưng sẽ không nhận vùng diện tích trùng nhau (cái này khá quan trọng vì nếu không cẩn thận sẽ đo nhầm diện tích)

 

4. Cũng cái lisp ấy các bác có thể sửa thành 1 lisp khác, cải tiến 1 tý. Đó là chuyển việc chọn diện tích từ pick vào vùng chọn thành pick vào đường bao không ạ, giống như hatch và bo đều có select object ấy. Hoặc kết hợp song song được pick đường bao và pick điểm được thì quá xuất sắc, sẽ tối ưu được việc chọn vùng cần tính lên gấp bội

 

Giải quyết được hết 4 điều trên thì cái lisp này quá ổn. Mong các bác cao tay nhiệt tình giúp đỡ. Nếu có bị trùng với topic nào nhờ các mod cho em cái link rồi hãy xóa nhé.

 

Em xin chân thành cảm ơn và chúc diễn đàn ngày các phát triển!

 

Lisp cần chỉnh sửa:

http://www.cadviet.c...h_va_ghi_so.lsp

 

 

File trắc ngang ví dụ:

http://www.mediafire...pik2b4aeebez0g5 (không hiểu sao không up được file này lên cadviet)

[Doan Van Ha 3.196]

Trước hết, mình vừa "đi ngang" thì thấy y/c của bạn, liền phá lệ "Like This" cho bạn ngay.

Lý do: bạn post bài lần đầu trên CadViet nhưng nêu 1 yêu cầu khá hay, cách y/c chuẩn mực, rõ ràng, rành mạch.

Chỉ tiếc một điều: nếu có file cad để test đi kèm thì y/c này không chê nào đâu được

Chúc mừng bạn và hy vọng sẽ có người giúp bạn.

[Dzzzung 6]

Dạ cảm ơn bác Doan Van Ha đã đi ngang và cho một đường like (hay plike không biết). Bác chỉnh quá chuẩn, em đã bổ sung 1 file TN. Mong các bác giúp đỡ.

[ketxu 2.984]

File CAD thì mình chưa xem, nhưng lisp này không biết bạn nào viết mà tệ quá. Phần chào mừng thì nhìn nick khá quen, như có thâm niên Request ở CV ý ^^

Đọc qua thấy có vẻ giống lisp tính tổng diện tích các đối tượng được chọn, rồi ghi ra một text có sẵn, như vậy thì trên diễn đàn đã có khá nhiều. Mình code lại 1 cái gọn theo ý bạn :

 

(defun c:ss(/ i *error* oVars oVals s e a)(vl-load-com)
(defun *error*(msg)(princ msg)(if (and oVars oVals) (mapcar 'setvar  oVars oVals))(princ))
(setq oVars '("cmdEcho" "Dimzin") oVals (mapcar 'getvar oVars) i -1 a 0)
(mapcar 'setvar oVars '(0 0))
(cond
 ((setq s (ssget))
  (while  (setq e (ssname s (setq i (1+ i))))
(if (vlax-property-available-p (setq e (vlax-ename->vla-object e)) 'Area)
 	(setq a (+ (vla-get-area e) a))
)
  )
  (cond ((> a 0)
(while (not (setq e (nentsel "\nChon text ghi ket qua :"))))
(vla-put-textstring (setq e (vlax-ename->vla-object (car e)))(rtos (/ a 1000 1000.0) 2 2))
(vla-put-color e 1)
  ))
 )
)
(*error* "\nDone!")
)

[Doan Van Ha 3.196]

File CAD thì mình chưa xem, nhưng lisp này không biết bạn nào viết mà tệ quá. Phần chào mừng thì nhìn nick khá quen, như có thâm niên Request ở CV ý ^^

Đọc qua thấy có vẻ giống lisp tính tổng diện tích các đối tượng được chọn, rồi ghi ra một text có sẵn, như vậy thì trên diễn đàn đã có khá nhiều. Mình code lại 1 cái gọn theo ý bạn :

Code khá kín kẻ! Người khác thì không hỏi nhưng với Ket thì hỏi để học hỏi:

"cmdecho" chắc thừa, và (/ a 1000 1000.0) có thể thay bằng (/ a 1000 1000) hoặc (/ a 1000000.0) hoặc (/ a 1E6) được không?

[ketxu 2.984]

Được bác ạ. Ket để chỗ ấy để bạn chủ topic biết sau này lo liệu ^^ Cmd với Dimzin ket cũng hok biết người ta đưa vào mần chi, nhưng vẫn giữ nó

[Doan Van Ha 3.196]

Dimzin chắc phải có, chứ cmdecho thì không cần vì không có command.

[Dzzzung 6]

Cảm ơn các bác, em vừa thử cái lisp mà bác Ketxu đã chỉnh sửa, quá trình như sau: ss- chọn các obj - chọn text ghi kết quả - kết quả chỉ hiển thị với các obj hoặc pline khép kín còn với các line không được.

 

Thực ra với công việc của em thì chủ yếu sử dụng pick điểm để đo diện tích thôi. Các lisp "do dien tich và ghi ra so" em đã gửi đã thực hiện khá chính xác việc đó (ss- pick vùng cần tính diện tích (vùng bao kín bởi các line, pline hoặc object khác - trừ hatch) - lisp gạch chéo (hatch) các vùng đó để đánh dấu - chèn vào text sẵn có). Nhưng có những bất cập ở 3 điều 1,2,3 mà em nêu ở bài đầu tiên. Bác Doan Van Ha, bác Ketxu và các cao nhân khác xem lại giúp em với (tạm bỏ yêu cầu số 4 đi ạ).

 

Hi vọng qua lần này (hoặc vài lần nhờ vả trên tư thế học hỏi khác ^^) em sẽ khá hơn về lisp và có những đóng góp giúp ích cho forum chứ không chỉ góp bài xin xỏ.

[ketxu 2.984]

Mình đáp ứng cả 4 điều 1 lúc, nhưng hình như giờ bạn đã chỉnh sửa (thêm cả phần "song song" - chứ Line làm j có diện tích mà được), thật không khoái lắm :) Rảnh mình sẽ giúp bạn song song và add hatch, cũng chỉ thêm mấy dòng thôi

[Dzzzung 6]

Hic, em có sửa yêu cầu 4 đi 1 tý mà không báo, sorry bác. Khi nào bác rảnh giúp em thì may quá :D

[Dzzzung 6]

Các bác tuần rồi khỏe chứ, chúc cả nhà sang tuần mới công việc thuận lợi. Làm nóng lại topic tý mong có bác nào giúp em nốt với

[phamthe 1]

 

File CAD thì mình chưa xem, nhưng lisp này không biết bạn nào viết mà tệ quá. Phần chào mừng thì nhìn nick khá quen, như có thâm niên Request ở CV ý ^^

Đọc qua thấy có vẻ giống lisp tính tổng diện tích các đối tượng được chọn, rồi ghi ra một text có sẵn, như vậy thì trên diễn đàn đã có khá nhiều. Mình code lại 1 cái gọn theo ý bạn :

 

(defun c:ss(/ i *error* oVars oVals s e a)(vl-load-com)
(defun *error*(msg)(princ msg)(if (and oVars oVals) (mapcar 'setvar  oVars oVals))(princ))
(setq oVars '("cmdEcho" "Dimzin") oVals (mapcar 'getvar oVars) i -1 a 0)
(mapcar 'setvar oVars '(0 0))
(cond
  ((setq s (ssget))
   (while  (setq e (ssname s (setq i (1+ i))))
	(if (vlax-property-available-p (setq e (vlax-ename->vla-object e)) 'Area)
  	(setq a (+ (vla-get-area e) a))
	)
   )
   (cond ((> a 0)
	(while (not (setq e (nentsel "\nChon text ghi ket qua :"))))
	(vla-put-textstring (setq e (vlax-ename->vla-object (car e)))(rtos (/ a 1000 1000.0) 2 2))
	(vla-put-color e 1)
   ))
  )
)
(*error* "\nDone!")
)

anh ơi có thể cho tính dtich bằng cách pick điểm và pick hình nào thì hatch tạm hình đó cho đỡ nhầm được không anh?

[fatboy279x 0]

Em có một file lisp tính diện tích dưới đây. Em muốn khi mình pick diện tích xong thì các kết quả diện tích các mặt cắt được xuất ra bảng excel. Mong bác Nguyễn Hoanh và các cao thủ viết thêm đoạn mã để có thể xuất ra file excel được không?

(defun c:sss()

  (if (= tl nil) (progn

    (setq tl (getreal "\nDrawing scale : "))

    (setq ntl (/ 1000 tl))

    (setq tl2 (* ntl ntl))

    )

  )

  (setq dtl 0)

  (setq ss (ssadd))

  (setq oslast (getvar "OSMODE"))

  (command "osnap" "")

  (print)

  (print)

  (setq pt1 (getpoint "\nPick internal point : "))

  (while (/= pt1 nil)

    (command "-boundary" pt1 "")

    (setq et (entlast))

    (ssadd et ss)

    (command "area" "e" "last")

    (setq vsize ( /(getvar "VIEWSIZE") 3 ))

    (command "hatch" "ANSI31" vsize "0" "last" "")

    (setq et (entlast))

    (ssadd et ss)

    (setq dtcon (getvar "AREA"))

    (setq dtl (+ dtcon dtl))

    (print)

    (print)

    (setq pt1 (getpoint "\nPick internal point : "))

  )

  (command "setvar" "OSMODE" oslast)

  (command "erase" ss "")

  (setq ss nil)

  (command "redraw")

  (setq dtl (/ dtl tl2))

  (print dtl)

  (setq elst (entget (car (entsel "Thay cho so: "))))

  (setq elst (subst (cons 1 (rtos dtl 2 2)) (assoc 1 elst) elst))

  (entmod elst)

  (print)

  (prompt (strcat "\nTotal area : " (rtos dtl 2 4)))

  (print)

;  (setq pt2 (getpoint "\nPoint to write: "))

;  (command "text" pt2 (/ vsize 6) "0" (rtos dtl 2 2))

);defun

 

(defun c:sss()

  (if (= tl nil) (progn

    (setq tl (getreal "\nDrawing scale : "))

    (setq ntl (/ 1000 tl))

    (setq tl2 (* ntl ntl))

    )

  )

  (setq dtl 0)

  (setq ss (ssadd))

  (setq oslast (getvar "OSMODE"))

  (command "osnap" "")

  (print)

  (print)

  (setq pt1 (getpoint "\nPick internal point : "))

  (while (/= pt1 nil)

    (command "-boundary" pt1 "")

    (setq et (entlast))

    (ssadd et ss)

    (command "area" "e" "last")

    (setq vsize ( /(getvar "VIEWSIZE") 3 ))

    (command "hatch" "ANSI31" vsize "0" "last" "")

    (setq et (entlast))

    (ssadd et ss)

    (setq dtcon (getvar "AREA"))

    (setq dtl (+ dtcon dtl))

    (print)

    (print)

    (setq pt1 (getpoint "\nPick internal point : "))

  )

  (command "setvar" "OSMODE" oslast)

  (command "erase" ss "")

  (setq ss nil)

  (command "redraw")

  (setq dtl (/ dtl tl2))

  (print dtl)

  (setq elst (entget (car (entsel "Thay cho so: "))))

  (setq elst (subst (cons 1 (rtos dtl 2 2)) (assoc 1 elst) elst))

  (entmod elst)

  (print)

  (prompt (strcat "\nTotal area : " (rtos dtl 2 4)))

  (print)

;  (setq pt2 (getpoint "\nPoint to write: "))

;  (command "text" pt2 (/ vsize 6) "0" (rtos dtl 2 2))

);defun

 

(defun c:sss()

  (if (= tl nil) (progn

    (setq tl (getreal "\nDrawing scale : "))

    (setq ntl (/ 1000 tl))

    (setq tl2 (* ntl ntl))

    )

  )

  (setq dtl 0)

  (setq ss (ssadd))

  (setq oslast (getvar "OSMODE"))

  (command "osnap" "")

  (print)

  (print)

  (setq pt1 (getpoint "\nPick internal point : "))

  (while (/= pt1 nil)

    (command "-boundary" pt1 "")

    (setq et (entlast))

    (ssadd et ss)

    (command "area" "e" "last")

    (setq vsize ( /(getvar "VIEWSIZE") 3 ))

    (command "hatch" "ANSI31" vsize "0" "last" "")

    (setq et (entlast))

    (ssadd et ss)

    (setq dtcon (getvar "AREA"))

    (setq dtl (+ dtcon dtl))

    (print)

    (print)

    (setq pt1 (getpoint "\nPick internal point : "))

  )

  (command "setvar" "OSMODE" oslast)

  (command "erase" ss "")

  (setq ss nil)

  (command "redraw")

  (setq dtl (/ dtl tl2))

  (print dtl)

  (setq elst (entget (car (entsel "Thay cho so: "))))

  (setq elst (subst (cons 1 (rtos dtl 2 2)) (assoc 1 elst) elst))

  (entmod elst)

  (print)

  (prompt (strcat "\nTotal area : " (rtos dtl 2 4)))

  (print)

;  (setq pt2 (getpoint "\nPoint to write: "))

;  (command "text" pt2 (/ vsize 6) "0" (rtos dtl 2 2))

);defun