Jump to content
InfoFile
Tác giả: ngokiet
Bài viết gốc: 446962
Tên lệnh: fixpl
Nhờ viết Lisp đánh dấu đối tượng

Đọc hiểu ý chủ thớt thôi cũng mệt.

Mình có 2 lisp này viết cho vui.

- Lisp 1. Loại bỏ dỉnh trùng nhau liên tiếp và tụ động close pline nếu điểm đầu cuối trùng nhau.

(defun c:fixpl(/ fpl)
  (defun fpl(e1 / c s1 s2 s3 st pn)
    (setq e1 (entget e1)
	  s1 (vl-remove-if '(lambda(x / sa) (Cond ((= (Setq sa (car x)) 10)
						   (setq s2 (cons...
>>

Đọc hiểu ý chủ thớt thôi cũng mệt.

Mình có 2 lisp này viết cho vui.

- Lisp 1. Loại bỏ dỉnh trùng nhau liên tiếp và tụ động close pline nếu điểm đầu cuối trùng nhau.

(defun c:fixpl(/ fpl)
  (defun fpl(e1 / c s1 s2 s3 st pn)
    (setq e1 (entget e1)
	  s1 (vl-remove-if '(lambda(x / sa) (Cond ((= (Setq sa (car x)) 10)
						   (setq s2 (cons (reverse st) s2)
						         st (list (cdr x))))
						  ((member sa '(40 41 42 91)) (setq st (cons (cdr x) st)))))
	       e1)
	  c (cdr(assoc 70 s1))
	  s2 (cdr (reverse (cons (reverse st) s2)))
	  pn (car s2))
    (foreach x (cdr s2)
      (if (>= (distance (car pn) (car x)) 1e-6)
        (setq s3 (cons pn s3)))
      (setq pn x))
    (if (< (distance (car pn) (car(last s3))) 1e-6)
      (setq c 1)
      (setq s3 (cons pn s3)))
    (entmod (append (subst (cons 70 c) (assoc 70 s1) (subst (cons 90 (length s3)) (assoc 90 s1) s1))
		      (apply 'append (mapcar '(lambda(x) (mapcar 'cons '(10 40 41 42 91) x)) (reverse s3))))))
  (mapcar 'fpl (acet-ss-to-list (ssget '((0 . "LWPOLYLINE")))))
  
  (princ))

Lisp 2. Là chọn nhanh polyline theo cạnh hay open/close. Muốn đổi màu hay làm gì thì tùy.

(defun c:sspl(/ a)
  (initget 0 "Open Close")
  (if (setq a (getint "Chon so dinh polyline :")
	    a (cond ((= a "Open") '(70 . 0))
		    ((= a "Close") '(70 . 0))
		    (a (cons 90 a))))
    (sssetfirst nil (ssget (list '(0 . "LWPOLYLINE") a)))))

Ai thích thì có thể thêm chọn nhanh hình chữ nhật, polygon thì tùy.

@Doan Nguyen Van Nếu pline có cạnh là arc mà 4 dĩnh theo hình chữ nhật thì lisp của bạn vẫn xem là hình chữ nhật nhỉ.


<<

Filename: 446962_fixpl.lsp
Tác giả: ngokiet
Bài viết gốc: 446962
Tên lệnh: sspl
Nhờ viết Lisp đánh dấu đối tượng

Đọc hiểu ý chủ thớt thôi cũng mệt.

Mình có 2 lisp này viết cho vui.

- Lisp 1. Loại bỏ dỉnh trùng nhau liên tiếp và tụ động close pline nếu điểm đầu cuối trùng nhau.

(defun c:fixpl(/ fpl)
  (defun fpl(e1 / c s1 s2 s3 st pn)
    (setq e1 (entget e1)
	  s1 (vl-remove-if '(lambda(x / sa) (Cond ((= (Setq sa (car x)) 10)
						   (setq s2 (cons...
>>

Đọc hiểu ý chủ thớt thôi cũng mệt.

Mình có 2 lisp này viết cho vui.

- Lisp 1. Loại bỏ dỉnh trùng nhau liên tiếp và tụ động close pline nếu điểm đầu cuối trùng nhau.

(defun c:fixpl(/ fpl)
  (defun fpl(e1 / c s1 s2 s3 st pn)
    (setq e1 (entget e1)
	  s1 (vl-remove-if '(lambda(x / sa) (Cond ((= (Setq sa (car x)) 10)
						   (setq s2 (cons (reverse st) s2)
						         st (list (cdr x))))
						  ((member sa '(40 41 42 91)) (setq st (cons (cdr x) st)))))
	       e1)
	  c (cdr(assoc 70 s1))
	  s2 (cdr (reverse (cons (reverse st) s2)))
	  pn (car s2))
    (foreach x (cdr s2)
      (if (>= (distance (car pn) (car x)) 1e-6)
        (setq s3 (cons pn s3)))
      (setq pn x))
    (if (< (distance (car pn) (car(last s3))) 1e-6)
      (setq c 1)
      (setq s3 (cons pn s3)))
    (entmod (append (subst (cons 70 c) (assoc 70 s1) (subst (cons 90 (length s3)) (assoc 90 s1) s1))
		      (apply 'append (mapcar '(lambda(x) (mapcar 'cons '(10 40 41 42 91) x)) (reverse s3))))))
  (mapcar 'fpl (acet-ss-to-list (ssget '((0 . "LWPOLYLINE")))))
  
  (princ))

Lisp 2. Là chọn nhanh polyline theo cạnh hay open/close. Muốn đổi màu hay làm gì thì tùy.

(defun c:sspl(/ a)
  (initget 0 "Open Close")
  (if (setq a (getint "Chon so dinh polyline :")
	    a (cond ((= a "Open") '(70 . 0))
		    ((= a "Close") '(70 . 0))
		    (a (cons 90 a))))
    (sssetfirst nil (ssget (list '(0 . "LWPOLYLINE") a)))))

Ai thích thì có thể thêm chọn nhanh hình chữ nhật, polygon thì tùy.

@Doan Nguyen Van Nếu pline có cạnh là arc mà 4 dĩnh theo hình chữ nhật thì lisp của bạn vẫn xem là hình chữ nhật nhỉ.


<<

Filename: 446962_sspl.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 434184
Tên lệnh: ct
Nhờ tạo giúp lisp cad thay đổi text là cao độ đường ống trong cad

15 giờ trước, trinhcaro đã nói:

Kính gửi các bác cao...

>>
15 giờ trước, trinhcaro đã nói:

Kính gửi các bác cao nhân. 

Chuyện là em đang làm bản vẽ thoát nước có liên quan đến cốt cao độ của điểm đầu và cuối ống theo độ dốc của ống. Nhưng em phải điều chỉnh cốt cao độ đó khi đã làm xong rồi. Nói cho các bác dễ hình dung là: vd: cốt điểm đầu em đang điền là "BOP=V-0,8" (trong đó BOP=V- là tiền tố, 0,8 là cao độ của ống) sau đó các đoạn sau em đã đánh cốt theo chiều dài và độ dốc rồi. Nhưng giờ em phải chuyển cao độ kia từ 0,8 thành 0,6. Nếu chỉ như vậy thì em có thể dùng lệnh find được. Nhưng vấn đề phát sinh ở những cao độ khác vd: 0.5, 0.53, 0.87, 0.97,... 

 Mong các bác có thể nghĩ ra lisp gì đó dạng như chọn các text đó, lọc tiền tố và sửa lại cao độ giúp em với ạ. Mục đích của em là chuyển tất cả các cao độ đã đánh giảm đi 0,2m (hoặc có thể nhập lại số khác).

PS: Văn em hơi lủng củng mong các bác giúp đỡ với ạ em đang cần gấp quá. 

Em gửi kèm file CAD để các bác xem ạ.

 

 

bản mẫu.dwg

(vl-load-com)
(defun c:ct (/ ss a ent txt new)
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "TEXT") (cons 1 "BOP=V-*"))))
	a (getreal "\nNhap so cong them: "))
  (foreach ent ss
    (setq txt (vla-get-textstring (vlax-ename->vla-object ent)))
    (setq new (rtos (+ a (atof (substr txt 7))) 2 2))
    (vla-put-textstring (vlax-ename->vla-object ent) (strcat "BOP=V-" new))
    ))

Quick Code cho bạn!


<<

Filename: 434184_ct.lsp
Tác giả: duy782006
Bài viết gốc: 447073
Tên lệnh: n
Nhờ tạo danh sách các lệnh được gán bằng một lệnh
(defun c:n (/ lc)
 (initget "N1 N2 N3 N4")
 (setq lc (getkword "\nChon lenh "))
(cond
((= lc "N1") (princ "Ban chon lenh N1") (c:n1))
((= lc "N2") (princ "Ban chon lenh N2") (c:n2))
((= lc "N3") (princ "Ban chon lenh N3") (c:n3))
((= lc "N4") (princ "Ban chon lenh N4") (c:n4))
)
(princ))

 


Filename: 447073_n.lsp
Tác giả: LuytBui
Bài viết gốc: 447220
Tên lệnh: cbp
Nhờ viết Lisp chèn Block tại các điểm (point) có sẵn

Bạn thử xem đúng ý chưa?

cbp - Chen block vao cac point co san.lsp

 

(defun c:cbp()
	(Prompt "\nChon vung chua cac Point")
	(setq ss (ssget '((0 . "POINT")	) ))
	(setq blockname (getstring "\nNhap ten block: "))
	(setq Xscale (getreal "\nNhap ti...
>>

Bạn thử xem đúng ý chưa?

cbp - Chen block vao cac point co san.lsp

 

(defun c:cbp()
	(Prompt "\nChon vung chua cac Point")
	(setq ss (ssget '((0 . "POINT")	) ))
	(setq blockname (getstring "\nNhap ten block: "))
	(setq Xscale (getreal "\nNhap ti le Scale phuong X:"))
	(setq Yscale (getreal "\nNhap ti le Scale phuong Y:"))
	(setq Rotation (getreal "\nNhap goc xoay:"))
	(setq i 0)
	(repeat (sslength ss)
		(setq po (cdr (assoc 10 (entget (ssname ss i ) ))) )
		(command "-insert" blockname "_nod" po Xscale Yscale Rotation)
		(setq i (+ 1 i))
	);repeat
); end Defun

 


<<

Filename: 447220_cbp.lsp
Tác giả: thanhduan2407
Bài viết gốc: 447268
Tên lệnh: 00
Vấn đề mở nhanh các thư mục đường dẫn

Bạn thay đường dẫn tới thư mục đó là xong!

(defun C:00()
(startapp "explorer" Path)
 (princ)
 )

 


Filename: 447268_00.lsp
Tác giả: thanhduan2407
Bài viết gốc: 447327
Tên lệnh: 00
Nhờ viết Lsp xuất toạ độ tâm block

8 giờ trước, hoangtienphuchung2014 đã nói:

Cảm ơn bác...

>>
8 giờ trước, hoangtienphuchung2014 đã nói:

Cảm ơn bác Duân và Phạm Yến đã viết và chia sẻ! Mình vừa tải về nhưng lúc chạy thử thì báo lỗi! Thật làm phiền các bạn lần nữa nhé

Bạn ấy gửi thiếu hàm!
 

(defun C:00 (/ DEM I LTSBL LTSDONG SSBL TDO)
;;;;;;;XUAT TOA DO BLOCK
  (vl-load-com)
  (setvar "CMDECHO" 0)
  (setq ssBl (ssget (list (cons 0 "INSERT"))))
  (if ssBl
    (progn
      (setq LtsBl (acet-ss-to-list ssBl))
      (setq LtsDong nil)
      (setq i 1)
      (foreach eBl LtsBl
	(setq Tdo (cdr (assoc 10 (entget eBl))))
	(setq LtsDong (append LtsDong
			      (list (list (rtos i 2 0)
					  (rtos (cadr Tdo) 2 3)
					  (rtos (car Tdo) 2 3)
					  (rtos (caddr Tdo) 2 3)
				    )
			      )
		      )
	)
	(setq i (1+ i))
      )

      (setq Dem (length LtsDong))
      (alert
	(strcat	"\nC\U+00F3 t\U+1EA5t c\U+1EA3 "
		(rtos Dem 2 0)
		" \U+0111\U+01B0\U+1EE3c xu\U+1EA5t t\U+1ECDa \U+0111\U+1ED9"
	)
      )
      (if (/= Dem 0)
	(progn
	  (if (vlax-get-or-create-object "Excel.Application")
	    (WriteToExcel LtsDong)
	    (WriteToCSV LtsDong)
	  )
	)
      )
    )
  )

  (princ)
)
(defun WriteToExcel (lst_data / col row x xlApp xlCells)
  (setq	xlApp	(vlax-get-or-create-object "Excel.Application")
	xlCells	(vlax-get-property
		  (vlax-get-property
		    (vlax-get-property
		      (vlax-invoke-method
			(vlax-get-property xlApp "Workbooks")
			"Add"
		      )
		      "Sheets"
		    )
		    "Item"
		    1
		  )
		  "Cells"
		)
  )
  (setq row 1)
  (foreach pt lst_data
    (setq col 1)
    (foreach coor pt
      (vlax-put-property xlCells 'Item row col coor)
      (setq col (1+ col))
    )
    (setq row (1+ row))
  )
  (vla-put-visible xlApp :vlax-true)
  (mapcar
    (function (lambda (x)
		(vl-catch-all-apply
		  (function (lambda ()
			      (if x
				(vlax-release-object x)
			      )
			    )
		  )
		)
	      )
    )
    (list xlCells xlApp)
  )
  (gc)
  (gc)
)

(defun WriteToCSV (lst_data / fl)
  (if (setq fl (getfiled "Output File" "" "csv" 1))
    (if	(setq fl (open fl "w"))
      (progn
	(foreach pt lst_data
	  (write-line
	    (LM:lst->str pt ",")
	    fl
	  )
	)
	(close fl)
      )
    )
  )
  (princ)
)
 ;|«Visual LISP© Format Options»
(200 2 60 2 nil "end of " 80 9 0 0 0 T T T T)
;*** DO NOT add text below the comment! ***|;

 


<<

Filename: 447327_00.lsp
Tác giả: Duong Nhat Duy
Bài viết gốc: 447331
Tên lệnh: demo
Nhờ chỉnh sửa Lsp theo layers

Của bạn đây:

(defun c:demo (/ ss)
  (if
    (setq ss (ssget "_:L" '((8 . "E-CAB-BORE-NP,E-CAB-PART-NP,E-CAB-POCKET-NP"))))
    (command "PSELECT" ss "")
    )
  (princ)
  )
(command "PROPERTIES")
(command "PROPERTIESCLOSE")

 


Filename: 447331_demo.lsp
Tác giả: thiep
Bài viết gốc: 447470
Tên lệnh: c2pl
Nhờ tiền bối viết giùm lisp chuyển hình tròn thành đa giác

1 giờ} trướ}c, hawking312 đã nói:

Cảm ơn bác đã giúp đỡ, có...

>>
1 giờ} trướ}c, hawking312 đã nói:

Cảm ơn bác đã giúp đỡ, có thể bỏ bảng thông báo này mà thay bằng dòng command phía dưới cho dễ chịu và tăng tốc hơn được không bác, xin cảm ơn bác nhiều.

 

;;;   LISP convert ARC, CIRCLE, ELLIPSE, SPLINE to LWPOLYLINE
;;;   By Trân Thiêp 0918.841230
;;;       05/2020.
(defun curve->Lstpo (ent num / LL_UR )
    (setq LL_UR (acet-ent-geomextents ent))
    (ACET-GEOM-SPLINE-POINT-LIST ent
                                 (/ (distance (car LL_UR) (cadr LL_UR)) num)
    )
)
(defun c:c2pl (/ ss lstpo obj col Ltype LtypeScale)
    (command "undo" "be")
    (acet-error-init '(("cmdecho" 0 "osmode" 0) 0))
    (or ucshold_thiep (setq ucshold_thiep (acet-ucs-get nil)))
    (acet-ucs-cmd '("w"))
    (PROMPT "\nSelect curves to convert it into Lwpolylines" )
    (while (NOT (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,SPLINE")))))
        (PROMPT "\nSelect arn't right, please select curves again" )
    )
    (mapcar '(lambda (x)
                 (setq eng (entget x))
                 (cond ((wcmatch (acet-dxf 0 eng) "ARC,CIRCLE,ELLIPSE")
                        (acet-Lwpline-make (list (curve->Lstpo x 2020)))
                       )
                       (T (acet-Lwpline-make (list (curve->Lstpo x 3000))))
                 )
                 (setq obj (vlax-ename->vla-object (entlast)))
                 (if (setq Ltype (acet-dxf 6 eng)) (Vla-put-Linetype obj Linetype))
                 (if (setq LtypeScale (acet-dxf 48 eng)) (Vla-put-LinetypeScale obj LtypeScale))
                 (Vla-put-LinetypeGeneration obj :vlax-true)
                 (Vla-put-layer obj (acet-dxf 8 eng))
                 (if (setq col (acet-dxf 62 eng)) (Vla-put-color obj col))
                 (entdel x)
             )
            (acet-ss-to-list ss)
    )
    (acet-ucs-set ucshold_thiep)
    (acet-error-restore)
    (command "undo" "en")
    (princ "\nOk")
    (princ) 
)

Thử lại xem bạn. Nhân tiện fix luôn 1 lỗi nhỏ về color của đối tượng.


<<

Filename: 447470_c2pl.lsp
Tác giả: Tue_NV
Bài viết gốc: 173498
Tên lệnh: ins
Viết lisp Break Pline tại điểm chèn Block.

Đây bạn!

;Doan Van Ha CADViet.com
(defun C:INS(/ obj p0 blk)
(setq oldcm (getvar "cmdecho") oldos (getvar "osmode"))
(setvar...
>>

Đây bạn!

;Doan Van Ha CADViet.com
(defun C:INS(/ obj p0 blk)
(setq oldcm (getvar "cmdecho") oldos (getvar "osmode"))
(setvar "cmdecho" 0) (setvar "osmode" 0)
(command "undo" "begin")
(setq obj (car (entsel "\n Chon Lwpolyline hoac Line...")))
(princ "\n Chon cac Block da insert tren Lwpolyline/Line...")
(setq blk (acet-ss-to-list (ssget '((0 . "INSERT")))))
(if (= (cdr (assoc 0 (entget obj))) "LINE")
 (progn
  (command "pedit" obj "")
  (setq obj (entlast))))
(if (= (cdr (assoc 0 (entget obj))) "LWPOLYLINE")
 (foreach ent blk
  (setq p0 (cdr (assoc 10 (entget ent))))
  (command "break" obj p0 p0)
  (command "pedit" obj "j" (entlast) "" "")))
(setvar "cmdecho" oldcm) (setvar "osmode" oldos)
(command "undo" "end")
(princ))

1. Giả sử như chọn nhầm lẫn Block có điểm chèn không nằm trên LINE thì Lisp chạy không đúng nữa.

-> Nên giải quyết thêm trường hợp : chọn Block -> Xét thêm điểm chèn của Block đó có nằm trên LINE hay PLINE hay không cái đã rồi mới thực hiện công việc tiếp theo.

Hoặc có thể chọn Block nằm trên Pline -> Xét điểm chèn .... -> Thực hiện công việc....

2. Giải quyết thêm việc chọn nhiều LINE/PLINE nữa.

Lisp trên chỉ cho phép chọn 1 LINE/PLINE


<<

Filename: 173498_ins.lsp
Tác giả: duy782006
Bài viết gốc: 447515
Tên lệnh: cpdpl
Rải đối tượng trên 4 góc hình chữ nhật.

Viết kiểu tổng hợp và sẽ không sửa theo yêu cầu.

-Lệnh: CPDPL

-Thao tác: 

+Chọn nhóm đối tượng  dùng copy. Enter để kết thúc chọn.

+Chọn điểm gốc nhóm đối tượng

+Chọn pline dùng copy đến.

-Tác dụng: copy nhóm đối tượng tại điểm gốc mình chọn đến tất cả các đỉnh của pline vừa chọn.

>>

Viết kiểu tổng hợp và sẽ không sửa theo yêu cầu.

-Lệnh: CPDPL

-Thao tác: 

+Chọn nhóm đối tượng  dùng copy. Enter để kết thúc chọn.

+Chọn điểm gốc nhóm đối tượng

+Chọn pline dùng copy đến.

-Tác dụng: copy nhóm đối tượng tại điểm gốc mình chọn đến tất cả các đỉnh của pline vừa chọn.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:c_curve (/ cur)
(setq ddd (entsel "\nChon cuver:"))
(while
(or
(null ddd)
(or (= "TEXT" (cdr (assoc 0 (entget (car ddd))))) (= "MTEXT" (cdr (assoc 0 (entget (car ddd))))) (= "HATCH" (cdr (assoc 0 (entget (car ddd))))) (= "INSERT" (cdr (assoc 0 (entget (car 

ddd))))) (= "REGION" (cdr (assoc 0 (entget (car ddd))))) (= "DIMENSION" (cdr (assoc 0 (entget (car ddd)))))
)
)
(setq ddd (entsel "\nDoi tuong khong phai cuver! Chon lai"))
)
(setq  cur (car ddd))
cur)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:pline>listdinh (curve / listd)
(if (wcmatch (cdr(assoc 0 (entget curve))) "*POLYLINE")
  (foreach x (entget curve) (if (= (car x) 10) (setq listd (append listd (list(cdr x))))))
)
listd)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:cpdpl ()
(princ  "\nChon cac doi tuong muon copy: ")
(setq dtcopy (ssget ))
(setq dc (getpoint "\nChon diem goc copy"))
(setq tapdinh (duy:pline>listdinh (duy:c_curve)))
(foreach dinhchen tapdinh
(command ".copy" dtcopy ""  "_non" dc  "_non" dinhchen "")
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 


<<

Filename: 447515_cpdpl.lsp
Tác giả: quoctuan23rd
Bài viết gốc: 447508
Tên lệnh: cv
Lỗi lisp cad đánh số tự động

Chào các anh em, mình có một đoạn lisp cad tải trên trang này. Mình có sửa đổi lại đôi chút để phù hợp hơn với nhu cầu. Nhưng không hiểu vì sao đoạn code không thể chèn thêm 2 số 0 vào mã số ở giữa để đủ 11 ký tự. VD: mình muốn A.01.001.01-->A.01.002.01, nhưng dùng lisp này chỉ có thể đánh thành A.01.1.01. Rất mong nhận được sự giúp đỡ! Mình cảm ơn!

(defun...
>>

Chào các anh em, mình có một đoạn lisp cad tải trên trang này. Mình có sửa đổi lại đôi chút để phù hợp hơn với nhu cầu. Nhưng không hiểu vì sao đoạn code không thể chèn thêm 2 số 0 vào mã số ở giữa để đủ 11 ký tự. VD: mình muốn A.01.001.01-->A.01.002.01, nhưng dùng lisp này chỉ có thể đánh thành A.01.1.01. Rất mong nhận được sự giúp đỡ! Mình cảm ơn!

(defun C:CV (/ dsdt dt dt1 dt2 p1 p2 sl x kwrd strt strp num sym ds daup giaso)					;khai bao hàm
(vl-load-com) (command "undo" "be") (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
(setq giaso (getreal "\nGia so tang/giam: "))									;nhan gia so tu ban phim
(princ "\nChon cac doi tuong can Copy tang/giam...")
(setq dsdt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (setq dt (ssget)))))
   		dt1 dt p1 (getpoint "\nDiem goc: ") x 1)
(foreach n dsdt
  (if (or (= "TEXT" (cdr (assoc 0 (entget n)))) (= "MTEXT" (cdr (assoc 0 (entget n)))))
   (if (KT_NUM (cdr (assoc 1 (entget n))))
	(setq dt2 n))))
(if dt2 (setq dt1 (ssdel dt2 dt) dt3 dt1))
(while (setq p2 (getpoint p1 "\nDiem den: "))
  (setvar "osmode" 0) (setvar "cmdecho" 0)
  (if dt2
   (progn
	(command ".copy" dt2 "" p1 p2)
	(CHIA3 (cdr (assoc 1 (entget dt2))))
	(setq daup 0)		;(if (not (vl-string-search "." (cadr ds))) 0 (- (strlen (cadr ds)) (vl-string-search "." (cadr ds)) 1)) ; gan daup la so chu so sau dau thap phan
	(entmod (subst (cons 1 (strcat (car ds) (THEM0 (cadr ds) (rtos (+ (atof (cadr ds)) (* x giaso)) 2 daup)) (caddr ds))) (assoc 1 (entget (entlast))) (entget (entlast))))
	(entupd (entlast))
	(setq x (1+ x))))
  (if dt1
   (command ".copy" dt1 "" p1 p2)))
(command "undo" "e") (setvar "osmode" osm) (setvar "cmdecho" cmd) (princ))
;----- Chia text ra tiento_num_hauto.
(defun CHIA3 (str / trai phai lstt lstn)
(setq lstt (vl-string->list str) lstn (reverse lstt))							;chuyen chuoi ky tu str sang ASCII code
;(while lstt
;  (cond ((or (< (car lstt) 48) (> (car lstt) 57)) (setq trai (cons (car lstt) trai) lstt (cdr lstt)))
 ;			(T (setq lstt nil))))
;(while lstn
;  (cond ((or (< (car lstn) 48) (> (car lstn) 57)) (setq phai (cons (car lstn) phai) lstn (cdr lstn)))
; 			(T (setq lstn nil))))
(setq phai (cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr lstt)))))))))				;set trai la tien to
  (setq trai (cdr(cdr(cdr(cdr(cdr(cdr lstn)))))))					;set phai la hau to
  (setq ds (list (vl-list->string (reverse trai))
                    	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-string-right-trim (vl-list->string phai) (vl-string-left-trim (vl-list->string trai) str)))
                    	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-list->string phai)))))
;----- Kiem tra 1 text co chua num hay khong?
(defun KT_NUM(str / ds kt)
(foreach n (vl-string->list str)
  (if (and (>= n 48) (<= n 57)) (setq kt T)))
kt)
;----- Thong ke so chu so truoc dau thap phan.
(defun KT_FIX(str / m)
(setq m 0)
(while (and (> (strlen str) 0) (/= (substr str 1 1) "."))
  (setq m (1+ m) str (substr str 2)))
m)
;----- Them so chu so 0 vao dau text cho phu hop.
(defun THEM0(strt strs)
(while (> (- (KT_FIX strt) (KT_FIX strs)) 0)
  (setq strs (strcat "0" strs)))
strs)


 


<<

Filename: 447508_cv.lsp
Tác giả: vbao
Bài viết gốc: 5113
Tên lệnh: sd
Viết Lisp theo yêu cầu
Lệnh là SD (sắp dim)

 

Chương trình sẽ yêu cầu người sử dụng chọn đường Dim chuẩn. Sau đó, yêu cầu người sử dụng chọn các đường Dim cần sắp...

>>
Lệnh là SD (sắp dim)

 

Chương trình sẽ yêu cầu người sử dụng chọn đường Dim chuẩn. Sau đó, yêu cầu người sử dụng chọn các đường Dim cần sắp xếp. Chương trình sẽ tự động dàn các Dim theo hàng đều.

sapdim.gif

(defun c:sd ()
 (defun ss2ent	(ss / sodt index lstent)
   (setq
     sodt  (cond
      (ss (sslength ss))
      (t 0)
    )
     index 0
   )
   (repeat sodt
     (setq ent	   (ssname ss index)
    index  (1+ index)
    lstent (cons ent lstent)
     )
   )
   (reverse lstent)
 )
 (defun hoanh_newerror	(msg)
   (if	(and (/= msg "Function cancelled")
     (/= msg "quit / exit abort")
)
     (princ (strcat "\n" msg))
   )
   (done)
 )
 ;;----------
 (defun init ()
   (setq
     HOANH_CMD	     (getvar "CMDECHO")
     HOANH_OLDERROR *error*
     *error*	     hoanh_newerror

   )
   (setvar "CMDECHO" 0)
   (command ".undo" "BE")
 )
 ;;----------
 (defun done ()
   (command ".redraw")
   (command ".undo" "E")
   (if	HOANH_CMD
     (setvar "CMDECHO" HOANH_CMD)
   )
   (if	HOANH_OLDERROR
     (setq *error* HOANH_OLDERROR)
   )
   (princ)
 )
 ;;----------

 (defun cdim (entdt	pchan	 pduong	  /	   tt	    old10
       old13	old14	 new10	  new13	   new14    p10n
       p13n	p14n	 p10o	  p13o	   p14o	    gocduong
       gocchan	pchanb	 pduongb  loaidim
      )
   (defun chanvuonggoc	(ph p1 p2 / ptemp pkq goc)
     (setq
goc   (+ (angle p1 p2) (/ pi 2.0))
ptemp (polar ph goc 1000.0)
pkq   (inters ph ptemp p1 p2 nil)
     )
     pkq
   )
   (setq
     tt       (entget entdt)
     old10    (assoc '10 tt)
     old13    (assoc '13 tt)
     old14    (assoc '14 tt)
     p10o     (cdr old10)
     p13o     (cdr old13)
     p14o     (cdr old14)
     loaidim  (logand (cdr (assoc '70 tt)) 7)
     gocduong (cond
	 ((= loaidim 1) (angle p13o p14o))
	 ((= loaidim 0) (cdr (assoc '50 tt)))
	 (t nil)
       )
     pchan    (cond
	 (pchan (list (car pchan) (cadr pchan) 0.0))
	 (t pchan)
       )
     pduong   (cond
	 (pduong (list (car pduong) (cadr pduong) 0.0))
	 (t pduong)
       )

   )
   (if	gocduong
     (progn
(if pchan
  (setq
    pchanb (polar pchan gocduong 1000.0)
    p13n   (chanvuonggoc
	     (list (car p13o) (cadr p13o) 0.0)
	     pchan
	     pchanb
	   )
    p14n   (chanvuonggoc
	     (list (car p14o) (cadr p14o) 0.0)
	     pchan
	     pchanb
	   )
    new13  (cons 13 p13n)
    new14  (cons 14 p14n)
    tt	   (subst new13 old13 tt)
    tt	   (subst new14 old14 tt)
  )
)
(if pduong
  (setq
    pduongb (polar pduong gocduong 1000.0)
    p10n    (chanvuonggoc
	      (list (car p10o) (cadr p10o) 0.0)
	      pduong
	      pduongb
	    )
    new10   (cons 10 p10n)
    tt	    (subst new10 old10 tt)
  )
)
(entmod tt)
     )
   )
   gocduong
 )

 (defun textdimheight (ent / tmp)
   (command ".copy" ent "" (list 0.0 0.0 0.0) "@")
   (command ".explode" (entlast) "")
   (setq tmp (cdr (assoc 40 (entget (entlast)))))
   (command ".erase" "p" "")
   tmp
 )
 (defun phia (p1 p2 p3 / x1 y1 z1 x2 y2 z2 x3 y3 z3)
   (setq
     x1  (car p1)
     y1  (cadr p1)
     z1  (caddr p1)
     x2  (car p2)
     y2  (cadr p2)
     z2  (caddr p2)
     x3  (car p3)
     y3  (cadr p3)
     z3  (caddr p3)
     tmp (+ (* (- x1 x2) x3)
     (* (- y1 y2) y3)
     (* (- z1 z2) z3)
  )
   )
   (cond
     ((= tmp 0.0) 0.0)
     (t (/ tmp (abs tmp)))
   )
 )
 (defun khoangcachdim (p1 ent goc / tt p2 A B D)
   (setq tt (entget ent)
  p2 (cdr (assoc 10 tt))
  B  (cdr (assoc 50 tt))
  A  (angle p1 p2)
  D  (distance p1 p2)
   )
   (* (* D (sin (- A :unsure:)) (phia p1 (polar p1 goc 1.0) p2))
 )

 (defun phanloai (ent)
   (setq
     kc   (khoangcachdim pgoc ent goc)
     loai (fix (/ kc heightdimgoc 0.93))
   )
   (cons loai ent)
 )

 (init)
 (princ "\nSap xep dim © CADViet.com")
 (while (not (setq entgoc (car (entsel "\nChon duong dim goc: "))))
 )
 (setq
   ttgoc	 (entget entgoc)
   p13goc	 (cdr (assoc 13 ttgoc))
   pgoc	 (cdr (assoc 10 ttgoc))
   goc		 (cdr (assoc 50 ttgoc))
   heightdimgoc (textdimheight entgoc)
   ssd		 (ssget	(list
		  (cons 0 "DIMENSION")
		  (cons -4 "<OR")
		  (cons 70 32)
		  (cons 70 64)
		  (cons 70 96)
		  (cons 70 128)
		  (cons 70 160)
		  (cons 70 196)
		  (cons 70 224)
		  (cons -4 "OR>")
		  (cons -4 "<OR")
		  (cons 50 goc)
		  (cons 50 (+ goc pi))
		  (cons 50 (- goc pi))
		  (cons -4 "OR>")
		)
	 )
   lstd	 (ss2ent ssd)
   lstd	 (mapcar 'phanloai lstd)
   lstlevel	 nil
 )
 (foreach pp lstd
   (if	(not (member (car pp) lstlevel))
     (setq lstlevel (append lstlevel (list (car pp))))
   )
 )
 (setq	lstlevel    (vl-sort lstlevel '(lambda (x1 x2) (< x1 x2)))
lstam	    nil
lstduong    nil
lstamtmp    nil
lstduongtmp nil
 )
 (foreach pp lstlevel
   (if	(< pp 0.0)
     (setq lstam (append lstam (list pp)))
   )
   (if	(> pp 0.0)
     (setq lstduong (append lstduong (list pp)))
   )
 )
 (setq index 0)
 (foreach pp (reverse lstam)
   (setq
     index    (1+ index)
     lstamtmp (append lstamtmp (list (cons pp index)))
   )
 )
 (setq
   lstam lstamtmp
   index 0
 )
 (foreach pp lstduong
   (setq
     index	  (1+ index)
     lstduongtmp (append lstduongtmp (list (cons pp index)))
   )
 )
 (setq lstduong lstduongtmp)
 (setq lstlevel (append lstduong lstam (list (cons 0.0 0))))

 (setq kcdimstandard (* 3.0 heightdimgoc))
 (foreach pp lstd
   (setq plht (car pp))
   (progn
     (setq
kcdimht	   (khoangcachdim pgoc (cdr pp) goc)
duongthu   (cdr (assoc plht lstlevel))
heso	   (cond
	     ((/= 0 kcdimht)
	      (abs (* (/ kcdimstandard kcdimht) duongthu))
	     )
	     (t 0.0)
	   )
diemchenht (cdr (assoc 10 (entget (cdr pp))))
pmoi	   (polar pgoc
		  (angle pgoc diemchenht)
		  (* heso (distance pgoc diemchenht))
	   )
     )

     (cdim (cdr pp) p13goc pmoi)
   )
 )
 (done)
)
(princ "\nSap xep dim, SD - free lisp from www.cadviet.com")
(princ)

 

Anh Hoành xem lại giúp, tôi chạy chương trình gặp lỗi :

Command: (load"xepdim")

; error: malformed list on input

cảm ơn anh.


<<

Filename: 5113_sd.lsp
Tác giả: VUVUZELA
Bài viết gốc: 109083
Tên lệnh: vl
Cùng nhau học LISP
Có ngay : Vẽ các line nối các điểm đã chọn.

(defun c:vl (/ lst pt1 pt2 )
 (setq pt1 (getpoint "\nDiem dau :")
lst (cons pt1 lst))
 (while (setq pt2 (getpoint pt1...
>>
Có ngay : Vẽ các line nối các điểm đã chọn.

(defun c:vl (/ lst pt1 pt2 )
 (setq pt1 (getpoint "\nDiem dau :")
lst (cons pt1 lst))
 (while (setq pt2 (getpoint pt1 "\nDiem ke :"))
   (grdraw pt1 pt2 4) 
   (setq lst (cons pt2 lst)
  pt1 pt2)  )
 (redraw)
 (setq pt1 (car lst))
 (foreach pt2 (cdr lst)
   (entmakex (list (cons 0 "LINE")(cons 10 pt1)(cons 11 pt2) ))
   (setq pt1 pt2))  
 (Princ))

 

Chài ơi

Bác gia_bach này nhanh thật

Em định REPLY bài này do cái này quá dễ (là có bác gia_bach)

Sao bác ko reply cái khó đi

huhu

:(

hihi


<<

Filename: 109083_vl.lsp
Tác giả: phamngoctukts
Bài viết gốc: 109214
Tên lệnh: test
Cùng nhau học LISP
(defun c:test()
(setq
GOC1 (getpoint "\nDiem dat.: ")
GOC3 (getpoint "\nDiem 2:")
dt (polar GOC3 (dtr 180) 100))
(vl-cmdf "._dimlinear" GOC1 GOC3 dt)
(princ...
>>
(defun c:test()
(setq
GOC1 (getpoint "\nDiem dat.: ")
GOC3 (getpoint "\nDiem 2:")
dt (polar GOC3 (dtr 180) 100))
(vl-cmdf "._dimlinear" GOC1 GOC3 dt)
(princ dt)
(princ)
)

Các bác cho e hỏi code trên sai ở đâu mà bến dt e đặt thế nào cũng không ảnh hưởng tới hình dim nhận được?:( Hay nó có ảnh hưởng mà e k biết.Hay trong dòng lệnh dimliner thì biến dt không đồng nghĩa với việc kick chuột vào tọa độ dt ?

Đã thế dim ra lại bị lệch 1 chân,và chân dim khi dài khi ngắn nữa chứ :(

Cái (dtr 180) là cái gì vậy bạn. Theo mình nghĩ bạn định lấy goc 180 độ chứ gì nếu đúng thì bạn thay bằng thế này (/ (* 180 pi) 180) đây là cách đổi độ ra radian.


<<

Filename: 109214_test.lsp
Tác giả: gia_bach
Bài viết gốc: 109230
Tên lệnh: test
Cùng nhau học LISP
(defun c:test()
(setq
GOC1 (getpoint "\nDiem dat.: ")
GOC3 (getpoint "\nDiem 2:")
dt (polar GOC3 (dtr 180) 100))
(vl-cmdf "._dimlinear" GOC1 GOC3 dt)
(princ...
>>
(defun c:test()
(setq
GOC1 (getpoint "\nDiem dat.: ")
GOC3 (getpoint "\nDiem 2:")
dt (polar GOC3 (dtr 180) 100))
(vl-cmdf "._dimlinear" GOC1 GOC3 dt)
(princ dt)
(princ)
)

Các bác cho e hỏi code trên sai ở đâu mà bến dt e đặt thế nào cũng không ảnh hưởng tới hình dim nhận được?:( Hay nó có ảnh hưởng mà e k biết.Hay trong dòng lệnh dimliner thì biến dt không đồng nghĩa với việc kick chuột vào tọa độ dt ?

Đã thế dim ra lại bị lệch 1 chân,và chân dim khi dài khi ngắn nữa chứ :(

Góp ý cùng bạn :

1. cách đặt tên biến : dĩ nhiên mỗi nguời có 1 cách đặt tên khác nhau nhưng cái tên phải có ý nghĩa gợi nhớ liên quan đến phần nội dung nó chuyển tải. Chữ in hay chữ thuờng đều đuợc.

vd :

- với giá trị góc -> đặt là GOC, G1 hay ANG (Víêt tắt cùa Angle)

- với giá trị điểm-> đặt là d1 hay Pt (Víêt tắt cùa Point)

 

2.Về cú pháp của hàm POLAR : (polar pt ang dist)

- pt là tọa độ điểm

- ang là giá trị của góc đo đơn vị Radian

- dist là khoảng cách từ điểm pt

Bạn thiếu hàm dtr có nhiệm vụ đổi số đo góc từ Degrees sang Radian.

như vậy dòng : (polar GOC3 (dtr 180) 100) đổi thành (polar GOC3 (/ pi 2) 100)

 

3. Khi dùng các lệnh CAD trong Lisp, nên tắt các Osnap, Ortho để tránh các hệ lụy không mong muốn.


<<

Filename: 109230_test.lsp
Tác giả: Biet ve CAD
Bài viết gốc: 447680
Tên lệnh: t1
Nhờ viết Lisp lọc đường vành khăn
19 phút trước, huunhantvxdts đã nói:

Chưa nghiên cứu sâu về...

>>
19 phút trước, huunhantvxdts đã nói:

Chưa nghiên cứu sâu về đối tượng trên. cám ơn bạn đã cung cấp thêm thông tin về đối tượng vẽ bằng donut

^^, chỉ cần xác định dxf 70 và 42 là có thể chọn được bạn à

(defun C:T1( / e ssd)
  (setq ssd (ssadd))
(foreach e (acet-ss-to-list (ssget '((0 . "*POLYLINE"))))
  (if (and (eq (cdr (assoc 70 (entget e))) 1)
	   (eq (cdr (assoc 42 (entget e))) 1.0)
	   )
    (ssadd e ssd)
    )
  )
  (sssetfirst nil ssd)
  )

 


<<

Filename: 447680_t1.lsp
Tác giả: Biet ve CAD
Bài viết gốc: 447691
Tên lệnh: t1
Nhờ viết Lisp lọc đường vành khăn
1 giờ} trướ}c, haiha90 đã nói:

chuẩn rồi bác ạ!cảm ơn bác...

>>
1 giờ} trướ}c, haiha90 đã nói:

chuẩn rồi bác ạ!cảm ơn bác nhiều!với cho em hỏi có thể thêm chức năng chọn các vành khăn có cùng đường kính trong và ngoài giống nhau không hả bác  nghĩa là các hình vành khăn giống nhau ý ạ?

(defun C:T1( / e ssd x y d d0 d4 d2)
  (sssetfirst nil nil)
  (setq ssd (ssadd)
	e (car(entsel "\nPick Donut mau:"))
	)
  (vla-getboundingbox (vlax-ename->vla-object e) 'x 'y)
  (setq d0(distance (vlax-safearray->list x)(vlax-safearray->list y))
	d2 (cdr (assoc 41 (entget e)))
	)
(foreach e (acet-ss-to-list (ssget '((0 . "*POLYLINE")(70 . 1)(42 . 1.0))))
  (vla-getboundingbox (vlax-ename->vla-object e) 'x 'y)
  (setq d(distance (vlax-safearray->list x)(vlax-safearray->list y))
	d4 (cdr (assoc 41 (entget e)))
	)
  (if (and (equal d  d0) (equal d2  d4)) (ssadd e ssd) )
  )
  (sssetfirst nil ssd)
  )

Đây bạn


<<

Filename: 447691_t1.lsp
Tác giả: naturooo
Bài viết gốc: 447699
Tên lệnh: sup bup
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
8 phút trước, Biet ve CAD đã nói:
>>
8 phút trước, Biet ve CAD đã nói:
  • cadvietlisp.lsp
    lisp help
  •  

(if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))
  (progn
    ;thuc hien khi co block
    (sssetfirst nil ss)
    (c:BUP)
    )
  (progn
    ;thuc hien khi khong co block
    (princ "\nKhong tim thay block")
    )
  )

 

Em thử như vậy rồi nó vẫn bắt enter để qua viewport tiếp theo anh ạ!

;;===============UP DIM, UP TEXT, UPBLOCK THEO VIEWPORT=======================================
(defun c:SUP( / oldCmdEcho listVPorts itemVPort ss ssl temp ed old new )
(vl-load-com)
(setq oldCmdEcho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq currentLayout (getvar "ctab"))
(setvar "CTAB" "Model")
(command "_.ucs" "w");Ve lai Model va dat lai UCS ve World
(foreach lay (layoutlist) (setvar "CTAB" lay)

(if (/= (getvar "CTAB") "Model")
 (progn
  (setq listVPorts (vl-sort (vports) '(lambda(v1 v2) (< (car v1) (car v2)))))
  (if (> (length listVPorts) 1)
   (progn
    (command "_MSPACE")
    (foreach itemVPort (cdr listVPorts)
     (setvar "CVPORT" (car itemVPort))
      (vpsel "W")
      (setq ent (vlax-vla-object->ename
                    (vla-get-activepviewport
                      (vla-get-activedocument (vlax-get-acad-object)))))
      (setq cvscale (vla-get-customscale (vlax-ename->vla-object ent)))
      (setvar "dimscale" (/ 1 cvscale))
      (vpsel "W")
	(if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))
  	   (progn
    	   ;thuc hien khi co block
    		(sssetfirst nil ss)
    		(c:BUP)
           )
  	   (progn
    	   ;thuc hien khi khong co block
    		(princ "\nKhong tim thay block")
    	   )
       );end if
;      (vpsel "C")
;     (getkword "\nPress <ENTER> to go to next viewport")
    )
    (command "_PSPACE")
   )
   (prompt "\nThere are no viewports defined in this Layout!")
  )
 )
 (prompt "\nThis routine works only in Layout!")
)
);END foreach
(setvar "CMDECHO" oldCmdEcho)
(setvar "CTAB" currentLayout)
(princ)
)
;=====================================================================================
;https://lispbox.wordpress.com/2015/05/05/selecting-objects-within-viewport-and-copy-it-to-clipboard-by-selecting-a-ps-viewport/
;;; vpsel.lsp
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2006 JTB World, All Rights Reserved
;;; Website: http://www.jtbworld.com (http://www.jtbworld.com)
;;; E-mail: info@jtbworld.com
;;; 2000-04-14 - First release
;;; Tested on AutoCAD 2000
;;; DESCRIPTION
;;; Select all visible objects in selected or active paperspace viewport Works transparently when in modelspace and for polygonal viewports too
;;; Example1: ERASE ALL R 'VPC >>> Erase all in model except what is visible
;;; Example2: (command "erase" "all" "r" (c:vpc) "")
;;; Example3: VPC ERASE >>> VPC is run previous the command and the objects are also in previous selection set
;;; c:vpc - select all visible objects with crossing in viewport
;;; c:vpw - select all visible objects with window in viewport
;;; Phai dua UCS ve World ******************************************************************************************************************************************
(defun vpsel (typ / ad ss ent vpno ok vpbl vpur msbl msur msul mslr ss1 pl nlist x n)
 (vl-load-com)
 (setq ok t)
 (if (= (getvar "tilemode") 0)
  (progn
   (setq ad (vla-get-activedocument (vlax-get-acad-object)))
   (if (= (getvar "cvport") 1)
    (if (and (= (getvar "cmdactive") 0) (/= (setq ss (ssget ":E:S" '((0 . "VIEWPORT")))) nil))
     (progn
      (setq ent (ssname ss 0))
      (setq vpno (dxf 69 (entget ent)))
      (vla-Display (vla-get-activepviewport ad) :vlax-true)
      (vla-put-mspace ad :vlax-true)
      (setvar "cvport" vpno))
     (progn
      (setq ok nil)
      (princ)))
  (setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))))
(if (and ok (/= 1 (logand 1 (dxf 90 (setq ed (entget ent))))))
(progn
(if (= (vla-get-clipped (vlax-ename->vla-object ent)) :vlax-false)
(progn
(vla-getboundingbox
(vla-get-activepviewport ad) 'vpbl 'vpur)
(setq msbl (trans (vlax-safearray->list vpbl) 3 2))
(setq msur (trans (vlax-safearray->list vpur) 3 2))
(setq msul (list (car msbl) (cadr msur)))
(setq mslr (list (car msur) (cadr msbl)))
(setq ss1
(ssget (strcat typ "P") (list msbl msul msur mslr))))
(progn
(setq pl (entget (dxf 340 (entget ent))))
(setq nlist nil)
(foreach x pl
(if (eq 10 (car x))
(setq nlist (cons (trans (cdr x) 3 2) nlist))))
(setq ss1 (ssget (strcat typ "P") nlist))))
(sssetfirst nil ss1)
(if ss1
(setq n (sslength ss1))
(setq n 0))
(princ n)
(princ " found ")
(if (and ss1 (= (getvar "cmdactive") 1))
ss1
(princ)))
(princ)))
(princ)))
;=====================================================================================
;--------------------------------------------------------------------------------
(defun DXF (code elist)
  (cdr (assoc code elist))
)
(defun b_ssget ( / ssl  nsset temp ed )
  (setq sset (ssget))
  (setq ssl (sslength sset) 
        nsset (ssadd)
  )
  (print ssl)
  (princ "entities found. ")  
  (princ "\nVerifying the selected entities -- please wait. ")
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl))))
      (setq ed (entget temp))
      (if (= (DXF 0 ed) "INSERT") (ssadd temp nsset))
    )
  )
  (setq ssl (sslength nsset)
        sset nsset
  )
  (print ssl)
  (princ "INSERT entities found. ")
  (princ)
);defun b_ssget
;---------------------------------------------------------------------
(defun c:BUP( / sset ssl temp ed old new )
(setvar "cmdecho" 0)
(setvar "REGENMODE" 0)
  (setq SCALE (getvar "dimscale"))
(b_ssget)
(if (= scale nil) (setq scale (getreal "\nInput current scale: ")))
 
(setq ssl (sslength sset))
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl)))
            ed (entget temp)
            basept (dxf 10 ed)
            oldscale (dxf 41 ed)
            old (cons 41 (DXF 41 ed))
            new (cons 41 scale)
            ed (subst new old ed)

            old (cons 42 (DXF 42 ed))
            new (cons 42 scale)
            ed (subst new old ed)

            old (cons 43 (DXF 43 ed))
            new (cons 43 scale)
            ed (subst new old ed)
      )
      (entmod ed)  
      (setq temp (entnext temp))

      (if (/= temp nil)
         (progn
           (setq ed (entget temp)
                 pt1 (dxf 10 ed)
                 pt2 (dxf 11 ed)
                 old (cons 40 (DXF 40 ed))
                 new (cons 40 (* scale 2))
                 ed (subst new old ed)
                 ratio (/ scale oldscale)
                 pt1 (list (+ (car basept) (* (- (car pt1) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt1) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt1) (caddr basept)) ratio))
                     )
                 pt2 (list (+ (car basept) (* (- (car pt2) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt2) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt2) (caddr basept)) ratio))
                     )
                 old (cons 10 (DXF 10 ed))
                 new (cons 10 pt1)
                 ed (subst new old ed)

                 old (cons 11 (DXF 11 ed))
                 new (cons 11 pt2)
                 ed (subst new old ed)
           )
           (entmod ed)  
         )
      )
    )
  )
(command "regen")
 (princ)
);defun

Anh xem lại giúp em ạ!


<<

Filename: 447699_sup_bup.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 447714
Tên lệnh: sup bup
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
29 phút trước, naturooo đã nói:
29 phút trước, naturooo đã nói:

@Doan Nguyen Van Code em toàn xào nấu từ các đoạn code nhỏ lại với nhau nên rất lủng củng ^^!. Như bác sửa nó chạy qua được viewport không chứa block nhưng viewport chúa block nó lại k BUP được ạ :((

Sửa lại cho bạn đây

;;===============UP DIM, UP TEXT, UPBLOCK THEO VIEWPORT=======================================
(defun c:SUP( / oldCmdEcho listVPorts itemVPort ss ssl temp ed old new )
(vl-load-com)
(setq oldCmdEcho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq currentLayout (getvar "ctab"))
(setvar "CTAB" "Model")
(command "_.ucs" "w");Ve lai Model va dat lai UCS ve World
(foreach lay (layoutlist) (setvar "CTAB" lay)

(if (/= (getvar "CTAB") "Model")
 (progn
  (setq listVPorts (vl-sort (vports) '(lambda(v1 v2) (< (car v1) (car v2)))))
  (if (> (length listVPorts) 1)
   (progn
    (command "_MSPACE")
    (foreach itemVPort (cdr listVPorts)
     (setvar "CVPORT" (car itemVPort))
      (vpsel "W")
      (setq ent (vlax-vla-object->ename
                    (vla-get-activepviewport
                      (vla-get-activedocument (vlax-get-acad-object)))))
      (setq cvscale (vla-get-customscale (vlax-ename->vla-object ent)))
      (setvar "dimscale" (/ 1 cvscale))
      (vpsel "W")
	(if (and ss1
		 (> (sslength ss1) 0)
	  (setq ss (acet-list-to-ss
		(vl-remove-if-not '(lambda (X) (and (wcmatch (cdr (assoc 0 (entget x))) "INSERT")
						    (wcmatch (strcase (cdr (assoc 2 (entget x))) nil) "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))
				     ) (acet-ss-to-list ss1))))
		 )
  	   (progn
    		(sssetfirst nil ss)
    		(c:BUP)
           )
  	   (progn
    	   ;thuc hien khi khong co block
    		(princ "\nKhong tim thay block")
    	   )
       );end if
;      (vpsel "C")
;     (getkword "\nPress <ENTER> to go to next viewport")
    )
    (command "_PSPACE")
   )
   (prompt "\nThere are no viewports defined in this Layout!")
  )
 )
 (prompt "\nThis routine works only in Layout!")
)
);END foreach
(setvar "CMDECHO" oldCmdEcho)
(setvar "CTAB" currentLayout)
(princ)
)
;=====================================================================================
;https://lispbox.wordpress.com/2015/05/05/selecting-objects-within-viewport-and-copy-it-to-clipboard-by-selecting-a-ps-viewport/
;;; vpsel.lsp
;; By Jimmy Bergmark
;; Copyright (C) 1997-2006 JTB World, All Rights Reserved
;; Website: http://www.jtbworld.com (http://www.jtbworld.com)
;; E-mail: info@jtbworld.com
;; 2000-04-14 - First release
;; Tested on AutoCAD 2000
;; DESCRIPTION
;; Select all visible objects in selected or active paperspace viewport Works transparently when in modelspace and for polygonal viewports too
;; Example1: ERASE ALL R 'VPC >>> Erase all in model except what is visible
;; Example2: (command "erase" "all" "r" (c:vpc) "")
;; Example3: VPC ERASE >>> VPC is run previous the command and the objects are also in previous selection set
;; c:vpc - select all visible objects with crossing in viewport
;; c:vpw - select all visible objects with window in viewport
;; Phai dua UCS ve World ******************************************************************************************************************************************
(defun vpsel (typ / ad ss ent vpno ok vpbl vpur msbl msur msul mslr pl nlist x n)
 (vl-load-com)
 (setq ok t)
 (if (= (getvar "tilemode") 0)
  (progn
   (setq ad (vla-get-activedocument (vlax-get-acad-object)))
   (if (= (getvar "cvport") 1)
    (if (and (= (getvar "cmdactive") 0) (/= (setq ss (ssget ":E:S" '((0 . "VIEWPORT")))) nil))
     (progn
      (setq ent (ssname ss 0))
      (setq vpno (dxf 69 (entget ent)))
      (vla-Display (vla-get-activepviewport ad) :vlax-true)
      (vla-put-mspace ad :vlax-true)
      (setvar "cvport" vpno))
     (progn
      (setq ok nil)
      (princ)))
  (setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))))
(if (and ok (/= 1 (logand 1 (dxf 90 (setq ed (entget ent))))))
(progn
(if (= (vla-get-clipped (vlax-ename->vla-object ent)) :vlax-false)
(progn
(vla-getboundingbox
(vla-get-activepviewport ad) 'vpbl 'vpur)
(setq msbl (trans (vlax-safearray->list vpbl) 3 2))
(setq msur (trans (vlax-safearray->list vpur) 3 2))
(setq msul (list (car msbl) (cadr msur)))
(setq mslr (list (car msur) (cadr msbl)))
(setq ss1
(ssget (strcat typ "P") (list msbl msul msur mslr))))
(progn
(setq pl (entget (dxf 340 (entget ent))))
(setq nlist nil)
(foreach x pl
(if (eq 10 (car x))
(setq nlist (cons (trans (cdr x) 3 2) nlist))))
(setq ss1 (ssget (strcat typ "P") nlist))))
(sssetfirst nil ss1)
(if ss1
(setq n (sslength ss1))
(setq n 0))
(princ n)
(princ " found ")
(if (and ss1 (= (getvar "cmdactive") 1))
ss1
(princ)))
(princ)))
(princ)))
;=====================================================================================
;--------------------------------------------------------------------------------
(defun DXF (code elist)
  (cdr (assoc code elist))
)
(defun b_ssget (/ ssl  nsset temp ed )
  (setq sset (ssget))
  (setq ssl (sslength sset) 
        nsset (ssadd)
  )
  (print ssl)
  (princ "entities found. ")  
  (princ "\nVerifying the selected entities -- please wait. ")
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl))))
      (setq ed (entget temp))
      (if (= (DXF 0 ed) "INSERT") (ssadd temp nsset))
    )
  )
  (setq ssl (sslength nsset)
        sset nsset
  )
  (print ssl)
  (princ "INSERT entities found. ")
  (princ)
);defun b_ssget
;---------------------------------------------------------------------
(defun c:BUP( / sset ssl temp ed old new )
(setvar "cmdecho" 0)
(setvar "REGENMODE" 0)
  (setq SCALE (getvar "dimscale"))
(b_ssget)
(if (= scale nil) (setq scale (getreal "\nInput current scale: ")))
 ;(setq scale (getreal "\nInput current scale: "))
(setq ssl (sslength sset))
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl)))
            ed (entget temp)
            basept (dxf 10 ed)
            oldscale (dxf 41 ed)
            old (cons 41 (DXF 41 ed))
            new (cons 41 scale)
            ed (subst new old ed)

            old (cons 42 (DXF 42 ed))
            new (cons 42 scale)
            ed (subst new old ed)

            old (cons 43 (DXF 43 ed))
            new (cons 43 scale)
            ed (subst new old ed)
      )
      (entmod ed)  
      (setq temp (entnext temp))

      (if (/= temp nil)
         (progn
           (setq ed (entget temp)
                 pt1 (dxf 10 ed)
                 pt2 (dxf 11 ed)
                 old (cons 40 (DXF 40 ed))
                 new (cons 40 (* scale 2))
                 ed (subst new old ed)
                 ratio (/ scale oldscale)
                 pt1 (list (+ (car basept) (* (- (car pt1) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt1) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt1) (caddr basept)) ratio))
                     )
                 pt2 (list (+ (car basept) (* (- (car pt2) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt2) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt2) (caddr basept)) ratio))
                     )
                 old (cons 10 (DXF 10 ed))
                 new (cons 10 pt1)
                 ed (subst new old ed)

                 old (cons 11 (DXF 11 ed))
                 new (cons 11 pt2)
                 ed (subst new old ed)
           )
           (entmod ed)  
         )
      )
    )
  )
(command "regen")
 (princ)
);defun

 


<<

Filename: 447714_sup_bup.lsp

Trang 311/330

311