Chào bạn Phamvanthiet108,
Bạn thử dùng cái này nhé. Mình cải tạo thêm từ chính cái lisp bạn đã post lên. Lưu ý rằng ở lisp này mình chỉ giải quyết đến mức độ đảo nhỏ cấp 1 thôi nhé. Nghĩa là nếu trong vùng chọn của bạn có vùng trống trong đảo cấp một là sẽ bị sai đó. Việc tổ hợp đảo và vùng trống nhiều cấp hiện tại mình chưa nghĩ ra giải pháp nào hợp lý cả. Lisp...

Chào bạn Phamvanthiet108,
Bạn thử dùng cái này nhé. Mình cải tạo thêm từ chính cái lisp bạn đã post lên. Lưu ý rằng ở lisp này mình chỉ giải quyết đến mức độ đảo nhỏ cấp 1 thôi nhé. Nghĩa là nếu trong vùng chọn của bạn có vùng trống trong đảo cấp một là sẽ bị sai đó. Việc tổ hợp đảo và vùng trống nhiều cấp hiện tại mình chưa nghĩ ra giải pháp nào hợp lý cả. Lisp đã được chạy thử trên file bạn đã boundary xong chứ không phải file chưa tạo boundary bạn nhé. Việc tạo Boundary mình chưa giải quyết được.
Việc ghi diện tích ra file hay vẽ lên bản vẽ mình không làm do thiết nghĩ không phải quá khó đối với bạn.
Hy vọng bạn sẽ hài lòng dùng tạm.


Chúc bạn vui.

em sưu tầm dc cái lisp tính tọa độ trên cad việt rất hay . nhưng chưa phục vụ dc nhu cầu làm việc vì em là dân cầu đường . tọa độ của máy toàn đạc hay vn2000 nó ngược với tọa độ của cad . nên em post bài này mong anh em chỉnh sửa dùm để cho đúng mục đích sử dụng .
1 ) tọa độ x của cad thành tọa độ Y của vn2000
2 ) tọa độ Y của cad thành tọa độ Y của vn 2000
3 ) sửa...

em sưu tầm dc cái lisp tính tọa độ trên cad việt rất hay . nhưng chưa phục vụ dc nhu cầu làm việc vì em là dân cầu đường . tọa độ của máy toàn đạc hay vn2000 nó ngược với tọa độ của cad . nên em post bài này mong anh em chỉnh sửa dùm để cho đúng mục đích sử dụng .
1 ) tọa độ x của cad thành tọa độ Y của vn2000
2 ) tọa độ Y của cad thành tọa độ Y của vn 2000
3 ) sửa vòng tròn bao quanh số thứ tự thành hình elip , và hình elip này tự phóng to theo chiều dàu của text nằm trong nó
4 ) bảng tọa độ khi xuất ra text bị đè lên nhau , nhờ các anh chỉnh lại cho nó nằm trong ô . bảng thống kê này cũng có XY ngược với cad .

cảm ơn anh em .
;; free lisp from cadviet.com
(prompt"\n - THONG KE TOA DO\n")
----------------------------------------------
(defun C:TTD ()
(setvar "cmdecho" 0 )
(command "Undo" "Begin")
(setq om (getvar "osmode"))
(if (not h) (setq h 1))
(setq caot1 (getreal (strcat "\nCao text < " (rtos h 2 2) " >:")))
(if caot1 (setq h caot1))
(setq tapx '() tapy '() stt '())
(setq bit1 (cond (bit1) ("Yes")))
(initget "Yes No")
(setq Tmp1 (strcat "\nTu dong ghi ten nut? <" bit1 ">: ")
bit1 (cond ((getkword Tmp1)) (bit1)))
(if (eq bit1 "Yes")
(progn
(setq ten (getstring "\nTen Nut:"))
(if (not i) (setq i 1))
(setq i1 (getreal (strcat"\nSTT cua nut bat dau < " (rtos i 2 0) " >: ")))
(if i1 (setq i i1))
(setvar "osmode" 125)
(setq lacol (getvar "CEColor") k (- i 1))
(While
(setq D1 (getpoint (strcat"\nPick diem thu "(rtos (+ k 1) 2 0)"")))
(Progn
(setvar "osmode" 0)
(setq DX (getpoint (strcat"\nDiem dat text thu "(rtos (+ k 1) 2 0)"") D1)
DY (getpoint (strcat"\nHuong goc nghieng cua text "(rtos (+ k 1) 2 0)"") Dx)
angr (angle Dx Dy)
angd (/ (* 180 angr) pi)
x (rtos (car D1) 2 4)
y (rtos (cadr D1) 2 4)
TX (strcat "X:"(rtos (Car D1) 2 4))
TY (strcat "Y:"(rtos (Cadr D1) 2 4))
tapx (append tapx (list x))
tapy (append tapy (list y))
k (+ 1 k)
N (strcat ten (rtos k 2 0))
stt (append stt (list N))
);setq
(setq dt (* 0.5 (- (strlen N) 2) h));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (>= (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 h)))
(command "text" "BL" D2 h angd tX)
(setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 h)))
pt4 (polar D2 (- angr (* pi 0.5)) (* 1.35 h))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT4 PT5 h ty
"pline" D1 DX PT3 ""
"circle" (polar PT3 angr (+ (* 1.5 h ) dt)) (+ (* 1.5 h) dt)
"text" "m" (polar PT3 angr (+ (* 1.5 h) dt )) h angd N
"CECOLOR" 8
"circle" (polar PT3 angr (+ (* 1.5 h) dt)) (+ (* 1.35 h) dt)
);command
(setvar "CECOLOR" lacol)
);progn
);if
(if (< (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 h)))
(command "text" "BR" D2 h (+ angd 180) tx)
(setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 h)))
pt4 (polar D2 (+ angr (* pi 0.5)) (* 1.35 h))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT5 PT4 h TY
"pline" D1 DX PT3 ""
"circle" (polar PT3 angr (+ (* 1.5 h) dt)) (+ (* 1.5 h) dt)
"text" "m" (polar PT3 angr (+ (* 1.5 h) dt)) h (+ angd 180) N
"CECOLOR" 8
"circle" (polar PT3 angr (+ (* 1.5 h) dt)) (+ (* 1.35 h) dt)
);command
(setvar "CECOLOR" lacol)
);progn
);if
);progn
(setvar "osmode" 125)
);while
(setq i (+ k 1))
);progn
);if
(if (eq bit1 "No")
(progn
(setvar "osmode" 125)
(setq lacol (getvar "CEColor") i 1 k (- i 1))
(While
(setq D1 (getpoint (strcat"\nPick diem thu "(rtos (+ k 1) 2 0)"")))
(Progn
(setvar "osmode" 0)
(progn
(setq LOOP T)
(while (= LOOP T)
(while (null (setq ten (nentsel "\nChon mot text lam ten nut: ")))
(princ "\nChua tim thay doi tuong la text, chon lai !"));while
(setq Source_text (entget (car ten)))
(if (or (= (cdr (assoc '0 Source_text)) "TEXT")
(= (cdr (assoc '0 Source_text)) "MTEXT")
(= (cdr (assoc '0 Source_text)) "ATTRIB"));or
(progn
(setq N (cdr (assoc 1 Source_text)))
(setq LOOP nil));progn
(progn
(princ "Phai chon mot text lam ten nut !")
(setq LOOP T));progn
)if
);while
);progn
(setq DX (getpoint (strcat"\nDiem dat text cua nut "N"") D1)
DY (getpoint (strcat"\nHuong goc nghieng cua text") Dx)
angr (angle Dx Dy))
(setq angd (/ (* 180 angr) pi)
x (rtos (car D1) 2 4)
y (rtos (cadr D1) 2 4)
TX (strcat "X:"(rtos (Car D1) 2 4))
TY (strcat "Y:"(rtos (Cadr D1) 2 4))
tapx (append tapx (list x))
tapy (append tapy (list y))
k (+ 1 k)
stt (append stt (list N))
);setq
(setq dt (* 0.5 (- (strlen N) 2) h));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (>= (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 h)))
(command "text" "BL" D2 h angd tX)
(setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 h)))
pt4 (polar D2 (- angr (* pi 0.5)) (* 1.35 h))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT4 PT5 h ty
"pline" D1 DX PT3 ""
"circle" (polar PT3 angr (+ (* 1.5 h) dt)) (+ (* 1.5 h) dt)
"text" "m" (polar PT3 angr (+ (* 1.5 h) dt)) h angd N
"CECOLOR" 8
"circle" (polar PT3 angr (+(* 1.5 h) dt)) (+ (* 1.35 h) dt)
);command
(setvar "CECOLOR" lacol)
);progn
);if
(if (< (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 h)))
(command "text" "BR" D2 h (+ angd 180) tx)
(setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 h)))
pt4 (polar D2 (+ angr (* pi 0.5)) (* 1.35 h))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT5 PT4 h TY
"pline" D1 DX PT3 ""
"circle" (polar PT3 angr (+ (* 1.5 h) dt)) (+ (* 1.5 h) dt)
"text" "m" (polar PT3 angr (+ (* 1.5 h) dt)) h (+ angd 180) N
"CECOLOR" 8
"circle" (polar PT3 angr (+ (* 1.5 h) dt)) (+ (* 1.35 h) dt)
);command
(setvar "CECOLOR" lacol)
);progn
);if
);progn
(setvar "osmode" 125)
);while
(setq i (+ k 1))
);progn
);if
(setq bit (cond (bit) ("Yes")))
(initget "Yes No")
(setq Tmp (strcat "\nXuat bang toa do? <" bit ">: ")
bit (cond ((getkword Tmp)) (bit)))
(if (eq bit "Yes")
(progn
(setq di (- di (* 0.4 h))
kc (* 2 di)
PT (getpoint"\nVi tri dat bang")
PTC (list (+ (* 2 kc) (- di h h h h) (car PT)) (cadr PT))
p1 (list (car PT) (+ (cadr PT)(* 2 h)))
p2 (list (car PTC) (+ (cadr PTC)(* 2 h)))
p3 (list (car p1) (+ (cadr p1)(* 2 h)))
p4 (list (car p2) (+ (cadr p2)(* 2 h)))
PTD (list (+ (/ di 2) (car PT)) (+ h (cadr PT)))
PTX (list (+ di (/ di 2) (- 0 h) (car PTD)) (cadr PTD))
PTY (list (+ kc (- h h h h) (car PTX)) (cadr PTX))
p11 (list (+ (/ di 2) (car p1)) (+ (* 1.1 h) (cadr p1)))
p22 (list (+ di (/ di 2) (- 0 h) (car p11)) (- (cadr p11) (* 0.1 h)))
p33 (list (+ kc (- h h h h) (car p22)) (cadr p22))
L1 (list (+ di (car p3))(cadr p3))
L2 (list (+ kc (- 0 h h)(car L1))(cadr L1))
PTB (list (+ (- (* 2 h)) (* 0.5 (+ (* 2 kc) di)) (car PT)) (+ (cadr P3) (* 1.8 h)))
n (length tapx)
k 0
);setq
(setvar "osmode" 0)
(command "CECOLOR" 3 "line" p1 p2 "" "line" p3 p4 "" "CECOLOR" 2
"text" "m" p11 h 0 "Ten diem"
"text" "m" p22 h 0 "Toa do X"
"text" "m" p33 h 0 "Toa do Y"
"text" "m" pTB (* 1.3 h) 0 "%&#186;ng thong ke toa do diem")
(while (< k n)
(setq xx (nth k tapx) yy (nth k tapy) tstt(nth k stt))
(command "CECOLOR" 2
"text" "m" PTD h 0 tstt
"text" "m" PTX h 0 xx
"text" "m" PTY h 0 yy
"CECOLOR" 3
"line" PT PTC "")
(setq PT (list (car PT) (- (cadr PT)(* 2 h)))
PTC (list (+ (* 2 kc) (- di h h h h) (car PT)) (cadr PT))
PTD (list (+ (/ di 2) (car PT)) (+ h (cadr PT)))
PTX (list (+ di (/ di 2) (- 0 h) (car PTD)) (cadr PTD))
PTY (list (+ kc (- h h h h) (car PTX)) (cadr PTX))
k (+ 1 k));setq
);while
(if (= k n)
(setq PT (list (car PT) (+ (cadr PT)(* 2 h)))
PTC (list (+ (* 2 kc) (- di h h h h) (car PT)) (cadr PT))
L11 (list (+ di (car PT))(cadr PT))
L22 (list (+ kc (- 0 h h) (car L11))(cadr L11))
);setq
);if
(command "CECOLOR" 3
"line" p3 PT ""
"line" p4 PTC ""
"line" L1 L11 ""
"line" L2 L22 "")
);progn
);if
(setvar "CECOLOR" lacol)
(setvar "osmode" om)
(prompt"\n\n")
(command "Undo" "End")
(setvar "cmdecho" 1)
(princ)
);DONG toa do

http://www.cadviet.com/upfiles/3/71598_1_1.png

Em xin nói lại yêu cầu của em:
- Đoạn lisp 1 của Bác SSG dùng để vẽ bảng Toạ Độ Góc Ranh có lệnh : vc

---Yêu cầu 1: thêm hình tròn có tô hatch tại các đỉnh ( nếu được thì mong Bác có thể cho người dùng nhập đường kính vòng tròn)
---Yêu cầu 2: chuyển lại font chữ giũa kích thước và số TT ( số TT cho font chữ nghiêng và kích thước cho font chữ thẳng và tô...

Em xin nói lại yêu cầu của em:
- Đoạn lisp 1 của Bác SSG dùng để vẽ bảng Toạ Độ Góc Ranh có lệnh : vc

---Yêu cầu 1: thêm hình tròn có tô hatch tại các đỉnh ( nếu được thì mong Bác có thể cho người dùng nhập đường kính vòng tròn)
---Yêu cầu 2: chuyển lại font chữ giũa kích thước và số TT ( số TT cho font chữ nghiêng và kích thước cho font chữ thẳng và tô đậm)
---Yêu cầu 3: mong Bác có thể cho người dùng được chọn save lại hay không save lại bảng TĐGR ngay tại thư mục đã mở bản vẽ ra bằng file excel từng cột để cần thì có thể phục vụ cho công tác sau này.
Dưới đây là đường link file mẫu:

http://www.cadviet.com/upfiles/Mau_2_2.dwg

Do hôm nay Upload file len cadviet ko được nên nếu bài có dài quá thì mong các Bác thông cảm, do em chưa biết cách cho bài vào box

Chào dienlicogi và xuantran
Đoạn Code sau Tue_NV đã cải thiện theo ý của dienlicogi và xuantran
Các bạn dùng thử và cho ý kiến :


Tick Thanksss thay lời nói cảm ơn

>>

Chào dienlicogi và xuantran
Đoạn Code sau Tue_NV đã cải thiện theo ý của dienlicogi và xuantran
Các bạn dùng thử và cho ý kiến :


Tick Thanksss thay lời nói cảm ơn

1. Không thể loại bỏ những đường gióng có cao độ gần như nhau được. Vì khi chạy Lisp sẽ hiểu là chạy từ đầu đỉnh đến cuối đỉnh của Pline
Lisp này Tue_NV đã chỉnh lại :


PS : Tue_NV không thích gọi bằng "cậu". Hãy tôn trọng


@Xuantran : Tue_NV không hiểu file của bạn bị lỗi gì nữa. Bạn hãy lấy file này của Tue_NV test thử.
File test thử...

1. Không thể loại bỏ những đường gióng có cao độ gần như nhau được. Vì khi chạy Lisp sẽ hiểu là chạy từ đầu đỉnh đến cuối đỉnh của Pline
Lisp này Tue_NV đã chỉnh lại :


PS : Tue_NV không thích gọi bằng "cậu". Hãy tôn trọng


@Xuantran : Tue_NV không hiểu file của bạn bị lỗi gì nữa. Bạn hãy lấy file này của Tue_NV test thử.
File test thử đây : http://www.cadviet.com/upfiles/Coc.dwg
Chiều cao chữ bạn chọn khoảng bằng 2 tronh hình vẽ thôi nhé

Ng­ười ta yêu cầu như thế nào chỉ mần vậy thui các bác

(defun c:linhtinh(/ a)(vl-load-com)
(vla-put-textstring
(vlax-ename->vla-object (car(nentsel "\nThay gia tri vao dau day ?")))
(rtos (distance (setq a (getpoint "\nP1 :"))(getpoint a "\nP2 :")) 2 2)
)
(command...

Ng­ười ta yêu cầu như thế nào chỉ mần vậy thui các bác

(defun c:linhtinh(/ a)(vl-load-com)
(vla-put-textstring
(vlax-ename->vla-object (car(nentsel "\nThay gia tri vao dau day ?")))
(rtos (distance (setq a (getpoint "\nP1 :"))(getpoint a "\nP2 :")) 2 2)
)
(command "regen")
)