Mình cũng có tham khảo và code như sau:

;Doi layer LkUp thanh LkDn
(defun c:chon()
  (princ "\n Change Layer")
  (sssetfirst nil (ssget '((8 . "1"))))
  (setq sset (ssget))
(command "_.change" sset " " "P" "LA" "1a" " ")
(princ)
  );The End.

Mình muốn là: thực hiện lệnh > quét chọn > " " ... thì lisp sẽ giúp mình phân loại những đt thuộc layer đã định trước chuyển lần lượt sang những...

Mình cũng có tham khảo và code như sau:

;Doi layer LkUp thanh LkDn
(defun c:chon()
  (princ "\n Change Layer")
  (sssetfirst nil (ssget '((8 . "1"))))
  (setq sset (ssget))
(command "_.change" sset " " "P" "LA" "1a" " ")
(princ)
  );The End.

Mình muốn là: thực hiện lệnh > quét chọn > " " ... thì lisp sẽ giúp mình phân loại những đt thuộc layer đã định trước chuyển lần lượt sang những layer đích đã định trước.

- Nhưng code trên mình quét và lisp nhận được đt thuộc Layer "1" > " " ... thì bị lỗi sau:

Select objects: Specify opposite corner: 2 found

Select objects:  2 found


*Invalid selection*
Expects a point or 
Window/Last/Crossing/BOX/ALL/Fence/WPolygon/CPolygon/Group/Add/Remove/Multiple/P
revious/Undo/AUto/SIngle
; error: Function cancelled

Select objects:  Specify change point or :
No changeable object selected

Mong AE giải giúp dùm mình. THanks nhiều.

Thây yêu cầu cũng đơn giản nên mình viết nhanh cho bạn.

Tên lệnh vdc nhé

(defun dxf (code e) (cdr (assoc code (entget e))))
(defun MakeText (string point height)
(entmake (mapcar 'cons '(0 1 10 40) (list "TEXT" string point height)))
)
(defun C:vdc(/ h0 h ss i e pt pt_Insert cd_String)
(setvar "cmdecho" 0)
(if (not h0) (setq h0 2.0))
(setq h (getreal (strcat "\nNhap chieu cao <" (rtos h0 2 2) ">:")))
(if (not h) (setq h...

Thây yêu cầu cũng đơn giản nên mình viết nhanh cho bạn.

Tên lệnh vdc nhé

(defun dxf (code e) (cdr (assoc code (entget e))))
(defun MakeText (string point height)
(entmake (mapcar 'cons '(0 1 10 40) (list "TEXT" string point height)))
)
(defun C:vdc(/ h0 h ss i e pt pt_Insert cd_String)
(setvar "cmdecho" 0)
(if (not h0) (setq h0 2.0))
(setq h (getreal (strcat "\nNhap chieu cao <" (rtos h0 2 2) ">:")))
(if (not h) (setq h h0) (setq h0 h))
(setq ss (ssget (list (cons 0 "INSERT"))))
(repeat (setq i (sslength ss))
(setq
e (ssname ss (setq i (1- i)))
pt (dxf 10 e)
pt_Insert (list (car pt) (cadr pt))
cd_String (rtos (last pt))
)
(MakeText cd_String pt_Insert h)
)
(setvar "cmdecho" 1)
(princ "\nViet boi Hoc hoai van dot")
(princ)
)

Đang luyện nên mần đại cái này

Đưa lên đây để chờ đá :D :D :D

;dien cao do
(defun c:DCD( / i ss n ch o)
(setq ss (ssget (list (cons 2 "DCAOTH")))
	n (sslength ss)
	i 0)
(while (< i n)
(progn 
(setq ch (entget (ssname ss i))
	o (list (cadr (assoc 10 ch)) (caddr (assoc 10 ch))))
(if (= 0 (cdr (assoc 40 (tblsearch "Style" (getvar 'TEXTSTYLE)))))
(command ".text" "j" "c" o 2.5 0 (rtos (last (assoc 10 ch)) 2 2))
(command...
>>

Đang luyện nên mần đại cái này

Đưa lên đây để chờ đá :D :D :D

;dien cao do
(defun c:DCD( / i ss n ch o)
(setq ss (ssget (list (cons 2 "DCAOTH")))
	n (sslength ss)
	i 0)
(while (< i n)
(progn 
(setq ch (entget (ssname ss i))
	o (list (cadr (assoc 10 ch)) (caddr (assoc 10 ch))))
(if (= 0 (cdr (assoc 40 (tblsearch "Style" (getvar 'TEXTSTYLE)))))
(command ".text" "j" "c" o 2.5 0 (rtos (last (assoc 10 ch)) 2 2))
(command ".text" "j" "c" o 0 (rtos (last (assoc 10 ch)) 2 2)))
(setq i (+ 1 i))
))
(princ)
)

xin được đính chính BT 4.2.4 vì lý do: xảy ra lỗi oái oăm:

Khi thang = 8 (int) ---> (/ (- thang 1 2) 2) lại =2 >>> nên đành cho thêm anh chàng LTL cho nó chắc :D

;Bai 4.2.4
(defun c:GOI( / thu chuoi ngay thang nam d_of_m so_ngay)
(setq chuoi (rtos (getvar "cdate") 2 0)
	ngay (atoi (substr chuoi 7))
	thang (atoi (substr chuoi 5 2))
	nam (atoi (substr chuoi 1 4))
	)
(if (< thang 3) (setq...
>>

xin được đính chính BT 4.2.4 vì lý do: xảy ra lỗi oái oăm:

Khi thang = 8 (int) ---> (/ (- thang 1 2) 2) lại =2 >>> nên đành cho thêm anh chàng LTL cho nó chắc :D

;Bai 4.2.4
(defun c:GOI( / thu chuoi ngay thang nam d_of_m so_ngay)
(setq chuoi (rtos (getvar "cdate") 2 0)
	ngay (atoi (substr chuoi 7))
	thang (atoi (substr chuoi 5 2))
	nam (atoi (substr chuoi 1 4))
	)
(if (< thang 3) (setq d_of_m (* (- thang 1) 31)) 
	(if (= 0 (rem nam 4))
		(if (< thang 9) (setq d_of_m (+ 31 29 (* 30 (- thang 1 2)) (ltl (/ (- thang 1 2) 2.0)))) 
			(setq d_of_m (+ 31 29 31 30 31 30 31 (* 30 (- thang 1 7)) (ltl (/ (- thang 1 7) 2.0)))))
		(if (< thang 9) (setq d_of_m (+ 31 28 (* 30 (- thang 1 2)) (ltl (/ (- thang 1 2) 2.0)))) 
			(setq d_of_m (+ 31 28 31 30 31 30 31 (* 30 (- thang 1 7)) (ltl (/ (- thang 1 7) 2.0)))))
	)
)
(setq so_ngay (+ (* 365 (- nam 1)) (fix (/ (- nam 1) 4)) d_of_m ngay))
(if (= 0 (rem so_ngay 7)) (setq thu "thu bay") 
(if (= 1 (rem so_ngay 7)) (setq thu "chu nhat") (setq thu (strcat "thu " (itoa (rem so_ngay 7))))))
(alert (strcat "Hom nay la " thu " _ " (itoa ngay) "/" (itoa thang) "/" (itoa nam)))
(princ)
)

;Ham lam tron len mot so bat ky
(defun LTL(a / b)
(if (= a (fix a)) (setq b a)
	(if (< a 0) (setq b (- a 1)) (setq b (+ a 1))))
(fix b)
)

sao không có cao thu nào gúp su đệ nay cả

Bài trả lời của thấp thủ nhiều chuyện đây  :D :D :D

;Ve duong tam cho cac duong tron
(defun c:VT( / cmd os ss n i ten chuoi tam bk)
(setq cmd (getvar 'cmdecho)
	os (getvar 'osmode))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(if (setq ss (ssget (list (cons 0...
>>

sao không có cao thu nào gúp su đệ nay cả

Bài trả lời của thấp thủ nhiều chuyện đây  :D :D :D

;Ve duong tam cho cac duong tron
(defun c:VT( / cmd os ss n i ten chuoi tam bk)
(setq cmd (getvar 'cmdecho)
	os (getvar 'osmode))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(if (setq ss (ssget (list (cons 0 "CIRCLE"))))
(progn 
(setq n (sslength ss)
	i 0)
(while (< i n)
(setq ten (ssname ss i)
	chuoi (entget ten)
	tam (cdr (assoc 10 chuoi))
	bk (cdr (assoc 40 chuoi)))
(command ".line" (polar (list (car tam) (cadr tam)) pi (+ 2 bk)) (polar (list (car tam) (cadr tam)) 0 (+ 2 bk)) "")
(command ".line" (polar (list (car tam) (cadr tam)) (/ pi 2) (+ 2 bk)) (polar (list (car tam) (cadr tam)) (* 3 (/ pi 2)) (+ 2 bk)) "")
(setq i (+ 1 i))
))
(princ "\nKhong co duong tron nao duoc chon !")
)
(mapcar 'setvar '("osmode" "cmdecho") (list os cmd))
(princ)
)

em ké 1 tí nhí vì chủ đề gần giống vậy!
 
các anh ơi cho em hỏi tí là có lisp nào có thể vẽ đường tim đường giựa trên cơ sở ta chọn 2 mép đường (có thể là Line hoặc Pline) của 2 bên...

>>

em ké 1 tí nhí vì chủ đề gần giống vậy!
 
các anh ơi cho em hỏi tí là có lisp nào có thể vẽ đường tim đường giựa trên cơ sở ta chọn 2 mép đường (có thể là Line hoặc Pline) của 2 bên đường, để xác định tâm giữa và vẽ tim đường luôn không nhỉ?

_Cám ơn bạn Polyline  rất nhiều  như vậy code của lisp sẽ cập nhật thêm và hoàn thiện như sau, midnh đã sử dụng và rất Ok. Khi kết thúc lệnh sẽ tự động trả về cá chế độ truy bắt điểm ban đầu :D 
 
 

>>

thành thật cảm on bác hiepttr. nó thật tuyệt.... chỉ có 1 cái nhỏ nữa thoi.. đó là các đường tâm em cần là các đường center, màu đỏ và đường tâm này tỉ lệ(linetype sacle) thay đổi  theocác đường tròn to, nhỏ.

Ngoài ra còn thêm đk phần mút thừa cũng tỉ lệ luôn :D

thành thật cảm on bác hiepttr. nó thật tuyệt.... chỉ có 1 cái nhỏ nữa thoi.. đó là các đường tâm em cần là các đường center, màu đỏ và đường tâm này tỉ lệ(linetype sacle) thay đổi  theocác đường tròn to, nhỏ.

Ngoài ra còn thêm đk phần mút thừa cũng tỉ lệ luôn :D

;Ve duong tam cho cac duong tron
(defun c:VT( / cmd os cel lay ss n i ten chuoi tam bk)
(setq cmd (getvar 'cmdecho)
	os (getvar 'osmode)
	cel (getvar 'CELTSCALE)
	lay (getvar 'Clayer))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(if (not (tblsearch "layer" "tam-db1"))
(command "-layer" "m" "tam-db1" "c" 1 "" "l" "center" "" "") 
(setvar 'clayer "tam-db1"))
(if (setq ss (ssget (list (cons 0 "CIRCLE"))))
(progn 
(setq n (sslength ss)
	i 0)
(while (< i n)
(setq ten (ssname ss i)
	chuoi (entget ten)
	tam (cdr (assoc 10 chuoi))
	bk (cdr (assoc 40 chuoi)))
(setvar 'CELTSCALE (/ bk 5))
(command ".line" (polar (list (car tam) (cadr tam)) pi (+ (/ bk 10) bk)) (polar (list (car tam) (cadr tam)) 0 (+ (/ bk 10) bk)) "")
(command ".line" (polar (list (car tam) (cadr tam)) (/ pi 2) (+ (/ bk 10) bk)) (polar (list (car tam) (cadr tam)) (* 3 (/ pi 2)) (+ (/ bk 10) bk)) "")
(setq i (+ 1 i))
))
(princ "\nKhong co duong tron nao duoc chon !")
)
(mapcar 'setvar '("osmode" "cmdecho" "CELTSCALE" "Clayer") (list os cmd cel lay))
(princ)
)

cảm ơn anh tainguyen79 rất nhiều! bây giờ đỡ phải vẽ Pline và vẽ lại tâm nữa rồi. à có thể sửa được để chỉ cần chọn 2 mép bên đường (bằng đường Pline) là vẽ luôn cho mình tim không nhỉ?  

Đây là lisp vẽ đường tâm của 2 đường cong hở, của Alan J. Thompson, khá là...

cảm ơn anh tainguyen79 rất nhiều! bây giờ đỡ phải vẽ Pline và vẽ lại tâm nữa rồi. à có thể sửa được để chỉ cần chọn 2 mép bên đường (bằng đường Pline) là vẽ luôn cho mình tim không nhỉ?  

Đây là lisp vẽ đường tâm của 2 đường cong hở, của Alan J. Thompson, khá là hay.

; Draw (LW)Polyline between two selected curves (at midpoint of vertices).
(defun c:LBL (/ foo AT:GetSel _pnts _pline _lwpline _dist e1 e2)
 (vl-load-com)
 (defun foo (e)
  (and (wcmatch (cdr (assoc 0 (entget (car e)))) "LINE,*POLYLINE,SPLINE")
   (not (vlax-curve-isClosed (car e)))))
 (defun AT:GetSel (meth msg fnc / ent)
  (while
   (progn
    (setvar 'ERRNO 0)
    (setq ent (meth (cond (msg) ("\nSelect object: "))))
    (cond
   ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
     ((eq (type (car ent)) 'ENAME)
      (if (and fnc (not (fnc ent)))
       (princ "\nInvalid object!"))))))
  ent)
 (defun _pnts (e / p l)
  (if e
   (cond
    ((wcmatch (cdr (assoc 0 (entget e))) "ARC,LINE,SPLINE")
     (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e)))
    ((wcmatch (cdr (assoc 0 (entget e))) "*POLYLINE")
     (repeat (setq p (1+ (fix (vlax-curve-getEndParam e))))
      (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l)))))))
 (defun _pline (lst)
  (if
   (and
    (> (length lst) 1)
    (entmakex '((0 . "POLYLINE") (10 0. 0. 0.) (70 . 8)))
    (foreach x lst (entmakex (list '(0 . "VERTEX") (cons 10 x) '(70 . 32)))))
   (cdr (assoc 330 (entget (entmakex '((0 . "SEQEND"))))))))
 (defun _lwpline (lst)
  (if (> (length lst) 1)
   (entmakex (append
     (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 (* (getvar 'plinegen) 128)))
     (mapcar (function (lambda (p) (list 10 (car p) (cadr p)))) lst)))))
 (defun _dist (a b)
  (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
  (if
   (and
    (setq e1 (_pnts (car (AT:GetSel entsel "\nSelect first open curve: " foo))))
    (setq e2 (_pnts (car (AT:GetSel entsel "\nSelect next open curve: " foo))))
    (not (initget 0 "Lwpolyline Polyline"))
    (setq *LBL:Opt* (cond ((getkword (strcat "\nSpecify line to draw:  <" (cond (*LBL:Opt*) ((setq *LBL:Opt* "Lwpolyline"))) ">: "))) (*LBL:Opt*))))
   ((if (eq *LBL:Opt* "Lwpolyline") _lwpline _pline)
    (vl-remove nil
     (mapcar (function (lambda(a b) 
   (if (and a b (not (grdraw (trans a 0 1) (trans b 0 1) 1 1)))
    (mapcar (function (lambda (a b) (/ (+ a b) 2.))) a b))))
       e1
      (if (< (_dist (car e1) (car e2)) (_dist (car e1) (last e2))) e2 (reverse e2))))))
 (princ))
 

Nhờ các bác và anh em trên diễn đàn viết hộ em 1 lisp với nội dung sau:

Em có các text nối với nhau bằng dấu "+" bây giờ em muốn tách các text đó ra theo hàng dọc bằng 1 lệnh .

Lisp thực hiện tất cả các chuỗi text sau khi quét hàng loạt như ví dụ sau:

>>

Nhờ các bác và anh em trên diễn đàn viết hộ em 1 lisp với nội dung sau:

Em có các text nối với nhau bằng dấu "+" bây giờ em muốn tách các text đó ra theo hàng dọc bằng 1 lệnh .

Lisp thực hiện tất cả các chuỗi text sau khi quét hàng loạt như ví dụ sau:http://www.cadviet.com/upfiles/3/98866_vi_du_3.rar

Cám ơn các Bác nhiều...

Quick code cho bạn:

(defun c:tmt (/ ss i ename elast egename)
  (setq i -1)
  (if (setq ss (ssget '((0 . "TEXT"))))
    (while (setq ename (ssname ss (setq i (1+ i))))
      (setq str (cdr(assoc 1 (entget ename))))
      (while (vl-string-search "+" str)
            (setq str (vl-string-subst "\\P" "+" str))
      )
      (command "txt2mtxt" ename "")
      (setq elast (entget (entlast)))
      (setq egename (subst (cons 1 str) (assoc 1 elast) elast))
      (entmod egename)
   )
 )
 )

Đây là lisp mình lấy từ diễn đàn cadviet của bác Tue_NV và chỉnh sửa thêm 1 tí nhưng bị lỗi nhờ mọi người giúp đỡ 

để mình nói sơ qua ý tưởng của mình đây là lisp sắp xếp text bây giờ mình muốn lọc các giá trị text trước khi sắp xếp, cụ thể là các giá trị text bằng nhau (cao độ bằng nhau) chỉ lấy 1 giá trị đầu tiên các giá trị khác sẽ bị xoá sau đó mới sắp xếp...

Đây là lisp mình lấy từ diễn đàn cadviet của bác Tue_NV và chỉnh sửa thêm 1 tí nhưng bị lỗi nhờ mọi người giúp đỡ 

để mình nói sơ qua ý tưởng của mình đây là lisp sắp xếp text bây giờ mình muốn lọc các giá trị text trước khi sắp xếp, cụ thể là các giá trị text bằng nhau (cao độ bằng nhau) chỉ lấy 1 giá trị đầu tiên các giá trị khác sẽ bị xoá sau đó mới sắp xếp lại text.

đây là lisp 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=560
(defun c:sxtt(/ ss kc i obj lispobj lisdau lisobj diemBcuoi tdi spt des)
(vl-load-com)
;copyright by Tue_NV
(setq ss (ssget '((0 . "*TEXT"))) i 0 lispobj (list))
(if (not kco) (setq kco (cdr(assoc 40 (entget(ssname ss 0))))))
(setq kc (getdist (strcat "\n Khoang cach giua cac Text <" (rtos kco 2 2) "> :")))
(if (not kc) (setq kc kco) (setq kco kc))
;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;; Phan xu ly gia tri text bang nhau do minh viet dang bi loi
;(defun xoatext( ss / nhom tam i j sdtc sslst)
  (setq nhom (ssadd))
  (setq sdtc (ssadd))
  (setq i 0)
  (repeat (sslength ss)
    (setq tam (ssname ss 0))
    (setq j 1)
    (repeat (- (sslength ss) 1)
     (if (/= (ssname ss j) nil)
	  (progn
	  (if (= (cdr (assoc 1 (entget tam)))
			   (cdr (assoc 1 (entget (ssname ss j)))) )
	    (progn
	      (setq nhom (ssadd (ssname ss j) nhom))
	      (setq ss (ssdel (ssname ss j) ss))
		  )
	  )
	  )
      )
      (setq j (+ j 1))
    )
    (if	(/= tam nil)
	  (progn
      (setq ss (ssdel tam ss))
	  (setq sdtc (ssadd tam sdtc)) 
	  )
    )
    (setq i (+ i 1))
  )
  (command "ERASE" nhom "" )
  ;(setq ss (acet-ss-to-list sdtc))
  (setq ss sdtc)
 ;;;;;;;;;;;;;;;;;;;;;;;; ket thuc phan xu ly text 
 ;;;;;;;;;;;;;;;;;;;;;;;
(while (< i (sslength ss))
	(vla-getboundingbox (setq obj (vlax-ename->vla-object (ssname ss i))) 'bl 'tl)
	(setq lispobj (cons (cons (list (safearray-value tl) (safearray-value bl)) obj) lispobj))
	(setq i (1+ i))
)
(setq lispobj (vl-sort lispobj
			'(lambda (x y)
				(< (caaar x) (caaar y))
			 )
	      )
)
(setq lisdau (mapcar 'caar lispobj))
;(setq liscuoi (mapcar 'cadar lispobj))
(setq lisobj (mapcar 'cdr lispobj))
(setq diemBcuoi (list (car (last lisdau)) (cadr (last lisdau)) 0))

(setq tdi (tdiem (car lisdau) diemBcuoi))
(setq spt (/ (float (length lispobj)) 2) i spt)
;(if (= (rem i 1) 0) 
    (progn
	(setq i (- i 0.5)) (setq j 0) 
	(foreach x lisobj
		(setq des (list (- (car tdi) (* i kc)) (cadr (nth j lisdau)) 0))
		(vla-move x (vlax-3d-point (nth j lisdau)) (vlax-3d-point tdi))
		(vla-move x (vlax-3d-point tdi) (vlax-3d-point des))
		(setq i (1- i)) (setq j (1+ j))

       )
    )

(princ )
)
;
(defun tdiem(x y)
(list (/ (+ (car x) (car y)) 2) (/ (+ (cadr x) (cadr y)) 2) 0)
)

bạn đưa nguyên code lên coi nhé để mình xem thử,chứ Code viết như trên không hiểu đc lắm.Thực ra trong VBA đối tượng SelectionSet làm việc rất hiệu quả đó chứ.Các bộ lọc của nó cũng tương đương với bên Lisp.

Cảm ơn bạn đã quan tâm đến vấn đề của mình : mình ví dụ luôn như sau...

bạn đưa nguyên code lên coi nhé để mình xem thử,chứ Code viết như trên không hiểu đc lắm.Thực ra trong VBA đối tượng SelectionSet làm việc rất hiệu quả đó chứ.Các bộ lọc của nó cũng tương đương với bên Lisp.

Cảm ơn bạn đã quan tâm đến vấn đề của mình : mình ví dụ luôn như sau :

Sub Example_PickfirstSelectionSet()
    ' This example lists all the objects in the pickfirst selection set.
    ' Before running this example, create some objects in the active
    ' drawing and select those objects. The objects currently selected
    ' in the active drawing will be returned in the pickfirst selection set.
            
    Dim pfSS As AcadSelectionSet
    Dim ssobject As AcadEntity
    Dim msg As String
    msg = vbCrLf
    
    Set pfSS = ThisDrawing.PickfirstSelectionSet
    For Each ssobject In pfSS
        msg = msg & vbCrLf & ssobject.ObjectName
    Next ssobject
    MsgBox "The Pickfirst selection set contains: " & msg
    
End Sub

*  Ý mình là hàm Ssget trong lisp --> cho phép chọn trước 1 đối tượng , còn trong vbarun có lẽ không làm được điều này !

==> Bạn thử làm theo các bước sau :

* Chọn trước mấy đối tượng trong bản vẽ :

* Trong trình soạn thảo vba : ấn F5 run code trên :====> code sẽ liệt kê hết tên các đối tượng được chọn trước trên bản vẽ

* Nhưng nếu trên autocad : bạn gõ lệnh : vbarun --> run code ở trên ==> code trên hoàn toàn không hoạt động

** Mình cũng không hiểu tại sao ???

==> Không có lẽ trong VBA ta không có cách nào lựa chọn các đối tượng trước khi thực hiện lệnh ???

ví dụ : như lệnh copy trong autocad : ta có thể chọn trước đối tượng rồi gõ lệnh copy

* Nhưng trong vba : kiểu gì ta cũng phải chọn lại đối tượng sau khi gõ lệnh ???? 

mình thử viết 1 đoạn code để thay đổi màu các đối tương như sau :

Sub ssget()
    Dim ssetObj As AcadSelectionSet
    Dim entity As AcadEntity
    On Error Resume Next
        Set ssetObj = ThisDrawing.PickfirstSelectionSet
        If ssetObj.Count Then
            For Each entity In ssetObj
                entity.color = 8
            Next
        Else
            Set ssetObj = ThisDrawing.SelectionSets.Add("#")
            If Err <> 0 Then
               Set ssetObj = ThisDrawing.SelectionSets("#"): ssetObj.Clear
            End If
            ssetObj.SelectOnScreen
            For Each entity In ssetObj
                entity.color = 8
            Next
        End If
End Sub

==> Nó hoàn toàn không " mạnh " bằng hàm ssget trong lisp  như sau :

(defun c:test ()
(setq ss (ssget))
(command "chprop" ss "" "c" "8" "")
)

Bạn dùng Lisp này thử xem đúng ý chưa.

1. Lệnh SetColor để chạy chương trình

2. Chọn các đường đồng mức

3. Chọn màu 1 ứng với đường đồng mức cao nhất

4. Chọn màu 2 ứng với đường đồng mức thấp nhất

Ưu điểm của Lisp này là bạn có thể thay đổi thang màu tuỳ ý.

;LISP TO MAU DUONG DONG MUC
;KANGKUNG 28/08/2013
(vl-load-com)

(defun...
>>

Bạn dùng Lisp này thử xem đúng ý chưa.

1. Lệnh SetColor để chạy chương trình

2. Chọn các đường đồng mức

3. Chọn màu 1 ứng với đường đồng mức cao nhất

4. Chọn màu 2 ứng với đường đồng mức thấp nhất

Ưu điểm của Lisp này là bạn có thể thay đổi thang màu tuỳ ý.

;LISP TO MAU DUONG DONG MUC
;KANGKUNG 28/08/2013
(vl-load-com)

(defun C:SetColor( / COLORRANGE LST_COLOR LST_ELEV OCOLOR ORGBCOLOR SECONDCOLOR SS)
  (if (setq ss(ssget '((0 . "*POLYLINE"))))
    (progn
      (foreach obj (#SS->Objlist ss)
	(if (> (fix(vla-get-elevation obj)) 0)
	  (setq lst_elev(cons (fix (/ (vla-get-elevation obj) 10)) lst_elev))
	  )
	)
      (setq lst_elev(vl-sort lst_elev '<))
      (if (not firstColor)
	(setq tempcolor (LM:RGB->True 255 0 0))
	(setq tempcolor (LM:RGB->True (car firstColor) (cadr firstColor) (caddr firstColor)))
	)
      (setq firstColor(TrueColor-split (cdr (assoc 420 (acad_truecolordlg (cons 420 tempcolor) nil)))))
      (setq secondColor(TrueColor-split(cdr (assoc 420 (acad_truecolordlg '(420 . 2686760) nil)))))
      (setq colorRange (- (last lst_elev) (car lst_elev)))
      (setq lst_color(MakeColorRange firstColor secondColor colorRange))
      (foreach obj (#SS->Objlist ss)
	(if (> (fix(vla-get-elevation obj)) 0)
	  (progn
	    (setq oColor (vlax-get-property obj 'TrueColor))
	    (setq oRGBcolor (nth (- (fix (/ (vla-get-elevation obj) 10)) (car lst_elev))  lst_color))
	    (vlax-invoke-method oColor 'SetRGB (car oRGBcolor) (cadr oRGBcolor) (caddr oRGBcolor))
	    (vlax-put-property obj 'TrueColor oColor)
	    (vla-update obj)
	    )
	  )
	)
      )
    )
  )

(defun LM:RGB->True ( r g b )
    (+  (lsh (fix r) 16)
        (lsh (fix g) 08)
        (fix b)
    )
)

(Defun #SS->Objlist (ss / i lst )
 (repeat (setq i (sslength ss))
  (setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))))

(defun MakeColorRange (firstColor secondColor colorRange / rangeRed rangeGreen rangeBlue result)
  (setq	rangeRed(fix (/ (- (car firstColor) (car secondColor)) colorRange)))
  (setq	rangeGreen(fix(/ (- (cadr firstColor) (cadr secondColor)) colorRange)))
  (setq	rangeBlue (fix (/ (- (caddr firstColor) (caddr secondColor)) colorRange)))
  (setq result (cons firstColor (setq result (list))))
  (repeat colorRange
    (setq firstColor (list (- (car firstColor) rangeRed) (- (cadr firstColor) rangeGreen) (- (caddr firstColor) rangeBlue)))
    (setq result (cons firstColor result))
    )
  (reverse result)
)

(defun TrueColor-split (c /)
  (list	(+ (lsh (fix c) -16) 0)
	(lsh (lsh (fix c) 16) -24)
	(lsh (lsh (fix c) 24) -24)
  )
)

update !

;bai tap 4.3.2
(defun c:CN2( / old pt a b d)
(setq old (mapcar 'getvar '("cmdecho" "osmode")))
(mapcar 'setvar '("cmdecho" "osmode") '(0 0))
(setq pt (getpoint "\nNhap goc duoi ben trai hcn ngoai: ")
	a (getdist pt "\nNhap chieu cao hcn ngoai: ")
	b (getdist pt "\nNhap chieu rong hcn ngoai: ")
	d (getdist "\nNhap khoang offset: ")
	)
(command ".rectang" pt (list (+ b (car pt)) (+ a (cadr pt)))) 
(command ".rectang" (list (+ d (car pt)) (+ d...
>>

update !

;bai tap 4.3.2
(defun c:CN2( / old pt a b d)
(setq old (mapcar 'getvar '("cmdecho" "osmode")))
(mapcar 'setvar '("cmdecho" "osmode") '(0 0))
(setq pt (getpoint "\nNhap goc duoi ben trai hcn ngoai: ")
	a (getdist pt "\nNhap chieu cao hcn ngoai: ")
	b (getdist pt "\nNhap chieu rong hcn ngoai: ")
	d (getdist "\nNhap khoang offset: ")
	)
(command ".rectang" pt (list (+ b (car pt)) (+ a (cadr pt)))) 
(command ".rectang" (list (+ d (car pt)) (+ d (cadr pt))) (list (- (+ b (car pt)) d) (- (+ a (cadr pt)) d)))
(mapcar 'setvar '("cmdecho" "osmode") old)
(princ)
)

;bai tap 4.3.3
(defun REMOVE(part lst / lst1 lst2)
(setq lst1 (cdr (member part lst))
	lst2 (reverse (cdr (member part (reverse lst))))
	)
(append lst2 lst1)
)

;bai tap 4.3.4
(defun c:GIA( / loai)
(setq loai (getint "\nNhap loai hang <1/2/3>: "))
(princ (strcat "\n Gia tien cua mat hang loai " (itoa loai) " la: " (rtos (nth (1- loai) (list 100000 200000 300000)) 2 0)))
(princ)
)

;bai tap 4.3.4_2
(defun c:GIA2( / loai)
(initget 1 "L1 L2 L3 _0 1 2")
(setq loai (getkword "\nNhap loai hang <L1/L2/L3>: "))
(princ (strcat "\n Gia tien cua mat hang loai " (itoa (+ 1 (atoi loai))) " la: " (rtos (nth (atoi loai) (list 100000 200000 300000)) 2 0)))
(princ)
)

;bai tap 4.3.5 TRA TU DIEN
(defun c:TRANS()
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq TV '("YEU" "GHET" "TUYET VOI" "VUI")
    ENG '("LOVE" "HATE" "WONDERFUL" "FUL")
    )
(setq str (xstrcase (getstring "\n Nhap tu Tieng Anh <LOVE/HATE/WONDERFUL/FUL>: "))
    tt (- (length ENG) (length (member str ENG))))
(if (/= (nth tt TV) nil) (princ (nth tt TV)) (princ))
(setvar "cmdecho" cmd)
(princ)
)

• 
  
• Gõ tên lệnh "copy_cad_txt" (copy tu Cad sang Txt)
• Chọn tên cho file txt và nơi lưu file
• Quét chọn các Text cần lưu...
  
  >>

• 
  
• Gõ tên lệnh "copy_cad_txt" (copy tu Cad sang Txt)
• Chọn tên cho file txt và nơi lưu file
• Quét chọn các Text cần lưu trữ
• Enter kết thúc lệnh