Bạn dùng thử lisp này. Lệnh là TM dùng được cho Text lẩn MText. Have fun!

;;;=========================================================;;;
;;; Cong dung: ALign Text Middle =====================================;;;
;;; Version: 1.0 =====================================================;;;
;;; Create by damvinhduy =============================================;;;
(defun C:TM (/ Txt PTxt PTX SS n OSMLAST lstpoint1 lstpoint2 pc pt pp)

>>

Bạn dùng thử lisp này. Lệnh là TM dùng được cho Text lẩn MText. Have fun!

;;;=========================================================;;;
;;; Cong dung: ALign Text Middle =====================================;;;
;;; Version: 1.0 =====================================================;;;
;;; Create by damvinhduy =============================================;;;
(defun C:TM (/ Txt PTxt PTX SS n OSMLAST lstpoint1 lstpoint2 pc pt pp)
(vl-load-com)
(setq SS (ssget "I" '((0 . "*TEXT"))))
(command ".undo" "BE")
(if (not SS)
(progn
(prompt "- Select text object")
(setq SS (ssget '((0 . "*TEXT"))))
);progn
);if
(setq OSMLAST (getvar "osmode"))
(setvar "OSMODE" 0)
(setq n 0)
(repeat (sslength SS)
(setq txt (ssname SS n))
(if (= (DXF 0 txt) "TEXT")
(progn
(setq PTxt (GET_MIDTEXT txt))
(setq lstpoint1 (lstpoint (UOject txt)))
(setq lstpoint2 (lstpoint (AOject txt)))
(setq pt (pmin lstpoint1))
(setq pp (pmax lstpoint2))
(setq PTX (CV:Geom-Midpoint pt pp))
(setq Pc (list (car PTxt) (cadr PTX) 0.0))
(vl-cmdf "move" txt "" PTxt Pc)
)
(progn
(TM txt)
(setq PTxt (DXF 10 txt))
(setq lstpoint1 (lstpoint (UOject txt)))
(setq lstpoint2 (lstpoint (AOject txt)))
(setq pt (pmin lstpoint1))
(setq pp (pmax lstpoint2))
(setq PTX (CV:Geom-Midpoint pt pp))
(setq Pc (list (car PTxt) (cadr PTX) 0.0))
(entmod (subst (cons 10 Pc) (cons 10 PTxt) (entget txt)))
)
)
(setq n (1+ n))
);repeat
(command ".undo" "E")
(princ "\n***Copyright © 2012 damvinhduy***")
(setvar "osmode" OSMLAST)
(princ)
);end TC
;;;---------------------------------------------------------------------
(defun GET_MIDTEXT (EN / TB PTxt PT0 PTA)
(setq TB (textbox (entget EN))
PTxt (CV:Geom-Midpoint (car TB) (cadr TB))
PT0 (DXF 10 EN)
PTA (list (+ (car PT0) (car PTxt)) (+ (cadr PT0) (cadr PTxt))))
(polar PT0 (+ (DXF 50 EN) (angle PT0 PTA)) (distance PT0 PTA))
);end
;;;---------------------------------------------------------------------
(defun DXF (Id Obj)
(cdr (assoc Id (entget Obj)))
)
;;;---------------------------------------------------------------------
(defun TM (txt / p pl hor at atnew)
(setq ver (cdr (assoc 43 (entget txt))))
(setq at (cdr (assoc 71 (entget txt))))
(setq P (cdr (assoc 10 (entget txt))))
(if
(and (/= at 4) (/= at 5) (/= at 6))
(progn
(cond
((or (= at 1) (= at 2) (= at 3))
(setq p1 (polar p (* 1.5 pi) (* ver 0.5)))
)
((or (= at 7) (= at 8) (= at 9))
(setq p1 (polar p (* 0.5 pi) (* ver 0.5)))
)
)
(cond
((or (= at 1) (= at 7))
(setq atnew 4)
)
((or (= at 2) (= at 8))
(setq atnew 5)
)
((or (= at 3) (= at 9))
(setq atnew 6)
)
)
(entmod (subst (cons 10 p1) (cons 10 p) (entget txt)))
(entmod (subst (cons 71 atnew) (cons 71 at) (entget txt)))
(setq txt txt)
)
(setq txt txt)
)
)
;;;---------------------------------------------------------------------
(defun AOject (txt / h l p0 p1 ss1 LOj)
(setq h (DXF 40 txt))
(setq l (* 70 h))
(setq p0 (DXF 10 txt))
(setq p1 (polar p0 (* 0.5 pi) l))
(setq ss1 (ssget "F" (list p0 p1) (list (cons 0 "*LINE"))))
(setq AOj (ssname ss1 0))
AOj
)
;;;---------------------------------------------------------------------
(defun UOject (txt / h l p0 p2 ss2 ROj)
(setq h (DXF 40 txt))
(setq l (* 70 h))
(setq p0 (DXF 10 txt))
(setq p2 (polar p0 (* 1.5 pi) l))
(setq ss2 (ssget "F" (list p0 p2) (list (cons 0 "*LINE"))))
(setq UOj (ssname ss2 0))
UOj
)
;;;---------------------------------------------------------------------
(defun lstpoint (eline)
(cond
(
(wcmatch (cdr (assoc 0 (entget eline))) "LINE")
(append (list (vlax-curve-getStartPoint eline) (vlax-curve-getEndPoint eline)))
)
(
(wcmatch (cdr (assoc 0 (entget eline))) "LWPOLYLINE")
(getvert-en eline)
)
)
)
;;;---------------------------------------------------------------------
(defun pmin (lstpoint)
(apply 'mapcar (cons 'min lstpoint))
)
;;;---------------------------------------------------------------------
(defun pmax (lstpoint)
(apply 'mapcar (cons 'max lstpoint))
)
;;;---------------------------------------------------------------------
(defun getvert-en (en / i L)
(setq i -1 L nil)
(repeat (fix (1+ (vlax-curve-getEndParam en)))
(setq i (1+ i) L (append L (list (vlax-curve-getPointAtParam en i))))
)
)
;;;---------------------------------------------------------------------
(defun CV:Geom-Midpoint (p1 p2)(mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2))

Nhưng khi tôi bỏ hẳn alert trong hàm IF thì vẫn không hiểu ^C^C để thoát lệnh.
Vẫn chưa hiểu, xin chỉ giúp thêm!

(Prompt "\Thi hanh bang lenh \"chaythu\".")
;Chuong trinh chinh
(Defun C:chaythu ()

(chophep)

(command "_.TEXT" "mc" (list 0.0 0.0 0.0) 5.0 0.0 "CHAY BINH THUONG")

(alert "Chuong trinh chay binh...

Nhưng khi tôi bỏ hẳn alert trong hàm IF thì vẫn không hiểu ^C^C để thoát lệnh.
Vẫn chưa hiểu, xin chỉ giúp thêm!

(Prompt "\Thi hanh bang lenh \"chaythu\".")
;Chuong trinh chinh
(Defun C:chaythu ()

(chophep)

(command "_.TEXT" "mc" (list 0.0 0.0 0.0) 5.0 0.0 "CHAY BINH THUONG")

(alert "Chuong trinh chay binh thuong!")
(princ)
);end defun chinh
(defun chophep (/ CHECK)
(setq CHECK (findfile "C:\\Windows\\win11111.ini"))
(if (= CHECK nil)
^^C)
);end chophep


Kết quả vẫn chạy ra dòng text: CHAY BINH THUONG. Chứ không ngắt lệnh!?

em định up vào đây không biết có sai box không^^nếu có sai thì mod chuyển cho em ra thư giãn ạ
lisp em có gõ tìm kiếm chưa có nên mạo hiểm up lên đây lisp tính chỉ số BMI cho các bác cadviet vừa làm vừa có cái giải trí trong lúc căng thẳng ạ
do em mới học lỏm được 1 2 hàm nên nó còn sơ sài...

em định up vào đây không biết có sai box không^^nếu có sai thì mod chuyển cho em ra thư giãn ạ
lisp em có gõ tìm kiếm chưa có nên mạo hiểm up lên đây lisp tính chỉ số BMI cho các bác cadviet vừa làm vừa có cái giải trí trong lúc căng thẳng ạ
do em mới học lỏm được 1 2 hàm nên nó còn sơ sài và không gọn code . Chúc các bác có 1 thân hình đẹp . (Cái này phân cấp độ béo ra 3 cấp) các mốc bmi là 18- 25- 30- 35

;;; kiem tra BMI
;;; hamster2102
(defun C:BMI ( / w h chiso )
(princ "\nCanh bao: nguoi dep thi khong can kiem tra vi ktr roi lai cu muon kiem tra lai de tu suong ma tu suong thi khong nen, thank ")
(setq
h (getreal "\nChieu cao cua ban bao nhieu (m) ")
w (getreal "\nCan nang cua ban bao nhieu (kg) ")
)
(setq h2 (* h h))
(setq chiso (/ w h2))
(princ "\nChi so BMI cua ban la")
(princ chiso)
(if (< chiso 18) (princ "\nBo xuong kho cua ban can phai cho an uong day du, han che tu suong, ra duong nho cong ~ them bao cat phong chong gio thoi bay nguoi"))
(if (and (>= chiso 18) (< chiso 25)) (princ "\nCo cau nguoi dep thi cho nao cung dep, ban hang chuan khong can chinh, sua thi vo tu"))
(if (and (>= chiso 25) (< chiso 30))(princ "\nChuc mung ban beo phi cap do 1 can an nhieu hon de len lv 2"))
(if (and (>= chiso 30) (< chiso 35))(princ "\nChuc mung ban beo phi cap do 2 can an nhieu hon de len lv 3"))
(if (>= chiso 35) (princ "\nOh yeah! Chuc mung ban da dat dinh cao phong do beo khoe beo dep beo nhu heo roi, ^^max lever ^^den luc phai gac kiem an kieng khan cap"))
(princ "\nChuc ban mot ngay vui ve")
(princ)
)

Cả 2 cách sửa trên của Tue_NV và ketxu đều can thiệp vào file Lisp, tức là phải mở file Lisp lên và sửa
Tue_NV nghĩ rằng nên gán các giá trị mặc định cho Hatch và tiến hành Hatch theo giá trị này.
1. Lisp của bạn ketxu Hatch các mẫu theo 1 giá trị mặc định ở trong Lisp, muốn thay đổi giá trị lại vào trong Lisp mà sửa lại. Hơi phiền nhỉ?

Cách gán giá trị mặc định của...

Cả 2 cách sửa trên của Tue_NV và ketxu đều can thiệp vào file Lisp, tức là phải mở file Lisp lên và sửa
Tue_NV nghĩ rằng nên gán các giá trị mặc định cho Hatch và tiến hành Hatch theo giá trị này.
1. Lisp của bạn ketxu Hatch các mẫu theo 1 giá trị mặc định ở trong Lisp, muốn thay đổi giá trị lại vào trong Lisp mà sửa lại. Hơi phiền nhỉ?

Cách gán giá trị mặc định của Tue_NV là cách như sau
1. Thiết lập các biến hệ thống bằng cách gõ tên biến hệ thống ở dòng Command và thiết lập giá trị cho nó.
Trường hợp bạn không nhớ tên biến hệ thống thì bạn có thể làm như sau :
Bật hộp thoại hatch lên bằng cách sử dụng lệnh H
-> Thiết lập các giá trị Associate, Gap Tolerance....
Trỏ vào Scale, Angle, thiết lập giá trị cho Hatch (làm cuối cùng)
Thiết lập xong rồi, Không làm gì cả -> Enter kết thúc lệnh

Bây giờ thì các giá trị quy định về Scale, Angle,.. của Hatch đã được thiết lập mặc định rồi đấy. Bạn có thể bật hộp thoại Hatch lên lại để kiểm tra. (hoặc xem lại giá trị của biến hệ thống quy định các giá trị của Hatch
Bạn chỉ việc Hatch mà thôi và đương nhiên Lisp của bạn ketxu cũng sẽ được sửa lại 1 chút:



Như vậy các biến hệ thống có thể được thiết lập mặc định thông qua hộp thoại Hatch.
Sử dụng Lisp trên sẽ Hatch theo giá trị được thiết lập mặc định thông qua hộp thoại Hatch
Các Bạn thử xem nhé.

Bạn thông cảm cho mình vì mình code quá nhanh nên thành ra quên cả những cái cơ bản nhất
Tạm thời mình reply đặt gạch giải quyết 3 vấn đề của bạn đã nhé.
Lúc khác rảnh mình sẽ xử tiếp những yêu cầu còn lại
1. Kích thước bảng: Nó sẽ phù hợp với chiều cao text bạn nhập vào ...

Bạn thông cảm cho mình vì mình code quá nhanh nên thành ra quên cả những cái cơ bản nhất
Tạm thời mình reply đặt gạch giải quyết 3 vấn đề của bạn đã nhé.
Lúc khác rảnh mình sẽ xử tiếp những yêu cầu còn lại
1. Kích thước bảng: Nó sẽ phù hợp với chiều cao text bạn nhập vào (Cái này dễ chỉnh, bạn muốn chỉnh sao mình sẽ chỉ sau)
2. Vấn đề text ra toàn 0 tròn là do bạn đang để một text style có chiều cao chữ, bạn chuyển sang 1 cái text style không có chiều cao chữ là ngon thui
3. Quay màn hình mình dùng snagit bạn hỏi bác GG nhé
Các vấn đề còn lại cho mình nợ khi khác vậy
Bạn xài code này

;; free lisp from cadviet.com
;;; Edit by mathan
----------------------------------------------
(defun C:tkd ()
(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 TP (getint (strcat "\nSo chu so thap phan :")))
(setq tapx '() tapy '() stt '())
(command "CECOLOR" 0)
;;; Phan dim
(setq ktra "OK")
(While (= ktra "OK")
(setvar "osmode" 125)
(setq DD (getpoint"\nPick diem dau"))
(setq TDD (getstring"\nNhap ten diem dau:"))
(setq DC (getpoint"\nPick diem cuoi"))
(setq TDC (getstring"\nNhap ten diem cuoi:"))
(setvar "osmode" 0)

(setq kc (distance DD DC))

(setq textdim (rtos kc 2 tp))
(setq textdiem (strcat TDD "-" TDC))
(setq ghichu "Do thuc te")
(command "_DIMALIGNED" DD DC (getpoint"\nDiem dat dim"))
(setq ktra (getstring"\nBan muon dung lai nhap - de tiep tuc :"))
(if (or (= ktra "S") (= ktra "s")) (setq ktra "NOT OK") (setq ktra "OK"))

(setq
tapx (append tapx (list textdim))
tapy (append tapy (list ghichu))
stt (append stt (list textdiem))
);setq
);;end while

;;;;;;;;;;;;; Phan lap bang thong ke
(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 (* 8 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 "Diem do"
"text" "m" p22 h 0 "Chieu dai"
"text" "m" p33 h 0 "Ghi chu"
"text" "m" pTB (* 1.3 h) 0 "Bang thong ke chieu dai dim")
(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 by Thaistreetz - Edit by Mathan")
(command "Undo" "End")
(setvar "cmdecho" 1)
(princ)
);DONG toa do

Em có cái lisp ghi kích thước sưu tầm được của 1 bác trên diễn đàn. Xin các bác giúp em chỉnh sửa lisp này để có thể chọn đường thằng cần ghi kích thước theo một layer nào đó. Thanks!



;----kich thuoc duong thang --------
(defun c:kt2(/ vl ov ss d1 d2 d3 d4 d5 ent kc)
(vl-load-com)
(command "_.undo" "_begin")
(setq vl '("osmode" "orthomode"...

Em có cái lisp ghi kích thước sưu tầm được của 1 bác trên diễn đàn. Xin các bác giúp em chỉnh sửa lisp này để có thể chọn đường thằng cần ghi kích thước theo một layer nào đó. Thanks!



;----kich thuoc duong thang --------
(defun c:kt2(/ vl ov ss d1 d2 d3 d4 d5 ent kc)
(vl-load-com)
(command "_.undo" "_begin")
(setq vl '("osmode" "orthomode" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(mapcar 'setvar vl '(0 0 0))
(princ "\nChon duong thang can ghi kich thuoc : ")
(if (and
(setq ss (ssget (list (cons 0 "LINE")) ))
(setq kc (getdist "\nNhap khoang cach : "))
(setq d4 (getpoint "\nHuong dat kich thuoc ? ") ) )
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq d1 (vlax-curve-getStartPoint ent)
d2 (vlax-curve-getEndPoint ent)
d5 (vlax-curve-getClosestPointTo ent d4 T)
d3 (polar d5 (angle d5 d4) kc))
(command "dimaligned" d1 d2 d3)
)
)
(mapcar 'setvar vl ov) ; reset Sys Vars
(command "_.undo" "_end")
(princ)
)

Quên béng mất lời hẹn ^^



(defun c:test ( / lst ss blkName change)
(defun change ( block layer )
(vl-load-com)
(if
(not
(vl-catch-all-error-p
(setq def
(vl-catch-all-apply 'vla-item
(list
(vla-get-blocks
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
...

Quên béng mất lời hẹn ^^



(defun c:test ( / lst ss blkName change)
(defun change ( block layer )
(vl-load-com)
(if
(not
(vl-catch-all-error-p
(setq def
(vl-catch-all-apply 'vla-item
(list
(vla-get-blocks
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
block
)
)
)
)
)
(vlax-for obj def
(vl-catch-all-apply 'vla-put-color (list obj
(if (= (setq col (vla-get-color obj)) 256)
(cdr (assoc 62 (tblsearch "LAYER" (vla-get-layer obj))))
col
)
))
(vl-catch-all-apply 'vla-put-layer (list obj layer))
)
)
)
(cond ((setq ss (ssget (list (cons 0 "INSERT"))))
(foreach blk (acet-ss-to-list ss)
(vl-catch-all-apply 'vla-put-layer (list (vlax-ename->vla-object blk) "Block"))
(if (not (vl-position (setq blkName (cdr (assoc 2 (entget blk)))) lst))
(progn
(change blkName "Block")
(setq lst (cons blkName lst))
)
)
)
)
)
(command "_.regenall")
(princ)
)

Hề hề hề,
Sorry vì đúng là có lỗi do mình test với block thuộc tính mà block của bạn không phải block thuộc tính.
Mình đã bổ sung để dùng được với cả block thuộc tính và block thường.
Bạn test lại nhé.
Trong lisp mình viết không đụng chạm gì tới màu sắc của đối tượng. Vì vậy nếu bạn thấy nó bị đổi màu ở đâu thì gửi cái đó cho mình để mình check lại...

Hề hề hề,
Sorry vì đúng là có lỗi do mình test với block thuộc tính mà block của bạn không phải block thuộc tính.
Mình đã bổ sung để dùng được với cả block thuộc tính và block thường.
Bạn test lại nhé.
Trong lisp mình viết không đụng chạm gì tới màu sắc của đối tượng. Vì vậy nếu bạn thấy nó bị đổi màu ở đâu thì gửi cái đó cho mình để mình check lại nhé.

Một lần nữa xin lỗi vì chưa test lisp với bản vẽ bạn gửi.

Bác Pro nào giúp em sửa đoạn lisp này của bác Tue_NV sao cho khi chọn 2 điểm xong thì kết quả chỉ ghi khoảng cách 2 điểm mà không thực hiện Dimlinear (Không có đường gióng kích thước) với nhé. Em cảm ơn nhiều.

Ví dụ:

http://img822.imageshack.us/img822/6663/dokichthuockhonghienduo.png



(vl-load-com)
(defun Tue:ss-drag-move (ss p / el lp)
;;;copyright by Tue_NV
(setq...

Bác Pro nào giúp em sửa đoạn lisp này của bác Tue_NV sao cho khi chọn 2 điểm xong thì kết quả chỉ ghi khoảng cách 2 điểm mà không thực hiện Dimlinear (Không có đường gióng kích thước) với nhé. Em cảm ơn nhiều.

Ví dụ:

http://img822.imageshack.us/img822/6663/dokichthuockhonghienduo.png



(vl-load-com)
(defun Tue:ss-drag-move (ss p / el lp)
;;;copyright by Tue_NV
(setq el (entlast))
(if (and ss p (vl-cmdf "copy" ss "" p pause) (null (equal (getvar "lastpoint") p)))
(setq lp (getvar "lastpoint")) (setq lp nil)
)
(while (setq el (entnext el)) (entdel el))
lp)
(defun c:dkt(/ p1 p2 ob)
(while (setq p1 (getpoint "\n diem do dau tien :"))
(if (vl-cmdf "DIMALIGNED" p1 (setq p2 (getpoint p1 "\n diem do tiep theo :")) pause )
(progn
(setq ob (vlax-ename->vla-object (entlast)))
(vla-addtext (vla-get-modelspace(vla-get-activedocument(vlax-get-acad-object)))
(rtos (vlax-get ob 'Measurement) 2 (vlax-get ob 'PrimaryUnitsPrecision))
(vlax-3d-point (vlax-get ob 'TextPosition)) (vlax-get ob 'TextHeight) )
(setq ptt (Tue:ss-drag-move (ssadd (entlast) (ssadd)) (vlax-get ob 'TextPosition)) )
(command "move" (entlast) "" (vlax-get ob 'TextPosition) ptt)

)
)
)
)

Các bác thử nghiên cứu lisp tạo tam giác này xem rồi chế nó thành của mình.
Đây là thuật toán tạo tam giác của người Nga

(defun c:taotamgiac (/ I L S)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
) ;_ setq
(progn (repeat (sslength s)
(setq l (cons (cdr (assoc 10 (entget (ssname s i)))) l)
i (1+ i)
) ;_ ...

Các bác thử nghiên cứu lisp tạo tam giác này xem rồi chế nó thành của mình.
Đây là thuật toán tạo tam giác của người Nga

(defun c:taotamgiac (/ I L S)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
) ;_ setq
(progn (repeat (sslength s)
(setq l (cons (cdr (assoc 10 (entget (ssname s i)))) l)
i (1+ i)
) ;_ setq
) ;_ repeat
(eea-delone-triangulate i l)
) ;_ progn
) ;_ if
) ;_ defun
(defun eea-delone-triangulate
(i1 L / A A1 A2 A3 I I2 L1 L2 L3 LP MA MI P S TI TR X1 X2 Y1 Y2)
;;*********************************************************
;;
;; Written by ElpanovEvgeniy
;; 17.10.2008
;; edit 20.05.2011
;; Program triangulate an irregular set of 3d points.
;;
;;*********************************************************
(if l
(progn
(setq ti (car (_VL-TIMES))
i 1
i1 (/ i1 100.)
i2 0
l (vl-sort (mapcar (function (lambda (p)
(list (/ (fix (* (car p) 1000)) 1000.)
(/ (fix (* (cadr p) 1000)) 1000.)
(caddr p)
) ;_ list
) ;_ lambda
) ;_ function
l
) ;_ mapcar
(function (lambda (a (>= (car a) (car )))
) ;_ vl-sort
x2 (caar l)
y1 (cadar l)
y2 y1
) ;_ setq
(while l
(setq a2 (car l))
(if (<= (cadr a2) y1)
(setq y1 (cadr a2))
(if (> (cadr a2) y2)
(setq y2 (cadr a2))
)
)
(setq a (fix (caar l))
a1 (list (car l))
l (cdr l)
) ;_ setq
(while (and l (= (fix (caar l)) a))
(setq a2 (car l))
(if (<= (cadr a2) y1)
(setq y1 (cadr a2))
(if (> (cadr a2) y2)
(setq y2 (cadr a2))
) ;_ if
) ;_ if
(setq a1 (cons (car l) (vl-remove a2 a1))
l (cdr l)
) ;_ setq
) ;_ while
(foreach a a1 (setq lp (cons a lp)))
) ;_ while
(setq x1 (caar lp)
a (list (/ (+ x1 x2) 2) (/ (+ y1 y2) 2))
a1 (distance a (list x1 y1))
ma (+ (car a) a1 a1)
mi (- (car a) a1)
s (list (list ma (cadr a) 0)
(list mi (+ (cadr a) a1 a1) 0)
(list (- (car a) a1) (- (cadr a) a1 a1) 0)
) ;_ list
l (list (cons x2 (cons a (cons (+ a1 a1) s))))
ma (1- ma)
mi (1+ mi)
) ;_ setq
(while lp
(setq p (car lp)
lp (cdr lp)
l1 nil
) ;_ setq
(while l
(setq tr (car l)
l (cdr l)
) ;_ setq
(cond ((< (car tr) (car p)) (setq l2 (cons (cdddr tr) l2)))
((< (distance p (cadr tr)) (caddr tr))
(setq tr (cdddr tr)
a1 (car tr)
a2 (cadr tr)
a3 (caddr tr)
l1 (cons (list (+ (car a1) (car a2)) (+ (cadr a1) (cadr a2)) a1 a2)
(cons (list (+ (car a2) (car a3)) (+ (cadr a2) (cadr a3)) a2 a3)
(cons (list (+ (car a3) (car a1)) (+ (cadr a3) (cadr a1)) a3 a1) l1)
) ;_ cons
) ;_ cons
) ;_ setq
)
(t (setq l3 (cons tr l3)))
) ;_ cond
) ;_ while
(setq l l3
l3 nil
l1 (vl-sort l1
(function (lambda (a
(if (= (car a) (car )
(<= (cadr a) (cadr )
(< (car a) (car )
) ;_ if
) ;_ lambda
) ;_ function
) ;_ vl-sort
) ;_ setq
(while l1
(if (and (= (caar l1) (caadr l1)) (= (cadar l1) (cadadr l1)))
(setq l1 (cddr l1))
(setq l (cons (eea-data-triangle p (cddar l1)) l)
l1 (cdr l1)
) ;_ setq
) ;_ if
) ;_ while
(if (and (< (setq i (1- i)) 1) (< i2 100))
(progn
(setvar
"MODEMACRO"
(strcat
" "
(itoa (setq i2 (1+ i2)))
" % "
(substr
"||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||"
1
i2
) ;_ substr
(substr "..." 1 (- 100 i2))
) ;_ strcat
) ;_ setvar
(setq i i1)
) ;_ progn
) ;_ if
) ;_ while
(foreach a l (setq l2 (cons (cdddr a) l2)))
(setq l2 (vl-remove-if-not
(function (lambda (a) (and (< mi (caadr a) ma) (< mi (caaddr a) ma))))
l2
) ;_ vl-remove-if
) ;_ setq
(foreach a l2
(entmake (list (cons 0 "3DFACE")
(cons 10 (car a))
(cons 11 (car a))
(cons 12 (cadr a))
(cons 13 (caddr a))
) ;_ list
) ;_ entmake
) ;_ foreach
) ;_ progn
) ;_ if
(setvar "MODEMACRO" "")
(princ (strcat "\n " (rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4) " secs."))
(princ)
) ;_ defun
(defun eea-data-triangle (P1 l / A A1 P2 P3 P4 S)
;;*********************************************************
;;
;; Written by ElpanovEvgeniy
;; 17.10.2008
;; Calculation of the centre of a circle and circle radius
;; for program triangulate
;;
;; (eea-data-triangle (getpoint)(list(getpoint)(getpoint)))
;;*********************************************************
(setq p2 (car l)
p3 (cadr l)
p4 (list (car p3) (cadr p3))
) ;_ setq
(if (not (zerop (setq s (sin (setq a (- (angle p2 p4) (angle p2 p1)))))))
(progn (setq a (polar p4
(+ -1.570796326794896 (angle p4 p1) a)
(setq a1 (/ (distance p1 p4) s 2.))
) ;_ polar
a1 (abs a1)
) ;_ setq
(list (+ (car a) a1) a a1 p1 p2 p3)
) ;_ progn
) ;_ if
) ;_ defun

đây là lisp mình tìm trên mạng đã sữa lại theo những gì mình muốn nhưng còn một số chỗ chưa sữa được mong mọi người sữa lại giùm
những yêu cầu sau:
1. Có thể undo lại khi vẽ thấy taluy không hợp lí:
- Thay đổi khoảng cách giữa các vạch ngắn dài
- Thay đổi chiều đánh taluy
2. Có chọn điểm bắt đầu và điểm kết thúc ( bỡi trên đường mình chọn chỉ...

đây là lisp mình tìm trên mạng đã sữa lại theo những gì mình muốn nhưng còn một số chỗ chưa sữa được mong mọi người sữa lại giùm
những yêu cầu sau:
1. Có thể undo lại khi vẽ thấy taluy không hợp lí:
- Thay đổi khoảng cách giữa các vạch ngắn dài
- Thay đổi chiều đánh taluy
2. Có chọn điểm bắt đầu và điểm kết thúc ( bỡi trên đường mình chọn chỉ muốn đánh 1 đoạn nào đó)
sau đây là đoạn lisp:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=5947
;;; ======================== VE DUONG TALUY - LENH B1 (BATTER) =========================
;;; ================================================================================
=======
;; ============================================= Batter ================================================
(defun c:Batter()
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(setvar "aunits" 0)
(setvar "angbase" (/ pi 2))
(setvar "angdir" 1)
(if (not lint) (setq lint 10.0))
(setq int (getdist (strcat "\nKhoang cach giua vach ngan - vach dai <" (rtos lint 2 3) ">: ")))
(if int (setq lint int) (setq int lint))
(command "line" (list 0.0 0.0) (list 0.0 0.0001) "")
(if (tblsearch "block" "tadtick")
(command "block" "tadtick" "y" (list 0.0 0.0) (entlast) "")
(command "block" "tadtick" (list 0.0 0.0) (entlast) "")
)
(while (setq refent (entsel "\nChon duong thu nhat: "))
(command "undo" "group")
(redraw (car refent) 3)
(initget 1 "Dao Mai")
(setq reply (getkword "\nMai ao or ai dap: "))
(setq s (ssget))
(command "measure" refent "b" "tadtick" "y" int)
(setq p (ssget "p") cn 0)
(if s
(progn
(while (< cn (sslength p))
(setq en (entget (ssname p cn)) p0 (cdr (assoc 10 en)) pt1 p0 pt2 nil b (cdr (assoc 50 en)))
(entdel (ssname p cn))
(setq p1 (polar p0 (+ (/ pi 2) 0.0001))
(command "line" p0 p1 "")
(command "extend" s "" (list (entlast) p1) "")
(setq xent (entget (entlast)))
(setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent))))
(if (not (equal xdist 0.0001 0.0001))
(setq pt2 (cdr (assoc 11 xent)))
(progn
(command "extend" s "" (list (entlast) p0) "")
(setq xent (entget (entlast)))
(setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent))))
(if (not (equal xdist 0.0001 0.0001))
(setq pt2 (cdr (assoc 10 xent)))
)
)
)
(entdel (entlast))
(if pt2
(if (= reply "Mai")
(if (= (rem cn 2) 0)
(progn
(command "-layer" "set" "canh dai" "")
(command "line" pt1 pt2 "")
)
(progn
(command "-layer" "set" "canh ngan" "")
(command "line" pt1 (polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2)) "")
)
)
(if (= (rem cn 2) 0)
(progn
(command "-layer" "set" "canh dai" "")
(command "line" pt2 pt1 "")
)
(progn
(command "-layer" "set" "canh ngan" "")
(command "line" pt2 (polar pt2 (angle pt2 pt1) (/ (distance pt2 pt1) 2)) "")
)
)
)
)
(setq cn (1+ cn))
)
)
)
(command "undo" "en")
)
(setvar "blipmode" 1)
(princ)
)
(prompt "\nDraw cut/fill batter slope lines.")
;====================== BAT1 (BATTER)===========================================
(defun c:B1( / mode)
(command "-layer" "new" "canh dai" "color" "8" "canh dai" "")
(command "-layer" "new" "canh ngan" "color" "2" "canh ngan" "")
;(command "-layer" "set" "canh dai" "")
(setvar "osmode" 0)
(c:batter)
(setvar "blipmode" 0)
(setvar "osmode" 167)
)

Đây là lisp vẽ taluy mà mình đã chỉnh sửa theo mong muốn của mình nhưng còn 1 số vướng mắc không biết làm sao mong mọi người giúp đỡ.
Những vướng mắc sau đây.
1. Có thể undo lại sau khi vẽ
- Nhập lại khoảng cách giữa các vạch ngắn dài
-Đổi chiều đánh taluy từ đắp sang đào hoặc ngược lại
2. Có thể chọn được điểm bắt đầu và kết thúc đánh taluy (vì chỉ...

Đây là lisp vẽ taluy mà mình đã chỉnh sửa theo mong muốn của mình nhưng còn 1 số vướng mắc không biết làm sao mong mọi người giúp đỡ.
Những vướng mắc sau đây.
1. Có thể undo lại sau khi vẽ
- Nhập lại khoảng cách giữa các vạch ngắn dài
-Đổi chiều đánh taluy từ đắp sang đào hoặc ngược lại
2. Có thể chọn được điểm bắt đầu và kết thúc đánh taluy (vì chỉ muốn đánh 1 đoạn)
rất cám ơn mọi người giúp đỡ
Sau đây là lisp

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=5947
;;; ======================== VE DUONG TALUY - LENH B1 (BATTER) =========================
;;; ================================================================================
=======
;; ============================================= Batter ================================================
(defun c:Batter()
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(setvar "aunits" 0)
(setvar "angbase" (/ pi 2))
(setvar "angdir" 1)
(if (not lint) (setq lint 10.0))
(setq int (getdist (strcat "\nKhoang cach giua vach ngan - vach dai <" (rtos lint 2 3) ">: ")))
(if int (setq lint int) (setq int lint))
(command "line" (list 0.0 0.0) (list 0.0 0.0001) "")
(if (tblsearch "block" "tadtick")
(command "block" "tadtick" "y" (list 0.0 0.0) (entlast) "")
(command "block" "tadtick" (list 0.0 0.0) (entlast) "")
)
(while (setq refent (entsel "\nChon duong thu nhat: "))
(command "undo" "group")
(redraw (car refent) 3)
(initget 1 "Dao Mai")
(setq reply (getkword "\nMai ao or ai dap: "))
(setq s (ssget))
(command "measure" refent "b" "tadtick" "y" int)
(setq p (ssget "p") cn 0)
(if s
(progn
(while (< cn (sslength p))
(setq en (entget (ssname p cn)) p0 (cdr (assoc 10 en)) pt1 p0 pt2 nil b (cdr (assoc 50 en)))
(entdel (ssname p cn))
(setq p1 (polar p0 (+ (/ pi 2) 0.0001))
(command "line" p0 p1 "")
(command "extend" s "" (list (entlast) p1) "")
(setq xent (entget (entlast)))
(setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent))))
(if (not (equal xdist 0.0001 0.0001))
(setq pt2 (cdr (assoc 11 xent)))
(progn
(command "extend" s "" (list (entlast) p0) "")
(setq xent (entget (entlast)))
(setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent))))
(if (not (equal xdist 0.0001 0.0001))
(setq pt2 (cdr (assoc 10 xent)))
)
)
)
(entdel (entlast))
(if pt2
(if (= reply "Mai")
(if (= (rem cn 2) 0)
(progn
(command "-layer" "set" "canh dai" "")
(command "line" pt1 pt2 "")
)
(progn
(command "-layer" "set" "canh ngan" "")
(command "line" pt1 (polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2)) "")
)
)
(if (= (rem cn 2) 0)
(progn
(command "-layer" "set" "canh dai" "")
(command "line" pt2 pt1 "")
)
(progn
(command "-layer" "set" "canh ngan" "")
(command "line" pt2 (polar pt2 (angle pt2 pt1) (/ (distance pt2 pt1) 2)) "")
)
)
)
)
(setq cn (1+ cn))
)
)
)
(command "undo" "en")
)
(setvar "blipmode" 1)
(princ)
)
(prompt "\nDraw cut/fill batter slope lines.")
;====================== BAT1 (BATTER)===========================================
(defun c:B1( / mode)
(command "-layer" "new" "canh dai" "color" "8" "canh dai" "")
(command "-layer" "new" "canh ngan" "color" "2" "canh ngan" "")
;(command "-layer" "set" "canh dai" "")
(setvar "osmode" 0)
(c:batter)
(setvar "blipmode" 0)
(setvar "osmode" 167)
)

(1 +2 )

(defun C:brk2(/ d ent ipts ss)
(defun ssget->ss-list (ss / i obj allobj)
(setq i -1)
(while (setq obj (ssname ss (setq i (1+ i))) )
(setq allobj (cons obj allobj)) )
allobj )
(defun break_obj (ent pt dis / brkpte brkpts len)
(setq brkptS pt brkptE pt)
(if (> dis 0)
(progn
(setq len (vlax-curve-getDistAtPoint ent pt))
(if (> len dis)
(setq brkptS...

(1 +2 )

(defun C:brk2(/ d ent ipts ss)
(defun ssget->ss-list (ss / i obj allobj)
(setq i -1)
(while (setq obj (ssname ss (setq i (1+ i))) )
(setq allobj (cons obj allobj)) )
allobj )
(defun break_obj (ent pt dis / brkpte brkpts len)
(setq brkptS pt brkptE pt)
(if (> dis 0)
(progn
(setq len (vlax-curve-getDistAtPoint ent pt))
(if (> len dis)
(setq brkptS (vlax-curve-getPointAtDist ent (- len dis))))
(if (> (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (+ len dis))
(setq brkptE (vlax-curve-getPointAtDist ent (+ len dis)) )) ))
(command "._break" ent "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1)) )

(defun Select1obj(objName msg)
(while (not (and(setq ent (car (entsel msg)))
(if ent (wcmatch (cdr (assoc 0 (entget ent))) objName) ) ) )
(princ "\nSelect Again: ") )
ent )
; main
(vl-load-com)
(command "undo" "be")
(setq ent (Select1obj "LINE,ARC,RAY,XLINE" "Duong chuan : ")
ent (vlax-ename->vla-object ent))
(princ "\nVat bi cat...")
(if(setq ss (ssget "_:L" (list (cons 0 "LINE,ARC"))))
(progn
(or d (setq d 1))
(initget 4)
(setq d (cond ((getdist (strcat "\nKhoang cach <" (rtos d) "> :"))) (d)))
(foreach e (ssget->ss-list ss)
(if (setq iPts (vlax-Invoke ent "IntersectWith" (vlax-ename->vla-object e) 0))
(break_obj e ipts d)) )))
(command "undo" "e")(princ) )


PS : Bổ sung hàm con.