Viết Lisp theo yêu cầu

[Nguyen Hoanh 4.663]

bác Nguyen hoanh em gửi bác file cad này bác nghiên cứu cho em file lisp nhé. em vẽ ra các hình đó và thực hiện lisp để tính ra diện tích rồi ghi vào đúng tâm hình đó. sau đó lại dùng lisp để xuất cái diện tích đó ra file *TXT. cám ơn bác nhieu.

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

Nghĩa là sao nhỉ? tôi đang đi vào mê cung với vấn đề của bạn.

Xin nêu lại sơ bộ các yêu cầu của bạn.

Lần 1: Bạn yêu cầu xuất text ra file txt hoặc csv, mỗi layer theo 1 cột, mỗi text là 1 hàng. Tôi phản hồi là bạn nêu rõ hơn thứ tự text được xuất ra.

Lần 2: Bạn đưa cho tôi 1 hình dwg và 1 file csv chẳng liên quan gì đến nhau. Tôi phản hồi là bạn hãy giải thích rõ hơn.

Lần 3: Bạn giải thích bằng cách đưa ra khái niệm hình mà trước đó chưa xuất hiện bao giờ. Tôi muốn bạn lý giải rõ về hình.

Lần 4: Bạn lại muốn xuất text ra file txt, chẳng thấy nhắc đến hình, layer,....

 

Bạn có thể nói thật ngắn gọn, súc tích cái bạn muốn được không?

[vanduong 536]

Nghĩa là sao nhỉ? tôi đang đi vào mê cung với vấn đề của bạn.

Bạn có thể nói thật ngắn gọn, súc tích cái bạn muốn được không?

thật khó cho bác hoành, ông dvdcad này đặt vấn đề khó hiểu ý quá - mập mờ - mập mờ ngay cả trên file (hãy ghi rõ yêu cầu trên flle dwg kèm theo - thật súc tích-chi tiết nếu muốn người ta giúp)

[Sony2007 86]

Tại sao nhỉ?

 

Kết quả Lisp này tạo ra 1 hàng text nằm dưới hàng text thứ 2 mà!

Bạn đã dùng lisp chưa?

Em dùng rồi mà. Dùng rồi mới bị trùng ngay ở hàng text thứ nhất đấy mà. Thì em dùng code mà em gửi lên đấy thôi. Hay có trục trặc ở chố nào không bác.

[Nguyen Hoanh 4.663]

Em dùng rồi mà. Dùng rồi mới bị trùng ngay ở hàng text thứ nhất đấy mà. Thì em dùng code mà em gửi lên đấy thôi. Hay có trục trặc ở chố nào không bác.

bạn up file ví dụ của bạn lên diễn đàn xem?

[Nguyen Hoanh 4.663]

Em nhờ các bác trên CadViet giúp e viết 1 lệnh với

- Lệnh này khi chọn 2 điểm trên màn hình

(thì có 1 khoảng cách khác 0)

- NHập vào số điểm cần chia đều

(chia đều khoảng cách bên trên giống lệnh Divide)

- Vẽ các đoạn line có chiều dài 500 đơn vị và chèn vào các điểm đó

(Ở lệnh Div có tuỳ chon là Block )

Cảm ơn các bác trước nhé !

Bạn hãy upload 1 file dwg ví dụ đi.

2 điều kiện đầu tiên thì tôi hiểu.

Đến điều kiện thứ 3, vẽ các line có chiều dài 500 đơn vị và chèn vào các điểm đó thì chiều hướng các line này thế nào?

[Sony2007 86]

bạn up file ví dụ của bạn lên diễn đàn xem?

File của em upload đây

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

em ở file ra, sau đó load file lsp. thực hiện lệnh cong, chọn hàng đầu tiên enter, chọn hàng thứ hai enter. Và kết quả nằm trùng với hàng thứ nhất. Bác xem em phạm lỗi nào, chỉ giúp em với. Cám ơn bác

[Nguyen Hoanh 4.663]

File của em upload đây

 

em ở file ra, sau đó load file lsp. thực hiện lệnh cong, chọn hàng đầu tiên enter, chọn hàng thứ hai enter. Và kết quả nằm trùng với hàng thứ nhất. Bác xem em phạm lỗi nào, chỉ giúp em với. Cám ơn bác

Lỗi là do file của bạn, hàng trên điểm chèn nằm phía dưới, hàng dưới điểm chèn lại nằm lên trên. Vì vậy, kết quả là một text mới có hàng xác định không chuẩn.

 

Đây là lisp đã sửa cho trường hợp riêng của bạn:

(defun c:cong () (xulytext +))
(defun c:tru () (xulytext -))
(defun c:nhan () (xulytext *))
(defun c:chia () (xulytext /))

(defun xulytext	(ham / lst1 lst2 sst1 sst2 ykq)
 (princ "\nNhap vao hang text dau tien: ")
 (setq sst1 (ssget '((0 . "TEXT"))))
 (princ "\nNhap vao hang text thu hai: ")
 (setq sst2 (ssget '((0 . "TEXT"))))

 (if (/= (sslength sst1) (sslength sst2))
   (alert
     "\nHai tap chon co so doi tuong khong bang nhau!\nHay chon lai!"
   )
   (progn
     (setq
lst1   (mapcar 'entget (ss2ent sst1))
lst2   (mapcar 'entget (ss2ent sst2))
Ykq    (cadr (getpoint "\nVao toa do y cua hang ket qua: "))
lsterr ""
     )
     (mapcar
'entmake
(mapcar	'(lambda (t1 t2 / tt pp gt)
	   (setq gt (vl-catch-all-apply
		      'ham
		      (list (atof (cdr (assoc 1 t1)))
			    (atof (cdr (assoc 1 t2)))
		      )
		    )
	   )
	   (if (vl-catch-all-error-p gt)
	     (setq lsterr (strcat lsterr
				  "- "
				  (vl-catch-all-error-message gt)
				  "\n"
			  )
		   gt	  "#"
	     )
	     (setq gt (vl-string-right-trim
			"."
			(vl-string-right-trim "0" (rtos gt))
		      )
	     )
	   )
	   (setq
	     p	(cdr (assoc 10 t1))
	     pp	(list 11 (car p) Ykq (caddr p))
	     tt	(subst (cons 1 gt) (assoc 1 t1) t1)
	     tt	(subst pp (assoc 11 t1) tt)		     
	   )
	 )
	lst1
	lst2
)
     )
     (if (/= lsterr "")
(alert
  (strcat "Trong qua trinh tinh toan, co cac loi sau:\n"
	  lsterr
  )
)
     )
   )
 )
)
(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)
)

[Sony2007 86]

Lỗi là do file của bạn, hàng trên điểm chèn nằm phía dưới, hàng dưới điểm chèn lại nằm lên trên. Vì vậy, kết quả là một text mới có hàng xác định không chuẩn.

 

Cám ơn bác nhé. Bây giờ có thể đặt kết quả theo tọa độ Y tùy ý rồi. Cám ơn bác Hoành nhiều.

[kien_long 0]

Bạn hãy upload 1 file dwg ví dụ đi.

2 điều kiện đầu tiên thì tôi hiểu.

Đến điều kiện thứ 3, vẽ các line có chiều dài 500 đơn vị và chèn vào các điểm đó thì chiều hướng các line này thế nào?

 

Nó đây ah !

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

Cảm ơn a Nguyễn Hoành nhé !

:rolleyes:

[Nguyen Hoanh 4.663]

Nó đây ah !

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

Cảm ơn a Nguyễn Hoành nhé !

:rolleyes:

 

Tên lệnh là DBL (Devide by Line)

(defun c:DBL( / p1 p2 pgx pgy pgz)
 (princ "\ndevide by line\nFree lisp from cadviet.com!")
 (setq p1 (trans (getpoint "\nDiem dau: ") 1 0)
p2 (trans (getpoint p1 "\nDiem cuoi: ") 1 0)
sl (cond
     ((setq tmp (getint "\nSo lan:")) tmp)
     (t 2)
   )
x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
pgx (/ (+ (car p1) (car p2)) 2.0)
pgy (/ (+ (cadr p1) (cadr p2)) 2.0)
pgz (/ (+ (caddr p1) (caddr p2)) 2.0)
tm (/ 1.0 sl)
index -1
g (+ (angle p1 p2) (/ pi 2.0))	
 )  
 (repeat (1+ sl)
   (setq index (1+ index)
  tht (* tm index)
  xht (+ (* x1 tht) (* x2 (- 1.0 tht)))
  yht (+ (* y1 tht) (* y2 (- 1.0 tht)))
  p (list xht yht 0.0)
  p1 (polar p g 250.0)
  p2 (polar p g -250.0)
   )
   (entmake (list (cons 0 "LINE") (cons 10 p1)(cons 11 p2)))    
 )    
 (princ)
)

[kien_long 0]

Tên lệnh là DBL (Devide by Line)

(defun c:DBL( / p1 p2 pgx pgy pgz)
 (princ "\ndevide by line\nFree lisp from cadviet.com!")
 (setq p1 (trans (getpoint "\nDiem dau: ") 1 0)
p2 (trans (getpoint p1 "\nDiem cuoi: ") 1 0)
sl (cond
     ((setq tmp (getint "\nSo lan:")) tmp)
     (t 2)
   )
x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
pgx (/ (+ (car p1) (car p2)) 2.0)
pgy (/ (+ (cadr p1) (cadr p2)) 2.0)
pgz (/ (+ (caddr p1) (caddr p2)) 2.0)
tm (/ 1.0 sl)
index -1
g (+ (angle p1 p2) (/ pi 2.0))	
 )  
 (repeat (1+ sl)
   (setq index (1+ index)
  tht (* tm index)
  xht (+ (* x1 tht) (* x2 (- 1.0 tht)))
  yht (+ (* y1 tht) (* y2 (- 1.0 tht)))
  p (list xht yht 0.0)
  p1 (polar p g 250.0)
  p2 (polar p g -250.0)
   )
   (entmake (list (cons 0 "LINE") (cons 10 p1)(cons 11 p2)))    
 )    
 (princ)
)

 

Cảm ơn a Nguyễn Hoành rất nhiều !

Chúc tất cả ae tên CV mạnh khoẻ nhé

[duy782006 1.544]

Nhờ bác Nguyenhoanh giúp cho cái lisp sau với:

 

-Hỏi chọn đối tượng:

-Hỏi tỉ lệ phóng: chấp nhận cả số <0 nếu nhận cả "a/b" và "a*b" thì càng hay.

*Thay đổi tất cả Lineltype Scale trong tập hợp chọn lên một tỉ bằng tỉ lệ phóng.

*Bác có thể không dùng các hàm VL- được không.

Cám ơn!

[longines 0]

Các bác ơi!Viết giúp em lisp cái!Trong quá trình vẽ em có mấy vấn đề khá bất tiện mà không xử lý được!các bác giúp em nhé!

1.Khi sử dụng lệnh copy giá trị của Text để gán qua một đối tượng text khác_lệnh này là lisp không biết em sưu tầm được ở đâu thì em thấy rằng đối với các đối tượng là Group của các Text thì khi mình thực hiện lệnh sẽ bị gán giá trị cho tất cả các Text có trong nhóm rất bất tiện. Các bác giúp em viết lisp mà chỉ gán giá trị cho Text trong Group nhưng chỉ là Text mà mình chon không làm ảnh hưởng đến giá trị các Text khác. Lệnh gán giá trị đó:

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

(defun Copytext ()

(setvar "Cmdecho" 0)

(prompt "\n<< Select Data >>")

(setq sstcong (entsel))

(setq sdk (entget (car sstcong)))

(if (= (cdr (assoc 0 sdk)) "TEXT")

(setq tckl (cdr (assoc 1 sdk)))

(prompt "\n<< ERROR : Nothing Text Selected. >>")

)

(prompt "\n<< Select Text To Copy. >>")

(setq tcong (ssget))

(setq sslen (sslength tcong))

(while (> sslen 0)

(setq stc (entget (ssname tcong (setq sslen (1- sslen)))))

(if (= (cdr (assoc 0 stc)) "TEXT")

(entmod (subst (cons 1 tckl) (assoc 1 Stc) Stc))

(prompt "\n<< ERROR : Nothing Text Selected. >>")

)

)

(setvar "Cmdecho" 1)

)

;;*******************************

;(DEFUN C:Copytext ()(vmon)(Copytext))

(DEFUN C:CT ()(vmon)(Copytext))

(princ "\n CopyText Loaded . Start with CT")

(princ)

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

2.Khi sử dụng lệnh copy giá trị của Text có bước nhảy là 1 hoặc copy Text từ A ->B...dùng cho việc vẽ trục...Thì có vấn đề là không thực hiện được với đối tượng là Attribute, Bác nào giúp em sửa Lisp dưới đây để dùng cho cả Block Attribute thì tốt quá:

*********************************************************************

Copy Intelligent

;*********************************************************************

(defun ketthuc ()

(setvar "cmdecho" luuecho)

(setq *error* luu

luu nil

luuecho nil

);setq

(princ)

)

;*********************************************************************

(defun modau ()

(setq luu *error

luuecho (getvar "cmdecho")

*error (ketthuc)

)

)

;*********************************************************************

(defun xulytext (text / kytu ma sokt luusokt lui )

(setq kytu (substr text (strlen text))

ma (ascii kytu)

sokt (read kytu)

lui 1

)

(if (numberp sokt)

(progn

(setq luusokt (1+ sokt))

(if (and (numberp sokt)

(> (strlen text) 1)

)

(progn

(setq kytu (substr text (1- (strlen text)))

sokt (read kytu)

)

(if (numberp sokt)

(setq luusokt (1+ sokt)

lui 2

 

)

)

);progn

)

(if (= luusokt 100) (setq luusokt 0))

(setq kytu (rtos luusokt 2 0)

 

text (strcat (substr text 1 (- (strlen text) lui)) kytu)

)

);progn

(if (or (= kytu "z")

(= kytu "Z")

)

(setq text (strcat text "0")

textxl "0"

)

(setq ma (1+ ma)

text (strcat (substr text 1 (1- (strlen text))) (chr ma))

)

);if

);if

)

;*********************************************************************

(defun doitext(tendoituong / chuoi doituong thoat tam dsach kieu text vitri10 vitri11 dem canle)

;Neu doi tuong la text thi tiep tuc

(setq doituong (entget tendoituong)

kieu (cdr (assoc 0 doituong))

canle (cdr (assoc 72 doituong))

)

(if (or (= kieu "TEXT")

(= kieu "MTEXT")

)

(progn

(setq textxl (xulytext textxl)

text (cons 1 textxl)

vitri10 (cdr (assoc 10 doituong))

vitri10 (list (+ (car vitri10) (car vitrilech)) (+ (nth 1 vitri10) (nth 1 vitrilech)))

vitri10 (cons 10 vitri10)

vitri11 (cdr (assoc 11 doituong))

vitri11 (list (+ (car vitri11) (car vitrilech)) (+ (nth 1 vitri11) (nth 1 vitrilech)))

vitri11 (cons 11 vitri11)

dem 0

dsach nil

)

(foreach tam doituong

(cond

((= (car tam) 1) (setq dsach (append dsach (list text))))

((= (car tam) 10) (setq dsach (append dsach (list vitri10))))

((= (car tam) 11) (setq dsach (append dsach (list vitri11))))

((setq dsach (append dsach (list tam))))

)

)

(entmake dsach)

);progn

);if

);

;*********************************************************************

;sao doi tuong cu sang vi tri moi

 

(defun copy_dt (tendoituong )

(command "copy" tendoituong "" goc toi )

);defun

 

;*********************************************************************

(defun c:CI ( / cumdt dodai thoat dem ten doituong textxl dem goc toi)

; Khoi dau cua chuong trinh

(princ "\nCopy Inteligent...\n")

(setq luuecho (getvar "cmdecho")

luu *error*

*error* ketthuc

cumdt (ssget)

dodai (sslength cumdt)

goc (getpoint "\nSelect base point:")

thoat nil

dem 0

textxl nil

);

(setvar "cmdecho" 0)

; Loc ra duoc ong text de xu ly

(while (and (= thoat nil)

(< dem dodai)

)

(setq ten (ssname cumdt dem)

dem (1+ dem)

doituong (entget ten)

kieu (cdr (assoc 0 doituong))

)

 

(if (or (= kieu "TEXT")

(= kieu "MTEXT")

)

(setq thoat T

textxl (cdr (assoc 1 doituong))

)

)

);

(while T

(setq toi (getpoint "\nSelect next point: " goc)

vitrilech (list (- (car toi) (car goc)) (- (nth 1 toi) (nth 1 goc)))

dem 0

)

(while (< dem dodai)

(setq ten (ssname cumdt dem)

dem (1+ dem)

doituong (entget ten)

kieu (cdr (assoc 0 doituong))

)

 

(if (or (= kieu "TEXT")

(= kieu "MTEXT")

)

(doitext ten)

(copy_dt ten)

 

);if

)

);while

(ketthuc)

);defun

(princ "Type \"DG\" to start")

;Note: bien toan cuc: textxl vitrilech

*******************************************************

3.Bác nào có lisp có tính năng như lệnh WIPEOUT trong Cad mà có thể chọn đối tượng là Circle hoặc các đối tượng khác không bất tiện như lệnh WIPEOUT phải thực hiện vẽ lại một polyline khác:

Các bác giúp em nhé!!!thanks các bác nhiều!!!hì...

[ssg 1.102]

Nhờ bác Nguyenhoanh giúp cho cái lisp sau với:

 

-Hỏi chọn đối tượng:

-Hỏi tỉ lệ phóng: chấp nhận cả số <0 nếu nhận cả "a/b" và "a*b" thì càng hay.

*Thay đổi tất cả Lineltype Scale trong tập hợp chọn lên một tỉ bằng tỉ lệ phóng.

*Bác có thể không dùng các hàm VL- được không.

Cám ơn!

1- Cái này đơn giản mà, bạn chỉ dùng lệnh "change" là OK. Nó "chơi" luôn cả ss:

(setq

ss (ssget)

k (getreal "\nHe so ty le:")

)

(command "change" ss "" "p" "s" k "")

 

2- Muốn kiểu a/b, a*b... thì bạn dùng (c:cal S), S là string dạng "a/b", "a*b"...

Lưu ý, trước khi dùng c:cal phải gọi: (if (not geomcal) (arxload "geomcal"))

 

3- LTscale không chấp nhận số <0, chỗ này không hiểu ý bạn!

[truongliem0902 0]

Bác Hoành ơi ! Bác viết giùm em một lisp như sau nha :

Em muốn cập nhật số nhà. em có sử dụng lệnh "CT" ( viết số liên tục ) nhưng lệnh đó chỉ áp dụng cho những số ở mặt tiền. Còn trong hẻm thì lệnh đó không sử dụng được ( Vd : 194/37, 194/37/4 ... ). Bác hãy chỉnh lại giùm em nha. Mong hồi âm của Bác.

[duy782006 1.544]

1- Cái này đơn giản mà, bạn chỉ dùng lệnh "change" là OK. Nó "chơi" luôn cả ss:

(setq

ss (ssget)

k (getreal "\nHe so ty le:")

)

(command "change" ss "" "p" "s" k "")

 

2- Muốn kiểu a/b, a*b... thì bạn dùng (c:cal S), S là string dạng "a/b", "a*b"...

Lưu ý, trước khi dùng c:cal phải gọi: (if (not geomcal) (arxload "geomcal"))

 

3- LTscale không chấp nhận số <0, chỗ này không hiểu ý bạn!

 

Vấn đề thế này:

-Khi làm quy hoạch thì mình nhận được file địa hình của các bác làm trắc địa trong đó có nhiều linetype scale khác nhau thể hiện phù hợp với tỉ lệ vẽ của các bác ấy thường là 1/200, 1/500.

-Khi Scale bản vẽ đó lên (theo thói quen về tỉ lệ để dể làm) thì các đường nét thể hiện với tỉ lệ không đúng với tương quan chung nửa . ví dụ đường taluy xẻ xít lại hơn.

-Lips phải làm việc đọc linetypescale của từng đối tượng và nhân với hệ số mình yêu cầu rồi chỉnh lại.

-Hệ số <0 nghĩa là thế này: ví dụ linetypescale đang là 2 hệ số điều chỉnh là 0,5 thì linetypescale sẽ thành 1 vậy mà.

[cuongtk2 342]

Vậy đâu có <0 mà chỉ < 1 thôi. Phải kiểm hàng trước khi xuất xưởng chứ.

[vinataba 3]

*******************************************************

3.Bác nào có lisp có tính năng như lệnh WIPEOUT trong Cad mà có thể chọn đối tượng là Circle hoặc các đối tượng khác không bất tiện như lệnh WIPEOUT phải thực hiện vẽ lại một polyline khác:

Các bác giúp em nhé!!!thanks các bác nhiều!!!hì...

 

mình cũng đang sử dụng cái lisp này nhung chẳng hiểu sao cứ đến 100 thì nó lại thành 11. bác nào sửa thì xem giúp luôn hộ cái lỗi đấy.

[thanhbinh166 3]

Nhờ bác Hoành viết giúp lisp theo ý tưởng như thế này:

1 - offset đường 3d polyline tương tự như offset đường polyline.

Vì 3d polyline sẽ có 3 phương X,Y,Z nên khi offset sẽ hỏi xem offset theo phương X=??; Y=??; Z=??

Thank

[ssg 1.102]

Vấn đề thế này:

-Khi làm quy hoạch thì mình nhận được file địa hình của các bác làm trắc địa trong đó có nhiều linetype scale khác nhau thể hiện phù hợp với tỉ lệ vẽ của các bác ấy thường là 1/200, 1/500.

-Khi Scale bản vẽ đó lên (theo thói quen về tỉ lệ để dể làm) thì các đường nét thể hiện với tỉ lệ không đúng với tương quan chung nửa . ví dụ đường taluy xẻ xít lại hơn.

-Lips phải làm việc đọc linetypescale của từng đối tượng và nhân với hệ số mình yêu cầu rồi chỉnh lại.

-Hệ số <0 nghĩa là thế này: ví dụ linetypescale đang là 2 hệ số điều chỉnh là 0,5 thì linetypescale sẽ thành 1 vậy mà.

Hiểu rồi, nếu vậy thì bạn dùng entmod cho từng entity trong ss. Mã DXF của LTScale là 48. Nếu LTScale = 1 nó sẽ không hiện diện trong data nhận được từ entget. Tiến trình chung như sau:

1- Ssget

2- Nhập hệ số điều chỉnh k. Dùng C:CAL tính các dạng a/b, a*b... như đã nói ở bài trên

3- Dùng vòng lặp xử lý từng "chú". Trong vòng lặp:

- Dùng entget lấy data -> rút ra k1 = LTScale hiện tại của đối tượng

- Nếu data không chứa mã DXF 48 -> k1 =1

- k2 = k*k1

- Entmod

Hy vọng là bạn tự làm được?

[duy782006 1.544]

Hiểu rồi, nếu vậy thì bạn dùng entmod cho từng entity trong ss. Mã DXF của LTScale là 48. Nếu LTScale = 1 nó sẽ không hiện diện trong data nhận được từ entget. Tiến trình chung như sau:

1- Ssget

2- Nhập hệ số điều chỉnh k. Dùng C:CAL tính các dạng a/b, a*b... như đã nói ở bài trên

3- Dùng vòng lặp xử lý từng "chú". Trong vòng lặp:

- Dùng entget lấy data -> rút ra k1 = LTScale hiện tại của đối tượng

- Nếu data không chứa mã DXF 48 -> k1 =1

- k2 = k*k1

- Entmod

Hy vọng là bạn tự làm được?

Cám ơn bác! Đã làm dược rồi. Sẳn đây gửi lên bà con ai có nhu cầu giống mình thì dùng.

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:sclt (/ c e ss dtsc tlsc dtsckt)

(setq tlsc (getreal "\nTi le phong : "))

(prompt "\nChon doi tuong muon chinh ltscale.")

(setq ss (ssget))

(setq c 0)

(setq N (sslength ss))

(while (< c N)

(setq e (ssname ss c))

(setq e (entget e))

(setq dtsckt (cdr (assoc 48 e)))

(if (Null tlsc)

(setq dtsc 1)

)

(IF (/= NIL dtsckt) (PROGN

(setq dtsc (* (cdr (assoc 48 e)) tlsc))

)

)

(setq e (subst (cons 48 dtsc) (assoc 48 e) e))

(entmod e)

(setq c (1+ c))

)

(Prin I)

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

Hỏi bác SSG tí:

Nếu không có phần màu đỏ thì chạy nhanh nhưng nếu gặp đối tượng có linetypescale bằng 1 thì xuất hiện lổi và không chạy tiếp được. Còn có như hiện giờ thì chạy ổn nhưng hơi chậm bác có cách gì hay hơn không thì giúp cải tạo lại với. cám ơn

[Snowman 92]

Bác nên đưa phần này ra ngoài vòng lặp (dưới dòng nhập tlsc: để giá trị mặc định cho tlsc = 1)

 

(if (Null tlsc)

(setq dtsc 1)

)

)

Và sửa lại thành:

(if (Null tlsc)

(setq tlsc 1)

)

 

Đồng thời sửa lại đoạn:

(IF (/= NIL dtsckt) (PROGN

(setq dtsc (* (cdr (assoc 48 e)) tlsc))

)

)

thành :

(IF (/= NIL dtsckt)

(setq dtsc (* (cdr (assoc 48 e)) tlsc))

(setq dtsc 1) ; Nếu dtsckt = nil thì gán dtsc = 1)

[Snowman 92]

Bác nên đưa phần này ra ngoài vòng lặp (dưới dòng nhập tlsc: để giá trị mặc định cho tlsc = 1)

 

(if (Null tlsc)

(setq dtsc 1)

)

)

Và sửa lại thành:

(if (Null tlsc)

(setq tlsc 1)

)

 

Đồng thời sửa lại đoạn:

(IF (/= NIL dtsckt) (PROGN

(setq dtsc (* (cdr (assoc 48 e)) tlsc))

)

)

thành :

(IF (/= NIL dtsckt)

(setq dtsc (* (cdr (assoc 48 e)) tlsc))

(setq dtsc 1) ; Nếu dtsckt = nil thì gán dtsc = 1)

 

Mạng lại lỗi rồi ... các Mod thông cảm nhé

[kts.ngocquan 37]

Bác nên đưa phần này ra ngoài vòng lặp (dưới dòng nhập tlsc: để giá trị mặc định cho tlsc = 1)

 

(if (Null tlsc)

(setq dtsc 1)

)

)

Và sửa lại thành:

(if (Null tlsc)

(setq tlsc 1)

)

 

Đồng thời sửa lại đoạn:

(IF (/= NIL dtsckt) (PROGN

(setq dtsc (* (cdr (assoc 48 e)) tlsc))

)

)

thành :

(IF (/= NIL dtsckt)

(setq dtsc (* (cdr (assoc 48 e)) tlsc))

(setq dtsc 1) ; Nếu dtsckt = nil thì gán dtsc = 1)

 

Mạng lại lỗi rồi ... các Mod thông cảm nhé

Ae trên diễn đàn có lisp có tính năng như lệnh WIPEOUT trong Cad mà có thể chọn đối tượng là Block ko thì cho tôi xin.

Nếu ko có lisp viết sẵn thì nhờ ae trên diễn đàn viết cho tôi nhé .

Theo tôi cái này rất hữu ích cho ae dùng CAD

[ssg 1.102]

Hỏi bác SSG tí:

Nếu không có phần màu đỏ thì chạy nhanh nhưng nếu gặp đối tượng có linetypescale bằng 1 thì xuất hiện lổi và không chạy tiếp được. Còn có như hiện giờ thì chạy ổn nhưng hơi chậm bác có cách gì hay hơn không thì giúp cải tạo lại với. cám ơn

Chương trình như hiện tại của bạn không lỗi khi LTSC = 1, nhưng nó không nhân với "Tỷ lệ phóng" như ý bạn muốn.

Bạn thử với code này xem. Mình đã thử, kết quả đúng trong mọi trường hợp. Còn về tốc độ thì... không biết! Mình đã cố tinh giản code đến mức thấp nhất có thể.

Nói chung, trong các vòng lặp phải xử lý một số lượng lớn đối tượng, các lưu ý sau sẽ làm chương trình chạy nhanh hơn:

- Giảm số lượng biến phải sử dụng

- Giảm số lượng thao tác mà chương trình phải làm trong vòng lặp (cái nào có thể thì nên đưa nó ra ngoài vòng lặp)

- Thay các phép tính phức tạp bằng các phép tính đơn giản hơn

- Nếu có thể, "chơi" luôn cả ss là nhanh nhất. Chỉ xử lý từng entity trong trường hợp bắt buộc.

(defun C:SLT( / k ss e d k1)
(setq
k (getreal "\nTi le phong: ")
ss (ssget)
)
(while (setq e (ssname ss 0))
(setq d (entget e))
(if (setq k1 (cdr (assoc 48 d)))
	(setq d (subst (cons 48 (* k k1)) (assoc 48 d) d))
	(setq d (append d (list (cons 48 k))))
)
(entmod d)
(ssdel e ss)
)
(princ)
)