Jump to content
InfoFile
Tác giả: quansla
Bài viết gốc: 415649
Tên lệnh: 11111
Lisp Chuyển Dim Từ Above Sang Below Và Ngược Lại
Thì dùng tạm

(defun c:11111(/ obj ss)
  (if (setq ss (ssget '((0  . "DIM*"))))
    (foreach dt (acet-ss-to-list ss)
      (setq obj (vlax-ename->vla-object dt))
      (if (= (vla-get-verticaltextposition obj) 1)
(vla-put-verticaltextposition obj 4)
(vla-put-verticaltextposition obj 1)
)
      )
    )
  (princ)
  )

Filename: 415649_11111.lsp
Tác giả: ketxu
Bài viết gốc: 127525
Tên lệnh: ht
Viết lisp theo yêu cầu [phần 2]

Do lệnh hatch trong lisp ban đầu của bạn còn thiếu thông số chọn điểm trong vùng Hatch đó mà
Bạn sửa thành như thế này nhé :


Góp ý với bạn : ngoài tiếng tks kèm theo lời yêu cầu,bạn có thể dùng nút thanks để động viên hoặc để báo cho người giúp bạn biết là bạn đã ngó qua cái phần người ta đáp ứng nhu cầu của bạn.:")

Filename: 127525_ht.lsp
Tác giả: vodoifx
Bài viết gốc: 415941
Tên lệnh: at
Cộng, Trừ, Nhân, Chia Hàng Loạt Att Cùng Tagname Trong Block Với Cùng 1 Số

Em có tham khảo lisp đánh số thứ tự bản vẽ để viết Cộng, trừ, nhân, chia hàng loạt Att cùng tagName trong Block với 1 số, nhưng khả năng có hạn nên chưa thể viết được. Mong các bác giúp em 
Lisp đánh sốt thứ tự Block

;; free lisp from cadviet.com
;;; this lisp was downloaded from...

>>

Em có tham khảo lisp đánh số thứ tự bản vẽ để viết Cộng, trừ, nhân, chia hàng loạt Att cùng tagName trong Block với 1 số, nhưng khả năng có hạn nên chưa thể viết được. Mong các bác giúp em 
Lisp đánh sốt thứ tự Block

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=38369&st=0&p=139366&hl=esport113&fromsearch=1&#entry139366
(defun c:stt (/ ans ins lst blkName tagName ent);Block Order
;; By : Gia_Bach, www.CadViet.com ;;
(vl-load-com)
(while (not (and
(setq ent (car (nentsel "\n Chon thuoc tinh can danh so: ")))
(if ent (eq (cdr (assoc 0 (entget ent))) "ATTRIB") ) ) )
(princ "\n Ban chon nham roi! ") )
(setq blkName (cdr (assoc 2 (entget (cdr (assoc 330 (entget ent))))))
tagName (cdr (assoc 2 (entget ent))) )

(initget 1 "Yes No")
(setq x (getkword "\nBan co muon nhap Tien to ? (Yes or No) "))
(if (= x "Yes")
(progn
(or prefix (setq prefix "KC-"))
(setq ans (getstring t (strcat "\n Nhap tien to <<"prefix ">> :")))
(if (/= ans "")(setq prefix ans)) )
(setq prefix ""))

(or stt (setq stt 1))
(initget 6)
(setq ans (getint (strcat "\n Nhap so bat dau <<"(itoa stt) ">> :")))
(if ans (setq stt ans))
(if (> stt 9)
(setq str (strcat prefix (itoa stt)))
(setq str (strcat prefix "0" (itoa stt))) )

(princ "\nChon Khung ten can danh so thu tu :")
(if (ssget(list (cons 0 "INSERT")(cons 66 1)(cons 2 blkName)))
(progn
(vlax-for e (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(setq ins (vlax-safearray->list (variant-value (vla-get-InsertionPoint e)))
lst (cons (list e ins)lst)) )
(setq lst (vl-sort lst '(lambda (x y) (or (> (cadr (cadr x)) (cadr (cadr y)))
(and (< (car (cadr x)) (car (cadr y)))
(= (cadr (cadr x)) (cadr (cadr y))) ) ) ) ))
(foreach e (append (mapcar 'car lst) )
(foreach Att (vlax-invoke e 'GetAttributes)
(if (= (vla-get-TagString att) tagName)
(vla-put-TextString att str) ))
(setq stt (+ 1 stt))
(if (> stt 9)
(setq str (strcat prefix (itoa stt)))
(setq str (strcat prefix "0" (itoa stt))) ) ) ) )
(princ))

 

 

Lisp cộng trừ nhân chia ATT với 1 số 

 

(defun c:at (/ goc cal e1 en numb Kieudoc)
(setq Kieudoc (cond (Kieudoc) ("Cong")))
(initget "1 2 3 4")
(setq Kieudoc (cond ((getkword (strcat "\Chon kieu can text <" Kieudoc ">"))) (Kieudoc)))
(setq goc1 (car (nentsel "\n Chon ATT can tinh")))
(redraw goc1 3)
(setq goc (atof (cdr (assoc 1 (entget goc1 )))))
(setq numb (getreal "\nNhap so Or bo qua de chon so: "))
(if (or (= numb nil) (= numb ""))
(setq numb (atof (cdr (assoc 1 (entget (car (entsel "\nChon so : "))))))))
(cond
((eq Kieudoc "1") (setq goc (+ goc numb)))
((eq Kieudoc "2") (setq goc (- goc numb)))
((eq Kieudoc "3") (setq goc (* goc numb)))
((eq Kieudoc "4") (setq goc (/ goc numb))))
(entmod (subst (cons 1 (rtos goc 2 2)) (assoc 1 (entget goc1)) (entget goc1)))
(entupd goc1))


<<

Filename: 415941_at.lsp
Tác giả: quansla
Bài viết gốc: 336382
Tên lệnh: l
Kiểm tra layer để thực hiện lệnh

Bác Quansla ơi. Em test thử với các lệnh khác như : Line, dim....thì không được. mà em thấy bác dùng biến Hplayer ở đây là không chuẩn. e đã thay đổi code như sau thì được ạ.
 
Giải thích: lệnh L là để vẽ pline, nếu tìm thấy layer  thì gán (setvar "clayer" "(HTS)-3-THAY"), nếu không tìm thấy thì...

>>

Bác Quansla ơi. Em test thử với các lệnh khác như : Line, dim....thì không được. mà em thấy bác dùng biến Hplayer ở đây là không chuẩn. e đã thay đổi code như sau thì được ạ.
 
Giải thích: lệnh L là để vẽ pline, nếu tìm thấy layer  thì gán (setvar "clayer" "(HTS)-3-THAY"), nếu không tìm thấy thì mặc định là lấy layer hiện hành, sau đó thực hiện lệnh (command "Pline")

Mình dùng biến HPlayer là do câu hỏi bạn hỏi chưa rõ, mình những tưởng bạn cần mặc định layer dùng để Hatch sau này luôn là (HTS)-3-THAY chứ không nghĩ bạn cần layer dùng để thực hiện mọi lệnhh sau đó là layer (HTS)-3-THAY luôn.

Thử thế này coi.

(defun c:L (/ oldlay )
; Luu lai bien layer hien hanh
(setq oldlay (getvar "clayer"))


;cach 1 dung code IF (tblsearch ....) KQ tra ve "DIM"
(if (tblsearch "layer" "DIM" ) (setvar "clayer" "DIM"))
;cach 2 dung code AND (tblsearch ...) KQ tra ve True (logic)
(and (tblsearch "layer" "DIM" ) (setvar "clayer" "DIM"))


;layer hien hanh thi di nhien khong can doi
;thuc hien lenh
(command ".pline" (while (> (getvar "cmdactive") 0)(command pause)))
(setvar "clayer" oldlay)
(princ))

<<

Filename: 336382_l.lsp
Tác giả: Hung_EL
Bài viết gốc: 416065
Tên lệnh: ctg
Chỉnh Sửa Lisp Để Lisp Lấy Thêm Được Giá Trị Chiều Dài Của *line

 

 

Nhờ a12k39duchao  sửa giúp lisp này do Tue_VN viết nhưng chắc do bận quá ko thấy trả lời.

Lỗi như sau: chuỗi mới bị mất 1 ký tự cuối. Vd: text "Hung:" sử dụng lisp sẽ thành "Hung"

>>

 

 

Nhờ a12k39duchao  sửa giúp lisp này do Tue_VN viết nhưng chắc do bận quá ko thấy trả lời.

Lỗi như sau: chuỗi mới bị mất 1 ký tự cuối. Vd: text "Hung:" sử dụng lisp sẽ thành "Hung"

;;; Mô tả: Lisp dưới dùng để chỉnh định dạng text đã viết về style gốc.

;;;Vd: dùng dùng lisp dưới để đưa text có định dang style X font vtime về font gốc của  style X là vtimeh. Tính năng trên thì ổn rồi

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/19152-sua-dinh-dang-font-trong-mtext/

(defun c:ctg(/ doc sset chuoi vitri)
;copyright by Tue_NV
(setq ss (ssget '((0 . "*TEXT"))))
(vl-load-com)
(setq doc (vla-get-activedocument(vlax-get-acad-object)))
(defun pos (sub st / l1 l2 index)
;Thank Mr Hoanh for this function
(setq index 1
l1 (strlen sub)
l2 (strlen st)
)
(while
(and (<= (+ index l1 -1) l2) (/= sub (substr st index l1)))
(setq index (1+ index))
)
(if (= sub (substr st index l1))
index
nil
)
);;;end defun POS
;;;Main function
(vlax-for x (setq sset (vla-get-activeselectionset doc))
(setq chuoi (vla-get-textstring x))
(setq vitri (1+ (pos ";" chuoi)))
(vla-put-textstring x (substr chuoi vitri (- (strlen chuoi) vitri)))
)
(vla-delete sset)
(princ)
)


http://www.cadviet.com/upfiles/7/160243_ctg.lsp


<<

Filename: 416065_ctg.lsp
Tác giả: Phiphi-
Bài viết gốc: 49241
Tên lệnh: num
Viết Lisp theo yêu cầu
Chưa có ai giúp chắc vì còn Tết.
Lisp num.lsp này cho phép đánh cả Chử + Số +Chử (TD: X1a, X2a, X3a...)
Nếu thêm được vào option để cho phép đánh theo cấp số nhân thì hay hơn (TD: +5m, +10m, +15m...)
Lệnh NUM

Filename: 49241_num.lsp
Tác giả: pdhuy
Bài viết gốc: 6332
Tên lệnh: cd
Kỹ năng nâng cấp lệnh AutoCAD bằng lisp
Mình có 1 lips CD chạy trong cad14 thì được nhưng chạy sang cad 2004-2006 thì không được. Nhờ Nguyên Hoàng và các các bạn giúp với. Có thể các lệnh tại Lips này không tương thích với các cad đời cao sao ?. xin cám ơn diễn đàn!

Filename: 6332_cd.lsp
Tác giả: thiep
Bài viết gốc: 416255
Tên lệnh: ctg
Sửa định dạng font trong MTEXT

Hung_EL: "Lỗi: sau khi dùng lisp chuỗi mất kỹ tự cuối cùng"

Đụng đến Mtext thật không dễ chút nào. Lisp của Tue_NV còn thiếu nhiều trường hợp xảy ra trong Mtext, Thiệp gửi lisp này các bạn xem:

Hung_EL: "Lỗi: sau khi dùng lisp chuỗi mất kỹ tự cuối cùng"

Đụng đến Mtext thật không dễ chút nào. Lisp của Tue_NV còn thiếu nhiều trường hợp xảy ra trong Mtext, Thiệp gửi lisp này các bạn xem:

http://www.cadviet.com/upfiles/7/11110_tra_font_mtext.lsp

(defun acet-mtext-format-bite (str / a f1 n)

(setq a (substr str 1 2)
n 0
)
(cond
((or (= "{" (substr str 1 1))
(= "}" (substr str 1 1))
) ;or
(setq f1 (substr str 1 1)
str (substr str 2)
) ;setq
) ;cond #1
((or (= "\\P" a)
(= "\\~" a)
)
(setq f1 (substr str 1 2)
str (strcat " " (substr str 3))
n -1
)
) ;cond #2
((or (= "\\{" a)
(= "\\}" a)
(= "\\O" a)
(= "\\L" a)
(= "\\S" a)
;(= "\\\\" a)
)
(setq f1 (substr str 1 2)
str (substr str 3)
)
) ;cond #3
((or (= "\\A1" (substr str 1 3))
(= "\\A2" (substr str 1 3))
(= "\\A3" (substr str 1 3))
) ;or
(setq f1 (substr str 1 3)
str (substr str 4)
) ;setq
) ;cond #4
((or (= "\\f" a)
(= "\\C" a)
(= "\\H" a)
(= "\\T" a)
(= "\\Q" a)
(= "\\W" a)
(= "\\p" a)
)
(setq n (acet-str-find ";" str)
f1 (substr str 1 n)
str (substr str (+ n 1))
n 0
) ;setq
) ;cond #6
) ;cond close
(list f1 str n)
) ;defun acet-mtext-format-bite
(defun acet-mtext-format-extract (str / lst raw len pos frmt flst a n j lst2)
(setq lst (list "{" "}" "\\P" "\\~" "\\{"
"\\}" "\\O" "\\L" "\\S" "\\A1"
"\\A2" "\\A3" "\\f" "\\C" "\\H"
"\\T" "\\Q" "\\W" "\\p"
) ;list
raw ""
len (strlen str)
pos 0
) ;setq
(while (> (strlen str) 0)

(setq lst2 (mapcar '(lambda (x) (acet-str-find x str)) lst)
lst2 (mapcar '(lambda (x)
(if x
(list x)
x
)
)
lst2
)
lst2 (apply 'append lst2)
j (apply 'min lst2)
) ;setq
(if (/= j 0)
(progn
(setq raw (strcat raw
(substr str 1 (- j 1))
)
str (substr str j)
a (acet-mtext-format-bite str)
;; (list format str offset)
frmt (car a)
str (cadr a)
n (+ pos j)
pos (+ pos
j
(caddr a)
(- (strlen frmt) 1)
)
frmt (list frmt n)
flst (cons frmt flst)
) ;setq
(setq n (+ (length lst) 10)) ;get out of inner loop
) ;progn
(setq raw (strcat raw str)
str ""
) ;setq then get out
) ;if

) ;while
(list raw (reverse flst))
) ;defun acet-mtext-format-extract
(vl-load-com)
(defun c:ctg (/ doc sset chuoi ch lst Lst_str str_new)
(setq ss (ssget '((0 . "MTEXT"))))
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vlax-for x (setq sset (vla-get-activeselectionset doc))
(setq chuoi (car(acet-mtext-format-extract (vla-get-textstring x))))
(vla-put-textstring x chuoi)
)
(vla-delete sset)
(princ)
)

 

Sorry, lâu ngày vô cadviet nên khi đưa lisp vào nó như vậy


<<

Filename: 416255_ctg.lsp
Tác giả: quansla
Bài viết gốc: 415860
Tên lệnh: 11111
Lisp Chuyển Dim Từ Above Sang Below Và Ngược Lại
Bạn đã cài Experss Tools cad chưa, nếu chưa thì LISP sẽ không chạy, nếu rồi bạn chịu khó sửa lại thêm dòng
(vl-load-com) vào đầu file LISP và Load lại nhé nếu lười thì tải lại líp như sau:
 (defun c:11111(/ obj ss)
  (vl-load-com)
  (if (setq ss (ssget '((0  . "DIM*"))))
    (foreach dt (acet-ss-to-list ss)
      (setq obj (vlax-ename->vla-object dt))
      (if (=...
>>
Bạn đã cài Experss Tools cad chưa, nếu chưa thì LISP sẽ không chạy, nếu rồi bạn chịu khó sửa lại thêm dòng
(vl-load-com) vào đầu file LISP và Load lại nhé nếu lười thì tải lại líp như sau:
 (defun c:11111(/ obj ss)
  (vl-load-com)
  (if (setq ss (ssget '((0  . "DIM*"))))
    (foreach dt (acet-ss-to-list ss)
      (setq obj (vlax-ename->vla-object dt))
      (if (= (vla-get-verticaltextposition obj) 1)
(vla-put-verticaltextposition obj 4)
(vla-put-verticaltextposition obj 1)
)
      )
    )
  (princ)
  )

<<

Filename: 415860_11111.lsp
Tác giả: duy782006
Bài viết gốc: 415723
Tên lệnh: dich
Lập trình phần mềm tự động dịch trong CAD

Mồi 1 cái lisp để người ra đề thử và có yêu cầu cụ thể thêm gì không ở đây tôi chỉ chuẩn bị từ điển nguồn gồm số "10" và số "2" từ điển đích dịch thành "muoi" và "hai".
-Khi dùng sẽ ra 1 đống vấn đề lúc đó thì người ra để sẽ rỏ thêm và ra cái đề đầy đủ cho mọi người giải.
*Hông hiểu sao code hông hiện? Nhấn trả lời thì sẽ lòi ra.

-List từ điển bạn tự...
>>
Mồi 1 cái lisp để người ra đề thử và có yêu cầu cụ thể thêm gì không ở đây tôi chỉ chuẩn bị từ điển nguồn gồm số "10" và số "2" từ điển đích dịch thành "muoi" và "hai".
-Khi dùng sẽ ra 1 đống vấn đề lúc đó thì người ra để sẽ rỏ thêm và ra cái đề đầy đủ cho mọi người giải.
*Hông hiểu sao code hông hiện? Nhấn trả lời thì sẽ lòi ra.

-List từ điển bạn tự nhập thêm trong lisp bằng cách thêm vào:
(setq listnguonchuyenm (list "10" "2"))
(setq listdichchuyenm (list "muoi" "hai"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Thay noi dung 1 doan trong chuoi
;;;Cu phap su dung (duy:s_chuoi>thay chuoigoc noidungcanthay thaythanhnoidung)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:s_chuoi>thay (ndnhap ndsua ndthay / ndnhap ndsua ndthay skt sktd ndnhan ktd)
(setq skt (strlen ndnhap))
(setq sktd (strlen ndsua))
(setq stt 1)
(setq ndnhan "")
(while 
(< stt (+ skt 1))
(cond 
((=  (substr ndnhap stt sktd) ndsua) (setq ktd ndthay) (setq stt (+ stt sktd))) 
((/=  (substr ndnhap stt sktd) ndsua) (setq ktd (substr ndnhap stt 1)) (setq stt (+ stt 1))) 
)
(setq ndnhan (strcat ndnhan ktd))
)
ndnhan)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Thay noi dung chuoi bang list nguon va list dich
;;;Cu phap su dung (duy:s_chuoi>thay chuoigoc noidungcanthay thaythanhnoidung)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:chuyenma (chuoi lstgoc lstthay / chuoi listgoc listthay goc thay)
(mapcar '(lambda(goc thay)(setq chuoi (duy:s_chuoi>thay chuoi goc thay))) lstGoc lstThay)
chuoi)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun c:dich (/ b i N DTMs kqthay)
(command "undo" "be")
(setq listnguonchuyenm (list "10" "2"))
(setq listdichchuyenm (list "muoi" "hai"))
(setq b (ssget (list (cons 0 "*TEXT,DIMENSION"))))
(setq SUMb 0)
(setq i 0)
(setq N (sslength b))
(while (< i N)
(setq kqthay (duy:chuyenmatong (cdr (assoc 1 (entget (ssname b i))))  listnguonchuyenm listdichchuyenm)) 
(setq DTMs (subst (cons 1 kqthay) (assoc 1 (entget (ssname b i))) (entget (ssname b i))))
(entmod DTMs)

(setq i (1+ i))
)
(command "undo" "end")
(Princ)) 

<<

Filename: 415723_dich.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 216029
Tên lệnh: ha
Đố vui với LISP

Mới mới đố chứ cũ đố mần chi! :lol:
Gởi bác LSP+DCL để test cho lẹ. Bác có thể thay đổi để ra 4 tổ hợp.

Filename: 216029_ha.lsp
Tác giả: nhoclangbac
Bài viết gốc: 363401
Tên lệnh: dileader dil diledit
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Các bác cho em hỏi, khi entmake Mleader thì làm sao để user Block (ở content) hiện hành ạ? Mtext thì ok, nhưng block thì phải vào lại mleaderstyle để chọn lại blk (kể cả block của CAD). Mong các bác chỉ giáo!

Nhoc có sưu tầm lisp này, anh

Các bác cho em hỏi, khi entmake Mleader thì làm sao để user Block (ở content) hiện hành ạ? Mtext thì ok, nhưng block thì phải vào lại mleaderstyle để chọn lại blk (kể cả block của CAD). Mong các bác chỉ giáo!

Nhoc có sưu tầm lisp này, anh quocmanh04tt có mót ji thì mót nhé :P

(princ "\nDILEADER (DIL) v. 1.2 by Andrea Andreetti -Loaded-")
(defun c:DILEADER () (C:DIL)) (vl-load-com)
(defun c:DIL (/ Llead Ltext MainDLactive DQobject DragMess PointMethod ASPoint
DQLcursorPosition OKaccept Ltext Input DLactive DL_textsize VLAo DXItemHandle 
DQL_llpoint DQL_urpoint cen)
(setq DL_textsize (getvar "DIMTXT")) (setvar "CMDECHO" 0)
(while (not DQobject) (setq DQobject (nentsel "\nSelect Object...")))
(if DQobject (progn (princ "\nPick Text location...")
(DleaderWhile nil (vlax-ename->vla-object (car DQobject)) nil)
(while (and (/= (car input) 25)		;RIGHT CLICK
(/= (car input) 11) (/= (car input) 12) (/= (car input) 3)		;LEFT CLICK
(not (and (= (car input) 2) (= (cadr input) 32))) ;ESCAPE
(not (and (= (car input) 2) (= (cadr input) 13)))	) ;ENTER
(DleaderWhile nil (vlax-ename->vla-object (car DQobject)) nil)	)))
(princ "\nDleader Finish.") (princ))
;;DLEADER While Loop;;
(defun DleaderWhile (nnn VLAo Lleadprop	/ NewMod Ltext) 
;TEXTEname;VLAobject;LeaderPropreties
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
(setq DXItemHandle (vla-get-Handle VLAo)) (Setq DLactive T)
(while (and DLactive (setq input (grread t 4 4))
(or (= (car input) 5) (= (car input) 3))	) ;Cursor;PickPoint
(if (= (car input) 5) (setq DQLcursorPosition (cadr input)))
(if (and VLAo DQLcursorPosition)
(DLEADER_C&M_OBJECT DQLcursorPosition nnn VLAo cen Lleadprop)	)
(if (= (car input) 3) (progn (setq DLactive nil) (if (and Ltext (not nnn))
(command "._MTEDIT" (cdar (entmod (subst (cons 1 "") (assoc 1 (entget Ltext)) (entget Ltext)))))	)))) ;while
(if (and Ltext DXLeaderHandle DXItemHandle)
(DLEADERPUTXDATA Ltext "DLEADER_TEXT"
(vl-prin1-to-string (list DXLeaderHandle DXItemHandle))	))
(if (and NewMod DXLeaderHandle DXItemHandle)
(DLEADERPUTXDATA NewMod "DLEADER_TEXT"
(vl-prin1-to-string (list DXLeaderHandle DXItemHandle))	))
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
(setq DLactive nil)	)
;;DLEADER While Loop ;;DLEADER UPDATE for REACTOR
(defun Dleader_Updated_By_reactor (cursp cenpoint Lleadprop TXTobj)
(setq int (vlax-curve-getClosestPointTo VLAo cursp))
(setq DL_textsize (vla-get-Height (vlax-ename->vla-object TXTobj)))
(if (and int Lleadprop) (progn (if (> (car cursp) (car int))
(setq v71 1 co1 (list (- (car cursp) DL_textsize) (- (nth 1 cursp) (/ DL_textsize 2))
(nth 2 cursp)) co2 (list (- (car cursp) (/ DL_textsize 3)) (- (nth 1 cursp) (/ DL_textsize 2))
(nth 2 cursp)) LR 1)
(setq v71 3 co1 (list (+ (car cursp) DL_textsize) (- (nth 1 cursp) (/ DL_textsize 2)) 
(nth 2 cursp)) co2 (list (+ (car cursp) (/ DL_textsize 3)) (- (nth 1 cursp) (/ DL_textsize 2)) 
(nth 2 cursp)) LR 3)	)
(repeat 3 (setq Lleadprop (vl-remove (assoc 10 Lleadprop) Lleadprop)))
(setq Lleadprop (entmod (append Lleadprop (list (cons 10 int)) (list (cons 10 co1)) 
(list (cons 10 co2)) )))
(setq Llead (cdar (entmod (subst (cons 71 v71) (assoc 71 Lleadprop) Lleadprop))))
(setq TXTobjdata (entget TXTobj))
(setq Ltext (cdar (entmod (subst (cons 71 LR) (assoc 71 TXTobjdata) TXTobjdata))))
(setq DXLeaderHandle (cdr (assoc 5 (entget Llead)))) (setq int nil Lleadprop nil)	)))
;;DLEADER UPDATE for REACTOR;;DLEADER CREATE & MODIFY OBJECT
(defun DLEADER_C&M_OBJECT (cursp DLtext VLAo cenpoint Lleadprop / FicLine)
(setq int (vlax-curve-getClosestPointTo VLAo cursp))   
;;Create Mtext
(if Ltext (progn (command "._erase" Ltext "") (setq Ltext nil)))
(if (> (car cursp) (car int)) (setq v71 1
co1 (list (- (car cursp) DL_textsize) (- (nth 1 cursp) (/ DL_textsize 2))(nth 2 cursp))
co2 (list (- (car cursp) (/ DL_textsize 3)) (- (nth 1 cursp) (/ DL_textsize 2)) (nth 2 cursp)) )
(setq v71 3
co1 (list (+ (car cursp) DL_textsize) (- (nth 1 cursp) (/ DL_textsize 2)) (nth 2 cursp))
co2 (list (+ (car cursp) (/ DL_textsize 3)) (- (nth 1 cursp) (/ DL_textsize 2)) (nth 2 cursp)) ))  
(if (and int (not DLtext)) (progn
(setq Ltext (entmakex (list (cons 0 "MTEXT") (cons 100 "AcDbEntity")
(cons 100 "AcDbMText") (cons 1 "NOTE") (cons 10 cursp) (cons 40 DL_textsize)
(cons 50 0.0) (cons 71 v71) (cons 72 5))))	))
(if (and int DLtext) (progn
(setq NewMod (entmod(subst (cons 10 cursp)(assoc 10 DLtext) DLtext)))
(setq NewMod (cdar (entmod (subst (cons 71 v71)(assoc 71 NewMod) NewMod))))	))
;;Create Leader
(if (and int (not Lleadprop)) (progn
(if Llead (progn (command "._erase" Llead "") (setq Llead nil)))
(setq Llead (entmakex (list (cons 0 "LEADER") (cons 100 "AcDbEntity")
(cons 100 "AcDbLeader")	(cons 10 int) (cons 10 co1) (cons 10 co2))))
(vla-put-ArrowheadSize (vlax-ename->vla-object Llead) (getvar "DIMASZ"))
(setq DXLeaderHandle (cdr (assoc 5 (entget Llead))))	))  
(if (and int Lleadprop) (progn
(repeat 3 (setq Lleadprop (vl-remove (assoc 10 Lleadprop) Lleadprop)))
(setq Lleadprop (entmod (append Lleadprop (list (cons 10 int)) (list (cons 10 co1)) 
(list (cons 10 co2)) )))
(setq Llead (cdar (entmod (subst (cons 71 v71)(assoc 71 Lleadprop) Lleadprop))))
(setq DXLeaderHandle (cdr (assoc 5 (entget Llead))))	)) )
;;DLEADER CREATE & MODIFY OBJECT;;X D A T A;;
(defun DLEADERPUTXDATA (item xdataname tag / ent type1 valeur)
(setq ent (vlax-ename->vla-object item) type1 (vlax-make-safearray vlax-vbInteger 
(cons 0 1)) Valeur (vlax-make-safearray vlax-vbVariant (cons 0 1)))
(vlax-safearray-put-element type1 0 1001) 
(vlax-safearray-put-element valeur 0 xdataname)
(vlax-safearray-put-element type1 1 1000) (vlax-safearray-put-element valeur 1 tag)
(setq type1  (vlax-make-variant type1) valeur (vlax-make-variant valeur))
(vla-setxdata ent type1 valeur) )
;;X D A T A;;E D I T O R;;
(defun c:DILEDIT (/ sbs Llead Lleadprop vla-QDLitem LtextData valeur type1 Ltexti 
FLtext ent)
(setq sbs nil) (while (not sbs)
(setq Ltexti (nentsel "\nSelect TEXT Object..."))
(if Ltexti (progn (setq ent (vlax-ename->vla-object (setq FLtext (car Ltexti))))
(vla-getxdata ent "DLEADER_TEXT" 'type1 'valeur)
(if valeur (setq sbs (vlax-variant-value (nth 1 (vlax-safearray->list valeur)))))	)))
(if sbs (progn (setq DL_textsize (vla-get-Height (vlax-ename->vla-object FLtext)))
(setq LtextData (entget FLtext)) (setq Llead (handent (car (read sbs))))
(setq Lleadprop (entget Llead))
(setq vla-QDLitem (vlax-ename->vla-object (handent (cadr (read sbs)))))
(DleaderWhile (entget FLtext) vla-QDLitem Lleadprop)	)))
;R E A C T O R S
(defun Dleader_ObjectWasEdited (/ DLobj DLobj_data Llead)
(setq DLobj (cadr (ssgetfirst)))
(if DLobj (progn (setq DLobj (ssname DLobj 0)) (setvar "CMDECHO" 0)
(setq DLobj_data (entget DLobj)) (setq DLobj_5 (cdr (assoc 5 DLobj_data)))
(setq VLAo (vlax-ename->vla-object DLobj)) (if VLAo (progn
(vla-getboundingbox VLAo 'x 'y) (setq DQL_llpoint (vlax-safearray->list x))
(setq DQL_urpoint (vlax-safearray->list y))
(setq cen (polar DQL_llpoint (angle DQL_llpoint DQL_urpoint)
(/ (distance DQL_llpoint DQL_urpoint) 2)))
(setq cen (list (nth 0 cen) (nth 1 cen) (getvar "ELEVATION")))	))
(setq DLallText (ssget "X" '((0 . "MTEXT") (100 . "AcDbMText") (-3 ("DLEADER_TEXT") )))) (if DLallText (progn
(setq sscount (sslength DLallText)) (setq val1 (- sscount 1))
(repeat sscount (setq ent (vlax-ename->vla-object (ssname DLallText val1)))
(Setq cursp (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint ent))))
(vla-getxdata ent "DLEADER_TEXT" 'type1 'valeur)
(setq sbs (vlax-variant-value (nth 1 (vlax-safearray->list valeur))))
(setq Llead (handent (car (read sbs)))) (setq ObjHandle (cadr (read sbs)))
(if (and Llead (eq ObjHandle DLobj_5))
(Dleader_Updated_By_reactor cursp cen (entget Llead) (ssname DLallText val1))	)
(setq val1 (1- val1))	))))))
;;Reactor on ended MOVE
(defun *Dleader_object_Modification* (call-reactor scI /)
(if (member (car scI) (list "GRIP_MOVE" "GRIP_STRETCH" "GRIP_SCALE" 
"GRIP_ROTATE")) (Dleader_ObjectWasEdited)	)) ;;;;;
(defun DLEADER_run_reac ()
(if Dleader_object_Modification (progn (vlr-remove Dleader_object_Modification)
(setq Dleader_object_Modification nil)	))
(setq Dleader_object_Modification (vlr-command-reactor nil
'((:vlr-commandEnded . *Dleader_object_Modification*))	))) ;;;;;
(DLEADER_run_reac)


<<

Filename: 363401_dileader_dil_diledit.lsp
Tác giả: ketxu
Bài viết gốc: 416549
Tên lệnh: p1
Vẽ Đường Pl Có Điểm Nút Là Đường Tròn Có Bán Kính Được Định Trước

Quick code, số 2 vẫn là số e phải sửa. 
A để những đối tượng này vào một group, nếu muốn liền hoặc rời thì sử dụng tổ hợp phím Ctrl + Shift + A để bật/ tắt chế độ Group

(defun c:p1(/ e e1 s)
	(setq e (entlast) s (ssadd))
	(command ".pline") (while (/= (getvar 'cmdactive) 0) (command pause))
	(and
		(setq e1 (entlast))
		(not (equal e e1))
		(mapcar '(lambda(x)(entmake (list (cons 0...
>>

Quick code, số 2 vẫn là số e phải sửa. 
A để những đối tượng này vào một group, nếu muốn liền hoặc rời thì sử dụng tổ hợp phím Ctrl + Shift + A để bật/ tắt chế độ Group

(defun c:p1(/ e e1 s)
	(setq e (entlast) s (ssadd))
	(command ".pline") (while (/= (getvar 'cmdactive) 0) (command pause))
	(and
		(setq e1 (entlast))
		(not (equal e e1))
		(mapcar '(lambda(x)(entmake (list (cons 0 "CIRCLE")(cons 40 2)(cons 10 (cdr x))))) (vl-remove-if-not '(lambda(a)(= (car a) 10)) (entget e1)))
	)
(while (setq e (entnext e))
	(ssadd e s)
)
(command "-group" "_Create" "*" "" s "")
)

<<

Filename: 416549_p1.lsp
Tác giả: Bee
Bài viết gốc: 416619
Tên lệnh: kc1
lisp đo khoảng cách dán bào block att

Em xin chào cả nhà e là thành viên mới của diễn đàn, e có việc này muốn nhờ các cao nhân giúp đỡ, nói thật lisp e chỉ biết sử dụng thôi chứ còn viết chép gì thì chịu thua, e có tải  lisp của bác DOAN VAN HA về lisp lấy...

>>

Em xin chào cả nhà e là thành viên mới của diễn đàn, e có việc này muốn nhờ các cao nhân giúp đỡ, nói thật lisp e chỉ biết sử dụng thôi chứ còn viết chép gì thì chịu thua, e có tải  lisp của bác DOAN VAN HA về lisp lấy khoảng cách giữa 2 điểm rồi chèn vào block att .Tuy nhiên em muốn mấy a đặt biệt là bác Ha giúp e viết lại đoạn code giúp e: "Lấy khoảng cách tổng của nhiều điểm P1,P2, P3, Pn bằng cách pick chuột, lấy kết quả theo hệ mét chèn vào block att. Rất mong mọi người giúp đỡ e, e cảm ơn.http://www.cadviet.com/upfiles/7/160653_lay_khcach_chen_vao_attkc_1.lsp

Sửa nhanh chút thôi ^_^

(defun C:KC1 (/ p lst_p sum ent data obj tag lst len)

  (vl-load-com)

  (setq lst_p nil sum 0)

  (while (setq p (getpoint "\nChon diem : "))
    (setq lst_p (cons p lst_p))
  )
  (setq sum (apply '+ (mapcar 'distance lst_p (cdr lst_p))))

  (setq ent (nentsel "\nChon Attribute: "))

  (setq	obj (vlax-ename->vla-object
	      (cdr (assoc 330 (setq data (entget (car ent)))))
	    )
  )
  (setq tag (cdr (assoc 2 data)))

  (setq lst (list (cons tag (setq len (strcat (rtos (/ sum 1000.) 2 0) " m.")))))

  (foreach att (setq atts (vlax-safearray->list
			    (vlax-variant-value (vla-getattributes obj))
			  )
	       )

    (if	(= (vla-get-tagstring att) tag)

      (vla-put-textstring att len)
    )
  )

  (vla-update obj)
)

<<

Filename: 416619_kc1.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 416531
Tên lệnh: p2
Vẽ Đường Pl Có Điểm Nút Là Đường Tròn Có Bán Kính Được Định Trước

Giải pháp là cuộn Pline tại các đỉnh thành các đường tròn.

 
Để khẳng định điều nói trên. Chạy thử:

(defun c:p2 ()
(entmake '((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 1)
(100 . "AcDbPolyline")
(90 . 17)
(70 . 0)
(43 . 0.0)
(38 ....

>>

Giải pháp là cuộn Pline tại các đỉnh thành các đường tròn.

 
Để khẳng định điều nói trên. Chạy thử:

(defun c:p2 ()
(entmake '((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 1)
(100 . "AcDbPolyline")
(90 . 17)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 254.464 206.656)
(40 . 0.0)
(41 . 0.0)
(42 . -1.2303)
(91 . 0)
(10 250.631 205.856)
(40 . 0.0)
(41 . 0.0)
(42 . -0.812807)
(91 . 0)
(10 254.464 206.656)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 252.631 205.856)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 298.757 225.991)
(40 . 0.0)
(41 . 0.0)
(42 . 0.540215)
(91 . 0)
(10 302.055 225.43)
(40 . 0.0)
(41 . 0.0)
(42 . 1.85112)
(91 . 0)
(10 298.757 225.991)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 300.59 226.791)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 324.163 204.883)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 322.698 206.245)
(40 . 0.0)
(41 . 0.0)
(42 . 1.64675)
(91 . 0)
(10 326.12 205.3)
(40 . 0.0)
(41 . 0.0)
(42 . 0.607257)
(91 . 0)
(10 322.698 206.245)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 324.163 204.883)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 363.786 213.322)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 361.83 212.905)
(40 . 0.0)
(41 . 0.0)
(42 . -2.05449)
(91 . 0)
(10 364.657 211.522)
(40 . 0.0)
(41 . 0.0)
(42 . -0.486738)
(91 . 0)
(10 361.83 212.905)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(210 0.0 0.0 1.0)))
(princ))

P/s: Vấn đề còn lại là Code. Ket tiếp tục đê...! Giúp thì giúp cho trót...  :D 


<<

Filename: 416531_p2.lsp
Tác giả: ketxu
Bài viết gốc: 416521
Tên lệnh: p1
Vẽ Đường Pl Có Điểm Nút Là Đường Tròn Có Bán Kính Được Định Trước
(defun c:p1(/ e e1)
	(setq e (entlast))
	(command ".pline") (while (/= (getvar 'cmdactive) 0) (command pause))
	(and
		(setq e1 (entlast))
		(not (equal e e1))
		(mapcar '(lambda(x)(entmake (list (cons 0 "CIRCLE")(cons 40 2)(cons 10 (cdr x))))) (vl-remove-if-not '(lambda(a)(= (car a) 10)) (entget e1)))
	)
) 

Quick code. Số 2 đằng sau số 40 là cái bạn cần chỉnh


Filename: 416521_p1.lsp
Tác giả: Bee
Bài viết gốc: 416656
Tên lệnh: kc1
lisp đo khoảng cách dán bào block att

p/S Do công việc tính chiều dài dây điện, với lisp của bác BEE trên thì tính tổng được chiều dài dây trên mặt bằng rất ok, hic còn trên mặt đứng nữa. Vậy đã nhờ bác BEE rồi thì e nhờ bác 1 lần nữa bác giúp e sửa lisp 1 chút. Bác thêm một dòng lệnh là "Nhập thêm hằng số cộng vào tổng:" sau khi...

>>

p/S Do công việc tính chiều dài dây điện, với lisp của bác BEE trên thì tính tổng được chiều dài dây trên mặt bằng rất ok, hic còn trên mặt đứng nữa. Vậy đã nhờ bác BEE rồi thì e nhờ bác 1 lần nữa bác giúp e sửa lisp 1 chút. Bác thêm một dòng lệnh là "Nhập thêm hằng số cộng vào tổng:" sau khi chọn pick điểm xong, để cộng thêm hằng số đó vào cái tổng chiều dài trên. Như vậy chiều dài dây từ bảng điện lên tới đèn mới giải quyết được. mong bác ra tay giúp e xin chân thành cảm ơn.

Ok mình sửa nhanh nên ko lằng nhằng các trường hợp khác. Nhập thêm hằng số theo hệ mm nhé. ^_^

(defun C:KC1 (/ p lst_p sum d ent data obj tag lst len)

  (vl-load-com)

  (setq lst_p nil sum 0)

  (while (setq p (getpoint "\nChon diem : "))
    (setq lst_p (cons p lst_p))
  )
  
  (setq sum (apply '+ (mapcar 'distance lst_p (cdr lst_p))))
  
  (setq d (getreal "\nNhap them hang so cong vao tong:"))
  
  (setq sum (+ sum d))
	 
  (setq ent (nentsel "\nChon Attribute: "))

  (setq	obj (vlax-ename->vla-object
	      (cdr (assoc 330 (setq data (entget (car ent)))))
	    )
  )
  (setq tag (cdr (assoc 2 data)))

  (setq lst (list (cons tag (setq len (strcat (rtos (/ sum 1000.) 2 0) " m.")))))

  (foreach att (setq atts (vlax-safearray->list
			    (vlax-variant-value (vla-getattributes obj))
			  )
	       )

    (if	(= (vla-get-tagstring att) tag)

      (vla-put-textstring att len)
    )
  )

  (vla-update obj)
)

<<

Filename: 416656_kc1.lsp
Tác giả: ssg
Bài viết gốc: 5747
Tên lệnh: ref
Tác giả: hsoso
Bài viết gốc: 245
Tên lệnh: cd cd
Lisp Cut dim, cut hatch, align it
Sau khi tìm hiểu, mình đã tìm được cái này trên diễn đàn.
 
Lisp cắt Dim.
 
Cách dùng:
- Sau khi upload, dùng lệnh CD.
- click điểm 1 để chọn vị trí cắt chân Dim,
- click điểm 2 để chọn vị trí cắt đường Dim.
 
Nếu không muốn cắt chân Dim hoặc đường Dim thì nhấn phím dấu cách.
 

(defun c:cd (/ entdt dcat1 dcat2 sodimsua index sodt ssdt tt)
  (defun cdim...
>>
Sau khi tìm hiểu, mình đã tìm được cái này trên diễn đàn.
 
Lisp cắt Dim.
 
Cách dùng:
- Sau khi upload, dùng lệnh CD.
- click điểm 1 để chọn vị trí cắt chân Dim,
- click điểm 2 để chọn vị trí cắt đường Dim.
 
Nếu không muốn cắt chân Dim hoặc đường Dim thì nhấn phím dấu cách.
 

(defun c:cd (/ entdt dcat1 dcat2 sodimsua index sodt ssdt tt)
  (defun cdim (entdt    pchan     pduong      /       tt        old10
           old13    old14     new10      new13       new14    p10n
           p13n    p14n     p10o      p13o       p14o        gocduong
           gocchan    pchanb     pduongb loaidim
          )
    (defun chanvuonggoc    (ph p1 p2 / ptemp pkq goc)
      (setq
    goc   (+ (angle p1 p2) (/ pi 2.0))
    ptemp (polar ph goc 1000.0)
    pkq   (inters ph ptemp p1 p2 nil)
      )
      pkq
    )
    (setq
      tt       (entget entdt)
      old10    (assoc '10 tt)
      old13    (assoc '13 tt)
      old14    (assoc '14 tt)
      p10o     (cdr old10)
      p13o     (cdr old13)
      p14o     (cdr old14)
      loaidim  (logand (cdr (assoc '70 tt)) 7)
      gocduong (cond
         ((= loaidim 1) (angle p13o p14o))
         ((= loaidim 0) (cdr (assoc '50 tt)))
         (t nil)
           )
      pchan (cond
          (pchan (list (car pchan) (cadr pchan) 0.0))
          (t pchan)
        )
      pduong (cond
          (pduong (list (car pduong) (cadr pduong) 0.0))
          (t pduong)
        )
      
    )
    (if    gocduong
      (progn
    (if pchan
      (setq
        pchanb (polar pchan gocduong 1000.0)
        p13n   (chanvuonggoc (list (car p13o) (cadr p13o) 0.0) pchan pchanb)
        p14n   (chanvuonggoc (list (car p14o) (cadr p14o) 0.0) pchan pchanb)
        new13  (cons 13 p13n)
        new14  (cons 14 p14n)
        tt       (subst new13 old13 tt)
        tt       (subst new14 old14 tt)
      )
    )
    (if pduong
      (setq
        pduongb (polar pduong gocduong 1000.0)
        p10n    (chanvuonggoc (list (car p10o) (cadr p10o) 0.0) pduong pduongb)
        new10   (cons 10 p10n)
        tt        (subst new10 old10 tt)
      )
    )
    (entmod tt)
      )
    )
    gocduong
  )

 
  (setq    ssdt     (ssget '((0 . "DIMENSION")))
    dcat1     (getpoint "\nDiem cat chan DIM: ")
    dcat2     (getpoint "\nDiem cat duong DIM: ")
        
    dcat1    (cond
           (dcat1 (trans dcat1 1 0))
           (t nil)
         )
    dcat2    (cond
           (dcat2 (trans dcat2 1 0))
           (t nil)
         )    
    sodt     (sslength ssdt)
    index     0
    sodimsua 0
  )
  (repeat sodt
    (setq entdt    (ssname ssdt index)
      index    (1+ index)
      tt    (entget entdt)

    )
    (if    (cdim entdt dcat1 dcat2)
      (setq sodimsua (1+ sodimsua))
    )
  )
  (princ (strcat "\nSo duong dim da sua: " (itoa sodimsua)))
 
)

<<

Filename: 245_cd_cd.lsp
Tác giả: nguyenducloi89
Bài viết gốc: 416869
Tên lệnh: trichthua
Cắt Đối Tượng Trong Khung

Lệnh EXTRIM (có cài Express).

;; free lisp from cadviet.com

;;;-----------------------

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

Lệnh EXTRIM (có cài Express).

;; free lisp from cadviet.com

;;;-----------------------

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

				)

		       )

		  )

		(; 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

;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))

;; ver 2.0 fix

					(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

	(foreach obj2brk masterlist

	  (break_obj (car obj2brk) (cdr obj2brk))

	)

      )

    )

  )

);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:trichthua (/ ss p2 encur lstss1 emin emax p3 LenssBR)
  (vl-load-com)	

  (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))

	*Model*	(vla-get-ModelSpace ActDoc)

  )

  (vla-StartUndoMark ActDoc)

  (setq	a (getreal "\n Nhap kich thuoc chieu dai: "))

  (setq	b (getreal "\n Nhap kich thuoc chieu rong "))

  (setq	emin (list (car (getvar "extmin")) (cadr (getvar "extmin"))))

  (setvar "cecolor" "104")

  (setq	lstp (list (car emin)

		   (cadr emin)

		   (+ (car emin) a)

		   (cadr emin)

		   (+ (car emin) a)

		   (+ (cadr emin) B)

		   (car emin)

		   (+ (cadr emin) B)

	     )

  )

  (vla-put-closed (LWP lstp *Model*) :vlax-True)

  (setq ss (ssadd (entlast) (ssadd)))

  (setq	p2 (ACET-SS-DRAG-MOVE

	     ss

	     (list (car emin) (cadr emin))

	     "Chon vi tri bat dau trich thua: "

	   )

  )

  (command ".move" ss "" emin 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 encur (ssname (ssget "X" '((62 . 104))) 0))

  (setq	lstobj1	(vl-remove encur (gettouching encur))

	ss	(acet-list-to-ss lstobj1)

  )

  (acet-ss-zoom-extents ss)

  (break_with  lstobj1 encur)

  (vlax-invoke-method ActDoc 'Regen acActiveViewport)

  (vla-offset (vlax-ename->vla-object encur) (* (getvar "viewsize") 0.002))

  (setq lst3 (acet-geom-vertex-list (entlast)))

  (entdel (entlast))

  (setq	LenssBR	(SS-enlst (ssget "F" lst3)))

  (foreach x LenssBR

    (if	(or (not (eq (dxf 0 x) "TEXT"))

	    (not (eq (dxf 0 x) "MTEXT"))

	)

      (entdel x)

    )

  )

  (vla-EndUndoMark ActDoc)
  (princ "\nChuc cac ban gat hai nhieu thanh cong. Thiep")

)

Mình muốn cắt như code của anh Duân, nhưng mà sẽ là select object vào một cái khung rồi cắt theo khung. Pro nào giúp được không nhỉ.


<<

Filename: 416869_trichthua.lsp

Trang 218/330

218