Đây là một bài toán hay.

 

Text trong file AutoCAD là text được tạo nên từ các ký tự Ascii có cấu trúc %%xxx. Chính vì vậy hiển thị trong CAD vẫn ngon...

>>

Đây là một bài toán hay.

 

Text trong file AutoCAD là text được tạo nên từ các ký tự Ascii có cấu trúc %%xxx. Chính vì vậy hiển thị trong CAD vẫn ngon lành, tuy nhiên nội dung của text là lộn xộn.

 

Đây không phải lỗi của lisp xt.lsp mà là từ cấu trúc của file CAD.

 

bạn dùng lisp fixtext dưới đây để sửa lỗi text trong file ACAD của bạn trước khi sử dụng lisp xuất sang excel:

(defun c:fixtext ()
 (setq	ss  (ssget '((0 . "TEXT")))
lst (ss2ent ss)
 )
 (foreach e lst
   (setq tt (entget e)
  tt (subst (cons 1 (thaytext (cdr (assoc 1 tt))))
	    (assoc 1 tt)
	    tt
     )
   )
   (entmod tt)
 )
 (princ)
)

(vl-load-com)

(defun thaytext	(str)
 (setq i 255)
 (while (> i 0)
   (setq cf (strcat "%%" (itoa i))
  cr (chr i)
   )
   (while (vl-string-search cf str)
     (setq str (vl-string-subst cr cf str))
   )
   (setq i (1- i))
 )
 str
)
(defun ss2ent (ss / sodt index lstent)
 (setq
   sodt  (if ss
    (sslength ss)
    0
  )
   index 0
 )
 (repeat sodt
   (setq ent	 (ssname ss index)
  index	 (1+ index)
  lstent (cons ent lstent)
   )
 )
 (reverse lstent)
)

Em rất cảm ơn bác Hoành. Tuy nhiên đối với những tên hộ viết bằng bảng mã Unicode thì em dùng 2 lisp trên thì cũng không thể xuất ra đựơc. Lỗi xuất hiện lúc này không phải là các dấu %% nữa mà nó là các sổ chéo kiểu như \ (ví dụ: Hoàng Văn Thụ ----> H\oan\g Va\n T\hu). Em không biết phải làm thế nào trong trường hợp này nữa. Rất mong bác ra tay "kíu" giúp em! Xin cảm ơn!

<<

Vài nhận xét về List của Thaistreetz :

Nói chung Lisp của bạn chạy đúng 99,99% trừ vài truờng hợp đặc biệt. (sẽ viết phía duới)

1. Với việc sử dụng 2...

>>

Vài nhận xét về List của Thaistreetz :

Nói chung Lisp của bạn chạy đúng 99,99% trừ vài truờng hợp đặc biệt. (sẽ viết phía duới)

1. Với việc sử dụng 2 vòng lặp vlax-for để truy xuất database trong CAD

(vlax-for lt (vla-get-layouts adoc)

(vlax-for obj (vla-get-block lt) .................. ...... ))

và kiểm tra điều kiện kiểu đối tuợng là TEXT

-> Lisp phải duyệt qua tất cả các đối tuợng trong bản vẽ, kể cả đối tuợng LINE, DIMENSION, ... do đó sẽ mất nhiều thời gian để thực hiện.

Đối với file CAD tuơng đối lớn, thời gian này là đáng kể (đủ để pha trà-cà phê hay .....)

Có thể tối ưu việc chọn đối tuợng khi kết hợp với 1 bộ lọc thích hợp.

VD : (ssget "_X" (list (cons 0 "TEXT")))

 

2.Với dòng lệnh WHILE :

(while (vl-string-search old_text (vla-get-textstring obj))

(vla-put-textstring obj (vl-string-subst new_text old_text (vla-get-textstring obj))) )

việc gọi hàm vla-get-textstring và vla-put-textstring trong vòng lặp là không cần thiết, mất nhiều thời gian truy xuất GET-PUT, ....

(thực ra điều này chỉ xảy ra khi chuỗi old_text cần thay thế đuợc lặp đi lặp lại trong TEXT)

có thể xử lý bằng cách lấy nội dung TEXT :

vla-get-textstring -> WHILE( thay thế old_text bằng new_text) -> gọi hàm vla-put-textstring

 

Cũng trong vòng lặp này, khi chuỗi new_text là tập con của chuỗi old_text thì LISP không thóat đuợc.

VD: khi thay thế chuỗi "Cadviet" với chuỗi "Forum Cadviet" -> CAD sẽ bi treo (OverFlow)

Bạn có thể kiểm chứng điều này. Sau đó tìm cách khắc phục nhé.

 

Vài góp ý chân thành (đừng nghĩ là vạch lá tìm sâu nha) đến Windows của Microsoft còn bị lỗi lên lỗi xuống cơ mà. <_<

Gửi bạn phuơng án khác (chưa xử lý lỗi trong vòng lặp)

(defun c:hg (/ new_text old_text ss str)
 (or vlax-ename->vla-object (vl-load-com))
 (setq old_text "Cadviet" new_text "Forum CADVIET")    
 (ssget "_X" (list (cons 0 "*TEXT")(cons 1 (strcat"*"old_text "*") )))
 (if (setq ss (vla-get-activeSelectionSet (vla-get-activedocument(vlax-get-acad-object))))
   (vlax-for obj ss
     (setq str (vla-get-TextString obj))
     (while (vl-string-search old_text str)
(setq str (vl-string-subst new_text old_text str)) )
     (vla-put-textstring obj str)
     )
   )
 (princ))

Thực ra đây không phải là lisp em viết anh ạ, nó được em tách ra từ một bộ lisp tổng hợp mà em sưu tầm được. Về lỗi vòng lặp while thì em cũng đã nhận ra và thử khắc phục ngay sau lần đầu test đoạn lisp này nhưng chưa có kết quả (em định dùng một hàm if trong vòng lặp, nếu đối tượng được duyệt có nhóm ký tự giống new_text thì sẽ bỏ qua không thực hiện việc thay thế, tuy nhiên chưa biết viết nó thế nào). hihi, chính vì thế nên em mới để cái old_text và new_text thế kia. không ngờ anh nhận ra ngay, sợ thật :cheers:

<<

 

 

Lisp thay đổi 1 thuộc tính của tất cả Att_Block được chọn theo tất cả giá trị của Text/Mtext được...

>>

 

 

Lisp thay đổi 1 thuộc tính của tất cả Att_Block được chọn theo tất cả giá trị của Text/Mtext được chọn.

Số lượng Block và Text được chọn phải bằng nhau.

Thứ tự tính theo thứ tự chọn. Chú ý điều này kẻo nó lấy râu ông nầy cắm cằm bà nọ nhé!

;Doan Van Ha - CADViet.com (05-12-2011)
;Thay 1 thuoc tinh cua N Att_Block duoc chon theo N Text/Mtext duoc chon (neu ten thuoc tinh ton tai trong Att_Block). Thu tu theo thu tu chon.
(defun C:HA( / ss ss1 objlst entlst txt tth lst lst1 lst2 lst3 i)
(vl-load-com)
(princ "\nChon cac Att_Block de thay doi thuoc tinh...")
(setq ss (ssget (list (cons 0 "insert"))))
(setq objlst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
(princ "\nChon cac Text/Mtext de lay thuoc tinh...")
(setq ss1 (ssget (list (cons 0 "text,mtext"))))
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1))))
(if (/= (length objlst) (length entlst)) (progn (alert "So luong cua Block va Text khac nhau.") (exit)))
(setq tth (getstring "\nNhap ten thuoc tinh muon thay doi: "))
(setq i 0)
(repeat (length objlst)
  (setq lst (GetAtt (nth i objlst)))
  (setq txt (cdr (assoc 1 (entget (nth i entlst)))))
  (foreach lst1 lst
   (if (= (strcase (car lst1)) (strcase tth))
	(setq lst2 (cons (car lst1) txt))
	(setq lst2 lst1))
   (setq lst3 (cons lst2 lst3)))
  (SetAtt (nth i objlst) lst3)
  (setq i (1+ i)))
(princ))
;-----by MENZI ENGINEERING GmbH, Switzerland. Thank you.
(defun GetAtt (obj)
(mapcar '(lambda (att) (cons (vla-get-TagString att) (vla-get-TextString att))) (vlax-invoke obj 'GetAttributes)))
(defun SetAtt (obj lst / attval)
(mapcar '(lambda (att) (if (setq attval (cdr (assoc (vla-get-TagString att) lst))) (vla-put-TextString att attval))) (vlax-invoke obj 'GetAttributes))
(vla-update obj))

Cũng phát triển theo lisp trên. anh Doan Van Ha có thể sửa lisp ngược lại được không. tức sửa text/Mtext theo thứ tự và lấy ra gán theo thuộc tính trong block. (sửa text ngoài theo thuôc tính ). thanhk anh!

<<

Cảm ơn Anh Tuệ rất nhiều. :bigsmile:

Đây là lisp đã đã được sửa để tính diện tích cả hình có lỗ khoét và không có lỗ khoét.

>>

Cảm ơn Anh Tuệ rất nhiều. :bigsmile:

Đây là lisp đã đã được sửa để tính diện tích cả hình có lỗ khoét và không có lỗ khoét.

(defun c:bdt()
(setvar "cmdecho" 0)
(command "undo" "begin")
(setq lacol (getvar "CEColor"))
(setq ladin (getvar "dimzin"))
(setq laos (getvar "osmode"))  
(if (not tl) (setq tl 1))
(if (not h) (setq h 1))
(setq tl1 (getreal (strcat "\nty le ban ve : 1/"))
   caot1 (getreal (strcat "\nCao text : ")))
(if tl1 (setq tl tl1))
(if caot1 (setq h caot1))
(setq k 0 tdt 0)

(setvar "dimzin" 0)
(setvar "OSMODE" 0)
(setq PT (getpoint "\nChon diem xuat bang thong ke dien tich (mep trai):"))
(setq     P1 (list (+ (car PT)(* 6 h)) (cadr PT))
   P2 (list (+ (car PT)(* 22 h)) (cadr PT))
   P3 (list (car PT) (- (cadr PT)(* 3 h)))
   P4 (list (car P1) (cadr P3))
   P5 (list (car P2) (cadr P3))
   P6 (list (+ (car PT)(* 11 h)) (+ (cadr PT)(* 2 h)))
   P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
   P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
);setq
(command "pline" PT P2 P5 P3 "C"
       "pline" P1 P4 ""
       "text" "m" P6 (* 1.2 h) 0 "%%UB¶ng thèng kª diÖn tÝch"
       "text" "m" P7 h 0 "STT"
       "text" "m" P8 h 0 "DiÖn tÝch (m2)"
);command

(setq pt1 (getpoint "\n Chon mien tinh dien tich : "))
(while (/= pt1 nil)
(command "erase" ss "")
(setq k (+ 1 k))
(command "TEXT" "m" pt1 (* 3 h) 0 (rtos k 2 0))
(setq PT (list (car P3) (cadr P3))
   P1 (list (+ (car PT)(* 6 h)) (cadr PT))
   P2 (list (+ (car PT)(* 22 h)) (cadr PT))
   P3 (list (car PT) (- (cadr PT)(* 3 h)))
   P4 (list (car P1) (cadr P3))
   P5 (list (car P2) (cadr P3))
   P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
   P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
   P9 (list (car PT) (- (cadr P3)(* 3 h)))
   P10 (list (car P1) (cadr P9))
   P11 (list (car P2) (cadr P9))
   P12 (list (car P7) (- (cadr P3)(* 1.5 h)))
   P13 (list (car P8) (cadr P12))
   );setq
(setq frome (entlast));; chon doi tuong cuoi cung truoc khi boundary
(command "cecolor"4 "-boundary" pt1 "");; boundary
(setq toe (entlast));; chon doi tuong cuoi cung sau khi boundary
(setq cur frome	ss (ssadd) S 0)
(while 	(not (eq cur toe));; chon cac doi tuong tu frome den toe
(setq cur (entnext cur) ss (ssadd cur ss))
(command "area" "S" "O" ss "" "")
(setq dt (getvar "area") S (+ S dt))
);while
(command "area" "A" "O" "L" "" "")
(setq dt (getvar "area"))
(setq S (* (+ S (* dt 2)) tl) tdt (+ s tdt))  
(setvar "CEColor" lacol)
(command "pline" PT P2 P5 P3 "C"
 "pline" P1 P4 ""
 "text" "m" P7 h 0 (rtos k 2 0)
 "text" "m" P8 h 0 (rtos s 2 2))
(setq pt1 (getpoint (strcat "\nTong dien tich = " (rtos tdt 2 3) "m2. chon mien do tiep theo...")))
);while
(command "erase" ss "")
(setq ss nil)
(setvar "DIMZIN" ladin)
(command     "pline" P3 P9 P11 P5 "C"
       "pline" P10 P4 ""
       "text" "m" P12 h 0 "Tæng"
       "text" "m" P13 h 0 (rtos tdt 2 2)
);command
(setvar "OSMODE" laos)
(command "undo" "end")
(setvar "cmdecho" 1)
)

 

@vantiteo: Mình đang bận quá, tranh thủ thời gian ngủ trưa để sửa lại lisp này cho mọi người thôi. bạn có thể xem lisp của anh Tuệ để tìm ra chỗ thiếu sót của bạn. lisp của anh Tuệ rất hay.

@xuandao0708: Bạn cần phân biệt tỷ lệ vẽ và tỷ lệ in nhé. lisp này yêu cầu nhập vào tỷ lệ vẽ vì chỉ có tỷ lệ vẽ mới ảnh hưởng trực tiếp đến kết quả tính toán. theo như bạn nói thì thì tỷ lệ 1/500 của bạn chính là tỷ lệ in của bản vẽ ra giấy. còn thực chất bản vẽ của bạn vẫn được vẽ với tỷ lệ 1/1. nghĩa là 1 đơn vị vẽ trong cad sẽ tương ứng với 1 đơn vị đo ngoài thực địa.

Rất mừng vì bạn đã xây dựng thành công code này. Và có lẽ người được chúng ta cảm ơn nhiều nhất chính là bác Hoành vì bác Hoành đã góp phần cho chúng ta có được code hay và xây dựng được các chương trình rất hay

Một lần nữa cảm ơn bác Hoành. Thanks

<<

Ồ, lần trước nói ý nói tứ rồi mà bạn lại lập tiếp cái nữa.

Thôi thì nói thẳng với bạn vậy : Hãy tránh dùng từ "

>>

Ồ, lần trước nói ý nói tứ rồi mà bạn lại lập tiếp cái nữa.

Thôi thì nói thẳng với bạn vậy : Hãy tránh dùng từ "Tôi muốn", vì bạn đang ở vị trí người cần được giúp đỡ ^^ (Mặc dù đội ngũ BQT thống nhất với tiền tố cho ngắn gọn)

- Về vấn đề của bạn, Hatch là đối tượng khó chịu, với khả năng của mình thì chỉ giúp bạn được ở mức thực hiện thao tác trim + Hatch lại giúp bạn thôi.

Lệnh : brh

Thao tác : Chọn Pline chia, Pick vào 1 phía của miếng Hatch

(defun c:brh ()
(grtext -1 "Free Lisp From Cadviet @Ketxu")
(setq Pline (car (entsel "\n Pick vao Pline"))
  e (entsel "\nPick vao vung Hatch ")
     hObj (car e)
  pt (cadr e)
)
(command ".trim"  Pline "" pt "" "-hatch" pt "" "_MATCHPROP" hObj (entlast) ""))

 

 

 

Oh! đc rồi thanks bạn ketxu nhiều thế là đc rồi, mình chỉ cần đến thế thôi.^^

<<

Lệnh GIAO dưới đây sẽ vẽ các điểm point vào giao điểm của 2 đối tượng.

 

(defun c:giao ()
 (defun GiaoDT	(ent1 ent2)
   (setq ob1...
>>

Lệnh GIAO dưới đây sẽ vẽ các điểm point vào giao điểm của 2 đối tượng.

 

(defun c:giao ()
 (defun GiaoDT	(ent1 ent2)
   (setq ob1 (vlax-ename->vla-object ent1)
  ob2 (vlax-ename->vla-object ent2)
   )
   (setq g (vlax-variant-value
      (vla-IntersectWith ob1 ob2 acExtendNone)
    )
   )
   (if	(/= (vlax-safearray-get-u-bound g 1) -1)
     (setq g (vlax-safearray->list g))
     (setq g nil)
   )
   (if	g
     (progn
(setq kq nil
      sd (fix (/ (length g) 3))
)
(repeat	sd
  (setq	kq (append kq (list (list (car g) (cadr g) (caddr g))))
	g  (cdddr g)
  )
)
kq
     )
     nil
   )
 )
 (setq ent1 (car (entsel "\nVao dt1: ")))
 (redraw ent1 3)
 (setq ent2 (car (entsel "\nVao dt2: ")))
 (redraw ent1 4)
 (setq giao (giaodt ent1 ent2))
 (if giao
   (foreach pp	giao
     (entmake (list (cons 0 "POINT") (cons 10 pp)))
   )
   (alert "2 doi tuong khong giao nhau!")
 )
 (princ)
)

 

Nhờ Bác 'Nguyen Hoanh và các bạn sửa giúp mình lisp này một chút;

khi gõ lệnh lisp sẽ tự tìm tất cả các giao điểm và đánh dấu point vào đó

(Cụ thể là tìm các đoạn giao của 2 layer)

Cám ơn rất nhiều !

<<

Em đồng ý, dù ai viết về vấn đề dù nhỏ nhất cũng cần nhìn nhận mọi khía cạnh điều mình hỏi. Lần này hay không bằng hên nên chẳng...

>>

Em đồng ý, dù ai viết về vấn đề dù nhỏ nhất cũng cần nhìn nhận mọi khía cạnh điều mình hỏi. Lần này hay không bằng hên nên chẳng may viết đúng ý bạn hanam1210, e cũng quên béng mất là các đường nó không bằng nhau, ngại quá ^^

 

Bạn nhìn theo cái này, cần thay chỗ nào mình đều ghi chú rồi tự sửa nhé

 

(defun c:tlt(/ eLine curve pt i j len dsttmp)
(vl-load-com)
(or #dist (setq #dist 10)) ; 10 = Khoang cach mac dinh
(setq #dist (cond ((getdist (strcat "\n D  <" (vl-princ-to-string #dist) " > :")))(#dist)))
(defun eLine (p1 P isFull / p2 col)
(if isFull
(setq p2 P col 1) ;1 = Mau cua Line full
(setq p2 (polar p1 (angle p1 P) (/ (distance p1 P) 2)) col 8) ; 8 = Mau cua Line nua
)
(entmake
 (list (cons 0 "LINE")(cons 10 p1)
 (cons 11 p2)(cons 62 col)
 (cons 8 "0") ;0 = Layer cua Duong Taluy
 )
)
)
;;Doan duoi nay khong can de y
(while
(and
(setq curve  (car(entsel "\nPath curve :")))
(wcmatch (cdadr (entget curve)) "*LINE,ARC")
(setq pt (getpoint "\n P :"))
(setq i -2 j -1 len (vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve)))
)
(progn
(while (< (setq dsttmp (* (setq i (+ i 2)) #dist)) len) (eLine (vlax-curve-getPointAtDist curve dsttmp) pt T))
(while (< (setq dsttmp (* (setq j (+ j 2)) #dist)) len) (eLine (vlax-curve-getPointAtDist curve dsttmp) pt nil))
)
))

Cảm ơn bác KETXU nhé. Lisp chạy rất chuẩn. Thế là diễn đàn mình có thêm một kiểu rải taluy nữa. Kiểu rải này đúng ở các góc của đường đắp. Hoặc ở phần giao của đường nhánh với đường chính ( Đắp )

<<

sau mấy ngày cặm cụi mình viết theo ý bạn đây:

(defun c:mc(/ ten p1 p2 y1 x1 cd rd nt nd pit pig pid cao tl bl tzo tt td lt...
>>

sau mấy ngày cặm cụi mình viết theo ý bạn đây:

(defun c:mc(/ ten p1 p2 y1 x1 cd rd nt nd pit pig pid cao tl bl tzo tt td lt lst l20t tzo olds pp ptl olay)
 (setq p1 (getpoint "\nchon diem 1: ")
       olds (getvar "osmode")
cd (getdist "\nchieu cao dam: ")
rd (getdist "\nchieu rong dam: ")
nt (getint "\nso luong thep tren: ")
pit (getstring "\nnhap duong kinh thep tren: ")
nd (getint "\nso luong thep duoi: ")
pid (getstring "\nnhap duong kinh thep duoi: ")
pig (getstring "\nnhap duong kinh thep dai: ")
cao (getstring "\nnhap cao do dam: ")
tl (getint "\nnhap ty le 1: ")
ten (getstring "\nnhap ten mat cat: ")
x1 (car p1)
y1 (cadr p1)
bl (getvar "dimdli")
tzo (getvar "textsize")
       olay (getvar "clayer")
)
 (setvar "osmode" 0)
 (setq p2 (list (+ x1 rd) (+ y1 cd))
)
 (command "layer" "n" "beam" "c" "2" "beam" "l" "continuous" "beam" "s" "beam" "")
 (command "rectang" p1 p2)
 (command "layer" "n" "rbar" "c" "7" "rbar" "l" "continuous" "rbar" "s" "rbar" "")
 (command "offset" "20" (entlast) (list (+ x1 20) (+ y1 20)) "")
 (command "fillet" "r" "10")
 (command "fillet" "p" "l")
 (command "change" "l" "" "p" "LA" "rbar" "")
 (command "line" (list (+ x1 37.0711) (- (+ y1 cd) 22.9289)) "@40<-45" "")
 (command "offset" "20" (entlast) p1 "")
 (command "layer" "n" "steel" "c" "2" "steel" "l" "continuous" "steel" "s" "steel" "")
 (command "donut" "0" "20" (list (+ x1 30) (-(+ y1 cd) 30)) "")
 (setq tt (entlast))
 (command "copy" tt "" p1 (strcat"@0," (rtos (- 60 cd)))"")
 (setq td (entlast))
 (command "array" tt "" "r" "1" nt (/ (- rd 60) (- nt 1)))
 (command "array" td "" "r" "1" nd (/ (- rd 60) (- nd 1)))
 (command "layer" "n" "dim" "c" "7" "dim" "l" "continuous" "dim" "s" "dim" "")
 (command "dimlinear" p1 (list x1 (cadr p2)) (strcat"@-" (rtos(* bl tl))",0"))
 (command "dimlinear" p2 (list x1 (cadr p2)) (strcat"@0," (rtos(* bl tl))))
 (command "solid" (list (- x1 (* 6 tl)) (cadr p2)) (list (- x1 (* 3.5 tl)) (+(cadr p2) (* tl 2.5))) (list (- x1 (* 8.5 tl)) (+(cadr p2) (* tl 2.5))) "" "")
 (setvar "textsize" (* tl 2.5))
 (command "layer" "n" "text 2.5" "c" "2" "text 2.5" "l" "continuous" "text 2.5" "s" "text 2.5" "")
 (command "text" (list (- x1 (* 10.5 tl)) (+(cadr p2) (* tl 3))) "" "" cao)
 (command "layer" "s" "dim" "")
 (command "qleader" (list (+ x1 30) (-(cadr p2)30)) (strcat "@0," (rtos (* 4 tl))) (strcat "@" (rtos (+ rd (* 6 tl))) ",0") nil)
 (setq lt (entlast)
l20t (nth 20(entget lt))
)
 (repeat (- nt 1)
   (command "copy" lt "" p1 (strcat "@" (rtos (/ (- rd 60) (- nt 1))) ",0") "")
   (setq lt (entlast)
  lst (entget lt))
   (setq lst (subst l20t (nth 20 lst) lst))
   (entmod lst)
   )
 (command "layer" "s" "text 2.5" "")
 (command "text" "j" "ML" (list (+ (cadr l20t)(* 1.25 tl)) (caddr l20t) (cadddr l20t)) "" "" (strcat (rtos nt) "%%c" pit))
 (command "layer" "s" "dim" "")
 (command "qleader" (list (+ x1 30) (+ y1 30)) (strcat "@0,-" (rtos (* 4 tl))) (strcat "@" (rtos (+ rd (* 6 tl))) ",0") nil)
(setq lt (entlast)
l20t (nth 20(entget lt))
)
 (repeat (- nd 1)
   (command "copy" lt "" p1 (strcat "@" (rtos (/ (- rd 60) (- nd 1))) ",0") "")
   (setq lt (entlast)
  lst (entget lt))
   (setq lst (subst l20t (nth 20 lst) lst))
   (entmod lst)
   )
 (setvar "clayer" "text 2.5")
 (command "text" "j" "ML" (list (+ (cadr l20t)(* 1.25 tl)) (caddr l20t) (cadddr l20t)) "" "" (strcat (rtos nd) "%%c" pid))
 (command "layer" "s" "dim" "")
 (command "qleader" (list (-(car p2)20) (/(+ y1 (cadr p2)) 2)) (list (cadr l20t) (/(+ y1 (cadr p2))2)) nil)
 (setvar "clayer" "text 2.5")  
 (command "text" "j" "ML" (list (+ (cadr l20t)(* 1.25 tl)) (/(+ y1 (cadr p2))2)) "" "" (strcat "%%c" pig))
 (setq pp (list (/(+ x1 (car p2))2) (- y1 (* 14 tl))))
 (setq ptl (list (car pp) (-(cadr pp)(* 3.5 tl))))
 (setvar "clayer" "text 2.5")
 (command "text" "j" "C" ptl "" "" (strcat "TL: " (rtos tl)))
 (command "layer" "n" "text 5.0" "c" "1" "text 5.0" "l" "continuous" "text 5.0" "s" "text 5.0" "")
 (setvar "textsize" (* tl 5))
 (command "text" "j" "BC" pp "" "" (strcat "%%uMC " ten))  
 (setvar "osmode" olds)
 (setvar "textsize" tzo)
 (setvar "clayer" olay)
 (princ)  
 )

bạn chú ý là lúc nhập tỷ lệ VD tl là 1/20 bạn chỉ nhập 20 thôi

còn text là theo ý bạn mình cho text có chiều cao là 2.5 và 5

màu layer là mình tạo theo mẫu của bạn.

khi bạn muốn thể hiện mc ở tl nào thì bạn phải chuyển dim sang tl tương ứng trước cũng như bạn phải chọn text stlye hiện hành. và trong dim phải có Baseline (như ban đầu bạn yêu cầu)

 

 

 

cảm ơn anh lp_hai nhiều lắm!

 

cái lisp vẫn còn chỗ này khi ghi chú bị sai. anh xem rồi sửa lại dùm em chút nha!

 

<<

 

Lsp của nhoc phải nhấp ngay cái dimtext thì nó mới làm.

Sửa cái lsp của chủ thớt.

 

>>

 

Lsp của nhoc phải nhấp ngay cái dimtext thì nó mới làm.

Sửa cái lsp của chủ thớt.

 

(defun changecolor (en col)
  (if (= (cdr (assoc 0 (entget en))) "DIMENSION")
    (vlax-for item (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
  (cdr (assoc 2 (entget en))))
      (if (= "AcDbMText" (vla-get-ObjectName item)) (vla-put-Color item col))
    )
    (command "change" en "" "P" "c" col "")
  )
)
 
(defun c:cl (/ m ss)
  (command "undo" "be") (setvar 'cmdecho 0)
  (princ "\nChon doi tuong muon doi mau:")
  (setq ss (ssget))
  (princ "\nChon mau muon doi :") (setq m (acad_colordlg 7))
  (mapcar '(lambda (x) (changecolor x m)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (vl-cmdf "regen")
  (command "undo" "end") (setvar 'cmdecho 1)
  (setvar "MODEMACRO" "**KTS_DUY**")
  (princ)
)
 
(defun c:ck (/ m ss)
  (command "undo" "be") (setvar 'cmdecho 0)
  (princ "\nChon doi tuong muon doi mau:")
  (setq ss (ssget))
  (setq m (getint "\nChon mau muon doi: "))
  (mapcar '(lambda (x) (changecolor x m)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (vl-cmdf "regen")  
  (command "undo" "end") (setvar 'cmdecho 1)
  (setvar "MODEMACRO" "**KTS_DUY**")
  (princ)
)
 

Cám ơn bạn nhoclangbat nhiệt tình giúp đỡ

Lisp này là được rồi :D

 

Sửa chút :

(defun c:cl (/ ss m)
(command "undo" "be")
(if (setq ss (ssget)) 
(progn            (setq m...
>>

 

Sửa chút :

(defun c:cl (/ ss m)
(command "undo" "be")
(if (setq ss (ssget)) 
(progn            (setq m (acad_colordlg 7))                                                     
        (command "change" ss "" "P" "c" m "")
        (command "._DIMOVERRIDE" "dimclrt" m "" (ssget "P" '((0 . "DIMENSION"))) "" )
  ))
(command "undo" "end")
(princ))

 

Li sp này ngon rồi. Mình cám ơn nhiều nhé :D

<<

 

Cách khác : 

(defun c:cl (/ m ss)
  (if (and (setq ss (ssget))
	   (setq m (acad_colordlg 7)))
    (foreach obj...
>>

 

Cách khác : 

(defun c:cl (/ m ss)
  (if (and (setq ss (ssget))
	   (setq m (acad_colordlg 7)))
    (foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (if (wcmatch (vla-get-objectname obj) "*Dimension")
	(progn(vla-put-TextColor obj m)(vla-update obj))
	(vla-put-Color obj m)  )  )    )
  (princ))

 

Lisp này là ngon lành rồi. 

Mình cám ơn nhiều nhé

<<

Thằng Mleader nó lại chẳng giống ai nhỉ ^^. bạn sửa lại như vầy (tách ra cho dễ)

(defun C:dc()
(vl-load-com)
(setq...
>>

Thằng Mleader nó lại chẳng giống ai nhỉ ^^. bạn sửa lại như vầy (tách ra cho dễ)

(defun C:dc()
(vl-load-com)
(setq txtcol 2 lcol 30) 
(setq colorObj (vla-getinterfaceobject (vlax-get-acad-object) "AutoCAD.AcCmColor.17"))   
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "DIMENSION,LEADER")))))))
(if (vlax-property-available-p ent 'TextColor)
(vla-put-Textcolor ent txtcol)
)
(if (vlax-property-available-p ent 'DimensionLinecolor)
(vla-put-DimensionLinecolor ent lcol)
)
(if (vlax-property-available-p ent 'ExtensionLinecolor)
(vla-put-ExtensionLinecolor ent lcol)
)

)
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "MULTILEADER")))))))    
   (vla-put-ColorIndex colorObj ldrcol) 
   (vla-put-LeaderLineColor ent colorObj)
    (vla-put-ColorIndex colorObj txtcol) 
   (vla-put-TrueColor ent colorObj)
)
)

 

Khi chạy thì e nhận được thông báo lỗi như sau :

Command: dc

error: Automation Error. Problem in loading application

<<

Chào tnmtpc

Bạn sử dụng Lisp này thử nhé :

(defun c:MPT(/ ss ss2 i j lis Z p p2 pkt ent L caoZ)
;copyright by Tue_NV
(setq ss (ssget "X" '((0 ....
>>

Chào tnmtpc

Bạn sử dụng Lisp này thử nhé :

(defun c:MPT(/ ss ss2 i j lis Z p p2 pkt ent L caoZ)
;copyright by Tue_NV
(setq ss (ssget "X" '((0 . "TEXT") (8 . "el"))) i 0 j 0 lis (list) Z (list))
(setq ss2 (ssget "X" '((0 . "POINT") )) )
(while (< i (sslength ss))
(setq p (cdr(assoc 10 (entget (ssname ss i)))))
(setq lis (append lis 
		(list (list (round (car p) 3) (round (cadr p) 3)) )
	  )
)
(setq Z (append Z (list (caddr p)))
)
(setq i (1+ i))
)
(while (< j (sslength ss2))
(setq ent (ssname ss2 j))
(setq p2 (cdr(assoc 10 (entget ent))))
(setq pkt (list (round (car p2) 3) (round (cadr p2) 3)) )
(if (setq L (member pkt lis))
	(progn 
		(setq caoZ (nth (- (length lis) (length L)) Z) )
		(command "move" ent "" '(0 0 0) 
				        (list 0 0 caoZ)
		)
  	)
)
(setq j (1+ j))
)
)
;
(defun round(so tp)
(setvar "dimzin" 0)
(atof (rtos so 2 tp))
)

Cám ơn tue_NV nhiều lắm, đúng là cực nhanh, trúng ý mình rồi. Tue_NV có thể chỉnh sửa lại một chút để tiện cho người sử dụng thao tác, đề phòng trường hợp một point có hai text số khác nhau mà trong đó có một text không phải là giá trị độ cao. Cách thao tác như sau:

nhập lệnh->yêu cầu chọn lớp chứa các point bằng cách chọn một point trên bản vẽ-> yêu cầu chọn lớp chứa các text độ cao bằng cách chọn một text độ cao -> enter

Một lần nữa cám ơn tue_NV nhiều

<<

Bạn thử xem code này được không. Nó array luôn 1 dòng bạn chọn.

Mình quên cho array luôn cái line (dòng kẻ). bạn thêm vào nhé

 

;Lisp by nPham...
>>

Bạn thử xem code này được không. Nó array luôn 1 dòng bạn chọn.

Mình quên cho array luôn cái line (dòng kẻ). bạn thêm vào nhé

 

;Lisp by nPham - www.cadviet.com
(defun copy+ (ss row / ename ent i number str p ssnew)  
(setq j 0)
(setq ssnew (ssadd))
(while 
	(setq ename (ssname ss j))  
(setq ent (entget ename))
(setq str (cdr (assoc 1 ent)))
(setq i 1)
	(while (< i (+ (strlen str) 1))
	  (if (not (wcmatch (substr str i) "*@*"))
		(progn
		  (setq number (substr str i))
		  (setq i 10000)
		  )
			(setq i (1+ i))
	  )
  )
   (if number (setq str (strcat (substr str 1 (- (strlen str) (strlen number)))
			(if (vl-string-search  " " number) " " "")
			(itoa (+ (atoi number) 1)))))	
	(setq ent (subst (cons 1 str) (assoc 1 ent) ent))	  
	(setq p  (cdr (assoc 10 ent)))
	(setq ent (subst (cons 10 (polar p (* pi 1.5) row)) (assoc 10 ent) ent))
  (setq p  (cdr (assoc 11 ent)))
  (setq ent (subst (cons 11 (polar p (* pi 1.5) row)) (assoc 11 ent) ent))
	(entmake ent)
	(entupd ename)	  
	(setq ssnew (ssadd (entlast) ssnew ))
 (setq j (1+ j))
 )
 ssnew 
)

(defun c:ar+ (/ ss num row)
(setq ss (ssget (list (cons 0 "TEXT"))))
(setq num (getint "\nSo luong dong:"))
(setq row (getint "\nKhoang cach dong:"))

(repeat num (setq ss (copy+ ss row)))
(redraw)  
(princ)
)

 

Bạn ơi ko ar khoảng cách lẻ được à, ví dụ khoảng cách dòng là 10,4 chẳng hạn?

<<

Dạo này ít người yêu cầu viết lisp quá nên mình viết nghịch chơi cái lisp này.

Ngày xưa các bác chắc cũng từng thương thầm chộm nhớ một người nào...

>>

Dạo này ít người yêu cầu viết lisp quá nên mình viết nghịch chơi cái lisp này.

Ngày xưa các bác chắc cũng từng thương thầm chộm nhớ một người nào đấy. Muốn viết thư cho người ta mà lại e ngại không biết ý người ta thế nào.

Thế là các bác này nghĩ ra cái chò viết thư bằng số.

Ý nghĩa là nếu người ta có thích mình thì sẽ tìm cách mày mò để dịch (điều này kiểm tra luôn IQ của người đó). Nếu người đó không thích mình thì vèo một cái bay vào sọt rác.

Code đây (dành cho các bác nhát gan). Chú ý chữ để dịch phải không có dấu.

;; free lisp from cadviet.com
(defun c:chutoso()
(setq lis_chu '("A" "B" "C" "D" "E" "G" "H" "I" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "X" "Y" " "))
(setq lis_so '("4" "13" "6" "15" "3" "9" "76" "1" "16" "1" "111" "11" "0" "10" "2" "12" "5" "7" "22" "21" "96" "27"))
(setq name (car (entsel "\nChon chu la text hay mtext can chuyen sang so")))
(setq ent (entget name))
(setq loai (cdr (assoc 0 ent)))
(if (or (= loai "TEXT") (= loai "MTEXT"))
(progn
 (setq chu (strcase (cdr (assoc 1 ent))))
  (setq L (strlen chu) i L ma nil)
  (Repeat L
   (if (= (vl-position (substr chu i 1) lis_chu) 22)
(progn
   (setq kt " ")
   (setq ma (append (list kt) ma))
)
(progn    
   (setq kt (atoi (nth (vl-position (substr chu i 1) lis_chu) lis_so)))
    (setq ma (append (list (rtos kt 2 0)) ma))
)
)
(setq i (1- i))
)
(setq dct (getpoint "\nchon diem chen chu da dich")
chumoi (subst (cons 10 dct) (assoc 10 ent) ent)
chumoi (subst (cons 1 (apply 'strcat ma)) (assoc 1 chumoi) chumoi)
)
(entmake chumoi)
)
(alert (strcat "doi tuong ma cac bac chon la : " loai " khong phai la text hay mtext"))
)
)

Bạn giúp mình việc chuyển số thành chử. Cám ơn.

<<

 

(defun C:hhh (/ CURCMD ATT OLDVAL TEXT)

Lisp đầu tiên. Tên lệnh HA.

Sẽ thay đổi tấc cả block thuộc tính. Chọn...

>>

 

(defun C:hhh (/ CURCMD ATT OLDVAL TEXT)

Lisp đầu tiên. Tên lệnh HA.

Sẽ thay đổi tấc cả block thuộc tính. Chọn thuộc tính và nhập chiều cao

;;Thay doi chieu cao thuoc tinh (attributes) Block

;;Viet boi Duong Ba Diep - hochoaivandot

;;www.cadonline.duyxuyen.vn

(defun PUT-GC (VALUE GROUP ENTITY / PROPERTIES)

(setq PROPERTIES (entget ENTITY))

(setq PROPERTIES (subst (cons GROUP VALUE) (assoc GROUP PROPERTIES) PROPERTIES))

(entmod PROPERTIES)

) ;_ end defun

(defun maklis ()  

(setq lis_hex '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F"))  

(setq lis_dec '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12" "13" "14" "15")) 

)

(defun GET-GC (GROUP ENTITY) (cdr (assoc GROUP (entget ENTITY))))

(defun 16t10 (hex / lis_hex lis_dec L kt S i j)

(maklis)

  (setq L (strlen hex) i L j 0 S 0)

  (Repeat L

    (setq kt (atoi (nth (vl-position (substr hex i 1) lis_hex) lis_dec)))

    (setq S (+ S (* (expt 16 j ) kt)))

    (setq i (1- i))

    (setq j (1+ j))

)

  (itoa S)

)

(defun 10t16 (dec / lis_hex lis_dec hex L dec1 i kt)

(maklis)

  (setq dec (fix dec))

  (setq hex (strcat))

  (setq L (1+ (fix (/ (log dec) (log 16)))) i (1- L) dec1 dec)

  (Repeat L

    (setq kt (nth (vl-position (itoa (fix (/ dec1 (expt 16 i)))) lis_dec) lis_hex))

(setq hex (strcat hex kt))

    (setq dec1 (- dec1 (* (expt 16 i ) (fix (/ dec1 (expt 16 i))))))

    (setq i (1- i))

)

  hex

)

(defun entback (ena / ena2 han1)

(setq han1 (GET-GC 5 ena))

(setq ena2 (handent (10t16 (- (atof (16t10 han1)) 1))))

)

(defun C:ha (/ *ERROR* ATT conti CURCMD e enn h i na OLDVAL ss tag)

(setq *ERROR* (defun MY-ERR (MSG)

(cond ((= MSG "Function cancelled") (princ "\t\tUser abort"))

(t (progn (princ MSG) (princ)))

) ;_ end cond

(setq *ERROR* NIL)

(princ)

) ;_ defun

) ;_ end setq

(setq CURCMD (getvar "CMDECHO"))

(setvar "CMDECHO" 0)

(while (/= (setq ATT (car (nentselp "\nChon ATT muon Edit H: "))) NIL)

(if (= (GET-GC 0 ATT) "ATTRIB")

(progn

(setq OLDVAL (GET-GC 40 ATT))

(setq tag (GET-GC 2 ATT))

(setq h (getreal (strcat "\Nhap chieu cao chu <" (rtos OLDVAL 2 2) ">:")))

(if (not h) (setq h OLDVAL))

(while (= (GET-GC 0 (setq ATT (entback ATT))) "INSERT")

(setq na (GET-GC 2 ATT))

(setq ss (ssget "X" (list (cons 0 "INSERT") (cons 2 na) (cons 66 1))))

)

(repeat (setq i (sslength ss))

(setq e (ssname ss (setq i (1- i))) conti T)

(setq enn e)

(while conti

(if (and (setq enn (EntNext enn)) (= "ATTRIB" (GET-GC 0 enn)) (= (GET-GC 2 enn) tag))

(progn

(setq conti nil)

(PUT-GC h 40 enn)

)

)

)

)

)

)

(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acActiveViewport)

) ;_ end while

 

(setvar "CMDECHO" CURCMD)

(setq *ERROR* NIL)

(princ "Viet boi Duong Ba Diep")

(princ)

) ;_ end defun

 

Lisp thứ 2. Chỉ thay đổi chiều cao 1 thuộc tính trong 1 block. Lisp này cũng có tác dụng với Text và Dim

(defun C:hhh (/ CURCMD ATT OLDVAL TEXT)

 

(setq *ERROR* (defun MY-ERR (MSG)

 

(cond ((= MSG "Function cancelled") (princ "\t\tUser abort"))

 

(t (progn (princ MSG) (princ)))

 

) ;_ end cond

 

(setq *ERROR* NIL)

 

(princ)

 

) ;_ defun

 

) ;_ end setq

 

(defun GET-GC (GROUP ENTITY) (cdr (assoc GROUP (entget ENTITY))))

 

(defun PUT-GC (VALUE GROUP ENTITY / PROPERTIES)

(setq PROPERTIES (entget ENTITY))

(setq PROPERTIES (subst (cons GROUP VALUE) (assoc GROUP PROPERTIES) PROPERTIES))

(entmod PROPERTIES)

) ;_ end defun

 

(setq CURCMD (getvar "CMDECHO"))

 

(setvar "CMDECHO" 0)

 

(while (/= (setq ATT (car (nentselp "\nCh\U+1ECDn thu\U+1ED9c tính \U+0111\U+1EC3 Edit: "))) NIL)

 

(if (or (= (GET-GC 0 ATT) "ATTRIB")

 

(= (GET-GC 0 ATT) "TEXT")

 

(= (GET-GC 0 ATT) "MTEXT")

 

(= (GET-GC 0 ATT) "DIMENSION")

 

) ;_ end or

(progn

(setq OLDVAL (GET-GC 40 ATT))

(setq h (getreal (strcat "\Nhap chieu cao chu <" (rtos OLDVAL 2 2) ">:")))

(if (not h) (setq h OLDVAL))

(PUT-GC h 40 ATT)

)

)

(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acActiveViewport)

) ;_ end while

(setvar "CMDECHO" CURCMD)

(setq *ERROR* NIL)

(princ)

) ;_ end defun

(defun C:hhh (/ CURCMD ATT OLDVAL TEXT)

 

(setq *ERROR* (defun MY-ERR (MSG)

 

(cond ((= MSG "Function cancelled") (princ "\t\tUser abort"))

 

(t (progn (princ MSG) (princ)))

 

) ;_ end cond

 

(setq *ERROR* NIL)

 

(princ)

 

) ;_ defun

 

) ;_ end setq

 

(defun GET-GC (GROUP ENTITY) (cdr (assoc GROUP (entget ENTITY))))

 

(defun PUT-GC (VALUE GROUP ENTITY / PROPERTIES)

(setq PROPERTIES (entget ENTITY))

(setq PROPERTIES (subst (cons GROUP VALUE) (assoc GROUP PROPERTIES) PROPERTIES))

(entmod PROPERTIES)

) ;_ end defun

 

(setq CURCMD (getvar "CMDECHO"))

 

(setvar "CMDECHO" 0)

 

(while (/= (setq ATT (car (nentselp "\nCh\U+1ECDn thu\U+1ED9c tính \U+0111\U+1EC3 Edit: "))) NIL)

 

(if (or (= (GET-GC 0 ATT) "ATTRIB")

 

(= (GET-GC 0 ATT) "TEXT")

 

(= (GET-GC 0 ATT) "MTEXT")

 

(= (GET-GC 0 ATT) "DIMENSION")

 

) ;_ end or

(progn

(setq OLDVAL (GET-GC 40 ATT))

(setq h (getreal (strcat "\Nhap chieu cao chu <" (rtos OLDVAL 2 2) ">:")))

(if (not h) (setq h OLDVAL))

(PUT-GC h 40 ATT)

)

)

(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acActiveViewport)

) ;_ end while

(setvar "CMDECHO" CURCMD)

(setq *ERROR* NIL)

(princ)

 

 

Mới làm nhanh chưa test. Bạn dùng nếu  có gì thì reply mình fix nhé

 

(defun C:hhh (/ CURCMD ATT OLDVAL TEXT)

(setq *ERROR* (defun MY-ERR (MSG)

(cond ((= MSG "Function cancelled") (princ "\t\tUser abort"))

     (t (progn (princ MSG) (princ)))

) ;_ end cond

(setq *ERROR* NIL)

(princ)

      ) ;_ defun

) ;_ end setq

(defun GET-GC (GROUP ENTITY) (cdr (assoc GROUP (entget ENTITY))))

(defun PUT-GC (VALUE GROUP ENTITY / PROPERTIES)

(setq PROPERTIES (entget ENTITY))

(setq PROPERTIES (subst (cons GROUP VALUE) (assoc GROUP PROPERTIES) PROPERTIES))

(entmod PROPERTIES) 

(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acActiveViewport)

) ;_ end defun

(setq CURCMD (getvar "CMDECHO"))

(setvar "CMDECHO" 0)

(while (/= (setq ATT (car (nentselp "\nCh\U+1ECDn thu\U+1ED9c tính \U+0111\U+1EC3 Edit: "))) NIL)

(if (or (= (GET-GC 0 ATT) "ATTRIB")

(= (GET-GC 0 ATT) "TEXT")

(= (GET-GC 0 ATT) "MTEXT")

(= (GET-GC 0 ATT) "DIMENSION")

) ;_ end or

(progn

(setq OLDVAL (GET-GC 40 ATT))

(setq h (getreal (strcat "\Nhap chieu cao chu <" (rtos OLDVAL 2 2) ">:")))

(if (not h) (setq h OLDVAL))

(PUT-GC h 40 ATT)

)

)

) ;_ end while

(setvar "CMDECHO" CURCMD)

(setq *ERROR* NIL)

 (princ)

) ;_ end defun

(setq *ERROR* (defun MY-ERR (MSG)

(cond ((= MSG "Function cancelled") (princ "\t\tUser abort"))

     (t (progn (princ MSG) (princ)))

) ;_ end cond

(setq *ERROR* NIL)

(princ)

      ) ;_ defun

) ;_ end setq

(defun GET-GC (GROUP ENTITY) (cdr (assoc GROUP (entget ENTITY))))

(defun PUT-GC (VALUE GROUP ENTITY / PROPERTIES)

(setq PROPERTIES (entget ENTITY))

(setq PROPERTIES (subst (cons GROUP VALUE) (assoc GROUP PROPERTIES) PROPERTIES))

(entmod PROPERTIES) 

(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acActiveViewport)

) ;_ end defun

(setq CURCMD (getvar "CMDECHO"))

(setvar "CMDECHO" 0)

(while (/= (setq ATT (car (nentselp "\nCh\U+1ECDn thu\U+1ED9c tính \U+0111\U+1EC3 Edit: "))) NIL)

(if (or (= (GET-GC 0 ATT) "ATTRIB")

(= (GET-GC 0 ATT) "TEXT")

(= (GET-GC 0 ATT) "MTEXT")

(= (GET-GC 0 ATT) "DIMENSION")

) ;_ end or

(progn

(setq OLDVAL (GET-GC 40 ATT))

(setq h (getreal (strcat "\Nhap chieu cao chu <" (rtos OLDVAL 2 2) ">:")))

(if (not h) (setq h OLDVAL))

(PUT-GC h 40 ATT)

)

)

) ;_ end while

(setvar "CMDECHO" CURCMD)

(setq *ERROR* NIL)

 (princ)

) ;_ end defun

cám ơn bạn hochoaivandot đã giúp đỡ.

mình đã thử lisp của bạn nhưng mình thấy lisp chỉ cho chọn 1 thuộc tính của 1 block, như vậy thì cũng không làm nhanh được. mình đang cần phải sửa toàn bộ các att của nhiều block cơ

Lisp mình muốn là thế này:

- gõ lệnh 

- chọn nhiều block thuộc tính để chỉnh sửa

- trong block đó có những thuộc tính nào thì sẽ liệt kê tên nó ra để mình lựa chọn chiều cao cho nó

Mình có update 1 file mẫu lên có 2 block thuộc tính nhưng là dynamic block. nếu có thể áp dụng được cho block này thì hay quá

 

 

 

 

 

 

 

 http://www.cadviet.com/upfiles/3/9928_thay_doi_chieu_cao_block_thuoc_tinh.dwg

<<

Ôi... Cái End_point... Của bạn đây:

(defun c:APO (/ i ss ent obj S-point E-point add_point_object...
>>

Ôi... Cái End_point... Của bạn đây:

(defun c:APO (/ i ss ent obj S-point E-point add_point_object ename)

(defun add_point_object (obj / make_po)

(defun make_po (point)

(entmakex (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 point))))

(setq obj (vlax-ename->vla-object ent)

S-point (vlax-curve-getstartpoint obj)

E-point (vlax-curve-getendpoint obj))

(cond ((or (eq ename "CIRCLE") (eq ename "ELLIPSE") (eq ename "RAY")) (make_po S-point))

(t (make_po E-point) (make_po S-point))))

;; main

(if (setq i 0

ss (ssget "_:L" '((0 . "*LINE,ARC,ELLIPSE,RAY,CIRCLE")))

n (sslength ss))

(progn (while (< i n)

(setq ent (ssname ss i)

ename (cdr (assoc 0 (entget ent))))

(add_point_object obj)

(setq i (1+ i)))))

(princ))

Lisp chạy ổn, 

nhưng cách viết và sử dụng hàm con (tên biến) trông như đánh đố đấy nhỉ ???

<<

Download lisp

Filename: 362320_apo.lsp

Sửa lại và xin các bác cho ý kiến.

(defun c:APO (/ i ss ent obj S-point E-point add_point_object ename)

(defun add_point_object (obj / make_po)

(defun make_po (point)

(entmakex

(list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 point) (cons 62 1))))

(setq obj (vlax-ename->vla-object ent)

S-point (vlax-curve-getstartpoint obj)

E-point (vlax-curve-getendpoint...

Sửa lại và xin các bác cho ý kiến.

(defun c:APO (/ i ss ent obj S-point E-point add_point_object ename)

(defun add_point_object (obj / make_po)

(defun make_po (point)

(entmakex

(list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 point) (cons 62 1))))

(setq obj (vlax-ename->vla-object ent)

S-point (vlax-curve-getstartpoint obj)

E-point (vlax-curve-getendpoint obj))

(cond ((or (eq ename "CIRCLE") (eq ename "RAY")) (make_po S-point))

((or(eq ename "ELLIPSE") (eq ename "LWPOLYLINE"))

(if (and(eq (car S-point) (car E-point))(eq (cadr S-point) (cadr E-point)))

(make_po S-point)

(progn (make_po S-point) (make_po E-point))))

(t (make_po E-point) (make_po S-point))))

;; main

(if (setq i 0

ss (ssget "_:L" '((0 . "*LINE,ARC,ELLIPSE,RAY,CIRCLE")))

n (sslength ss))

(progn (while (< i n)

(setq ent (ssname ss i)

ename (cdr (assoc 0 (entget ent))))

(add_point_object obj)

(setq i (1+ i)))))

(princ))

Hy vọng là được (Khuyến mại thêm Textstyle): :D​

(defun c:eb (/ get-gc put-gc getvalue *error* att curcmd...
>>

Hy vọng là được (Khuyến mại thêm Textstyle): :D​

(defun c:eb (/ get-gc put-gc getvalue *error* att curcmd dcledittext dcl_id editext file_dcl hei oldhei oldval oldwid str wid dialog taolist

lststy possty sty)

(setq *error* (defun my-err (msg)

(cond ((= msg "function cancelled") (princ "\t\tuser abort"))

(t (progn (princ msg) (princ))))

(setq *error* nil)

(princ)))

(defun get-gc (group entity) (cdr (assoc group (entget entity))))

(defun put-gc (value group entity / properties)

(setq properties (entget entity))

(setq properties (subst (cons group value) (assoc group properties) properties))

(entmod properties))

(defun getvalue ()

(setq str (get_tile "text")

hei (atof (get_tile "hei"))

wid (atof (get_tile "wid"))

sty (atoi (get_tile "sty"))))

(defun taolist (kieu / kieu nl lkq)

(setq lkq '())

(setq nl (tblnext kieu t))

(while nl (setq lkq (append lkq (list (cdr (assoc 2 nl))))) (setq nl (tblnext kieu)))

lkq)

(vl-load-com)

(setq dcledittext (list

"edit: dialog {label = \"CHANGE TEXT PROPERTIES\";initial_focus = \"text\";"

":edit_box {label = \"String:\"; allow_accept = true; edit_width = 45; key = \"text\";}" ": row {"

":edit_box {label = \"Height:\"; allow_accept = true; edit_width = 8; key = \"hei\";}"

":edit_box {label = \"Width:\"; allow_accept = true; edit_width = 8; key = \"wid\";}"

":popup_list {allow_accept = true; edit_width = 12; key = \"sty\";}" "}" "spacer_1;" "ok_cancel;}"))

(setq curcmd (getvar "cmdecho"))

(setvar "cmdecho" 0)

(while (/= (setq att (car (nentselp "\nselect attribute for edit: "))) nil)

(if (or (= (get-gc 0 att) "ATTRIB") (= (get-gc 0 att) "TEXT"))

(progn (setq oldval (get-gc 1 att)

oldhei (rtos (get-gc 40 att) 2 (getvar 'LUPREC))

oldwid (rtos (get-gc 41 att) 2 2)

oldsty (get-gc 7 att)

lststy (taolist "STYLE")

possty (vl-position oldsty lststy))

(setq editext.dcl (vl-filename-mktemp "edittext.dcl")

file_dcl (open editext.dcl "w"))

(foreach ll dcledittext (write-line ll file_dcl))

(close file_dcl)

(if (> 0 (setq dcl_id (load_dialog editext.dcl)))

(progn (alert "not found file edittext.dcl") (exit)))

(if (not (new_dialog "edit" dcl_id))

(progn (alert "not found edit dialog") (exit)))

(set_tile "text" oldval)

(set_tile "hei" oldhei)

(set_tile "wid" oldwid)

(set_tile "sty" (rtos possty))

(start_list "sty" 3)

(mapcar 'add_list lststy)

(end_list)

(action_tile "accept" "(getvalue)(setq dialog 1)(done_dialog)")

(action_tile "cancel" "(setq dialog nil)")

(start_dialog)

(unload_dialog dcl_id)

(if (eq dialog 1)

(progn (put-gc str 1 att) (put-gc hei 40 att) (put-gc wid 41 att) (put-gc (nth sty lststy) 7 att))))

(princ "select attrib/text")))

(if editext.dcl

(vl-file-delete editext.dcl))

(setvar "cmdecho" curcmd)

(setq *error* nil)

(princ))

Lisp này có thêm chức năng đổi màu nữa thì Tuyệt !

<<

Download lisp

Filename: 380957_eb.lsp

 

Bạn thử cái này.

 

(defun C:LGT (/ obn Tkq Lob)
(setq obn (vlax-ename->vla-object (car (nentsel "\nChon doi...
>>

 

Bạn thử cái này.

 

(defun C:LGT (/ obn Tkq Lob)
(setq obn (vlax-ename->vla-object (car (nentsel "\nChon doi tuong nguon")))
Tkq (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-objectid obn)) ">%).TextString>%")
)
(while (setq obd (car (nentsel "\nChon text dich")))
(vla-put-textstring (vlax-ename->vla-object obd) Tkq)
)
(vl-cmdf "regen")
(princ)
)

hay quá cảm ơn bạn nhiều

<<