Jump to content
InfoFile
Tác giả: loprjnce
Bài viết gốc: 238396
Tên lệnh: chon
Quét, lọc và thay đổi Layer cho nhóm đối tượ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...

>>

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

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

<<

Filename: 238396_chon.lsp
Tác giả: hochoaivandot
Bài viết gốc: 246931
Tên lệnh: vdc
(Yêu cầu) Viết lisp xuất cao độ từ block

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


<<

Filename: 246931_vdc.lsp
Tác giả: hiepttr
Bài viết gốc: 246998
Tên lệnh: dcd
(Yêu cầu) Viết lisp xuất cao độ từ block

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

<<

Filename: 246998_dcd.lsp
Tác giả: hiepttr
Bài viết gốc: 246831
Tên lệnh: goi
[LI] Chữa BT Chương 4.2 : Xử lý chuỗi

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

<<

Filename: 246831_goi.lsp
Tác giả: gia_bach
Bài viết gốc: 43392
Tên lệnh: dcen
Xin mọi người giúp đỡ Lisp Center mark.

Hy vọng đoạn LISP này đúng ý bạn : vẽ 2 đường line vuông góc giao nhau tại tâm đường tròn và có phần dư = 200, Layer trùng với layer của đường tròn.
bạn có thể thay đổi chiều dài phần dư này (thay đổi biến KC).

Filename: 43392_dcen.lsp
Tác giả: hiepttr
Bài viết gốc: 247273
Tên lệnh: vt
xin gúp đỡ lisp ve đường tâm

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

<<

Filename: 247273_vt.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 247276
Tên lệnh: chiatim
xin gúp đỡ lisp ve đường tâm

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ỉ?

Đây nè bạn :

(defun c:chiatim(/ lstp p1 p2 midp)
(setq lstp '() osm (getvar "osmode")) (setvar "osmode" 129)
(initget 1) (setq p1 (getpoint "\n Chon diem thu nhat :")) (initget 1) (setq p2 (getpoint p1 "\n Chon diem thu hai :"))
(setq midp (acet-geom-midpoint p1 p2) lstp (append lstp (list midp)))
(initget 1) (setq p1 (getpoint "\n Chon diem tiep theo :")) (initget 1) (setq p2 (getpoint p1 "\n Chon diem tiep theo :"))
(setq midp (acet-geom-midpoint p1 p2) lstp (append lstp (list midp)))
(while (setq p1 (getpoint "\n Chon diem tiep theo :"))
(initget 1) (setq p2 (getpoint p1 "\n Chon diem tiep theo :") midp (acet-geom-midpoint p1 p2) lstp (append lstp (list midp))))
(acet-pline-make (list lstp)) (setvar "osmode" osm)(princ))

Cứ chọn 1 diểm bên này đường , rồi qua bên kia đường chọn 1 điểm là hình chiếu vuông góc của nó. Cứ thế và cứ thế sẽ cho kết quả tương đối chính xác.
<<

Filename: 247276_chiatim.lsp
Tác giả: khanhmytho
Bài viết gốc: 246637
Tên lệnh: dkctd
Lisp dãn cách các text đè lên nhau với khoảng cách cho trước

_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 
 
 

>>

_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 
 
 

(defun c: dkctd (/ oldos p d enlst i ht cn cd ort)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" (+ (getvar "osmode") 16384))
(setq osmode-old nil)
(setq ;;;;; p (getpoint "\n Chon diem chuan ")
        d (getreal "\n Nhap khoang cach chuan: ") )
(prompt "\n Chon nhom text can sap xep")
(setq  enlst (acet-ss-to-list (ssget (list (cons 0 "text") ))))
(while enlst
   	(command "undo" "be")
   	(setq i 0)
   	(setq enlst (vl-sort enlst '(lambda (x y) (< (caar (acet-ent-geomextents x)) (caar (acet-ent-geomextents y))))))
   	(setq ort (getstring "\n Chon huong gian text <T or P>: "))
   	(if (= (strcase ort) "T")
   	(setq p (if (or (/= (cdr (assoc 72 (entget (car enlst)))) 0) (/= (cdr (assoc 73 (entget (car enlst)))) 0))
                        (cdr (assoc 11 (entget (car enlst)))) (cdr (assoc 10 (entget (car enlst))))  )
       		cn (cdr (assoc 72 (entget (car enlst))))
       		cd (cdr (assoc 73 (entget (car enlst))))
   	)
   	(setq p (if (or (/= (cdr (assoc 72 (entget (last enlst)))) 0) (/= (cdr (assoc 73 (entget (last enlst)))) 0))
                        (cdr (assoc 11 (entget (last enlst)))) (cdr (assoc 10 (entget (last enlst))))  )
       		cn (cdr (assoc 72 (entget (last enlst))))
       		cd (cdr (assoc 73 (entget (last enlst))))
               enlst (reverse enlst)
   	)
   	)
   	(foreach en enlst
            (setq encode (entget en)
                    ht (cdr (assoc 40 encode))                  
                    encode (subst (cons 72 cn) (assoc 72 encode) encode)
                    encode (subst (cons 73 cd) (assoc 73 encode) encode)                  
     		)
     		(if (= (strcase ort) "T")
         		(setq  encode (subst (cons 11 (list (+ (car p)  (* i (+ d ht))) (caddr (assoc 11 encode)))) (assoc 11 encode) encode))
         		(setq  encode (subst (cons 11 (list (- (car p)  (* i (+ d ht))) (caddr (assoc 11 encode)))) (assoc 11 encode) encode))
     		)
     		(entmod encode)
     		(setq  i (1+ i))
        )
   	;;; (setq ans (getstring "\n Ban muon tiep tuc chinh text <Y or N> : "))
   	;;; (if (= (strcase ans) "Y")
   	;;; 	(progn
         		(prompt "\n Hay chon nhom text can sap xep tiep theo")
         		(setq enlst (acet-ss-to-list (ssget (list (cons 0 "text")))))
(if osmode-old (setvar "osmode" osmode-old))
   	;;; 	)
  	;;; 	(setq enlst nil)
   	;;; )
        (command "undo" "e")
)
(setvar "osmode" oldos)
 
(princ)
)  

<<

Filename: 246637_dkctd.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 121867
Tên lệnh: chkss
Làm sao để trừ 2 tập hợp chọn với nhau?

Hề hề hề,
Tranh thủ lúc bác Tue_Nv còn bận, mình làm cái ni theo sự gợi ý của bác ấy, bạn coi thử nhé:


@ketxu:
Hề hề hề, bác chuẩn bị vòng hoa cho mình nhé, mũi sắp nổ rồi . hề hề hề

Filename: 121867_chkss.lsp
Tác giả: hiepttr
Bài viết gốc: 247398
Tên lệnh: vt
xin gúp đỡ lisp ve đường tâm

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

<<

Filename: 247398_vt.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 247501
Tên lệnh: lbl
xin gúp đỡ lisp ve đường tâm

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

<<

Filename: 247501_lbl.lsp
Tác giả: Tue_NV
Bài viết gốc: 247778
Tên lệnh: tmt
Viết lisp tách text sau dấu cộng "+"

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

<<

Filename: 247778_tmt.lsp
Tác giả: KangKung
Bài viết gốc: 248191
Tên lệnh: rota
Do you know each other? canadian online pharmacy certification However, please note - if you block/delete all cookies, some features of our websites, such as remembering your login

Filename: 248191_rota.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 248320
Tên lệnh: sxtt
sắp xếp text

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

 

;; free lisp from cadviet.com
(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)
)
 
;; free lisp from cadviet.com
(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)
)
 
;; free lisp from cadviet.com
(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)
)
 
;; free lisp from cadviet.com
(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)
)
 

<<

Filename: 248320_sxtt.lsp
Tác giả: HungDHXD
Bài viết gốc: 246790
Tên lệnh: test
VBA cho AutoCad-Hãy cùng tham gia trao đổi

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

<<

Filename: 246790_test.lsp
Tác giả: KangKung
Bài viết gốc: 248641
Tên lệnh: setcolor
Lisp tô màu tự động cho đường đồng mức

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

<<

Filename: 248641_setcolor.lsp
Tác giả: hiepttr
Bài viết gốc: 248696
Tên lệnh: expo
BT chương 4.3 - Xử lý list

Nhận xét : tốt

 

 

Tranh thủ bắn đc 1 phát :D

 

;bai tap 4.3.1
(defun c:EXPO( / old pt)
(setq old (mapcar 'getvar '("cmdecho" "osmode")))
(mapcar 'setvar '("cmdecho" "osmode") '(0 0))
(setq pt (getpoint "\nChon diem: "))
(princ (strcat "X= " (rtos (car pt)) "; Y= " (rtos (cadr pt)) "; Z= " (rtos (last pt))))
(mapcar 'setvar '("cmdecho" "osmode") old)
(princ)
)

Filename: 248696_expo.lsp
Tác giả: hiepttr
Bài viết gốc: 248850
Tên lệnh: cn2 gia gia2 trans
BT chương 4.3 - Xử lý list

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


<<

Filename: 248850_cn2_gia_gia2_trans.lsp
Tác giả: tuan_thietkedien
Bài viết gốc: 59809
Tên lệnh: test
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)


Ví dụ trong file mình đã gởi thì đầu tiếp xúc là đầu Polyline tiếp xúc với hình tròn, đầu còn lại chưa tiếp xúc với hình nào khác mình sẽ gắn mũi tên vào.

Mình đã thử làm cái Lisp này.

Do chưa biết cách để Lisp hiểu được Nếu Polyline có 1 đầu tiếp xúc với 1 hình khác nên
khi mình vẽ Polyline, mình luôn qui ước điểm đầu Polyline là điểm gắn với...
>>


Ví dụ trong file mình đã gởi thì đầu tiếp xúc là đầu Polyline tiếp xúc với hình tròn, đầu còn lại chưa tiếp xúc với hình nào khác mình sẽ gắn mũi tên vào.

Mình đã thử làm cái Lisp này.

Do chưa biết cách để Lisp hiểu được Nếu Polyline có 1 đầu tiếp xúc với 1 hình khác nên
khi mình vẽ Polyline, mình luôn qui ước điểm đầu Polyline là điểm gắn với hình tròn,
điểm cuối Polyline là điểm Lisp sẽ gắn mũi tên vào.

Như vậy vấn đề điểm chèn mũi tên đã được giải quyết, vấn đề tìm góc Polyline.
Trong file dwg dưới đây có 2 Polyline góc 45 độ và 315 độ mình chưa biết cách giải quyết được.
Bạn tham khảo rồi giúp mình nha.



http://www.cadviet.com/upfiles/Drawing2_21.dwg
<<

Filename: 59809_test.lsp
Tác giả: quansla
Bài viết gốc: 248966
Tên lệnh: copy cad txt
xin giúp về lisp xuất text và mtext ra excel
Bạn thử dùng cái này xem nào, mình viết lâu rồi , bạn xem nếu có cần thay đổi gì thì cm lại, nhưng cái này chỉ ghi ra file .txt thôi, chưa ghi ra excel đâu nhé, nếu cần bạn phải làm thủ công là copy tiếp vô file Excel
cách sử dụng

  • 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...
    >>
Bạn thử dùng cái này xem nào, mình viết lâu rồi , bạn xem nếu có cần thay đổi gì thì cm lại, nhưng cái này chỉ ghi ra file .txt thôi, chưa ghi ra excel đâu nhé, nếu cần bạn phải làm thủ công là copy tiếp vô file Excel
cách sử dụng

  • 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

(defun c:copy_cad_txt (/ Tieude TenFile f lst i xau N x y myerr)
  (setq olderr *error*
*error* (defun myerr (msg)
 (if olderr (setq *error* olderr))
 (command "undo" "end")
 (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
     (princ (strcat "\n** Error: " msg " **")))
 (princ)
 ))
  (command "undo" "begin")
  (vl-load-com)
  (if(and
       (setq TenFile (getfiled "Chon file .txt de ghi DATA tu Cad cua ban:" "" "txt" 5))
       (setq lst (vl-sort (acet-ss-to-list (ssget '(( 0 . "*text"))))
 '(lambda (x y / px py )
    (if (not (equal
(cadr (setq px (cdr(assoc 10 (entget x)))))
(cadr (setq py (cdr(assoc 10 (entget y)))))
1E-3))
      (> (cadr px) (cadr py))
      (< (car px) (car py))
      ))))
       (setq Tieude (strcat (getvar "dwgprefix") (getvar "dwgname") "\n" "\n"))
       (setq xau (strcat Tieude (cdr (assoc 1 (entget (setq m1 (car lst))) )))
    i 0
    N (length lst))
       )
    (progn
      (while (< i (1- N))
(if (equal
     (caddr(assoc 10 (entget (nth i lst)) ))
     (caddr(assoc 10 (entget (nth (1+ i) lst)) ))
     1E-3)
 (setq xau (strcat xau "\t" (cdr (assoc 1 (entget (nth (1+ i) lst))))))
 (setq xau (strcat xau "\n" (cdr (assoc 1 (entget (nth (1+ i) lst)))) ))
 )
(setq i (1+ i))
)
      (progn
(setq f (open TenFile "a"))
(write-line xau f)
(close f)
)
      (prompt (strcat "Da xuat cac Text duoc chon ra: "  TenFile ))
      (alert  (strcat "Da xuat cac Text duoc chon ra: "  TenFile ))
      (if olderr (setq *error* olderr))
      (command "undo" "end")
      (princ)
      )))

<<

Filename: 248966_copy_cad_txt.lsp

Trang 140/330

140