Jump to content
InfoFile
Tác giả: ginger
Bài viết gốc: 401193
Tên lệnh: xx
Sắp xếp thẳng hàng

Bản thân ket nhiều khi muốn sắp xếp các nhóm đối tượng cho ngay ngắn theo hàng lối, thường toàn kẻ Xline để gióng (hoặc kết hợp...

>>

Bản thân ket nhiều khi muốn sắp xếp các nhóm đối tượng cho ngay ngắn theo hàng lối, thường toàn kẻ Xline để gióng (hoặc kết hợp F11) rồi move. Thật kỳ lạ >"<

Trong khi đoạn code ngắn như thế này giúp tăng tốc bao nhiêu. Ý tưởng của ReachAndre trên Augi

 

P/s : Tự gióng theo khoảng cách gần nhất giữa Delta X và Delta Y nhé ^^

(defun c:xx (/ p pt d xd yd s)
(command "undo" "Mark")
(while (not (setq p (getpoint "\n\U+0110i\U+1EC3m chu\U+1EA9n :: "))))
(while
	(setq s (ssget))
		(while(not(setq pt (getpoint "\n\U+0110i\U+1EC3m gi\U+00F3ng :" p))))
		(setq 	xd (abs (- (car pt) (car p)))
				yd (abs (- (cadr pt) (cadr p)))
				d	(cond 	((> xd yd)(list (car pt) (cadr p) (caddr pt)))
							((< xd yd)(list (car p) (cadr pt) (caddr pt)))
					)
		)
		(command "_move" s "" "non" pt "non" d)
)
(command "undo" "end")
(princ)
) 

 

anh ketxu ơi lisp hay rồi nhưng em muốn ví dụ sắp xếp nhiều đối tượng một lần được không ? ở video của anh là mỗi lần click anh mới sắp xếp được 1 đối tượng giờ em muốn sắp xếp liền lúc 3 đối tượng theo hàng ngang chẳng hạn . thanks anh 


<<

Filename: 401193_xx.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 189324
Tên lệnh: h5
Hatch không đè lên Dim

Đông vui quá, E góp vui 1 code nhanh, mới chỉ test thử hình bạn ấy post

(defun c:h5(/ lstObj e p1 p2 Obj ObjB oldVal lstVar...
>>

Đông vui quá, E góp vui 1 code nhanh, mới chỉ test thử hình bạn ấy post

(defun c:h5(/ lstObj e p1 p2 Obj ObjB oldVal lstVar pt)
(command "undo" "be")
(setq oldVal (mapcar 'getvar (setq lstVar '("HPNAME" "CMDECHO" "OSMODE" "HPASSOC" "HPGAPTOL"))))
(mapcar 'setvar lstVar '("ansi31" 0 0 0))
(or *kc* (setq *kc* 0.5))
(setq *kc* (cond ((getdist (strcat "\nKhoang cach Offset de Hatch < " (rtos *kc* 2 2) " > :")))(*kc*)))
(command "-layer" "m" "Hatch" "c" "8" "" "")
(while (setq pt (getpoint "\n Pick diem ben trong vung Hatch :"))
(setq e (entlast) lstObj nil)
(command "boundary" pt "")
(cond ((not (eq e (entlast)))
  (while (setq e (entnext e))(setq lstObj (cons (vlax-ename->vla-object  e) lstObj)))
  (setq   Obj (car (vlax-invoke  (setq ObjB (car lstObj))  'Offset (- *kc*)))
p1 (vlax-curve-getStartPoint obj)
p2 (vlax-curve-getStartPoint objB)
  )
  (command "-bhatch"  (mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)) "")
  (while (/= (cdr (assoc 0 (entget (entlast)))) "HATCH")
(command "-bhatch"  (getpoint "\nChuong trinh gap loi khi tu dong tinh diem Hatch , ban hay chi dinh diem giua 2 bien Hatch :") ""))  
  (mapcar 'vla-delete (cons obj lstObj))
  (mapcar 'setvar lstVar oldVal)
  )
 (T (princ "\n Gap loi - chua ro nguyen nhan "))
)
)
(command "undo" "en")
)

Ket ơi, lỗi như bác Tue_NV rồi!


<<

Filename: 189324_h5.lsp
Tác giả: dinhthang8709
Bài viết gốc: 414885
Tên lệnh: bao
Viết Lisp Tạo Đường Bao

 

Quick code

(defun c:bao()
  (setq p (getpoint "pick diem :"))
  (command "._boundary" "A" "O" "R" "" p "")
 ...
>>

 

Quick code

(defun c:bao()
  (setq p (getpoint "pick diem :"))
  (command "._boundary" "A" "O" "R" "" p "")
  (Command "._region" "L" "")
  (setq el (entlast)) (redraw el 3)
  (while (setq p (getpoint "pick diem :"))
      (command "._boundary" p "")
      (Command "._region" "L" "")
    (command "._union" el "L" "")
    (setq el (entlast))
    (redraw el 3)
  )
)

Anh có thể bỏ bắt điểm được không. Vì ở đây mình chỉ cần pick vào vùng kín.

Với lại sau khi xong region nó cứ như là được chọn vậy anh, mặc dù nó có được đâu ạ.


<<

Filename: 414885_bao.lsp
Tác giả: Tue_NV
Bài viết gốc: 217475
Tên lệnh: tkd
thống kê đối tượng theo chiều dài

Mình có lisp này: do lượm lặt và chỉnh sửa code

Lisp tkd có chức năng thống kê các đối tượng có cùng chiều...

>>

Mình có lisp này: do lượm lặt và chỉnh sửa code

Lisp tkd có chức năng thống kê các đối tượng có cùng chiều dài

Khi thực hiện nếu có 5 đối tượng cùng có chiều dài 450 ( 3 line, 2 LWPL)

Nhưng chỉ hiện thị 3 line ?

Nhờ mọi người xem giúp

Cám ơn !

; Ham lay chieu dai doi tuong
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
 ;;;--------------------------------------------------------------------
(defun c:tkd ()
(prompt "\n Chon cac doi tuong can thong ke")
 (setq ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
d (getdist "\n Nh\U+1EADp chi\U+1EC1u d\U+00E0i \U+0111\U+1ED1i t\U+01B0\U+1EE3ng c\U+1EA7n th\U+1ED1ng k\U+00EA:")
i 0)
(vl-load-com)
(while (setq e (ssname ss 0))
(setq L (length1 e))
(if (= L d)
 	(setq i (1+ i)))
(ssdel e ss)
)
(alert (strcat "C\U+00F3 " (itoa i) " \U+0111\U+1ED1i t\U+01B0\U+1EE3ng c\U+00F3 kho\U+1EA3ng c\U+00E1ch = " (rtos d) " "))
 (princ)
)
 ;;;-------------------------------------------------------------------

Do hàm (= L d) . Do độ dài giữa các obj có sai số . Bạn nên thay bằng hàm equal có fuzz (sai số)

Tue_NV không có CAD để test. Bạn kiểm tra lại xem


<<

Filename: 217475_tkd.lsp
Tác giả: Quảng
Bài viết gốc: 218776
Tên lệnh: cot00 dc
Đánh cốt tự động bằng lisp DC

Bạn đã bao giờ mệt vì phải tính toán để đánh cốt cao độ của mặt cắt và mặt đứng hay chưa?

vừa phải tính xem từ...

>>

Bạn đã bao giờ mệt vì phải tính toán để đánh cốt cao độ của mặt cắt và mặt đứng hay chưa?

vừa phải tính xem từ điểm cần tính đến cốt 0.00 có khoảng cách h bao nhiêu, rồi lại nhập vào bản vẽ.

 

Bây giờ, bạn có thể làm điều này một cách nhanh chóng và tự động nhờ vào lisp dc của cadviet.

với lisp này, bạn chỉ cần gõ lệnh dc, chương trình sẽ hỏi bạn điểm bạn cần đánh cốt, sau đó chương trình sẽ chèn ký hiệu cốt vào đúng vị trí và giá trị mà bạn cần. Bạn dùng lệnh cot00 để định nghĩa điểm có cao độ là cot00.

 

Để sử dụng lệnh, trước tiên phải copy file cot.dwg vào thư mục support - Đây là file chứa nội dung của ký hiệu cốt. Sau đó appload file danhcot.lsp để sử dụng lệnh.

 

(defun c:cot00 ()
 (setq Cot00 (cadr (getpoint "\nDiem co cot 0.000: ")))
 (princ)
)
(defun c:dc (/ diem caodo dau giatri dodaichuoi)
 (if (not cot00)
(progn
 	(alert "chua co cot 0.000")
 	(c:cot00)
)
 )
 (grdraw (list	(+ (car (getvar "VIEWCTR")) (* -1.0 (getvar "VIEWSIZE")))
	cot00
 	)
 	(list	(+ (car (getvar "VIEWCTR")) (* 1.0 (getvar "VIEWSIZE")))
	cot00
 	)
 	1
 	1
 )
 (setq
diem   (getpoint "\nVao diem can danh cot: ")
caodo  (- (cadr diem) cot00)
dau       (cond
     ((equal caodo 0.0 0.01) "%%p")
     ((> caodo 0.0) "+")
     (t "-")
      )
giatri (rtos caodo 2 0)
 )
 (if (= "-" (substr giatri 1 1))
(setq giatri (substr giatri 2))
 )
 (while (< (strlen giatri) 4)
(setq giatri (strcat "0" giatri))
 )
 (setq	dodaichuoi (strlen giatri)
giatri       (strcat (substr giatri 1 (- dodaichuoi 3))
	       "."
	       (substr giatri (- dodaichuoi 2))
       )
 )
 (command ".insert" "danhcot" diem 100.0 100.0 0.0 dau giatri)
 (redraw)
)

file danhcot.lsp: http://www.cadviet.com/upfiles/danhcot.lsp

file danhcot.dwg: http://www.cadviet.com/upfiles/DANHCOT.zip

 

Lưu ý: Với mỗi file DWG mà bạn vẽ, bạn phải đặt lại biến ATTDIA về 0 trước khi dùng lệnh DC (chỉ cần đặt 1 lần cho mỗi file).

 

Rất mong có được sự phản hồi.

Cảm ơn.

bạn có thể làm cho phần text có mầu sắc là mầu của layer hiện hành không???. trong này mặc định là mầu Green nhưng mầu này in ra giấy nền mầu trắng mình thấy xấu quá. mình dùng mầu Blue mà phải chỉnh từng cái dim thấy mất công qua :D thank trước vì minh chỉ biết ăn sẵn không biết tẹo nào về viết lisp hjhj.


<<

Filename: 218776_cot00_dc.lsp
Tác giả: toanmda
Bài viết gốc: 166854
Tên lệnh: rft
Lisp lấy số liệu từ hộp thoại

Chào bạn !

Bạ thử đoạn code này xem. Kết quả ra 1 list cac giá trị đã chọn. Bạn có thể ghi ra text hoặc xử lý nó theo mong...

>>

Chào bạn !

Bạ thử đoạn code này xem. Kết quả ra 1 list cac giá trị đã chọn. Bạn có thể ghi ra text hoặc xử lý nó theo mong muốn.

 

(defun c:ai (/ id str pos data sublist key De Fl)

     (defun set_list ()
      (start_list "Wx")
      (foreach x
	      (setq sublist
		     (vl-remove-if '(lambda (x) (/= (substr x 1 3) (strcat "W" $value "x"))) data)
		    )
	      (add_list x)
      )
      (end_list)      	
     )

    (defun set_value (/ subdata)
            (if sublist
         (progn
             (setq key (nth (atoi (get_tile "Wx")) sublist))
       	     (setq subdata (member key data))            
             (set_tile "Depth"  (setq De (cadr subdata)))
       	     (set_tile "Flange" (setq Fl (caddr subdata)))
	     (mode_tile "accept" 0)
        )
             (mode_tile "accept" 1)
       )
     ) 


(setq f (open "d:/data.txt" "r"))
(setq str (read-line f))
(close f)
(setq data (append))

(while
(setq pos (vl-string-position 32 str))
(setq data (append data (list (substr str 1 pos))))
(setq str (vl-string-trim " " (substr str (+ pos 1)))) 
)
(setq data (append data (list str)))

(setq id (load_dialog "cadvietlisp")) 
(new_dialog "AISC" id)
  (mode_tile "accept" 1)
  (action_tile "W" "(set_list)(set_value)")
  (action_tile "Wx" "(set_value)")

(setq sta (start_dialog))
(unload_dialog id)

(if (= sta 1) (vl-remove 'nil (list key De Fl)))

)

 

 

Ketxu mới học DCL nên gà quá, thấy bác npham viết ngắn quá mà ham, nhưng bên mình xài không được, nên sửa lại 1 chút như thế này :

(defun c:RFT(/ sublist key lstdata data);Read File Txt 
(vl-load-com)  
(defun set_list ()
(start_list "Wx")
(foreach x (setq sublist (vl-remove-if '(lambda (x) (/= (substr (car x) 1 2) (strcat "W" $value))) lstdata))
	      (add_list (car x))
)
(end_list)      	
)
(defun set_value ()
            (if sublist
         (progn
             (setq key (nth (atoi (get_tile "Wx")) sublist))	       	                 
             (set_tile "Depth"   (cadr key))
       	     (set_tile "Flange" (caddr key))	     
        )	             
       )
     )

 (defun split (str  delim /    lst i  )	
 (while (setq i (vl-string-search delim str))
   (setq
     lst (cons (substr str 1 i) lst)
     str    (substr str (+ 2 i))
     )
   )
   (setq lst (cons str lst))
 (reverse lst)
 )


(setq f (open (findfile "data.txt") "r"))
  (while (setq Line (read-line f))
(if (not (vl-string-search "Name" Line))
  (progn
    (setq data (split Line "\t"))
	(setq lstData (cons data lstData))
	)
)
)
(setq lstData  (vl-remove '("") (reverse lstData)))

(setq dcl_id (load_dialog "AISC.dcl")) ; Load the DCL file.
 (if (not (new_dialog "AISC" dcl_id))   ; Initialize the dialog.
   (exit)                                ; Exit if this doesn't 
                                         ; work.
 )

 (action_tile "W" "(set_list)(set_value)")
 (action_tile "Wx" "(set_value)")
 (start_dialog)   
 (unload_dialog dcl_id)  
 key
)

 

 

Đúng là Lisp mà bác npham viết chưa chạy được nên Tue_NV cũng tham gia sửa 1 tí ^_^

(defun c:ai (/ id str pos data sublist key De Fl)

     (defun set_list ()
      (start_list "Wx")
      (foreach x
	      (setq sublist
		     (vl-remove-if '(lambda (x) (/= (substr x 1 3) (strcat "W" $value "x"))) data);
		    )
	      (add_list x)
      )
      (end_list)      	
     )

    (defun set_value (/ subdata)
            (if sublist
         (progn
             (setq key (nth (atoi (get_tile "Wx")) sublist))
       	     (setq subdata (member key data))            
             (set_tile "Depth"  (setq De (cadr subdata)))
       	     (set_tile "Flange" (setq Fl (caddr subdata)))
	     (mode_tile "accept" 0)
        )
             (mode_tile "accept" 1)
       )
     ) 

(setq f (open "d:/data.txt" "r"))
(setq data (append))

(while
(setq str (read-line f))
    (Repeat 2
(setq pos (vl-string-position 9 str))
(setq data (append data (list (substr str 1 pos))))
(setq str (vl-string-trim "\t" (substr str (+ pos 1)))) 
    )
(setq data (append data (list str)))
)

(setq id (load_dialog "AISC")) 
(new_dialog "AISC" id)
  (mode_tile "accept" 1)
  (action_tile "W" "(set_list)(set_value)")
  (action_tile "Wx" "(set_value)")

(setq sta (start_dialog))
(unload_dialog id)

(if (= sta 1) (vl-remove 'nil (list key De Fl)))
 (close f)
)

:rolleyes: Cơ bản với AutoCad (Autodesk) đã chạy ngon, còn ở cty mình dùng Cadian thì chưa chạy được, phải ngâm cứu cái đã. Mà nút thank đâu thế nhỉ, phải thanks các bác bằng lời thế này vậy. Chúc cả nhà chuẩn bị đón quốc khánh thật vui vẻ, hạnh phúc!


<<

Filename: 166854_rft.lsp
Tác giả: thanhduan2407
Bài viết gốc: 367552
Tên lệnh: ttt
Sửa lisp tự động extend và trim các đường Pline

 

>>

 

 

Bạn thử xem nhé!

(defun C:TTT (   /  LTSPLINE X)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setq LtsPline (CV:ss-to-list (ssget (list (cons 0 "*LWPOLYLINE,POLYLINE"))) nil))
  (command "Zoom" "e")
  (mapcar '(lambda(x)(Ttt1 x)) LtsPline)
(setvar "OSMODE" Olmode)
(princ)
)

(defun Ttt1 (ent  / A  CMD ENTTTT HV KC12 LENT LENTL LEPT LINT LSPT P1 P2 PNT_D PNT_T SSET TV)
  (vl-load-com)
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setvar "OSMODE" 0)
  (command "UNDO" "Begin")
;;;  (while (not ent)
;;;    (setq ent (car (entsel "Select edge line: ")))
;;;    (if	ent
;;;      (progn
;;;	(setq entl (entget ent))
;;;      )
;;;    )
;;;  )
  (if ent
    (progn
      (redraw ent 3)
      (setq a 0)
      (setq HV (LM:ssboundingbox (CV:List-to-ss (list ent))))
      (setq P1 (car HV))
      (setq P2 (cadr HV))
      (setq KC12 (distance P1 P2))
      (setq TV (list (/ (+ (car P1) (car P2)) 2) (/ (+ (cadr P1) (cadr P2)) 2)))
      (setq Pnt_T (list (- (car TV) (/ KC12 2)) (+ (cadr TV) (/ KC12 2))))
      (setq Pnt_D (list (+ (car TV) (/ KC12 2)) (- (cadr TV) (/ KC12 2))))
      (setq sset (ssget "W" Pnt_T Pnt_D (list (cons 0 "LINE"))))
      (if sset
	(repeat	(sslength sset)
	  (setq	lentl (entget (setq lent (ssname sset a)))
		lspt  (cdr (assoc 10 lentl))
		lept  (cdr (assoc 11 lentl))
	  )
	  (setq entttt (ssname sset a))
	  (setq lint (nth 0 (x_intlst ent entttt acExtendOtherEntity)))
	  (if lint
	    (progn

	      (if (< (distance lint lspt) (distance lint lept))
		(entmod	(subst
			  (cons 10 lint)
			  (assoc 10 lentl)
			  lentl
			)
		)
		(entmod	(subst
			  (cons 11 lint)
			  (assoc 11 lentl)
			  lentl
			)
		)
	      )
	    )
	  )
	  (setq a (1+ a))
	)
	
      )
      (redraw ent 4)
    )
  )
  (setvar "CMDECHO" cmd)
  (command "UNDO" "End")
  (princ)
)

;;; by kuangdao at xdcad
(defun x_intlst	(obj1 obj2 param / intlst1 intlst2 ptlst)

  (if (= 'ENAME (type obj1))
    (setq obj1 (vlax-ename->vla-object obj1))
  )
  (if (= 'ENAME (type obj2))
    (setq obj2 (vlax-ename->vla-object obj2))
  )
  (setq
    intlst1 (vlax-variant-value (vla-intersectwith obj1 obj2 param))
  )
  (if (< 0 (vlax-safearray-get-u-bound intlst1 1))
    (progn
      (setq intlst2 (vlax-safearray->list intlst1))
      (while (> (length intlst2) 0)
	(setq ptlst   (cons (list (car intlst2) (cadr intlst2) (caddr intlst2))
			    ptlst
		      )
	      intlst2 (cdddr intlst2)
	)
      )
    )
  )
  ptlst
)

(defun LM:ssboundingbox ( s / a b i m n o )
    (repeat (setq i (sslength s))
        (if
            (and
                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
                (vlax-method-applicable-p o 'getboundingbox)
                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
            )
            (setq m (cons (vlax-safearray->list a) m)
                  n (cons (vlax-safearray->list b) n)
            )
        )
    )
    (if (and m n)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
    )
)

(defun CV:List-to-ss (lst / ss)
(setq ss (ssadd))
(foreach item lst
  (or (= (type item ) 'Ename)
   (setq item (vlax-vla-object->ename  item)))
  (setq ss (ssadd item ss))
)
ss
)

(defun CV:ss-to-list (ss vla / n e l)
  (setq n (sslength ss))
  (while (setq e (ssname ss (setq n (1- n))))
	(setq l (cons (if vla (vlax-ename->vla-object e) e) l))
  ) 
)

Bac oi minh chi duoc quet chon doi tuong mot lan thoi a? Cach dung the nao vay a. Em quet chon thi khong thay gi ca. Bac xem giup em duoc khong. Cam on bac rat nhieu.

 

Chỉ cần quét Pline thôi bạn à


<<

Filename: 367552_ttt.lsp
Tác giả: duy782006
Bài viết gốc: 427506
Tên lệnh: vd vd1
thảo luận về Lisp thay block

-Giữ cơ bản của bạn mình chỉ chỉnh dòng đọc tên block được chọn sau đó array.

-Có hướng khác là đọc điểm chèn của block rồi copy nó tới điểm P0 xong array thì hiệu quả như nhau. bạn mò thêm.

-Cái nửa là hình như khi thứ tự và vị trí hai điểm chọn của bạn không đúng kiểu sẽ tính ra điểm P0 là ngoài căn phòng của bạn. Gợi ý trước hết so sánh xy của hai...

>>

-Giữ cơ bản của bạn mình chỉ chỉnh dòng đọc tên block được chọn sau đó array.

-Có hướng khác là đọc điểm chèn của block rồi copy nó tới điểm P0 xong array thì hiệu quả như nhau. bạn mò thêm.

-Cái nửa là hình như khi thứ tự và vị trí hai điểm chọn của bạn không đúng kiểu sẽ tính ra điểm P0 là ngoài căn phòng của bạn. Gợi ý trước hết so sánh xy của hai điểm P1 và P3 từ đó gán lại thứ tự hai điểm này để P0 luôn đúng.

(defun C:VD (/ P1 P3 HA CO P2 P4 D R KH KC D1 R1 P0)
        (setq P1 (getpoint "\n DIEM DAU TIEN CUA CAN PHONG")
          P3 (getcorner P1 "\n DIEM THU HAI CUA CAN PHONG")
          HA (getint "\n NHAP SO HANG DEN CUA CAN PHONG")
          CO (getint "\n NHAP SO COT DEN CUA CAN PHONG")
       
          P2 (list (car P1) (cadr P3))
          P4 (list (car P3) (cadr P1))
              D (distance P1 P4)
          R (distance P1 P2)
          KH (/ R HA)
          KC (/ D CO)
          D1 (/ D (* 2 CO))
          R1 (/ R (* 2 HA)) 
          P0 (list (+ (car P1) D1) (+ (cadr P1) R1)))
         (setq SEL (cdr (assoc 2 (entget (car (entsel "\nCHON DEN DE LAP"))))))
(command ".insert" SEL "_non" P0 "" "" "")
(command ".array" "last" "" "r" HA CO KH KC)
 )

(defun C:VD1 (/ P1 P3 HA CO P2 P4 D R KH KC D1 R1 P0)
        (setq P1 (getpoint "\n DIEM DAU TIEN CUA CAN PHONG")
          P3 (getcorner P1 "\n DIEM THU HAI CUA CAN PHONG")
          HA (getint "\n NHAP SO HANG DEN CUA CAN PHONG")
          CO (getint "\n NHAP SO COT DEN CUA CAN PHONG")
       
          P2 (list (car P1) (cadr P3))
          P4 (list (car P3) (cadr P1))
              D (distance P1 P4)
          R (distance P1 P2)
          KH (/ R HA)
          KC (/ D CO)
          D1 (/ D (* 2 CO))
          R1 (/ R (* 2 HA)) 
          P0 (list (+ (car P1) D1) (+ (cadr P1) R1)))
         (setq SEL (car (entsel "\nCHON DEN DE LAP")))
         (setq SELN (cdr (assoc 10 (entget SEL))))
(command ".copy" SEL "" "_non" SELN P0)
(command ".array" "last" "" "r" HA CO KH KC)
 )

 


<<

Filename: 427506_vd_vd1.lsp
Tác giả: proconeng86
Bài viết gốc: 323049
Tên lệnh: mx
Xin lisp tách và ghép bản vẽ

 

Lệnh MX (MultiXclip) dưới đây có thể sẽ giúp bạn.

 

Lệnh này yêu cầu bạn pick vào 1 block, sau đó yêu cầu...

>>

 

Lệnh MX (MultiXclip) dưới đây có thể sẽ giúp bạn.

 

Lệnh này yêu cầu bạn pick vào 1 block, sau đó yêu cầu bạn nhập các rectangle khung. Lệnh sẽ tạo ra các block bị cắt cúp trong các khung rectangle vừa bạn vừa nhập. Nếu công trình dạng tuyến của bạn chưa phải là block, bạn phải block nó trước khi dùng lệnh này.

 

(defun c:mx (/ ent ssr lstr tt)  (setq    ent	(car (entsel "\nHay pick vao block: "))    tt	(entget ent)    tt	(vl-remove '(102 . "{ACAD_XDICTIONARY") tt)    tt	(vl-remove (assoc 360 tt) tt)    tt	(vl-remove '(102 . "}") tt)  )  (redraw ent 3)  (while (= (length lstr) 0)    (princ "\nHay chon cac Polyline: ")    (setq      ssr  (ssget '((0 . "LWPOLYLINE") (90 . 4)))      lstr (ss2ent ssr)    )  )  (redraw ent 4)  (foreach entr	lstr    (redraw entr 3)    (entmake tt)    (command ".xclip" (entlast) "" "n" "s" entr)    (redraw entr 4)  )  (command ".erase" ent ""))(defun ss2ent (ss / sodt index lstent ent)  (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))

 

Lisp này rất hay tuy nhiên có 1 hạn chế đó là nó chỉ làm việc với khung hình chữ nhật thôi, chứ với polyline hình dạng bất kì thì chịu thua, thậm chí polyline hình dạng hình chữ nhật cũng không được. Bạn Nguyen Hoanh có thể sửa lại để nó có thể sử dụng với polyline hình dạng bất kì được không

Mình cám ơn nhiều


<<

Filename: 323049_mx.lsp
Tác giả: mhspirit
Bài viết gốc: 193106
Tên lệnh: ist
viết chữ theo đường thẳng bất kỳ bằng auto Lisp

Mình sửa lại như sau, tên lệnh đổi lại là ist vì int trùng với intersect của acad. Cao chữ nhập 1 lần, lần sau nếu k muốn đổi thì...

>>

Mình sửa lại như sau, tên lệnh đổi lại là ist vì int trùng với intersect của acad. Cao chữ nhập 1 lần, lần sau nếu k muốn đổi thì enter.

(defun c:ist(/ chu os ent obj ndai p1 p2 pm ang caoc)
 (setq	chu (getstring "Chen chu :")
caoc (getreal (strcat "\nCao chu <" (rtos (getvar "USERR1")) ">:"))
	os (getvar "OSMODE")
ent (car (entsel "\nChon duong de chen :")))
 (setvar "OSMODE" 0)
 (if (not caoc) (setq caoc (getvar "USERR1")) (setvar "USERR1" caoc))
 (while ent
(setq obj  (vlax-ename->vla-object ent)
 	ndai (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)) 2)
 	pr   (vlax-curve-getParamAtDist obj ndai)  
 	p1   (vlax-curve-getPointAtParam obj (- pr 0.1))
 	p2   (vlax-curve-getPointAtParam obj (+ pr 0.1))
 	pm   (vlax-curve-getPointAtParam obj pr)
 	ang  (if (< (car p1) (car p2)) (angle p1 p2) (angle p2 p1))
)
(command "text" "j" "BC" pm caoc (* 180 (/ ang pi)) chu)
(setq ent (car (entsel "\nChon duong de chen :")))
 )
 (setvar "OSMODE" os)
)

làm sao viết chữ tiếng việt được đây bạn,thanks


<<

Filename: 193106_ist.lsp
Tác giả: tankuljt
Bài viết gốc: 387473
Tên lệnh: c2p
Em muốn viết một Lisp để chuyển Spline thành Pline

Chương trình hoàn chỉnh, "chơi" được hàng loạt đối tượng là Line, Pline, Spline, Arc, Circle và Ellipse, với chú giải chi tiết cho từng dòng...

>>

Chương trình hoàn chỉnh, "chơi" được hàng loạt đối tượng là Line, Pline, Spline, Arc, Circle và Ellipse, với chú giải chi tiết cho từng dòng code:

 

;;;***********************************************************
;;;CONVERT TO PLINES PROGRAM WITH FULL COMMENTS!
;;;Convert all objects: Line, Pline, Spline, Arc, Circle, Ellipse_
;;;to Plines. Length of 1 segment is specified by user
;;;Copy code, Paste to Notepad, Save as *.lsp
;;;Call Appload command, Select *.lsp then Type C2P to run...
;;;Happy New Year 2008!
;;;Written by ssg - January 2008 - www.cadviet.com
;;;***********************************************************


;;;-------------------------------------------------------------
(defun makepl ( e d1 / ps pe d d2 p2) ;;;Make pline along curve e. Length of 1 segment = d1
(vl-load-com) ;;;Load Visual LISP extensions before use vlax-xxxx functions
(setq
ps (vlax-curve-getStartPoint e) ;;;Start point
pe (vlax-curve-getEndPoint e) ;;;End point
d (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) ;;;Length of curve e
d2 d1 ;;;Init variable distance
)
(command "pline") ;;;Call pline command
(command ps) ;;;Start point
(while (<= d2 d) ;;;While not over end point pe
(setq p2 (vlax-curve-getPointAtDist e d2)) ;;;Variable point at d2 = length along curve
(command p2) ;;;Continue pline command from current point to p2
(setq d2 (+ d2 d1)) ;;;Increase distance d2 by d1
) ;;;End while
(command pe "") ;;;Pline to pe and finish command
)
;;;-------------------------------------------------------------
(defun C:C2P( / d1 ss oldos i e ans) ;;;Convert to Plines
(if (not d0) (setq d0 0.5)) ;;;Init dividual distance, global variable
(setq d1 (getreal (strcat "\nLength of 1 segment <" (rtos d0) ">:"))) ;;;Input distance
(if d1 (setq d0 d1) (setq d1 d0)) ;;;Reset or get distance
(setq
ss (ssget '((0 . "LINE,LWPOLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE"))) ;;;Selection set
oldos (getvar "osmode") ;;;Save osmode
i 0 ;;;Init counter
)
(setvar "osmode" 0) ;;;Disable osmode
(repeat (sslength ss) ;;;Repeat for all entities in ss
(setq e (ssname ss i)) ;;;Set e for entity with ordinal i in selection set ss
(makepl e d1) ;;;Use makepl function. Make pline along e
(setq i (1+ i)) ;;;Increase counter
)
(initget "Y N") ;;;Init keywords
(setq ans (getkword "\nDelete source objects?  :")) ;;;Get answer from user
(if (= ans "Y") (command "erase" ss "")) ;;;Erase source objects if ans = "y" or "Y"
(setvar "osmode" oldos) ;;;Reset osmode
(princ) ;;;Silent quit
)
;;;-------------------------------------------------------------

mình dùng lisp này thì khi kết thúc lệnh đối tượng "đích" bị mất luôn.http://www.cadviet.com/upfiles/5/108637_library_cad.dwg

kết thúc lệnh chọn yes thì mất luôn đối tượng gốc, chọn no thì chỉ có đối tượng gốc, đối tượng đích thì k có.

ai giải thích giùm mình với.


<<

Filename: 387473_c2p.lsp
Tác giả: Sony2007
Bài viết gốc: 41205
Tên lệnh: tx txc tyh ty
Yêu cầu lisp căn chỉnh vị trí Text !
Text văng có thể là do bạn dùng Mtext.

Đây là Lisp tôi viết để dùng. Cái này giúp trình bày bản vẽ ngay ngắn hơn.

;CAN THANG HANG TEXT THEO PHUONG X...
>>
Text văng có thể là do bạn dùng Mtext.

Đây là Lisp tôi viết để dùng. Cái này giúp trình bày bản vẽ ngay ngắn hơn.

;CAN THANG HANG TEXT THEO PHUONG X VA PHUONG Y
(defun C:TX ( / ss pt Lst dem Tj X Pnew Vtriold VtriNew)
  	(SAVE_MODE)
  	(INIT)
  	(setq ss	(C_CHU "\n Chon cac hang text can can deu theo phuong X...")
	pt	(getpoint "\n Chon diem can dat cac dong text / 
                                       An enter se chon dong text dau tien lam chuan...")
	Lst	(SORT_X ss)
	dem 0
)
  	(if (null pt) (setq pt (cdr (POS_L0 Lst 0))))
  	(repeat (length Lst)
  	(setq	Tj		(TEXTJ (nth dem Lst))
	   		Vtriold (POS_L0 Lst dem)
			VtriNew (THAYTD Vtriold (cons Tj pt) "x")
	)
  	(entmod (subst VtriNew Vtriold (entget (nth dem Lst))))
   	(setq dem (1+ dem))
)
  	(RESTORE)
  	(DONE)
)

(defun C:TXC ( / ss pt Lst  dem Tj X Pnew Vtriold VtriNew le Tnew)
  	(SAVE_MODE)
  	(INIT)
  	(setq ss	(C_CHU "\n Chon cac hang text can can deu theo phuong X (can le center)...")
	pt	(getpoint "\n Chon diem can dat cac dong text /
                                     An enter se chon dong text dau tien lam chuan...")
	Lst	(SORT_X ss)
	dem 0
)
  	(if (null pt) (setq pt (cdr (POS_L0 Lst 0))))
  	(repeat (length Lst)
  	(setq	le		(assoc 72 (entget (nth dem Lst)))
	   		Vtriold (assoc 10 (entget (nth dem Lst)))
			VtriNew (THAYTD Vtriold (cons 11 pt) "Tj")
			VtriNew (THAYTD VtriNew (cons 11 pt) "x")
			Vtriold (assoc 11 (entget (nth dem Lst)))
			Tnew	(subst VtriNew Vtriold (entget (nth dem Lst)))
	)
   	(entmod (subst (cons 72 1) le Tnew))
   	(setq dem (1+ dem))
)
  	(RESTORE)
  	(DONE)
)
(defun C:TYH ( / ss1 ss2 pt Lst1 Lst2 Y1 Y2 Yp)
  	(SAVE_MODE)
  	(INIT)
  	(setq 	ss1	(C_CHU "\n Chon cac hang text thu nhat can can deu theo phuong Y...")
		ss2	(C_CHU "\n Chon cac hang text thu 2 can can deu theo phuong Y...")
		pt	(getpoint "\n Chon diem can dat cac hang text /
                                             An enter se chon dong text dau tien hang chon lan 1 lam chuan...")
		Lst1	(SORT_Y ss1)
		Lst2	(SORT_Y ss2)
)
  	(if (null pt) (setq pt (cdr (POS_L0 Lst1 0))))
 	(setq	Y1 		(POS_L_Y Lst1 0)
		Y2 		(POS_L_Y Lst2 0)
		Yp		(cadr pt)
)
  	(command "move" ss1 "" pt (strcat "@0," (rtos (- Yp Y1))))
(command "move" ss2 "" pt (strcat "@0," (rtos (- Yp Y2))))
  	(RESTORE)
  	(DONE)
)
(defun C:TY ( / ss pt Lst dem Tj X Pnew Vtriold VtriNew Tnew)
  	(SAVE_MODE)
  	(INIT)
  	(setq ss	(C_CHU "\n Chon cac hang text can can deu theo phuong Y...")
	pt	(getpoint "\n Chon diem can dat cac dong text / 
                                     An enter se chon dong text dau tien lam chuan...")
	Lst	(SORT_X ss)
	dem 0
)
  	(if (null pt) (setq pt (cdr (POS_L0 Lst 0))))
  	(repeat (length Lst)
  	(setq	le		(assoc 73 (entget (nth dem Lst)))
	   		Tj		(TEXTJ (nth dem Lst))
	   		Vtriold (POS_L0 Lst dem)
			VtriNew (THAYTD Vtriold (cons Tj pt) "y")
			Tnew	(subst VtriNew Vtriold (entget (nth dem Lst)))
	)
  	(entmod (subst (cons 73 0) le Tnew))
   	(setq dem (1+ dem))
)
  	(RESTORE)
  	(DONE)
)

; HAM BAY LOI
(defun INIT ()
 	(setq 	OLD_ERROR 	*error*
		*error* 	MYERROR
)
  	(command "Undo" "begin")
)

(defun MYERROR (errmsg)

 	(cond
   		(	(= errmsg "quit / exit abort")
	 	(princ)
	)
   		(	(/= errmsg "Function cancelled")
	 	(princ (strcat "\n Co loi: " errmsg))
	)
 	)
 	(command "Undo" 20)
 	(setvar "osmode" OLD_OSMODE)
(command "CECOLOR" OLD_CECOLOR)
	(DONE)
 	(prompt "\n Da thuc hien ham error, Reset lai thiet lap ban dau")
  	(command "Undo" "end")

)

(defun DONE ()
 	(if OLD_ERROR (setq *error* OLD_ERROR))
)
;;;;;----------------------------------------------------------
; HAM LUU VA TRA LAI CAC THONG SO BAN DAU
(defun SAVE_MODE()

 	(command "Undo" "begin")
(command "UCS" "W" "")
	(setq OLD_OSMODE 		(getvar "OSMODE")
			OLD_CECOLOR 	(getvar "CECOLOR")
		OLD_AUTOSNAP	(getvar "AUTOSNAP")
		OLD_ORTHOMODE	(getvar "ORTHOMODE")
)
 	(command "cmdecho" 0)

)
(defun RESTORE()

 	(command "Undo" "end")			
 	(setvar "osmode" 	OLD_OSMODE)
(setvar "AUTOSNAP"	OLD_AUTOSNAP)
(setvar	"ORTHOMODE" OLD_ORTHOMODE)
	(command "CECOLOR" OLD_CECOLOR)
 	(command "cmdecho" 1)
(Grtext -1 "Lisp's written by Nataca - 0983.715.333")
)
------------------------------------------
;;; CHON TEXT KEM DONG NHAC (BAT BUOC CHON)
(defun C_CHU (dongnhac / ss)
(while 	(and	(not (prompt dongnhac))
 						(not (setq ss	(ssget 
							'((-4 . ""))
										)
						  )
			  		)
			)
)
ss
)
;------------------------------------------
; SAP XEP LIST THEO THU TU TANG DAN CUA TOA DO X
(defun SORT_X (ss)
(setq 	lst 	(SS2LST ss)
	lst 	(vl-sort lst
			'(lambda (e1 e2)
			   	(<
					(cadr (assoc
						 	(if 	(and 	(= (cadr (assoc 11 (entget e1))) 0.0)
									(= (caddr (assoc 11 (entget e1))) 0.0)
								)
 								10 11)
							  	(entget e1)))
					(cadr (assoc
						 	(if 	(and 	(= (cadr (assoc 11 (entget e2))) 0.0)
									(= (caddr (assoc 11 (entget e2))) 0.0)
								)
 								10 11)
							   	(entget e2)))
				)
			)
		)
)
)
;------------------------------------------
;;;TOA DO DIEM CUA DOI TUONG TRONG LIST TAP HOP
(defun POS_L0 (Lst c / ob) 

(setq ob (entget (nth c Lst)))
(assoc
	(if	(and 	(= (cadr 	(assoc 11 	ob)) 0.0)
				(= (caddr 	(assoc 11 	ob)) 0.0)
		)
		10 11
	) 	
	ob
)
)
;------------------------------------------
;;;XAC DINH JUSTIFY CUA TEXTS
(defun TEXTJ (ent)
(if 	(and 	(= (cadr (assoc 11 (entget ent))) 0.0)
					(= (caddr (assoc 11 (entget ent))) 0.0)
		)
		10 11
)
)
------------------------------------------
;;; DOI TOA DO X HOAC Y HOAC Z
(defun THAYTD (TdOld TdNew vtri / Tj x y z)
(cond 	(	(= vtri "x")	
			(setq 	Tj	(car	TdOld)
					x 	(cadr 	TdNew)
					y	(caddr	TdOld)
					z	(caddr	TdOld)
			)
			(list Tj x y z)
		)
		(	(= vtri "y")	
			(setq 	Tj	(car	TdOld)
					x 	(cadr 	TdOld)
					y	(caddr	TdNew)
					z	(caddr	TdOld)
			)
			(list Tj x y z)
		)
		(	(= vtri "z")	
			(setq 	Tj	(car	TdOld)
					x 	(cadr 	TdOld)
					y	(caddr	TdOld)
					z	(caddr	TdNew)
			)
			(list Tj x y z)
		)
		(	(= vtri "Tj")	
			(setq 	Tj	(car	TdNew)
					x 	(cadr 	TdOld)
					y	(caddr	TdOld)
					z	(caddr	TdOld)
			)
			(list Tj x y z)
		)
)
)
; SAP XEP LIST THEO THU TU GIAM DAN CUA TOA DO Y
(defun SORT_Y (ss)
(setq 	lst 	(SS2LST ss)
	lst 	(vl-sort lst
			'(lambda (e1 e2)
			   	(>
					(caddr (assoc
						 	(if 	(and 	(= (cadr (assoc 11 (entget e1))) 0.0)
	 								(= (caddr (assoc 11 (entget e1))) 0.0)
								)
 								10 11)
							  	(entget e1)))
					(caddr (assoc
						 	(if 	(and 	(= (cadr (assoc 11 (entget e2))) 0.0)
	 								(= (caddr (assoc 11 (entget e2))) 0.0)
								)
 								10 11)
							   	(entget e2)))
				)
			)
		)
)
)
;------------------------------------------
;;;TOA DO Y CUA DOI TUONG TRONG LIST TAP HOP
(defun POS_L_Y (Lst c / ob ts nd) 

(setq ob (entget (nth c Lst))
		ts (assoc
				(if	(and 	(= (cadr 	(assoc 11 	ob)) 0.0)
							(= (caddr 	(assoc 11 	ob)) 0.0)
					)
					10 11
				) 	ob)

)
(caddr ts)

)

 

Khi tôi sử dụng lisp của a Nacata thì có báo lỗi như sau. Bác xem lỗi ở đâu nhé. Nghe nói bác có lisp dãn dòng cột của text đã up lên diễn đàn rồi mà tôi tìm không biết ở đâu.Chỉ giúp tôi đường link với.

 

Chon cac hang text can can deu theo phuong X...

Select objects: Specify opposite corner: 7 found

 

Select objects:

Chon diem can dat cac dong text / An enter se chon dong text dau tien lam

chuan...

Co loi: no function definition: SS2LST

Da thuc hien ham error, Reset lai thiet lap ban dau


<<

Filename: 41205_tx_txc_tyh_ty.lsp
Tác giả: dung12789
Bài viết gốc: 221755
Tên lệnh: ttt
LISP LẤY TEXT TỪ DIM

(defun dxf (code e) (cdr (assoc code (entget e))))
(defun c:ttt (/ ss e dis dmax)
(setq ss (ssget '((0 . "DIMENSION"))) dmax...
>>

(defun dxf (code e) (cdr (assoc code (entget e))))
(defun c:ttt (/ ss e dis dmax)
(setq ss (ssget '((0 . "DIMENSION"))) dmax 0)
(repeat (setq i (sslength ss))
 (setq e (ssname ss (setq i (1- i))))
 (setq dis (distance (dxf 13 e) (dxf 14 e)))
 (if (> dis dmax) (setq dmax dis))
)
(entmake (list
 (cons 0 "TEXT")
 (cons 10 (getpoint "\nDiem ghi gia tri Dim max"))
 (cons 1 (rtos dmax))
 (cons 40 1000)
  )
)
(princ)
)

thanks pro nhiều nhiều nha! lisp của pro tuyệt vời quá.


<<

Filename: 221755_ttt.lsp
Tác giả: dovananh.xd
Bài viết gốc: 172105
Tên lệnh: batter b1
Lisp rải taluy trên đường cong

Đây là Lisp mà tôi hay dùng, mọi người cùng thưởng thức

;;; ======================== VE DUONG TALUY - LENH B1 (BATTER)...
>>

Đây là Lisp mà tôi hay dùng, mọi người cùng thưởng thức

;;; ======================== VE DUONG TALUY - LENH B1 (BATTER) =========================
;;; ================================================================================

=======
;;;================================== Testlay (Tao ten va mau cho layer moi===============================
(defun testlay (lay co / tam)
	(setq datalay (list ""))     
		  	(setq tbl (tblnext "layer" 1))
		  	(while tbl
			  	(setq tam (cdr (assoc 2 tbl)))
		(setq datalay (append datalay (list tam)))
			  	(setq tbl (tblnext "layer"))
		       )
	(setq datalay (cdr datalay))
	(if (= (member lay datalay) nil)
    (command "LAYER" "n" lay "c" co lay  "s" lay "")
    (command "LAYER"   "s" lay "")
	)   
)
;; ============================================= Batter ================================================
(defun c:Batter()
  (setvar "cmdecho" 0)
  (setvar "blipmode" 0)
  (setvar "aunits" 0)
  (setvar "angbase" (/ pi 2))
  (setvar "angdir" 1)
  (if (not lint) (setq lint 10.0))
  (setq int (getdist (strcat "\nInterval <" (rtos lint 2 3) ">: ")))
  (if int (setq lint int) (setq int lint))
  (command "line" (list 0.0 0.0) (list 0.0 0.0001) "")
  (if (tblsearch "block" "tadtick")
     (command "block" "tadtick" "y" (list 0.0 0.0) (entlast) "")
     (command "block" "tadtick" (list 0.0 0.0) (entlast) "")
  )
  (while (setq refent (entsel "\nSelect reference line: "))
 	(command "undo" "group")
 	(redraw (car refent) 3)
 	(initget 1 "Cut Fill")
 	(setq reply (getkword "\nut or ill batter: "))
 	(setq s (ssget))
 	(command "measure" refent "b" "tadtick" "y" int)
 	(setq p (ssget "p") cn 0)
 	(if s
     (progn
		(while (< cn (sslength p))
	       (setq en (entget (ssname p cn)) p0 (cdr (assoc 10 en)) pt1 p0 pt2 nil b (cdr (assoc 50 en)))
	       (entdel (ssname p cn))
	       (setq p1 (polar p0 (+ (/ pi 2) B) 0.0001))
	       (command "line" p0 p1 "")
	       (command "extend" s "" (list (entlast) p1) "")
	       (setq xent (entget (entlast)))
	       (setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent))))
	       (if (not (equal xdist 0.0001 0.0001))
		  	(setq pt2 (cdr (assoc 11 xent)))
		  	(progn
			     (command "extend" s "" (list (entlast) p0) "")
			     (setq xent (entget (entlast)))
			     (setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent))))
			     (if (not (equal xdist 0.0001 0.0001))
					(setq pt2 (cdr (assoc 10 xent)))
			     )
		  	)
	       )
	       (entdel (entlast))
	       (if pt2
		  	(if (= reply "Fill")
			     (if (= (rem cn 2) 0) (command "line" pt1 pt2 "")
					(command "line" pt1 (polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2)) "")
			     )
			     (if (= (rem cn 2) 0) (command "line" pt2 pt1 "")
					(command "line" pt2 (polar pt2 (angle pt2 pt1) (/ (distance pt2 pt1) 2)) "")
			     )
		  	)
	       )
	       (setq cn (1+ cn))
		)
     )
 	)
 	(command "undo" "en")
  )
  (setvar "blipmode" 1)
  (princ)
)
(prompt "\nDraw cut/fill batter slope lines.")
;====================== BAT1 (BATTER)===========================================
(defun c:B1( / mode)

(testlay "BONG" "8")
(setvar "osmode" 0)
(c:batter)
(setvar "blipmode" 0)
(setvar "osmode" 167)
)

Bác ơi, bác có thể kiểm tra lại cái lisp này không? nó bị lỗi thế này: khi viết một đoạn text bằng lệnh DT hoặc bất cứ cái gì liên quan đến góc như: Rotation, Obliquing, ... Cụ thể hơn: khi bản vẽ chưa app lisp này vào thì khi click vào đoạn text DT và bấm Ctrl +1 thì các thông số:

Contents: Giúp em với

Style: .VnArialNarrow

Annotative: No

Justify: Left

Height: 1.5

Rotation: 0

Width factory: 1.000

Obliquing: 0

...

Nhưng sau khi sử dụng lisp này thì:

 

Contents: Giúp em với

Style: .VnArialNarrow

Annotative: No

Justify: Left

Height: 1.5

Rotation: 90

Width factory: 1.000

Obliquing: 90

...

Tại sao lại thế và sửa lại lisp như thế nào?

Xin cám ơn!


<<

Filename: 172105_batter_b1.lsp
Tác giả: proconeng86
Bài viết gốc: 306750
Tên lệnh: cvp
lisp chia viewport trong layout

Thanks ketxu. Một ý kiến hay.

Nhân đây mình post thêm version mới của Lisp chia Viewport. Sơ qua về Lisp...

>>

Thanks ketxu. Một ý kiến hay.

Nhân đây mình post thêm version mới của Lisp chia Viewport. Sơ qua về Lisp mới này:

1. Cắt viewport theo phương ngang (nếu chọn điểm chia nằm trên cạnh ngang)

2. Cắt theo phương thẳng đứng (nếu chọn điểm chia nằm trên cạnh đứng)

3. Cắt viewport thành 4 viewport nếu chọn điểm cắt không thỏa mãn cả 2 điều kiện trên.

4. Có thể mở rộng viewport bằng cách chọn điểm cắt nằm ngoài khung viewport gốc.

Tất cả đều dùng chung 1 lệnh là CVP và kết quả sẽ ra 2 hoặc 4 viewport tùy thuộc vào vị trí chọn điểm chia. Lisp này thỏa mãn được nhiều nhu cầu chia khác nhau tuy nhiên cách chọn điểm cắt sẽ phải chính xác hơn Lisp #2. Các bạn xem hình minh họa dưới đây rồi Test thử xem có lỗi gì không. Thanks

;==========LISP CHIA 1 VIEWPORT THANH 2 VIEWPORT================
;==================KANGKUNG 21/04/2013==========================
;UPDATE THEM PHAN CHIA THEO CHIEU NGANG, DOC, HOAC THANH 4 VPORT
(defun C:CVP ( / Viewport vpdata centerpoint VP_Width VP_Height pt cPWp utObj mPt xPt lbCon trCon verLst tyle
	      pt1 pt2 pt3 pt4 pt1A pt1B pt2A pt2B pt3A pt3B pt4A pt4B P1 P2 P3 P4 P5 list_VP kd kn layer)
  (vl-load-com)
  (if (= (getvar "TILEMODE") 0)
    (progn
      (if (/= (getvar "cvport") 1) (command "PSPACE"))
      (command "UNDO" "BE")
      (while (setq Viewport (ssget '((0 . "VIEWPORT"))))
	(setq vpdata(entget (ssname Viewport 0)))
	(setq layer(cdr(assoc 8 vpdata)))
	(setq n(cdr(assoc 69 vpdata)))
	(command "MSPACE") (setvar "cvport" n) (command "PSPACE")
	(setq centerpoint(cdr(assoc 10 vpdata))) (setq VP_Width(cdr(assoc 40 vpdata))) (setq VP_Height(cdr(assoc 41 vpdata)))
	(setq pt(getpoint "\n Chon diem chia: "))
	(setq os(getvar "OSMODE"))
	(setvar "OSMODE" 0)
	(if (not dist) (setq dist(atof(lisped "Nhap khoang cach giua cac Vport vao day.")))
	  (setq dist(atof(lisped (rtos dist 2 2)))))
	(setq cPWp(vlax-ename->vla-object (ssname Viewport 0))
	      utObj(vla-get-Utility(vla-get-ActiveDocument(vlax-get-acad-Object))))
	(vla-GetBoundingBox cPWp 'mPt 'xPt)
	(setq lbCon(vla-TranslateCoordinates utObj mPt acPaperSpaceDCS acDisplayDCS :vlax-false)
	      trCon(vla-TranslateCoordinates utObj xPt acPaperSpaceDCS acDisplayDCS :vlax-false))
	(if(and lbCon trCon) (setq verLst(list (vlax-safearray->list(vlax-variant-value lbCon)) (vlax-safearray->list(vlax-variant-value trCon)))))
	(setq tyle(/ VP_Width (- (car(cadr verLst)) (car(car verLst)))))
	(setq pt1(list (- (car centerpoint) (/ VP_Width 2)) (+ (cadr centerpoint) (/ VP_Height 2)))
	      pt2(list (+ (car centerpoint) (/ VP_Width 2)) (+ (cadr centerpoint) (/ VP_Height 2)))
	      pt3(list (+ (car centerpoint) (/ VP_Width 2)) (- (cadr centerpoint) (/ VP_Height 2)))
	      pt4(list (- (car centerpoint) (/ VP_Width 2)) (- (cadr centerpoint) (/ VP_Height 2)))
	      pt1A pt1
	      pt1B(list (+ (car pt1) (abs(- (car pt1) (car pt)))) (- (cadr pt1) (abs(- (cadr pt1) (cadr pt)))))
	      pt2A(list (+ (car pt1) (abs(- (car pt1) (car pt))) dist) (cadr pt1))
	      pt2B(list (+ (car pt2A) (abs(- (car pt2) (car pt)))) (cadr pt1B))
	      pt3A(list (car pt2A) (- (cadr pt2B) dist))
	      pt3B(list (car pt2B) (- (cadr pt3A) (abs(- (cadr pt3) (cadr pt)))))
	      pt4A(list (car pt1A) (cadr pt3A))
	      pt4B(list (car pt1B) (cadr pt3B)))
	(setq P1(list (car (car verLst)) (cadr (cadr verLst)))
	      P2(cadr verLst)
	      P3(list (car (cadr verLst)) (cadr (car verLst)))
	      P4(car verLst)
	      P5(list (+ (car P4) (/ (- (car pt) (car pt4)) tyle))
		      (+ (cadr P4) (/ (- (cadr pt) (cadr pt4)) tyle))))
	(if (= (car pt) (car pt1)) (setq kn 1) (setq kn 0))
	(if (= (cadr pt) (cadr pt1)) (setq kd 1) (setq kd 0))
	(setq list_VP(list (list pt1A pt1B P1 P5)
			   (list pt2A pt2B P2 P5)
			   (list pt3A pt3B P3 P5)
			   (list pt4A pt4B P4 P5)))
	(foreach VP list_VP
	  (if (/= (* (- (car (car VP)) (car (cadr VP))) (- (cadr (car VP)) (cadr (cadr VP)))) 0)
	    (progn
	      (command "MVIEW" (car VP) (cadr VP))
	      (command "MOVE" (entlast) "" (car VP) (list (- (car (car VP)) (* kn dist)) (+ (cadr (car VP)) (* kd dist))))
	      (command "MSPACE") (command "ZOOM" (caddr VP) (cadddr VP)) (command "PSPACE")
	      (vla-put-layer (vlax-ename->vla-object (entlast)) layer)
	      (vla-put-displaylocked (vlax-ename->vla-object (entlast)) :vlax-true)
	      )
	    )
	  )
	(command "ERASE" (ssname Viewport 0) "")
	(setvar "OSMODE" os)
	(command "UNDO" "END")
	)
      )
    (alert "Chuyen sang Layout truoc khi chay Lisp")
    )
  )
(defun *error* (msg)
  (if (/= os nil) (setvar "OSMODE" os))
  (command "UNDO" "END")
  )
(princ "\n              KangKung - 21/04/2013\n")
(princ "\n           Nhap CVP de chay chuong trinh\n") 

 

Minh họa tí cho sinh động:

71162_vp1_1.jpg71162_vp2_1.jpg

 

Lisp này rất hay tuy nhiên mình toàn chia luôn tại điểm chọn chuột, vì thế đưa ra bảng chọn khoảng cách view port thấy không cần thiết lắm, bạn sửa lại là bỏ lựa chọn đó đi, chia luôn tại điểm chọn chuột luôn giùm mình được không

Mình cám ơn nhiều


<<

Filename: 306750_cvp.lsp
Tác giả: LÉYHIEP
Bài viết gốc: 392359
Tên lệnh: addm
nhờ viết lisp vẽ thêm đường đồng mức phụ

 

Hề hề hề,

Gửi bạn cái này để dùng chơi xem sao nhé.

(defun c:addm (/ e...
>>

 

Hề hề hề,

Gửi bạn cái này để dùng chơi xem sao nhé.

(defun c:addm (/ e plst obj ss p0 e1 llst pls i j )
(vl-load-com)
(while (setq e (car (entsel "\n Chon duong dong muc thu nhat")))
   (setq plst (readpl e))
   (setq obj (vlax-ename->vla-object (car (entsel "\n Chon duong dong muc thu hai"))))
   (setq ss (ssadd))
   (command "undo" "be")
   (foreach p plst
        (setq p0 (vlax-curve-getclosestpointto obj p))
        (command "pline" p p0 "")
        (setq e1 (entlast)
                  ss (ssadd e1 ss)   )
   )
   (command "undo" "e")
   (setq llst (acet-ss-to-list ss)
             pls (list) )
   (command "undo" "be")
   (foreach en llst
        (command "divide" en 5)
        (setq ss1 (ssget "p"))
        (setq pts (list)
                 i 0)        
        (repeat 4
              (setq pt (cdr (assoc 10 (entget (ssname ss1 i))))
                        pts (append pts (list pt)) 
                        i (1+ i)  )
        )
        (setq pls (append pls (list pts)))
        (command "erase" ss1 "")
        (setq ss1 nil)
   )
   (command "undo" "e")
   (setq j 0)
   (command "undo" "be")
   (repeat 4
        (if (and (= (cdr (assoc 70 (entget e))) 5) (vlax-curve-isclosed obj))
            (progn
            (command "spline" )
            (foreach lst pls 
                   
                   (command (nth j lst))
            )
            (command "c" "" )
            )
            (progn
            (command "spline" ) 
                     (foreach lst (cdr pls )
                             (setq p (nth j lst))
                             (command p)
                     )
            (command  "" "" "")
            )
         )
         (setq j (1+ j))
    )
    (command "erase" ss"")
    (command "undo" "e")
)
)
 
;;;;;;;
(defun readpl (pl / e l ds p) ;;;; lay danh sach cac dinh cua pline
  (if (not (equal pl etcam))
    (progn
      (setq ds '())
      (setq e (entget pl))
      (setq l (cdr (assoc 0 e)))
      (if (= l "POLYLINE")
(progn
 (setq pl (entnext pl))
 (setq e (entget pl))
 (setq l (cdr (assoc 0 e)))
 (while (= l "VERTEX")
   (setq p (cdr (assoc 10 e)))
   (setq ds (cons p ds))
   (setq pl (entnext pl))
   (setq e (entget pl))
   (setq l (cdr (assoc 0 e)))
 )
)
      )
      (if (= l "LINE")
(setq ds (list
  (cdr (assoc 11 e))
  (cdr (assoc 10 e))
)
)
      )
;(if (/= convangbac 1001) (setq ds nil) )
      (setq ds (reverse ds))
     ;; (if (= l "LWPOLYLINE")
;;(setq ds (xddstdpl pl))
     ;; )
    )
  )
  (setq ds ds)
)

sao e ko chạy đc lisp nhỉ


<<

Filename: 392359_addm.lsp
Tác giả: chippy
Bài viết gốc: 277259
Tên lệnh: round
Lisp làm tròn số ( là Text) trong CAD ???????

 

Ứng dụng hàm Round của bác SSG đã trả lời trong topic Lisp nhân thêm hệ số K...

 

Ứng dụng hàm Round của bác SSG đã trả lời trong topic Lisp nhân thêm hệ số K vào Text. Mình đã phát triển nên đoạn Code này để làm tròn các Text sau các chữ số thập phân

;;;-------------------------------------------------------
;;;-------------------------------------------------------
(defun etype (e);;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------------
(defun rnd(x);;;Round x, return INT
(if (>= x 0) (fix (+ x 0.5)) (fix (- x 0.5)))
) 
;;;-------------------------------------------------------

(defun TP()
(setq thapphan 2);Ban co the thay doi so thap phan o dong nay
)

(defun round3(x / tue S i j S1 S3)

(setq tue (TP))

(setq S (itoa (rnd (* (abs x) (expt 10 tue)))))

(setq
i (strlen S)
j (- i tue)
S1 (substr S 1 j)
S3 (substr S (1+ j) tue)
)
(if (>= x 0) (strcat S1 "." S3) (strcat "-" S1 "." S3))
)
;;;-------------------------------------------------------
(defun C:Round( / ss k i e d v S)

(setq
ss (ssget '((0 . "TEXT,MTEXT")))
i 0

)

(repeat (sslength ss)
(setq e (ssname ss i))
(if (= (etype e) "MTEXT") (progn
(command "explode" e "")
(setq e (entlast))
))
(setq
d (entget e)
v (atof (cdr (assoc 1 d)))
S (round3 v)
d (subst (cons 1 S) (assoc 1 d) d)
)
(entmod d)
(setq i (1+ i))
)
(princ)
)
Bạn có thể thay đổi số thập phân ở dòng này : (setq thapphan 2)

Đoạn Code này chưa được hoàn thiện lắm vì theo yêu cầu của người sử dụng là khi đánh số thập phân vào thì chương trình sẽ hiểu. Nhưng ở đây lại phải thay đổi số thập phân bằng cách vào file Lisp sửa lại dòng (setq thapphan 2) mới ra được kết quả như ý.

 

Mình đã thử thay câu (setq thapphan 2) bằng câu (setq thapphan (getint "\nSo chu so thap phan la :"))

Nhưng kết quả lại không theo như ý. Vì dưới tác dụng của vòng lặp Repeat cái câu nhắc "nSo chu so thap phan la :" được lặp lại cho đến Text cuối cùng. Điều này nó không theo được ý của người sử dụng.

 

Mong bác SSG và tất cả mọi người cùng góp ý để đoạn Code trên được hoàn thiện một cách trọn vẹn.

 

Chân thành cảm ơn tất cả mọi người. sad.gif

anh TuệVN quả thật tài tình! cảm ơn anh vì những chia sẻ de đóng góp cho sự phát triển bền vững của cadviet.


<<

Filename: 277259_round.lsp
Tác giả: duy782006
Bài viết gốc: 427554
Tên lệnh: vd
thảo luận về Lisp thay block

-Lỗi do lisp tự bắt điểm. 

-Lưu ý thêm "_non" trước bất kỳ chỉ định điểm nào trong lisp thì sẽ vô hiệu hoá bắt điểm tự động ngay lúc đó.

-Sửa thêm cho bạn nếu x trùng thì không hỏi số cột, y trùng thì không hỏi số hàng.

-Cơ bản giữ nguyên của bạn, muốn tối ưu hoá cho gọn thì bạn mò nhé.

>>

-Lỗi do lisp tự bắt điểm. 

-Lưu ý thêm "_non" trước bất kỳ chỉ định điểm nào trong lisp thì sẽ vô hiệu hoá bắt điểm tự động ngay lúc đó.

-Sửa thêm cho bạn nếu x trùng thì không hỏi số cột, y trùng thì không hỏi số hàng.

-Cơ bản giữ nguyên của bạn, muốn tối ưu hoá cho gọn thì bạn mò nhé.

(defun C:VD (/ P1-Point P3-Point Max-Point Min-Point HA CO P2-Point P4-Point L-Dist W-Dist HA-Dist CO-Dist Insert-Point)
    (setq P1-Point (getpoint "\n DIEM DAU TIEN CUA CAN PHONG")
          P3-Point (getcorner P1-Point "\n DIEM THU HAI CUA CAN PHONG"))
          (setq HA 1)
          (setq CO 1)

(cond
((/= (cadr P1-Point) (cadr P3-Point))(setq HA (getint "\n NHAP SO HANG DEN CUA CAN PHONG")))
)
(cond
((/= (car P1-Point) (car P3-Point))(setq CO (getint "\n NHAP SO COT DEN CUA CAN PHONG")))
)

(prompt "\n NOI SUY THONG SO")
    (setq Max-Point (list (Max (car P1-Point) (car P3-Point)) (Max (cadr P1-Point) (cadr P3-Point)))
	  Min-Point (list (Min (car P1-Point) (car P3-Point)) (Min (cadr P1-Point) (cadr P3-Point)))
          P2-Point (list (car P1-Point) (cadr P3-Point))
          P4-Point (list (car P3-Point) (cadr P1-Point))
          L-Room (abs(- (car P3-Point) (car P1-Point)))
          W-Room (abs(- (cadr P3-Point) (cadr P1-Point)))
          HA-Dist (/ W-Room HA)
	  CO-Dist (/ L-Room CO)
          L-Dist-1 (/ L-Room (* 2 CO))
          W-Dist-1 (/ W-Room (* 2 HA)) 
         )


   (setq Sel-oject (car (entsel "\nCHON DEN DE LAP")))
   (setq Sel-oject-1 (cdr (assoc 10 (entget Sel-oject))))
  (if
    ((and (> L-Room 0) (> W-Room 0))
      (cond
	 ((and (> HA 1) (> CO 1))
	  (progn
	   (setq Insert-Point (list (+ (car Min-Point) L-Dist-1) (+ (cadr Min-Point) W-Dist-1)))
	     (command ".Pline" P1-Point P2-Point P3-Point P4-Point P1-Point "C"
                      ".copy" Sel-oject "" "_Non" Sel-oject-1 "_Non" Insert-Point
                      ".Array" "Last" "" "R" HA CO HA-Dist CO-Dist
		      )))
	 ((and (= HA 1) (> CO 1))
	  (progn
	    (setq Insert-Point (list (+ (car Min-Point) L-Dist-1) (+ (cadr Min-Point) W-Dist-1)))
	     (command ".Pline" P1-Point P2-Point P3-Point P4-Point P1-Point "C"
                      ".copy" Sel-oject "" "_Non" Sel-oject-1 "_Non" Insert-Point
                      ".Array" "Last" "" "R" 1 CO CO-Dist
		      )))
	 ((and (> HA 1) (= CO 1))
	  (progn
	    (setq Insert-Point (list (+ (car Min-Point) L-Dist-1) (+ (cadr Min-Point) W-Dist-1)))
	     (command ".Pline" P1-Point P2-Point P3-Point P4-Point P1-Point "C"
                      ".copy" Sel-oject "" "_Non" Sel-oject-1 "_Non" Insert-Point
                      ".Array" "Last" "" "R" HA 1 HA-Dist)))))
    (if
      ((and (> L-Room 0) (= W-Room 0))
	(progn
	  (setq Insert-Point (list (+ L-Dist-1 (car Min-Point)) (cadr Min-Point)))
	     (command ".Pline" P1-Point P2-Point P3-Point P4-Point P1-Point "C"
                      ".copy" Sel-oject "" "_Non" Sel-oject-1 "_Non" Insert-Point
                      ".Array" "Last" "" "R" 1 CO CO-Dist)))
      ((and (= L-Room 0) (> W-Room 0))
	(progn
	  (setq Insert-Point (list (car Min-Point) (+ (cadr Min-Point) W-Dist-1)))
	     (command ".Pline" P1-Point P2-Point P3-Point P4-Point P1-Point "C"
                      ".copy" Sel-oject "" "_Non" Sel-oject-1 "_Non" Insert-Point 
                      ".Array" "Last" "" "R" HA 1 HA-Dist)))
      )
    )
  )
      
 

 


<<

Filename: 427554_vd.lsp
Tác giả: oizdoi_oi
Bài viết gốc: 162913
Tên lệnh: tl
Routine tính tổng chiều dài các đối tượng

Tặng bạn một lisp "cực ngắn" theo đúng yêu cầu, tên lệnh là TL. Bạn có thể tuỳ nghi sửa đổi theo ý thích:

>>

Tặng bạn một lisp "cực ngắn" theo đúng yêu cầu, tên lệnh là TL. Bạn có thể tuỳ nghi sửa đổi theo ý thích:

;;;--------------------------------------------------------------------
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:TL( / Lay ss L e)
(setq
Lay (getstring "\nLayer name:")
ss (ssget "X" (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
	 (cons 8 Lay)))
L 0.0
)
(vl-load-com)
(while (setq e (ssname ss 0))
(setq L (+ L (length1 e)))
(ssdel e ss)
)
(alert (strcat "Total length of all objects in layer " Lay " = " (rtos L)))
)
;;;--------------------------------------------------------------------

Bài này tuy lâu rồi nhưng xin phép khai quật lại!

Cho mình hỏi là cái này là tính tổng chiều dài theo layer

Nhưng bạn có thể thêm cho chức năng tính theo màu (color) có được ko?

đã seach trên diễn đàn không thấy có rồi mới hỏi đấy nhé

xin cảm ơn!


<<

Filename: 162913_tl.lsp
Tác giả: toiyeuvietnam
Bài viết gốc: 302607
Tên lệnh: layoff layoff lo lo
Em cần Lisp bật tắt layer... (layon, layoff, layiso)

các anh ơi, nhò các anh giúp sủa doạn đoạn code Layoff dưới đây, dể pick đối tượng Layer nào thì đối tượng đó tắt ngay mà không phải Enter sau khi chon đối tượng giống như Freeze đấy! 


;;; ============================ Layer OFF =================================
(DEFUN LAYOFF (/ SSET SSL ENT LAY I MODE)
(setvar "cmdecho" 0)
(prompt "\nTuan Giap hay chon doi tuong...
>>

các anh ơi, nhò các anh giúp sủa doạn đoạn code Layoff dưới đây, dể pick đối tượng Layer nào thì đối tượng đó tắt ngay mà không phải Enter sau khi chon đối tượng giống như Freeze đấy! 


;;; ============================ Layer OFF =================================
(DEFUN LAYOFF (/ SSET SSL ENT LAY I MODE)
(setvar "cmdecho" 0)
(prompt "\nTuan Giap hay chon doi tuong tren layer(s) muon OFF: ")
(SETQ SSET (SSGET))
(IF (/= NIL SSET) (PROGN (SETQ SSL (SSLENGTH SSET)) (SETQ LAY "") (SETQ I 0) (SETQ MODE 0)
(WHILE (< I SSL) (SETQ ENT (ENTGET (SSNAME SSET I)))
(IF (= (CDR (ASSOC '8 ENT)) (GETVAR "CLAYER")) (SETQ MODE 1) )
(SETQ LAY (STRCAT LAY "," (CDR (ASSOC '8 ENT)) )) (SETQ I (+ I 1)))
(COMMAND "LAYER" "OFF" LAY "")
(IF (= MODE 1) (COMMAND ""))))
(setq Loff6 Loff5) (setq Loff5 Loff4) (setq Loff4 Loff3) (setq Loff3 Loff2) (setq Loff2 Loff1) (setq Loff1 LAY)
(princ (strcat "\n Layer : " LAY " da OFF.")) (setvar "cmdecho" 1) (princ))(defun c:LAYOFF () (layoff))
(defun c:LO () (layoff))

<<

Filename: 302607_layoff_layoff_lo_lo.lsp

Trang 271/330

271