Jump to content
InfoFile
Tác giả: tuvanthietke.hcm
Bài viết gốc: 91248
Tên lệnh: vlc
Vẽ các đường line và góc mà không cần góc hợp với phương ngang

Cho đoạn thẳng AB nghiêng với trục Ox góc a (a khác 0) . Dùng lệnh Line để vẽ đoạn thẳng AC hợp với AB 1 góc 75 độ hay góc BAC bằng 75 độ giống như...
>>
Cho đoạn thẳng AB nghiêng với trục Ox góc a (a khác 0) . Dùng lệnh Line để vẽ đoạn thẳng AC hợp với AB 1 góc 75 độ hay góc BAC bằng 75 độ giống như hình vẽ trên : BA=30; AC=90, góc BAC= 75 độ.

 

Command: L :-> gõ L

LINE Specify first point: -> pick điểm đầu tiên của Line cần vẽ-> Đó chính là điểm A

Specify next point or : 'cal -> gõ 'cal

>>>> Expression: rot(pldee(90),@,-75) -> gõ rot(pldee(90),@,-75)

>>>> Select one endpoint for PLDEE: Kích chọn điểm B

>>>> Select another endpoint for PLDEE: Kích chọn điểm A

 

Resuming LINE command.

-> Xong

-> Cách trên nếu sử dụng thuần thục thì rất nhanh :D

 

Lệnh này mình không hề biết tới! nên không hiểu ý nghĩa của nó lắm

 

Mình làm theo bạn và đây là kết quả đã thử lại 3 lần, không giống kết quả mong muốn

 

LT0.8662221_1_1.png

 

 

Chào bạn tuvanthietke.hcm,

Theo cái sự biết của mình thì trong cad không có lệnh nào trực tiếp để làm cái việc bạn muốn cả. Để thực hiện điều này, bắt buộc bạn phải dùng kết hợp lệnh line và lệnh ucs như bạn đã nói. Mình gửi bạn một đoạn lisp có thể giúp bạn làm điều này dễ dàng hơn một chút. Lệnh lisp là vlc.

(defun c:vlc ()
(command "undo" "be")
(setq p1 (getpoint "\n Chon diem dau"))
(command "line" p1 pause "")
(setq ln (entlast)
p2 (cdr(assoc 11 (entget ln)))
ans (getstring "\n Ban muon tiep tuc < y or n> : ")
)
(while (= ans "y")
(command "ucs" "n" "ob" ln)
(setq d (getreal "\n Nhap khoang cach: ")
gd (getreal "\n Nhap goc tuong doi theo do: ")
p1 p2
p1 (trans p1 0 1))
(command "line" p1 (setq p2 (polar p1 (/ (* pi gd) 180) d)) "")
(setq ln (entlast)
p2 (trans p2 1 0)
ans (getstring "\n Ban muon tiep tuc < y or n> : ")
)
)
(command "ucs" "w")
(command "undo" "e")
)

 

Khi chạy lisp, bạn sẽ chọn điểm bắt đầu của đoạn thẳng đầu tiên, sau đó bạn sẽ nhập điểm thứ hai theo các cách mà Cad chấp nhận như pick điểm, nhập tọa độ điểm tương đối hay tuyệt đối...... Lisp sẽ tạo đoạn thẳng đầu tiên rồi hỏi bạn có muốn tiếp tục hay không.

Nếu bạn trả lời "y" lisp sẽ yêu cầu bạn nhập khoảng cách và góc tạo với đoạn thẳng trước tính theo độ. (Bạn lưu ý rằng góc này đươc tình theo chiều dương của đoạn thẳng kề trước đoạn sẽ vẽ) và lisp sẽ tạo tiếp đoạn thẳng này.

Cứ thế cho tới khi bạn không muốn vẽ nữa và trả lời "n" khi lisp hỏi (hoặc nhấn ENTER)

 

Bạn dùng thử và cho ý kiến nhé. Nếu cần thiết mình sẽ sửa thêm cho phù hợp với yêu cầu của bạn.

Chúc bạn vui.

 

À về lisp này thì mình mù tịt, mình không có căn bản, bạn có thể gợi ý làm sao hiểu được nó và vận dụng nó không???


<<

Filename: 91248_vlc.lsp
Tác giả: gia_bach
Bài viết gốc: 325107
Tên lệnh: ha2
Lisp đổi tên hàng loạt Layouts!

 

Lisp đổi tên tất cả layout thành các số nguyên từ 1 đến n...

>>

 

Lisp đổi tên tất cả layout thành các số nguyên từ 1 đến n và thêm tiền tố chung.

 

;Doan Van Ha - CADViet.com - Ngay 04/12/2014
;Chuc nang: Thay doi ten tat ca layouts va them tien to, tu: HA-1->HA--2->HA-3...HA-n
(defun C:HA2(/ acdoc aclay actab i)
 (vl-load-com)
 (setq tto (getstring "\nTien to chung cua cac layouts: ")) 
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
       actab (strcase (getvar 'CTAB)))
 (vlax-for l (vla-get-layouts acdoc)
  (if (not (eq actab (strcase (vla-get-name l))))
   (setq aclay (cons (cons (vla-get-name l) l) aclay))))
 (setq aclay (vl-sort aclay '(lambda(a b) (< (vla-get-taborder (cdr a)) (vla-get-taborder (cdr b))))))
 (setq i 100000000)
 (foreach n aclay
  (vla-put-name (cdr n) (itoa (setq i (1+ i))))
  (vlax-release-object (cdr n)))
 (setq aclay nil)
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
       actab (strcase (getvar 'CTAB)))
 (vlax-for l (vla-get-layouts acdoc)
  (if (not (eq actab (strcase (vla-get-name l))))
   (setq aclay (cons (cons (vla-get-name l) l) aclay))))
 (setq aclay (vl-sort aclay '(lambda(a b) (< (vla-get-taborder (cdr a)) (vla-get-taborder (cdr b))))))
 (setq i 0)
 (foreach n aclay
  (vla-put-name (cdr n) (strcat tto (itoa (setq i (1+ i)))))
  (vlax-release-object (cdr n)))
 (princ))
 
 

Bác bổ sung thêm 1 số ràng buộc để Lisp chạy ngon hơn.

 1. Nhắc user chuyển qua Model trước khi gọi Lisp (bị lỗi khi đang ở Layout)

 2. Kiểm tra Tiền tố hợp lệ với SnValid (tránh t/h user nhập các kí tự đặc biệt )

 3. Hiếm có, nhưng vẫn có thể xảy ra t/hợp tồn tại 1 Layout có tên là số 1 trăm triệu lẻ ....


<<

Filename: 325107_ha2.lsp
Tác giả: hailuavnn
Bài viết gốc: 104454
Tên lệnh: od oc oca
Đánh số thứ tự cho text thuộc tính!
Bạn có thể dùng lisp này

 
(defun etype (e);;;Entity Type
;; free lisp from cadviet.com

;;;**********************************************
;;;CHUONG TRINH DANH SO...
>>
Bạn có thể dùng lisp này

 
(defun etype (e);;;Entity Type
;; free lisp from cadviet.com

;;;**********************************************
;;;CHUONG TRINH DANH SO THU TU VA COPY TANG DAN
;;;1. Lenh OD: danh so thu tu, tuy chon so bat dau (begin) va so gia (increment) tuy y
;;;2. Lenh OC: copy tang dan tu mot so thu tu co san
;;;3. Lenh OCA: copy tang dan voi doi tuong Attribute Block
;;;Chuong trinh chap nhan cac dinh dang bang so, chu, so va chu ket hop:
;;;1, 2... A, B..., A1, A2..., AB-01, AB-02..., AB-01-C1, AB-01-C2...
;;;Cac chu gioi han trong khoang tu A den Z. Cac so khong han che
;;;Copyright by ssg - www.cadviet.com - December 2008
;;;**********************************************
;;;-------------------------------------------------
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------
(defun wtxt (txt p / sty d h);;;Write txt on graphic screen, defaul setting
(setq
sty (getvar "textstyle")
d (tblsearch "style" sty)
h (cdr (assoc 40 d))
)
(if (= h 0) (setq h (cdr (assoc 42 d))))
(entmake
(list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 40 h) (assoc 41 d))
)
)
;;;-------------------------------------------------
(defun incN (n dn / n2 i n1);;;Increase number n
(setq
n2 (itoa (+ dn (atoi n)))
i (- (strlen n) (strlen n2))
)
(if (> i 0) (setq n1 (substr n 1 i)) (setq n1 ""))
(strcat n1 n2)
)
;;;-------------------------------------------------
(defun incC (c / i c1 c2);;;Increase character c
(setq
i (strlen c)
c1 (substr c 1 (- i 1))
c2 (chr (1+ (ascii (substr c i 1))))
)
(if (or (= c2 "{") (= c2 "["))
(progn (command "erase" (entlast) "") (alert "Over character!") (exit))
(strcat c1 c2)
)
)
;;;============================
(defun C:OD( / cn dn c n p);;;Make OrDinal number with any format
(setq
cn (getstring "\nBegin at <1>: " T)
dn (getint "\nIncrement <1>: ")
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn))
(setq n (vl-string-subst "" c cn))
(if (/= n "") (setq mode 1) (setq mode 0))
(while (setq p (getpoint "\nBase point : "))
(wtxt cn p)
(if (= n "") 
	(setq cn (incC cn))
	(setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))		
)
)
(princ)
)
;;;============================
(defun C:OC( / e dn p1 cn c n p2 dat);;;Make Ordinal number. Copy from template
(setq
e (car (entsel "\nSelect template text:"))
dn (getint "\nIncrement <1>: ")
p1 (getpoint "\nBase point:")
cn (cdr (assoc 1 (entget e)))
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq
c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn)
n (vl-string-subst "" c cn)
)
(while (setq p2 (getpoint p1 "\nNew point : "))
(command "copy" e "" p1 p2)
(if (= n "") 
	(setq cn (incC cn))
	(setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))		
)
(setq
	dat (entget (entlast))
	dat (subst (cons 1 cn) (assoc 1 dat) dat)
)
(entmod dat)	
)
(princ)
)
;;;============================
(defun C:OCA( / e e0 dn p1 cn c n p2 dat);;;Make Ordinal number. Copy from Atttribute block
(setq
e0 (car (entsel "\nSelect attribute block:"))
e (entnext e0)
)
(if (/= (etype e) "ATTRIB") (progn (alert "Object is not a Attribute Block!") (exit)))
(setq
dn (getint "\nIncrement <1>: ")
p1 (getpoint "\nBase point:")
cn (cdr (assoc 1 (entget e)))
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq
c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn)
n (vl-string-subst "" c cn)
)
(while (setq p2 (getpoint p1 "\nNew point : "))
(command "copy" e0 "" p1 p2)
(if (= n "") 
	(setq cn (incC cn))
	(setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))		
)
(setq
	dat (entget (entnext (entlast)))
	dat (subst (cons 1 cn) (assoc 1 dat) dat)
)
(entmod dat)
(command "regen")
)
(princ)
)
;;;============================

 

Chào bạn, đây cũng là một cách hay. Nhưng cách này cũng hơi thủ công quá là các bản vẽ được copy ra đều có đánh số thứ tự hẳn hoi, nhưng ngặc nổi là các tên của bản vẽ ( MB trệt, MB lầu...)và các thông tin khác nữa, cái này trong lúc vẽ mình đã hiệu chỉnh rồi. Cái quan trọng nhất là lúc cuối cùng, Khi tấc cả bản vẽ đã xong công đoạn cuối cùng là đánh số thứ tự cho toàn bộ bản vẽ. Trong Block bản vẽ có các Attribute giả sử mình chọn Attribute "STT" để đánh số thứ tự chẳn hạn thì khi ta chọn lệnh xong, bắt đầu Select các Block khung tên ( cái này thường thấy thì theo từ trái sang phải hoặc sang trái ) Khi mình Select các Block theo một hướng cụ thể , =>> Enter =>> nhập số bắt đầu =>> OK =>> Thì nó sẽ đánh số thứ thư theo các Attribute "STT" ban đầu. Như thế là OK, còn nếu muốn đánh STT theo một chiều khác từ dưới lên trên hoặc ngược lại, để đánh STT cho toàn bộ bản vẽ. Nếu được như thế thì tuyệt quá.


<<

Filename: 104454_od_oc_oca.lsp
Tác giả: trungthanh050983
Bài viết gốc: 207606
Tên lệnh: ccd
Lisp Cộng các số trong Dim thành một công thức

Ok. đúng rồi.

Cảm ơn mọi người rất nhiều...

M

>>

Ok. đúng rồi.

Cảm ơn mọi người rất nhiều...

M

Trên cái Lisp mà bạn lp_hai đã viết, Tue_NV thêm thắt chút ít .

Xuất hiện hộp thoại -> Bạn nhấn Copy -> Paste vào ô trong Excel


(defun c:ccd(/ gtt dt sdt ent id str)
 (setq dt (ssget '((0 . "DIMENSION")))
sdt (sslength dt)
id 0
gtt 0
str "="
)
 (repeat sdt
(setq
  ent (ssname dt id)
     id (1+ id)
  gtt (+ gtt (gt1 ent) )
str (strcat str  (Rtos (gt1 ent)) "+")
  )
)
(Lisped (substr str 1 (1- (strlen str))))
 (princ gtt)
 (princ)
 )
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun gt1(ent / so)
(if (wcmatch(cdr(assoc 1 (entget ent)))"")
  (setq so (cdr(assoc 42 (entget ent))))
  (setq so (atof(cdr(assoc 1 (entget ent)))))
  )
)

 

Trên cái Lisp mà bạn lp_hai đã viết, Tue_NV thêm thắt chút ít .

Xuất hiện hộp thoại -> Bạn nhấn Copy -> Paste vào ô trong Excel


(defun c:ccd(/ gtt dt sdt ent id str)
 (setq dt (ssget '((0 . "DIMENSION")))
sdt (sslength dt)
id 0
gtt 0
str "="
)
 (repeat sdt
(setq
  ent (ssname dt id)
     id (1+ id)
  gtt (+ gtt (gt1 ent) )
str (strcat str  (Rtos (gt1 ent)) "+")
  )
)
(Lisped (substr str 1 (1- (strlen str))))
 (princ gtt)
 (princ)
 )
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun gt1(ent / so)
(if (wcmatch(cdr(assoc 1 (entget ent)))"")
  (setq so (cdr(assoc 42 (entget ent))))
  (setq so (atof(cdr(assoc 1 (entget ent)))))
  )
)

Mình đã ap lisp của bạn vào trong cad và dùng rất hay. Nhưng mình xin làm phiền bạn một lần nữa.

Trong công thức mình muốn lấy giá trị làm tròn 2 chữ số làm tròn sau dấu phẩy có được không.

Ví dụ dãy công thức trong lisp của bạn hiện xuất ra là "60.3354+405.3438+26.0255"

Mình muốn nó chỉ đưa ra công thức : "60.34+405.34+26.03" .

Cảm ơn rất nhiều.


<<

Filename: 207606_ccd.lsp
Tác giả: leejang
Bài viết gốc: 166395
Tên lệnh: vtl
lisp khoá và mở khoá khung viewport !

Viewport Toggle chế độ DisplayLocked :

 

(defun C:vtl ( / SelSet ST:VP-Toggle-DisplayLocked) ;VP toggle Locked
;======== Local...
>>

Viewport Toggle chế độ DisplayLocked :

 

(defun C:vtl ( / SelSet ST:VP-Toggle-DisplayLocked) ;VP toggle Locked
;======== Local Function =========
(defun ST:VP-Toggle-DisplayLocked (vpObj / rt)
;vp : vlaObject
;RT : T if Lock VP / nil if Open
(cond ((eq (vla-get-DisplayLocked vpObj) :vlax-false)(vla-put-DisplayLocked vpObj :vlax-true)(setq rt T)(vla-put-color vpObj acBlue))
	(T (vla-put-DisplayLocked vpObj :vlax-False)(vla-put-color vpObj acByLayer)))
)
;========== Start Here ==============
(grtext -1 "Free Lisp from Cadviet @Ketxu")
(cond
 ((< (atof (getvar "ACADVER")) 15.0)
  (alert " Lisp requires AutoCAD 2000 or higher. ")
 )
 ((or (= (getvar "TILEMODE") 1) (> (getvar "CVPORT") 1))
  (alert " Lisp can only be done in paper space. ")
 )
 ((and
   (not (prompt "\nSelect Viewport for (un)lock... "))
   (not (setq SelSet (ssget '((0 . "VIEWPORT")))))
  )
  (princ "Nothing or no Viewport selected.")
 )
 (T
  (vl-load-com)
  (vlax-for vpObj (setq SelSet (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
 (ST:VP-Toggle-DisplayLocked vpObj)	 
   )
)
)
(princ)
)

P/s : sử dụng ActiveSS nhanh thật :)

hì. Em không biết cái lệnh mview kia vì e ko dùng lệnh đó bao h. Biết lệnh đó rùi thì e tự viết đc.

Gửi các bác, hic. làm j mà các bác mắng e ghê quá.

(defun C:lk() ; khóa khung layout

(SETQ SS (SSGET))

(command "mview" "L" "ON" SS "")

)

 

(defun C:ULK(); mở khóa khung layout

(SETQ SS (SSGET))

(command "mview" "L" "OFF" SS "")

)


<<

Filename: 166395_vtl.lsp
Tác giả: Bommak
Bài viết gốc: 2395
Tên lệnh: daimline
Lisp tính tổng chiều dài các đối tượng
Cách tính chiều dài của MLINE khá giống với LWPOLYLINE. Tuy nhiên ACAD cấu trúc dữ liệu hơi khác so với LWPOLYLINE một chút. Với LWPOLYLINE, tất cả các đỉnh đều có...
>>
Cách tính chiều dài của MLINE khá giống với LWPOLYLINE. Tuy nhiên ACAD cấu trúc dữ liệu hơi khác so với LWPOLYLINE một chút. Với LWPOLYLINE, tất cả các đỉnh đều có dạng (10 x y z), còn trong MLINE chỉ có đỉnh đầu tiên có dạng (10 x y z) còn các đỉnh sau đó đều có dạng (11 x y z). Sau đây là lệnh DAIMLINE để tính tổng chiều dài các MLINE được chọn:

(defun c:daimline ( / ss sdt tongdai index)
 (defun daione	(ent / pcu daiml p)
   (defun adp (pt)
     (cond ((= 10 (car pt))
     (setq pcu (cdr pt)
	   daiml 0.0
     )
    )
    ((= 11 (car pt))
     (setq
       p       (cdr pt)
       daiml (+ daiml (distance p pcu))
       pcu     p
     )
    )
     )
   )
   (setq tt	  (entget ent))
   (foreach pt	tt
     (adp pt)
   )
   daiml
 )
 (setq	ss	(ssget '((0 . "MLINE")))
sdt	(cond
	  (ss (sslength ss))
	  (t 0)
	)
index	0
tongdai	0.0
 )
 (repeat sdt
   (setq ent	  (ssname ss index)
  index	  (1+ index)
  tongdai (+ tongdai (daione ent))
   )
 )
 (princ (strcat "\nTong chieu dai cac MLine tren la: "
	 (rtos tongdai 2 2)
 )
 )
 (princ)
)

 

 

Em cảm ơn bác Hoành nhiều nhé. Em tính chiều dài LWPOLYLINE bằng lệnh Area sau đó truy xuất biến hệ thống PERIMETER. Em đang cố gắng học nên chưa thành thạo trong việc xử lý Record.

Chúc bác luôn vui.


<<

Filename: 2395_daimline.lsp
Tác giả: quangtunb
Bài viết gốc: 356058
Tên lệnh: acpr2t
Mọi người có cách gì để chuyển các cao độ trong bản vẽ này về dạng text dc ko?

Chào bạn thuyengt,

Bạn thử sử dụng đoạn lisp dưới đây xem sao nhé. Lisp này giúp bạn đổi các đối tượng...

>>

Chào bạn thuyengt,

Bạn thử sử dụng đoạn lisp dưới đây xem sao nhé. Lisp này giúp bạn đổi các đối tượng ACAD_PROXY_ENTITY thành các MTEXT và vẫn đặt tại vị trí của point.

Nếu có gì chưa phù hợp, hãy post lên mình sẽ xem lại.

Lisp này chỉ phù hợp với cấu trúc của Acad_proxy_entity trên bản vẽ bạn đã post. Nếu Acad_proxy_entity có cấu trúc khác sẽ không còn phù hợp nữa. Bạn hãy lưu ý nhé.

 

(defun c:acpr2t (/ ss n i en ssc pls p1 p2 ssp m j enp els strp lth str )
(vl-load-com)
(command "undo" "be")
(setq ss (ssget '((0 . "ACAD_PROXY_ENTITY"))))
(setq n (sslength ss)
i 0)
(while (< i n)
(setq en (ssname ss i)
ssc (ssadd en)
pls (acet-geom-ss-extents-fast ssc)
p1 (car pls)
p2 (cadr pls)
)
(command "explode" en)
(setq ssp (ssget "w" p1 p2)
m (sslength ssp)
j 0
)
(while (< j m)
(setq enp (ssname ssp j)
els (entget enp))
(if (= (cdr (assoc 0 els)) "CIRCLE")
(progn
(setq p0 (cdr (assoc 10 els)))
(entdel enp)
)
)
(setq j (1+ j))
)
(setq enp (ssname ssp 0)
els (entget enp))
(setq strp (cdr(assoc 1 els))
lth (strlen strp)
strp (substr strp (1- lth) 2))
(entdel enp)
(setq enp (ssname ssp 1)
els (entget enp))
(setq els (subst (cons 71 8) (assoc 71 els) els)
els (subst (cons 10 p0) (assoc 10 els) els)
str (cdr (assoc 1 els))
str (strcat str "." strp)
els (subst (cons 1 str) (assoc 1 els) els))
(entmod els)

(setq i (1+ i))
)
(command "undo" "e")
(princ)
)

Sau khi đã chuyễn các đối tượng này thành MTEXT thì việc bạn muốn thay đổi nó hoàn toàn đơn giản đúng không????

Chúc bạn vui.....

Cái này rất hay!cảm ơn pro!nhưng cho mình hỏi mỗi lần dùng lệnh chỉ chọn được 1 đối tượng không thể quét hết cùng lúc được ak?thứ 2 là những điểm có độ cao dưới 0 ví dụ như 0,45 thì nó nhẩy thành 45,45!mong sự giúp đỡ của pro!


<<

Filename: 356058_acpr2t.lsp
Tác giả: 4582
Bài viết gốc: 11042
Tên lệnh: tg
Routine tính tổng chiều dài các đối tượng

Nhờ sự giúp đỡ của bác Nguyễn Hoành em có viết 1 đoạn code nhằm tính tổng chiều dài của các đối tượng chọn (*Line, Arc, Circle, Elippse). Các bác dùng thử và cho ý...
>>
Nhờ sự giúp đỡ của bác Nguyễn Hoành em có viết 1 đoạn code nhằm tính tổng chiều dài của các đối tượng chọn (*Line, Arc, Circle, Elippse). Các bác dùng thử và cho ý kiến.

Một lần nữa xin cảm ơn bác Hoành về sự nhiệt tình giúp đỡ anh em.

Chúc cả nhà luôn vui..

 

(defun add_mline ()
 (foreach e_record_sub	e_record
   (cond ((= 10 (car e_record_sub))
   (setq pt1	   (cdr e_record_sub)
	 mline_len 0.0
   )
  )
  ((= 11 (car e_record_sub))
   (setq pt2	   (cdr e_record_sub)
	 mline_len (+ mline_len (distance pt2 pt1))
	 pt1	   pt2
   )
  )
   )
 )
 (setq tot_len (+ tot_len mline_len))
 (ssdel e_name ss)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun C:tg (/ tot_len ss e_name e_record e_type)
 (setq tot_len 0.0)
 (setq ss (ssget))
 (if (null ss)
   (exit)
 )
 (while (> (sslength ss) 0)
   (setq e_name (ssname ss 0))
   (setq e_record (entget e_name))
   (setq e_type (cdr (assoc '0 e_record)))
   (cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
   (command "lengthen" e_name "")
   (setq tot_len (+ tot_len (getvar "PERIMETER")))
   (ssdel e_name ss)
  )
  ((wcmatch e_type "MLINE") (add_mline))
  (e_type (ssdel e_name ss))
   )
 )
 (prompt (strcat "\nTotal length is: " (rtos tot_len 2 2)))
 (princ)
)

đoạn lisp này giúp cho mình thống kê vật liệu đơn giản hơn rất nhiều, cám ơn bạn lắm lắm!


<<

Filename: 11042_tg.lsp
Tác giả: thiep
Bài viết gốc: 63449
Tên lệnh: cdt
Ký hiệu ặt cắt
Bạn thử dùng cái này xem.

(defun c:cdt()
 (defun dnt(tx)
   (vl-list->string (reverse (vl-string->list tx)))
 )
 (vl-load-com)
 (setq ent  (car (entsel "\nChon text:"))
      ...
>>
Bạn thử dùng cái này xem.

(defun c:cdt()
 (defun dnt(tx)
   (vl-list->string (reverse (vl-string->list tx)))
 )
 (vl-load-com)
 (setq ent  (car (entsel "\nChon text:"))
       eget (entget ent)
tt1  (cdr (assoc 1 eget))
ttd  (cdr (assoc 10 eget))
dn   (dnt tt1)
tt10 (dnt (substr dn (+ 2 (vl-string-search " " dn))))
tt11 (dnt (substr dn 1 (vl-string-search " " dn)))
sc   (substr tt11 1 (vl-string-search "-" tt11)))
 (if (> (setq sc1 (atoi sc)) 0)
   (setq tt12 (strcat tt10 " " (itoa (1+ sc1)) "-" (itoa (1+ sc1))))
   (setq tt12 (strcat tt10 " " (chr (1+ (ascii sc))) "-" (chr (1+ (ascii sc))))))
 (command "copy" ent "" ttd pause)  
 (vla-put-TextString (vlax-ename->vla-object (entlast)) tt12)  
)

Bạn G288 thân,

Lisp của bạn chỉ thật tuyệt vời khi dòng text bạn copy chỉ có 1 khoảng trống trước vị trí 1-1 hoặc A-A. Còn nếu nó là 1 - 1 hoặc A - A, thì Lisp của bạn hiểu sai ngay. Thiep có một giải pháp khác: Trên bản vẽ của cựu CT nước, chưa có dòng text "MAT CAT 1-1" nào cả. Cựu CT chỉ gọi lệnh, cho chiều cao text, cad sẽ hỏi tên mặt cắt là số hay chữ, trả lời xong chỉ cần Pick Pick mà thôi. Lisp như thế này đây:

http://www.cadviet.com/upfiles/ghichuMC.lsp

Gửi Ducluongx3, khi bạn post bài, nhớ kiểm tra chính tả trước khi post nhé. Khi dùng được lisp nhớ bấm THANK cho mọi người vui


<<

Filename: 63449_cdt.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 100732
Tên lệnh: nn
Lisp nối Line thành Pline ?
Mạn phép bác Hoành : Tue_NV viết thêm vào code theo như ý Của bạn NguyenNgocSon

@NguyenNgocSon : Bạn hãy thử với code này :

(defun c:nn (/ tdt ssdt sodt...
>>
Mạn phép bác Hoành : Tue_NV viết thêm vào code theo như ý Của bạn NguyenNgocSon

@NguyenNgocSon : Bạn hãy thử với code này :

(defun c:nn (/ tdt ssdt sodt index)
(defun ObjName (ssdt /)
(cdr (assoc '0 (entget ssdt)))
)
(defun MoPL (ssdt /)
(= (cdr (assoc '70 (entget ssdt))) 0)
)
(defun NoiPL (ssdt /)
(if (MoPL ssdt)
(command ".PEDIT" ssdt "J" tdt "" "X")
)
)
(defun NoiLC (ssdt /)
(command ".PEDIT" ssdt "Y" "J" tdt "" "X")
)
(setq ent (car(entsel "\nPick vao 1 doi tuong mau de lay ten Layer :")))
(princ "\n Chon doi tuong de noi")
(setq
tdt (ssget 
(list 
   (assoc 8 (entget ent) )
)
    )
sodt (sslength tdt)
index 0
)
(repeat sodt
(setq
ssdt (ssname tdt index)
index (1+ index)
)
(if (or (= (Objname ssdt) "LWPOLYLINE")
(= (Objname ssdt) "POLYLINE")
)
(NoiPL ssdt)
)
(if (or (= (Objname ssdt) "LINE") (= (Objname ssdt) "ARC"))
(NoiLC ssdt)
)
)
(princ)
)

Cám ơn bác. Nhưng chỉ có điều khi pick chọn line đầu lệnh: NN không tự tìm đến các đường kép thành Pline thì phải ?

Em đã thử và thấy như vậy. Bác thử check lại xem có đúng không ?

Cám ơn bác !


<<

Filename: 100732_nn.lsp
Tác giả: toai
Bài viết gốc: 64432
Tên lệnh: ftd
Nhờ Mr Hoành kiểm tra lại lisp fakedim
Chào Toai, ltv_ngocphuoc

trong khi chờ bác Hoành nâng cấp phiên bản mới, bạn sử dụng tạm LISP này.

; FTD-> FixTextDimension
(defun c:FTD  (/ ss ent...
>>
Chào Toai, ltv_ngocphuoc

trong khi chờ bác Hoành nâng cấp phiên bản mới, bạn sử dụng tạm LISP này.

; FTD-> FixTextDimension
(defun c:FTD  (/ ss ent str entdata)
 (vl-load-com)
 (princ "\n Chon duong kich thuoc :")
 (if (setq ss (ssget '((0 . "DIMENSION"))))
   (foreach ent  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
     (setq str (TextDimension ent)
    entdata (entget ent)
    entdata (subst (cons 1 str) (assoc 1 entdata) entdata)
    )
     (entmod entdata)
     )
   (princ "\nKhong phai duong kich thuoc!"))
 (princ))

(defun TextDimension (dim / str)
 (setq str "")
 (vlax-for item
    (vla-item (vla-get-blocks
		(vla-get-activedocument (vlax-get-acad-object))
	      )
	      (cdr (assoc 2 (entget dim)))
    )
   (if	(vlax-property-available-p item 'Textstring)
     (setq str (vla-get-textstring item))
   )
 )
 str
)

Cám ơn Gia_Bach. Mình đã download đoạn lisp của bạn về nhưng khi sử dụng lại bị báo lỗi "quá nhiều đối số" (Mình dùng Acad2008). Bạn kiểm tra giúp mình nhé vì mình k biết chút nào về lisp cả.

http://www.cadviet.com/upfiles/Loi_lisp_FTD.jpg

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


<<

Filename: 64432_ftd.lsp
Tác giả: ngotheanh
Bài viết gốc: 105949
Tên lệnh: dcd
Nhờ các bác viết dùm Lisp đánh cao độ
Cám ơn anh giabach.

Em đang viết và cố gắng hoàn thành xong code này để giúp cho bạn auduongphuc.

Có gì trở ngại mong anh gia bách và mọi người hỗ trợ...

>>
Cám ơn anh giabach.

Em đang viết và cố gắng hoàn thành xong code này để giúp cho bạn auduongphuc.

Có gì trở ngại mong anh gia bách và mọi người hỗ trợ thêm.

Chào anh. Chúc anh thật nhiều sức khoẻ.

-----------

Tue_NV đã hoàn thành xong code này

Bạn auduongphuc chạy thử xem :

Chỉ Có 2 yêu cầu nhỏ khi chạy code :

1. Lisp chấp nhận bất cứ Block cao độ nào miễn là Block đó có 1 Atrtibute và Block đó phải có trên CAD để mà ta Pick chon Block mau

2. Điểm chèn Block đó nên nằm ngay cos cao độ chèn

Mong bạn auduongphuc hiểu

(defun c:dcd(/ tlv blm blname dmo cdm cd dm cdmi dmoc)
(setvar "attreq" 1)
(setvar "cmdecho" 0)
(setq oldim (getvar "DimZin"))
(setvar "Dimzin" 0)
(setq tlv (/ 1 (getreal "\n Nhap ti le ve : 1/")))
(setq blm (entget(car(entsel "\n Pick chon Block mau :"))))
(setq blname (cdr(assoc 2 blm)))
(setq TLX (cdr(assoc 41 blm)))
(setq TLY (cdr(assoc 42 blm)))
(setq dmo (getpoint "\n Pick diem moc : "))

(setq cdm (getreal "\n Nhap cao do cua diem moc :"))
(if (= cdm 0) (setq cd (strcat "%%p" (rtos cdm 2 3))))
(if (> cdm 0) (setq cd (strcat "+" (rtos cdm 2 3))))
(if (< cdm 0) (setq cd (rtos cdm 2 3)))
(command "insert" blname dmo TLX TLY "0" cd)
(setq dmoc dmo)
(while (setq dm (getpoint dmoc "\n Pick diem tiep theo :"))
(setq cdmi (* (- (cadr dm) cdm (cadr dmo)) tlv))
(if (= cdmi 0) (setq cdi (strcat "%%p" (rtos cdmi 2 3))))
(if (> cdmi 0) (setq cdi (strcat "+" (rtos cdmi 2 3))))
(if (< cdmi 0) (setq cdi (rtos cdmi 2 3)))
(command "insert" blname dm TLX TLY "0" cdi)
(setq dmoc dm)
)

(setvar "Dimzin" oldim)
(princ)
)

Bác ơi, tình hình là lisp của bạn rất hay, đúng ý mình, nhưng mà trong bản vẽ thì cốt cao độ sẽ là đơn vị mét, và thường là sau dấu thập phân chỉ cần hai số thôi, ví dụ như là +2.52, bác có thể sửa thêm giùm em dc không?Cảm ơn bác nhiều


<<

Filename: 105949_dcd.lsp
Tác giả: namhai
Bài viết gốc: 66265
Tên lệnh: eob
lisp xóa tất cả các đối tượng trong 1 vùng kín
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...

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

(defun C:EOB (  / en ss lst ssall bbox) ;EOB -> Erasre Out Boudary
(vl-load-com)
 (if (and (setq en (car(entsel "\n Chon duong bao : ")))
          (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))
   (progn
     (setq bbox (ACET-ENT-GEOMEXTENTS en))
     (setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
     (setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-3))
     (ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))
     (command "_.Zoom" "0.95x")
     (if (null etrim)(load "extrim.lsp"))
     (etrim en (polar
                 (car bbox)
                 (angle (car bbox)(cadr bbox))
                 (* (distance (car bbox)(cadr bbox)) 1.1)))
     (if (and
           (setq ss (ssget "_CP" lst))
           (setq ssall (ssget "_X" (list (assoc 410 (entget en)))))
          )
       (progn
         (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
         (foreach e1 lst (ssdel e1 ssall))
         (ACET-SS-ENTDEL ssall)
         )
       )
     )
   )
 )

Bác Gia Bach à, thanks bác rất nhiều về những lisp của bác nha, quả thật nó rất tuyệt vời,tiện đây cho e hỏi có thể mở rộng lisp eob để xoá các đối tượng nằm trong curve ko nhỉ?


<<

Filename: 66265_eob.lsp
Tác giả: VlaObject
Bài viết gốc: 409989
Tên lệnh: attdef2text
Xin lisp chuyển text thuộc tính att thành text thường

 

Hỏi ảnh GO trước đi. Heizz. Code này ngon nhé. ^_^

(defun c:AttDef2Text ( / ss )
  ;; © Lee Mac  ~  01.06.10
 ...
>>

 

Hỏi ảnh GO trước đi. Heizz. Code này ngon nhé. ^_^

(defun c:AttDef2Text ( / ss )
  ;; © Lee Mac  ~  01.06.10
  (vl-load-com)

  (if (setq ss (ssget "_:L" '((0 . "ATTDEF"))))
    (
      (lambda ( i / e o )
        (while (setq e (ssname ss (setq i (1+ i))))
          (if
            (
              (if (and (vlax-property-available-p
                         (setq o (vlax-ename->vla-object e)) 'MTextAttribute)
                       (eq :vlax-true (vla-get-MTextAttribute o)))

                MAttDef2MText AttDef2Text
              )
              (entget e)
            )
            (entdel e)
          )
        )
      )
      -1
    )
  )
  (princ)
)

(defun AttDef2Text ( eLst / dx74 dx2 )
  ;; © Lee Mac  ~  01.06.10

  (setq dx74 (cdr (assoc 74 eLst)) dx2 (cdr (assoc 2 eLst)))

  (entmake
    (append '( (0 . "TEXT") ) (RemovePairs '(0 100 1 2 3 73 74 70 280) eLst)
      (list
        (cons 73 dx74)
        (cons  1  dx2)
      )
    )
  )
)

(defun MAttDef2MText ( eLst )
  ;; © Lee Mac  ~  01.06.10

  (entmake
    (append '( (0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText") )
      (RemoveFirstPairs '(40 50 41 7 71 72 71 72 73 10 11 11 210)
        (RemovePairs '(-1 102 330 360 5 0 100 101 1 2 3 42 43 51 74 70 280) eLst)
      )
      (list (cons 1 (cdr (assoc 2 eLst))))
    )
  )
)

(defun RemoveFirstPairs ( pairs lst )
  ;; © Lee Mac

  (defun foo ( pair lst )
    (if lst
      (if (eq pair (caar lst))
        (cdr lst)
        (cons (car lst) (foo pair (cdr lst)))
      )
    )
  )

  (foreach pair pairs
    (setq lst (foo pair lst))
  )
  lst
)


(defun RemovePairs ( pairs lst )
  ;; © Lee Mac
  (vl-remove-if
    (function
      (lambda ( pair )
        (vl-position (car pair) pairs)
      )
    )
    lst
  )
)

 

Ông © Lee Mac này cái gì ổng cũng có.hahaha  :D


<<

Filename: 409989_attdef2text.lsp
Tác giả: SoftvnBin
Bài viết gốc: 207755
Tên lệnh: kt2
: Lisp ghi kích thước

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

>>

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

Bạn đổi dòng (setq ss (ssget (list (cons 0 "LINE")))) thành 2 dòng sau :

 

Nếu giờ mình muốn:

I. "nhap khoang cach" thành 2 bước

bước 1: "Dim lan <1, 2, 3, 4, 5>: 1"

bước 2: Nếu nhập 1 thì:

Nhap khoang cach <500>: 500 " với 500 là số gợi nhớ

Nếu nhập 2 thì:

Nhap khoang cach <1000>: 1000 " với 1000 là số gợi nhớ

Nếu nhập 3 thì:

Nhap khoang cach <1500>: 1500 " với 1500 là số gợi nhớ

Nếu nhập 4 thì:

Nhap khoang cach <2000>: 2000 " với 2000 là số gợi nhớ

Nếu nhập 5 thì:

Nhap khoang cach <2500>: 2500 " với 2500 là số gợi nhớ

 

II. Đo Pline thì tự đo từ đỉnh 1 đến đỉnh 2, từ đỉnh 2 đến đỉnh 3,....

 

(Mình sửa LINE thành *LINE thì đo được Pline rồi, nhưng Lisp đo từ điểm đầu tiên đến điểm cuối cùng mà bỏ qua các điểm đỉnh trung gian thuộc PLINE)

Nhờ Ketxu sửa giúp mình nhé!

Cẳm ơn Ket trước nhé


<<

Filename: 207755_kt2.lsp
Tác giả: doanduyhung
Bài viết gốc: 56561
Tên lệnh: cdc
Hỏi cách chuyển đổi vị trí tọa độ đầu cuối của 1 polyline
Bạn hãy sử dụng lại lệnh Align xem sao. Bạn binharch77 nói đúng đó.

Nếu sử dụng Lisp thì Code đây :

(defun c:Cdc()
(vl-load-com)
(prompt "\n Chon...
>>
Bạn hãy sử dụng lại lệnh Align xem sao. Bạn binharch77 nói đúng đó.

Nếu sử dụng Lisp thì Code đây :

(defun c:Cdc()
(vl-load-com)
(prompt "\n Chon polyline :")
(setq curve (car(entsel "\n Chon Polyline :")))
(setq dau (vlax-curve-getStartPoint curve))
(setq cuoi (vlax-curve-getEndPoint curve))
(Command "Align" curve "" dau cuoi cuoi dau "" "")
(princ)
)

Bác xem lại dùm nhé, làm cách này nếu polyline có nhiều đoạn thì nó bị thay đổi rồi


<<

Filename: 56561_cdc.lsp
Tác giả: 790312
Bài viết gốc: 153941
Tên lệnh: wo
Lisp chỉnh style TEXT trong block thuộc tính

Do viết vội quá. Sửa lại cho bạn đây :

(defun c:wo( / ssdt sodt index tt entdt w sty h)  
 (setq ssdt (ssget '((0 ....
>>

Do viết vội quá. Sửa lại cho bạn đây :

(defun c:wo( / ssdt sodt index tt entdt w sty h)  
 (setq ssdt (ssget '((0 . "INSERT") (66 . 1)))
sodt (sslength ssdt)
index 0
  )
(setq w (getreal "\n Nhap be rong chu :"))
(setq h (getreal "\n Nhap chieu cao chu :"))
(setq sty (getstring t "\n Nhap ten style : "))
 (repeat sodt
   (setq entdt (ssname ssdt index)
  index (1+ index))
   (while (/= (cdr(assoc 0 (entget entdt))) "SEQEND")
   	(setq
    entdt (entnext entdt)
  tt (entget entdt)
   	)
(if w (setq tt (subst (cons 41 w) (assoc 41 tt) tt)))
(if h (setq tt (subst (cons 40 h) (assoc 40 tt) tt)))
(if (tblsearch "style" sty) (setq tt (subst (cons 7 sty) (assoc 7 tt) tt)))

  	 (entmod tt)
   	(entupd entdt)
   )
 )

 (princ)
)

Chân thành cảm ơn bác rất nhiều,tiện thể bác giúp e thêm lần cuối với,chỗ nhập TÊN STYLE bác giúp cho hiện sẵn 1 tên nào đó chẳng hạn là 123 chẳng hạn để enter luôn khỏi phải nhập vì tên Style của e thường dài lắm,nếu muốn nhập tên Style khác vẫn được.


<<

Filename: 153941_wo.lsp
Tác giả: quanghuy181
Bài viết gốc: 409991
Tên lệnh: qdd
Xin Lisp Tự Động Đo Chiều Dài Nhiều Line (Ko Tính Tổng)

 

Quick code cho bạn :

(defun c:qdd(/ s sp 3d i dxf rAng rSup e obj) (vl-load-com)
;Quick dim Lines @ketxu...
>>

 

Quick code cho bạn :

(defun c:qdd(/ s sp 3d i dxf rAng rSup e obj) (vl-load-com)
;Quick dim Lines @ketxu 10/2016
(cond
	((setq s (ssget '((0 . "LINE")))) 
	(setq 	sp	(vlax-get (setq ac (vla-get-activedocument (vlax-get-acad-object)))
					(if (> (vla-get-activespace  ac) 0) 'ModelSpace 'PaperSpace)) 
			3d vlax-3d-point
			i -1
			dxf (lambda(i e)(cdr (assoc i (entget e))))
			rAng (lambda(a)(if (and (> a (/ pi 2.)) (<= a (* pi 1.5)))(+ a pi) a))
			rSup (lambda(p)(vlax-put-property obj p 1))
			
	)
	(while (setq e (ssname s (setq i (1+ i))))
			(setq obj 
				(vla-adddimaligned sp 
					(3d (setq p1 (dxf 10 e))) 
                    (3d (setq p2 (dxf 11 e)))     
					(3d (polar p1 (+ (angle p1 p2) (/ pi 2.)) 0))
                )			
			)
			(vla-put-Textrotation obj (rAng (angle p1 p2)))
			(vla-put-TextOverride obj "<>\\P   ")
			(mapcar 'rSup '(DimLine1Suppress DimLine2Suppress ExtLine1Suppress ExtLine2Suppress))
	)	
)
))

Bạn ơi mình muốn chiều dài cạnh chỉ lấy 1 số sau dấu , và chọn nhập chiều cao chữ thì làm như thế nào??? Xin cảm ơn!


<<

Filename: 409991_qdd.lsp
Tác giả: DanKhaosat
Bài viết gốc: 255177
Tên lệnh: ha
Nhờ các bác chỉnh hộ Lisp vẽ hình chữ nhật

 

đang luyện công nhưng mạo muội sửa bậy

>>>> hòng học đc nhiều cái hay sau 1 rổ đá :D :D :D

>>

 

đang luyện công nhưng mạo muội sửa bậy

>>>> hòng học đc nhiều cái hay sau 1 rổ đá :D :D :D

(defun C:HA( / pa pb h1 pc)
 (BAT_DAU)
 (initget 1) (setq pa (getpoint "\nPick diem A: "))
 (initget 1) (setq pb (getpoint pa "\nPick diem B: "))
 (acet-sysvar-set (list "cmdecho" 0))
 (command "ucs" "z" (/ (* 180 (angle pa pb)) pi))
 (setq pa (trans pa 0 1))
 (setq pb (trans pb 0 1))
 (grvecs (list -3 pa pb))
 (acet-sysvar-set (list "orthomode" 1))
 (if (not h) (setq h 100))
 (setq h1 (getdist pb (strcat "Chieu cao <" (rtos h 2 4) " >: ")))
 (if h1
	(setq h h1)
	)
 (princ (strcat "Nhan chieu cao " (rtos h 2 4)))
 (setq pc (polar pb (/ pi 2) h))
 (command "rectangle" pa pc)
 (redraw)
 (command "ucs" "w")
 (acet-sysvar-restore)
 (KET_THUC)
 (princ))
(defun BAT_DAU()
 (vl-load-com)
 (setq AcDoc (vla-get-activeDocument (vlax-get-acad-object)))
 (vla-StartUndoMark AcDoc)
 (setq err *error* *error* KHI_LOI))
(defun KET_THUC()
 (acet-sysvar-restore)
 (vla-EndUndoMark AcDoc)
 (setq *error* err))
(defun KHI_LOI(msg)
 (acet-sysvar-restore)
 (vla-EndUndoMark AcDoc)
 (redraw)
 (command "u")
 (princ (strcat "\n" msg ", Reset System Variables\n"))
 (setq *error* err))

Cảm ơn bạn

hiepttr

bạn làm đúng ý mình rồi nhưng cần sửa lại hộ mình là hình chữ nhật đó vẽ về phía nào la do mình

Chứ như chương trình bạn sửa là chỉ mạc định về 1 phía thôi!

CẢm ơn!


<<

Filename: 255177_ha.lsp
Tác giả: oneclicklogin
Bài viết gốc: 213687
Tên lệnh: cs
Thay thế text hàng loạt

Lisp này mình đã viết từ lâu rồi.

Link :

Lisp này mình đã viết từ lâu rồi.

Link : http://www.cadviet.c...ic=13203&st=700

Sửa theo ý bạn đây :


(defun c:cs(/ ss sx lis1 lis2 n i nn mm li li1)
;;write by Tue_NV
(vl-load-com)
(princ "\n Chon chuoi 1 :")
(setq ss (ssget '((0 . "TEXT"))))
(princ "\n Chon chuoi 2 :")
(setq sx (ssget '((0 . "TEXT"))))
(setq lis1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lis2 (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx))))
(setq lis1 (vl-sort lis1 '(lambda (x y)
(< (caddr (assoc 10 (entget x)))
 (caddr (assoc 10 (entget y)))
)
   )
  )
)
(setq lis2 (vl-sort lis2 '(lambda (x y)
(< (caddr (assoc 10 (entget x)))
 (caddr (assoc 10 (entget y)))
)
   )
  )
)
(setq n (sslength ss) i 0)

(if (= (length lis1) (length lis2))
(progn
  (while (< i (length lis1))

(setq nn (entget (nth i lis1)))
(setq mm (entget (nth i lis2)))

(setq li (cdr (assoc 1 nn)))

(setq li1 (cdr (assoc 1 mm)))


;(setq nn (subst (cons 1 li1) (assoc 1 nn) nn))
(setq mm (subst (cons 1 li) (assoc 1 mm) mm))

(entmod mm)
;(entmod nn)
(setq i (+ i 1))

)
)
(alert "\n Hai chuoi khong bang nhau. Lisp khong thuc hien duoc")
)

(princ)

)

Lisp của anh thật là tuyệt . Cảm ơn anh Tue_NV nhiều lắm .


<<

Filename: 213687_cs.lsp

Trang 240/330

240