1. Các thửa đất là các Closed_polyline, user làm bằng cách nào thì tuỳ, có thể dùng cadmap tạo topology để sau đó tạo Closed_polyline hoặc tự tạo bằng cách dùng lệnh Bounary...

2. Các điểm tâm thửa (Centroid) là các Point nằm trên layer "Centroid" cũng vậy hoặc tạo bằng Cadmap cho nhanh hoặc user tự tạo. Mục này...

1. Các thửa đất là các Closed_polyline, user làm bằng cách nào thì tuỳ, có thể dùng cadmap tạo topology để sau đó tạo Closed_polyline hoặc tự tạo bằng cách dùng lệnh Bounary...

2. Các điểm tâm thửa (Centroid) là các Point nằm trên layer "Centroid" cũng vậy hoặc tạo bằng Cadmap cho nhanh hoặc user tự tạo. Mục này elle sẽ cố gắng hoàn thiện tiếp trong nay mai vì đã có Closed_polyline thì việc xác định centroid và diện tích để gán cùng với số thửa chắc chắn sẽ làm được.

Lệnh là DST



file vd mẫu:
http://www.cadviet.com/upfiles/Out.dwg

Hề hề hề,
Phải chăng bạn ấy muốn cái như thế này:


@Bác Tue_NV và Ketxu: Mạn phép sửa lại tí chút cái lisp của các bác cái chổ :
(wtxt (strcat (if (< dau 10) (strcat pre "0" (itoa dau)) (itoa dau)) "/" sotong) po)
Có nhẽ phải là:
(wtxt (strcat pre (if (< dau...

Hề hề hề,
Phải chăng bạn ấy muốn cái như thế này:


@Bác Tue_NV và Ketxu: Mạn phép sửa lại tí chút cái lisp của các bác cái chổ :
(wtxt (strcat (if (< dau 10) (strcat pre "0" (itoa dau)) (itoa dau)) "/" sotong) po)
Có nhẽ phải là:
(wtxt (strcat pre (if (< dau 10) (strcat "0" (itoa dau)) (itoa dau)) "/" sotong) po)
mới đúng ạ.

Lisp làm toàn bộ rất khó vì phải mô hình hóa địa hình.

Có cách làm tay khá đơn giản tận dụng chức năng của 3DSMax:
Vào 3DSMax:
- Nhập đường đồng mức từ file DWG.
- Dùng lệnh Terrain để biến đường đồng mức thành mặt.
- Dùng lệnh Shell để biến mặt...

Lisp làm toàn bộ rất khó vì phải mô hình hóa địa hình.

Có cách làm tay khá đơn giản tận dụng chức năng của 3DSMax:
Vào 3DSMax:
- Nhập đường đồng mức từ file DWG.
- Dùng lệnh Terrain để biến đường đồng mức thành mặt.
- Dùng lệnh Shell để biến mặt thành khối.
- Dùng lệnh Boolean để giao các khối (khối A, Khối B và khối trụ tạo bởi đường biên khu đất) để tạo thành khối C.
- Export khối A, Khối B, Khối C sang CAD.

Từ mặt mesh này trong AutoCAD chúng ta có thể tính được khối tích của nó (của 3 khối A, B, C). Bằng cách explode chúng ra thành 3Dface, dùng lisp để tính khối tích của các hình lăng trụ tạo bởi các 3DFace này với mặt phẳng x0y. Tổng của chúng chính là khối tích của miền giới hạn bởi địa hình và mặt phẳng xoy. Khối tích được tính theo công thức: V = S * (z1+z2+z3)/3.

Mã lisp như sau:

Chào namhai
Với các đối tượng nằm trong và ngoài curve : Lisp làm việc bình thuờng.
Với đối tượng có giao với curve trên mặt bằng nhưng nếu trong không gian chúng không giao nhau (không đồng phẳng) thì Lisp không xử lý đuợc.
Bạn có thể dùng Lisp này để xóa tất cả đối tượng...

Chào namhai
Với các đối tượng nằm trong và ngoài curve : Lisp làm việc bình thuờng.
Với đối tượng có giao với curve trên mặt bằng nhưng nếu trong không gian chúng không giao nhau (không đồng phẳng) thì Lisp không xử lý đuợc.
Bạn có thể dùng Lisp này để xóa tất cả đối tượng nằm ngoài curve. (không phân biệt có giao trên mặt bằng hay giao trong không gian)

hì hì bác bảo em ém thì em post lsp lên làm chi. Mà post lên Cadviet em đã bỏ phần kiểm tra key bản quyền rùi mà. Mặc dù lsp này thì trên Internet thì vô vàn cách nhưng em vẫn muốn giữ một tý ty cho mình khì khì. Mà cái em viết chắc các bác cười em sái quai hàm lun. Nhưng kết quả okie là em zui zào.
Mà thui post lên cho các newbie có thêm tài liệu học...

hì hì bác bảo em ém thì em post lsp lên làm chi. Mà post lên Cadviet em đã bỏ phần kiểm tra key bản quyền rùi mà. Mặc dù lsp này thì trên Internet thì vô vàn cách nhưng em vẫn muốn giữ một tý ty cho mình khì khì. Mà cái em viết chắc các bác cười em sái quai hàm lun. Nhưng kết quả okie là em zui zào.
Mà thui post lên cho các newbie có thêm tài liệu học tập vậy vì tương lai Cadviet:
Sau đây là file lsp:

Đây là đoạn code bao gồm cả 2 hàm MUL và SUM.



Với người sử dụng, chẳng có gì khác hơn 2 đoạn mà ssg và bác Hoanh đã viết trên. Nhưng với lập trình viên lsp thì khác rất nhiều.
Hai điểm khác cơ bản là:
1) Tính cấu trúc của chương trình tốt hơn, dễ kiểm tra, sửa...

Đây là đoạn code bao gồm cả 2 hàm MUL và SUM.



Với người sử dụng, chẳng có gì khác hơn 2 đoạn mà ssg và bác Hoanh đã viết trên. Nhưng với lập trình viên lsp thì khác rất nhiều.
Hai điểm khác cơ bản là:
1) Tính cấu trúc của chương trình tốt hơn, dễ kiểm tra, sửa lỗi, phát triển thêm...
2) CheckObj, FilObj trở thành các defun dùng chung, có thể dùng cho các chương trình khác sau này, tiết kiệm khá nhiều công sức.
Đó cũng là một trong những lý do để ssg đề xuất với các bạn xây dựng CadViet Utility. Viết một đoạn code đáp ứng một yêu cầu cụ thể nào đó dễ hơn nhiều so với việc xây dựng một hệ thống. Nhưng các bạn thử hình dung, khi số lượng các chương trình lsp tương tự như trên tăng lên khá nhiều thì điều gì sẽ xảy ra? Chúng sẽ "đá" nhau, cái này sẽ vô hiệu hoá cái kia, có khi chẳng có cái nào dùng được, gây nên những lỗi không thể kiểm soát...
Rất mong được các bạn góp ý thêm.

Mình thực hiện trên file của bạn luôn nhé.Lisp này của bác thiệp mà bác thanhduan đã nói.Thực hiện được ý đồ của bạn rồi đó.Bạn xem video nhé
http://www.youtube.com/watch?v=UnQZYP3eAtU
Mình muốn xin bộ lisp về thiết kế nút của bạn được...

Mình thực hiện trên file của bạn luôn nhé.Lisp này của bác thiệp mà bác thanhduan đã nói.Thực hiện được ý đồ của bạn rồi đó.Bạn xem video nhé
http://www.youtube.com/watch?v=UnQZYP3eAtU
Mình muốn xin bộ lisp về thiết kế nút của bạn được không.Bạn có thể gửi lên đây hoặc gửi mail cho mình:anhtuan011185@gmail.com.Cảm ơn bạn rất nhiều vì mình cũng đang cần tiện ích này
;;;-----------------------
(defun SS-enlst (ss / c L)
(setq c -1)
(repeat (sslength ss)
(setq L (cons (ssname ss (setq c (1+ c))) L))
)
(reverse L)
)
;;;---------------------- -
(defun Text (model str po h ang / obj)
(setq obj (vla-AddText
*Model*
str
(vlax-3d-point po)
h
)
)
(vla-put-Alignment obj acAlignmentTopCenter)
(vla-put-TextAlignmentPoint obj (vlax-3d-point po))
)
;;;====================================================================
(defun break_with (Lstent enL / lst masterlist ss oc break_obj intpts)
(princ "\nCalculating Break Points, Please Wait.\n")

;;========================================
;; Break entity at break points in list
;;========================================
(defun break_obj (ent brkptlst / brkobjlst en
enttype maxparam closedobj minparam
obj obj2break p1param p2param
brkpt2 dlst idx brkptS
brkptE brkpt result result
ignore dist tmppt #ofpts
enddist lastent obj2break stdist
)
(setq obj2break ent
brkobjlst (list ent)
enttype (dxf 0 ent)
)
(if (not (or (eq (dxf 0 obj2break) "TEXT")
(eq (dxf 0 obj2break) "MTEXT")
)
)
(setq closedobj (vlax-curve-isclosed obj2break))
)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if
'(lambda (x)
(or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)
)
)
brkptlst
)
)

(if (and brkptlst
(not (or (eq (dxf 0 obj2break) "TEXT")
(eq (dxf 0 obj2break) "MTEXT")
)
)
)
(progn
(setq brkptlst
(mapcar
'(lambda (x)
(list
x
(vlax-curve-getdistatparam
obj2break
(cond
((vlax-curve-getparamatpoint obj2break x)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
x
)
)
)
)
)
)
)
brkptlst
)
)
(setq
brkptlst (vl-sort brkptlst
'(lambda (a1 a2) (< (cadr a1) (cadr a2)))
)
)
(foreach brkpt (reverse brkptlst)
(setq brkptS (car brkpt)
brkptE brkptS
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj2break tmppt)
)
)
)
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while
(and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj tmppt)
)
)
(null (setq obj2break obj))
; switch objects, null causes exit
t
)
)
)
)
)
)
); end (if brkobjlst

;;; Handle any objects that can not be used with the Break Command
;;; using one point, gap of 0.000001 is used
(if (not (or (eq (dxf 0 obj2break) "TEXT")
(eq (dxf 0 obj2break) "MTEXT")
)
)
(setq closedobj (vlax-curve-isclosed obj2break))
)
;;; single breakpoint ----------------------------------------------------
(if
(and closedobj
(not (setq
brkptE (vlax-curve-getPointAtDist
obj2break
(+ (vlax-curve-getdistatparam
obj2break
(cond
((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
)
)
)
(setq
brkptE (vlax-curve-getPointAtDist
obj2break
(- (vlax-curve-getdistatparam
obj2break
(cond ((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
); end setq brkptE
); end fi (and closedobj
;; (if (null brkptE) (princ)) ; debug
(setq LastEnt (GetLastEnt))
(if (not (or (eq (dxf 0 obj2break) "TEXT")
(eq (dxf 0 obj2break) "MTEXT")
)
)
(command "._break"
obj2break
"_non"
(trans brkptS 0 1)
"_non"
(trans brkptE 0 1)
)
)
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast)))
)
(setq brkobjlst (cons (entlast) brkobjlst))
); end (if (and
); end (foreach brkpt
);end progn brkptlst
); end if brkptlst
); defun break_obj
;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt (/ ename result)
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(if (and Lstent enL)
(progn
;; CREATE a list of entity & it's break points
(foreach en Lstent
; check each object in Lstent
(if (not (acet-layer-locked (dxf 8 en)))
(progn
(setq lst nil)
;; check for break pts with other objects in Lstentwith
(if (and (not (equal en enint))
(setq intpts (acet-geom-intersectwith en enL 0))
)
(setq lst (append intpts lst))
; entity w/ break points
)
(if lst
(setq masterlist
(cons (cons en lst) masterlist)
)
)
)
)
)
(princ "\nBreaking Objects.\n")
(if masterlist
(progn
(acet-ui-progress "hoan thanh %" (length masterlist))
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk))
(acet-ui-progress -1)
)
(acet-ui-progress)
)
)
)
)
);end break_with
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (en / ss lst lstb lstc objl)
(and
(setq objl (vlax-ename->vla-object en))
(setq
ss
(ssget
"_A"
(list
(cons 0
"LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
)
(cons 410 (getvar "ctab"))
)
)
)
(setq lst (SS-enlst ss)
lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith objl x acextendnone)
)
)
)
)
)
)
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
)
lst
)
)
lstc
)
;;;------------------------------------------------
(defun LWP (Lpoint *Model* / PntArr)
(setq PntArr (vlax-make-safearray
vlax-vbDouble
(cons 0 (1- (length Lpoint)))
)
)
(vlax-safearray-fill PntArr Lpoint)
(vla-AddLightWeightPolyline *Model* PntArr)
)
;;;------------------------------------------------
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;============================================================
;;;=======================MAIN LISP============================
;;;============================================================
(defun c:trichBD (/ ActDoc *Model* ss encur lsten p1 p2 p3 LenssBR lstp objCE)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object))
*Model* (vla-get-ModelSpace ActDoc)
)
(setq bit1 (cond (bit1)
("Rectangle")
)
)
(initget "Square Rectangle Circle Ellipse Different")
(setq tmp (strcat "\nChon duong bao: <" bit1 ">: ")
bit1 (cond ((getkword tmp))
(bit1)
)
)
(vla-StartUndoMark ActDoc)
(setvar "cecolor" "104")
(setq p1 (list (car (getvar "extmin")) (cadr (getvar "extmin"))))
(cond ((eq bit1 "Square")
(setq a (cond (a)
(50)
)
)
(setq olda a)
(setq a (getreal (strcat "\nChon kich thuoc canh Square <"
(rtos olda 2 1)
"> : "
)
)
)
(if (null a)
(setq a olda)
)
(setq lstp (list (list (car p1) (cadr p1) 0)
(list (+ (car p1) a) (cadr p1) 0)
(list (+ (car p1) a) (+ (cadr p1) a) 0)
(list (car p1) (+ (cadr p1) a) 0)
(list (car p1) (cadr p1) 0)
)
)
)
((eq bit1 "Rectangle")
(setq a (cond (a)
(50)
)
)
(setq olda a)
(setq a (getreal (strcat "\nChon chieu dai Rectangle <"
(rtos olda 2 1)
"> : "
)
)
)
(if (null a)
(setq a olda)
)
(setq b (cond (
(50)
)
)
(setq oldb
(setq b (getreal (strcat "\nChon chieu rong Rectangle <"
(rtos oldb 2 1)
"> : "
)
)
)
(if (null
(setq b oldb)
)
(setq lstp (list (list (car p1) (cadr p1) 0)
(list (+ (car p1) a) (cadr p1) 0)
(list (+ (car p1) a) (+ (cadr p1) 0)
(list (car p1) (+ (cadr p1) 0)
(list (car p1) (cadr p1) 0)
)
)
)
((eq bit1 "Circle")
(setq a (cond (a)
(50)
)
)
(setq olda a)
(setq a (getreal (strcat "\nChon ban kinh Circle <"
(rtos olda 2 1)
"> : "
)
)
)
(if (null a)
(setq a olda)
)
(setq objCE (vla-addCircle *Model* (vlax-3d-point p1) a))
(setq cir (entlast))
(setq cv (* a 2 pi)
lstp (list (vlax-curve-getStartPoint cir))
d (/ cv 160)
l 0.0
)
(repeat 160
(setq l (+ l d)
p (vlax-curve-getPointAtDist cir l)
lstp (append lstp (List p))
)
)
);end bit1 "Circle"

;;; ((eq bit1 "Ellipse")
;;; (setq a (getpoint p1 "\nPick diem ban kinh lon cua Ellipse"))
;;; (vl-cmdf ".Ellipse" pause pause pause); erro ttuc
;;; (setq objCE (entlast)
;;; p1 (vlax-curve-getStartPoint objCE))
;;; (command ".LENGTHEN" objCE "")
;;; (setq cv (getvar "perimeter")
;;; lstp (list p1)
;;; d (/ cv 160)
;;; l 0.0
;;; )
;;; (repeat 160
;;; (setq l (+ l d)
;;; p (vlax-curve-getPointAtDist objCE l)
;;; lstp (append lstp (List p))
;;; )
;;; )
;;; );end bit1 "Ellipse"
;;; ((eq bit1 "Different")
;;; (prompt "\nchon 1 curve kin:")
;;; (setq ss (ssget)
;;; encur (ssname ss 0)
;;; objCE (vlax-ename->vla-object encur)
;;; p1 (vlax-curve-getStartPoint encur))
;;; (if (or (eq (dxf 0 encur) "LWPOLYLINE")
;;; (eq (dxf 0 encur) "POLYLINE")
;;; )
;;; (setq lstp (acet-geom-VERTEX-LIST encur))
;;; (progn
;;; (command ".LENGTHEN" encur "")
;;; (setq cv (getvar "perimeter")
;;; lstp (list p1)
;;; d (/ cv 160)
;;; l 0.0
;;; )
;;; (repeat 160
;;; (setq l (+ l d)
;;; p (vlax-curve-getPointAtDist encur l)
;;; lstp (append lstp (List p))
;;; )
;;; )
;;; )
;;; )
;;; )
);end cond
(vla-ZoomExtents (vlax-get-acad-object))
(ACET-LWPLINE-MAKE (list lstp))
(setq ss (ssadd (entlast) (ssadd)))
(setq p2 (ACET-SS-DRAG-MOVE
ss
(list (car p1) (cadr p1))
"Chon vi tri bat dau trich thua: "
)
)
(command ".move" ss "" p1 p2)
(setq encur (entlast)
lstp (acet-geom-VERTEX-LIST encur))
(setq ss (ssdel encur (ssget "_CP" lstp)))
(command ".copy" ss "" p2 p2)
(setq p3 (ACET-SS-DRAG-MOVE
(ssadd encur ss)
p2
"Chon vi tri dat ban do trich thua: "
)
)
(command ".move" ss encur "" p2 p3)
(setvar "cecolor" "0")
(setq lsten (vl-remove encur (gettouching encur)))
(break_with lsten encur)
(vlax-invoke-method ActDoc 'Regen acActiveViewport)
(vla-offset (vlax-ename->vla-object encur) (* (getvar "viewsize") 0.0001))
(setq lstp (acet-geom-vertex-list (entlast)))
(entdel (entlast))
(if (equal (vlax-curve-getEndParam encur) 160 1) (entdel encur))
(setq LenssBR (SS-enlst (ssget "F" lstp)))
(mapcar '(lambda (x)
(if (or (not (eq (dxf 0 x) "TEXT"))
(not (eq (dxf 0 x) "MTEXT"))
)
(entdel x)
)
)
LenssBR
)
(if objCE (vla-move objCE (vlax-3d-point p1) (vlax-3d-point p3)))
(vla-EndUndoMark ActDoc)
(princ "\nChuc cac ban gat hai nhieu thanh cong. Thiep")
(princ)
)

Bạn dùng lisp này thử xem. Lệnh LTT:




@Tue_NV
Ssg đã xem lại vấn đề hôm nọ. Trong các system var liên quan, chỉ có dimzin ảnh hưởng trực tiếp, các "thằng" khác không thấy tác dụng gì khi dùng (rtos value 2 n). Có lẽ do số 2 đã xác định kiểu decimal. Nếu vậy, ta cứ "chơi"...

Bạn dùng lisp này thử xem. Lệnh LTT:




@Tue_NV
Ssg đã xem lại vấn đề hôm nọ. Trong các system var liên quan, chỉ có dimzin ảnh hưởng trực tiếp, các "thằng" khác không thấy tác dụng gì khi dùng (rtos value 2 n). Có lẽ do số 2 đã xác định kiểu decimal. Nếu vậy, ta cứ "chơi" như trên đơn giản hơn.

Gửi bạn,hy vọng đúng ý bạn

;free lisp by cadviet,cd2k44
;link bai viet http://www.cadviet.com/forum/index.php?showtopic=53830
(defun c:FTEXT (/ ent tstyle )
(command "undo" "be")
(setq ent (entsel "\n Pick text :"))
(setq TSTYLE (cdr (assoc 7 (entget (car ent)))))
(command "STYLE" TSTYLE ".vnavanth" "0" "1" "0" "N"...

Gửi bạn,hy vọng đúng ý bạn

;free lisp by cadviet,cd2k44
;link bai viet http://www.cadviet.com/forum/index.php?showtopic=53830
(defun c:FTEXT (/ ent tstyle )
(command "undo" "be")
(setq ent (entsel "\n Pick text :"))
(setq TSTYLE (cdr (assoc 7 (entget (car ent)))))
(command "STYLE" TSTYLE ".vnavanth" "0" "1" "0" "N" "N")
(setvar "TEXTSTYLE" Tstyle)
(command "undo" "end")
)