- page 251

Jump to content

Info

File

Tác giả: ui_troi_2005
Bài viết gốc: 52778
Tên lệnh: toado

Cần nhờ viết list về kích thước

Chào bạn Ui_troi_2005,

Bạn xài thử thằng này coi sao:

(DEFUN EXCUTE(/ n P TX TY)
(setq str (strcat "\nPhan so le muon lay  (press Enter or Space for get...
>>

Filename: 52778_toado.lsp

Tác giả: hai_1401
Bài viết gốc: 74408
Tên lệnh: er2l

Lisp xóa toàn bộ đối tượng được ngăn bởi đường thẳng

Chào Hai_1401, đây là lisp thay cho lệnh extrim, vừa cắt xóa 1 bên đối tượng giao với 1 đường thẳng, lại vừa xóa hết các đối tượng ở 1 bên của đường thẳng...

>>

Chào Hai_1401, đây là lisp thay cho lệnh extrim, vừa cắt xóa 1 bên đối tượng giao với 1 đường thẳng, lại vừa xóa hết các đối tượng ở 1 bên của đường thẳng chặn

;; ERCLINE.LSP free lisp from cadviet.com
;; copyright by Thiep,09/2009
;;;--------------------------
(defun line (Model p1 p2)
 (vla-Addline
   Model
   (vlax-3d-point p1)
   (vlax-3d-point p2)
 )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun CalcZ (Pt1 Pt2 Pt3 / v w)
 (setq	v (mapcar '- Pt1 Pt2)
w (mapcar '- Pt3 Pt2))
 (- (* (car v) (cadr w)) (* (cadr v) (car w)))
)
;;;-----------------------
(defun SS-enlst	(ss / c L)
 (setq c -1)
 (repeat (sslength ss)
   (setq L (cons (ssname ss (setq c (1+ c))) L))
 )
 (reverse L)
)
;;;-----------------------MAIN LISP----------------------------
(vl-load-com)
(defun c:er2l (/ encur	enobjL objL   objLW1 tmp    LenssBR
	 ss1	ss2    regn   ll     ur	    ul	   lr
	 oc1	oc2    oc3    oc4    c1	    c2	   c3
	 c4	ps     pe     p2     enXL   enc1   enc2
	 enc3	enc4   ssER   LenssER
	)
 (princ "\nFree lisp from www.cadviet.com")

 (acet-error-init
   (list
     (list "cmdecho"	0	    "highlight"	0	    "regenmode"
    1		"osmode"    0		"ucsicon"   0
    "offsetdist"	    0		"attreq"    0
    "plinewid"	0	    "plinetype"	1	    "gridmode"
    0		"celtype"   "CONTINUOUS"	    "ucsfollow"
    0		"limcheck"  0
   )
     T

;;;flag. True means use undo for error clean up.
     '
      (if
redraw_it
(redraw na 4)
      )
   )
 )
;;;acet-error-init
;;;--------------------
 (command "undo" "be")
 (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
*Model*	(vla-get-ModelSpace ActDoc)
 )
 (setvar "osmode" 0)
 (setvar "pdmode" 0)
 (setq ss1 (ssadd))
 ;; get objects to break
 (prompt "\nBreak objects touching selected objects.")
 (if
   (and (not (prompt "\nSelect object(s) to break & press enter: "))
 (setq encur (ssname (ssget '((0 . "LINE"))) 0))
 (mapcar '(lambda (x) (ssadd x ss1)) (gettouching encur))
   )
    (break_with ss1 encur)
 )
;;;======================================
 (redraw encur 3)
 (setq	objL (vlax-ename->vla-object encur)
ps   (vlax-curve-getstartpoint objL)
pe   (vlax-curve-getendpoint objL)
Xs (car ps)
Ys (cadr ps)
Xe (car pe)
Ye (cadr pe)
 )
 (setq p2 (getpoint "pick a point side:"))
 (setq	ll (getvar "extmin")
ur (getvar "extmax")
lr (list (car ur) (cadr ll) 0.0)
ul (list (car ll) (cadr ur) 0.0)
ll (list (car ll) (cadr ll) 0.0)
ur (list (car ur) (cadr ur) 0.0)
 )
 (setq regn (CalcZ ps p2 pe))
 (if (< regn 0)
   (setq flag -0.1)
   (setq flag 0.1)
 )
 (setq	objLW1 (car (vlax-safearray->list
	      (vlax-variant-value (vla-offset objL flag))
	    )
       )
enobjL (vlax-vla-object->ename objLW1)
 )
 (setq	LenssBR	(gettouching enobjL))
 (mapcar 'entdel LenssBR)
 ;;;-------------------------
 (vla-put-visible objL :vlax-false)
 (setq	enc1 (vlax-vla-object->ename (line *Model* ll ul))
enc2 (vlax-vla-object->ename (line *Model* ul ur))
enc3 (vlax-vla-object->ename (line *Model* ur lr))
enc4 (vlax-vla-object->ename (line *Model* lr ll))
c1 (car (acet-geom-intersectwith enc1 enobjL 2))
c2 (car (acet-geom-intersectwith enc2 enobjL 2))
c3 (car (acet-geom-intersectwith enc3 enobjL 2))
c4 (car (acet-geom-intersectwith enc4 enobjL 2))
 )
 (mapcar 'entdel
  (list enobjL enc1 enc2 enc3 enc4)
 )
 (cond	((and c1 c2 (< Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c2 ur lr ll c1))
    (setq lstfen (list c1 ul c2))
  )
)
((and c1 c2 (> Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c1 ul c2))
    (setq lstfen (list c2 ur lr ll c1))
  )
)
((and c1 c3 (< Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c1 c3 lr ll))
    (setq lstfen (list c1 c3 ur ul))
  )
)
((and c1 c3 (> Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c1 c3 ur ul))
           (setq lstfen (list c1 c3 lr ll))
  )
)
((and c1 c4 (< Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c1 c4 ll))
    (setq lstfen (list c1 ul ur lr c4))
  )
)
((and c1 c4 (> Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c1 ul ur lr c4))
    (setq lstfen (list c1 c4 ll))
  )
)
((and c2 c3 (< Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c2 c3 lr ll ul))
    (setq lstfen (list c2 c3 ur))
  )
)
((and c2 c3 (> Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c2 c3 ur))
    (setq lstfen (list c2 c3 lr ll ul))
  )
)
((and c2 c4 (< Ys Ye))
  (if (< regn 0)
    (setq lstfen (list c2 ur lr c4))
    (setq lstfen (list c2 c4 ll ul))
  )
)
((and c2 c4 (> Ys Ye))
  (if (< regn 0)
    (setq lstfen (list c2 c4 ll ul))
    (setq lstfen (list c2 ur lr c4))
  )
)
((and c3 c4 (< Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c3 lr c4))
    (setq lstfen (list c4 ll ul ur c3))
  )
)
((and c3 c4 (> Xs Xe))
  (if (< regn 0)
    (setq lstfen (list c4 ll ul ur c3))
    (setq lstfen (list c3 lr c4))
  )
)
 ); end cond
 (setq ssER (ssget "CP" lstfen))
 (if ssER
   (progn
     (setq LenssER (SS-enlst ssER))
     (if (member encur LenssER)
(setq LenssER (SS-enlst (ssdel encur ssER)))
     )
     (vla-put-visible objL :vlax-false)
     (mapcar 'entdel LenssER)
   )
 )
 (vla-put-visible objL :vlax-true)
 (vlax-invoke-method ActDoc 'Regen acActiveViewport) ; regen
 (command "undo" "end")
 (acet-error-restore)
 (setvar "pdmode" 35)
 (princ)
 (princ
   "\nChuc cac ban may man va thanh cong - Thiep 0918841230"
 )
(princ)
)
;;;====================================================================
(defun break_with (ss2brk enL /	lst masterlist ss oc break_obj intpts)
 (princ "\nCalculating Break Points, Please Wait.\n")

 ;;========================================
 ;; Break entity at break points in list
 ;;========================================

 (defun break_obj (ent	brkptlst   /	      brkobjlst	 en
		enttype	   maxparam   closedobj	 minparam
		obj	   obj2break  p1param	 p2param
		brkpt2	   dlst	      idx	 brkptS
		brkptE	   brkpt      result	 result
		ignore	   dist	      tmppt	 #ofpts
		enddist	   lastent    obj2break	 stdist
	       )
    (setq obj2break ent
  brkobjlst (list ent)
  enttype   (dxf 0  ent)
  closedobj (vlax-curve-isclosed obj2break)
   )
   (setq spt	   (vlax-curve-getstartpoint ent)
  ept	   (vlax-curve-getendpoint ent)
  brkptlst (vl-remove-if
	     '(lambda (x)
		(or (< (distance x spt) 0.0001)
		    (< (distance x ept) 0.0001)
		)
	      )
	     brkptlst
	   )
   )
   (if	brkptlst
     (progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst
       (mapcar
	 '(lambda (x)
	    (list
	      x
	      (vlax-curve-getdistatparam
		obj2break
		;; ver 2.0 fix
		(cond
		  ((vlax-curve-getparamatpoint obj2break x)
		  )
		  ((vlax-curve-getparamatpoint
		     obj2break
		     (vlax-curve-getclosestpointto
		       obj2break
		       x
		     )
		   )
		  )
		)
	      )
	    )
	  )
	 brkptlst
       )
)
;; sort primary list on distance
(setq
  brkptlst (vl-sort brkptlst
		    '(lambda (a1 a2) (< (cadr a1) (cadr a2)))
	   )
)

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

;; (if (equal a ent) (princ)) ; debug CAB -------------

(foreach brkpt (reverse brkptlst)
    (setq brkptS (car brkpt)
	  brkptE brkptS
    )
  ;; get last entity created via break in case multiple breaks
  (if brkobjlst
    (progn
      (setq tmppt brkptS)	; use only one of the pair of breakpoints
      ;; if pt not on object x, switch objects
      (if (not (numberp	(vl-catch-all-apply
			  'vlax-curve-getdistatpoint
			  (list obj2break tmppt)
			)
	       )
	  )
	(progn			; find the one that pt is on
	  (setq idx (length brkobjlst))
	  (while
	    (and (not (minusp (setq idx (1- idx))))
		 (setq obj (nth idx brkobjlst))
		 (if (numberp (vl-catch-all-apply
				'vlax-curve-getdistatpoint
				(list obj tmppt)
			      )
		     )
		   (null (setq obj2break obj))
				; switch objects, null causes exit
		   t
		 )
	    )
	  )
	)
      )
    )
  ); end (if brkobjlst

  ;;; Handle any objects that can not be used with the Break Command
  ;;; using one point, gap of 0.000001 is used
  (setq closedobj (vlax-curve-isclosed obj2break))
;;; single breakpoint ----------------------------------------------------
    (if
      (and closedobj
	   (not	(setq
		  brkptE (vlax-curve-getPointAtDist
			   obj2break
			   (+ (vlax-curve-getdistatparam
				obj2break
				;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
				;; ver 2.0 fix
				(cond
				  ((vlax-curve-getparamatpoint
				     obj2break
				     brkpts
				   )
				  )
				  ((vlax-curve-getparamatpoint
				     obj2break
				     (vlax-curve-getclosestpointto
				       obj2break
				       brkpts
				     )
				   )
				  )
				)
			      )
			      0.00001
			   )
			 )
		)
	   )
      )
       (setq
	 brkptE	(vlax-curve-getPointAtDist
		  obj2break
		  (- (vlax-curve-getdistatparam
		       obj2break
		       (cond ((vlax-curve-getparamatpoint
				obj2break
				brkpts
			      )
			     )
			     ((vlax-curve-getparamatpoint
				obj2break
				(vlax-curve-getclosestpointto
				  obj2break
				  brkpts
				)
			      )
			     )
		       )
		     )
		     0.00001
		  )
		)
       ); end setq brkptE
    ); end fi (and closedobj

  (setq LastEnt (GetLastEnt))
  (command "._break"
	   obj2break
	   "_non"
	   (trans brkptS 0 1)
	   "_non"
	   (trans brkptE 0 1)
  )
  (and (= "CIRCLE" enttype) (setq enttype "ARC"))
  (if (and (not closedobj)	; new object was created
	   (not (equal LastEnt (entlast)))
      )
    (setq brkobjlst (cons (entlast) brkobjlst))
  ); end (if (and
); end (foreach brkpt (reverse brkptlst)
     );end progn brkptlst
   ); end if brkptlst

 ); defun break_obj

 ;;====================================
 ;; CAB - get last entity in datatbase
 (defun GetLastEnt (/ ename result)
   (if	(setq result (entlast))
     (while (setq ename (entnext result))
(setq result ename)
     )
   )
   result
 )
 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 ;; S T A R T              S U B R O U T I N E             H E R E
 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(if (and ss2brk enL)
   (progn
     (setq oc 0)
     ;; CREATE a list of entity & it's break points
     (foreach en (SS-enlst ss2brk)
				; check each object in ss2brk
(if (not (acet-layer-locked (dxf 8 en)))
  (progn
    (setq lst nil)
    ;; check for break pts with other objects in ss2brkwith
    (if	(and (not (equal en enint))
	     (setq intpts (acet-geom-intersectwith en enL 0))
	)
      (setq lst (append intpts lst))
				; entity w/ break points
    )
    (princ (strcat "Objects Checked: "
		   (itoa (setq oc (1+ oc)))
		   "\r"
	   )
    )
    (if	lst
      (setq masterlist
	     (cons (cons en lst) masterlist)
      )
    )
  )
)
     )
     (princ "\nBreaking Objects.\n")
     (if masterlist
(foreach obj2brk masterlist
  (break_obj (car obj2brk) (cdr obj2brk))
)
     )
   )
 )
);end break_with
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (en / ss lst lstb lstc objl)
 (and
   (setq objl (vlax-ename->vla-object en))
   (setq
     ss
      (ssget
 "_A"
 (list
   (cons 0
	 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
   )
   (cons 410 (getvar "ctab"))
 )
      )
   )
   (setq lst (SS-enlst ss)
  lst (mapcar 'vlax-ename->vla-object lst)
   )
   (mapcar
     '(lambda (x)
 (if (not
       (vl-catch-all-error-p
	 (vl-catch-all-apply
	   '(lambda ()
	      (vlax-safearray->list
		(vlax-variant-value
		  (vla-intersectwith objl x acextendnone)
		)
	      )
	    )
	 )
       )
     )
   (setq lstc (cons (vlax-vla-object->ename x) lstc))
 )
      )
     lst
   )
 )
 lstc
)

Cám ơn bác rất nhiều, lisp bác viết rất đúng ý em và chạy cũng rất chuẩn, thanks :cheers:

<<

Filename: 74408_er2l.lsp

Tác giả: DuckieVra
Bài viết gốc: 86841
Tên lệnh: sct

Mình cần 1 lisp scale nhiều đối tượng 1lúc

Sao bạn không vẽ mặt cắt cốt thép bằng lệnh donut?
Lệnh scale donut tại tâm của nó nằm ở đây :

>>
Sao bạn không vẽ mặt cắt cốt thép bằng lệnh donut?
Lệnh scale donut tại tâm của nó nằm ở đây :

http://www.cadviet.com/forum/index.php?sho...amp;#entry68859

Bài viết số 10 bạn nhé

Còn Lisp scale "đường tròn" cốt thép của bạn thì bạn hãy thử code này nhé :
(defun TraceCIRCLE (obj / sp ep inc pt ptlst)
;Thanks gia_bach for this function;
(setq sp 0
ep (* 2 pi)
inc (/ ep 72) )
(while (< sp ep)
(setq pt (vlax-curve-getPointAtParam obj sp)
ptlst (cons pt ptlst)
sp (+ inc sp)) )
(reverse ptlst)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:sct (/ sscir i n ent cen lstp ss tl vl ov)
;copyright by Tue_NV 
(vl-load-com)
(setq vl '("osmode" "orthomode" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(mapcar 'setvar vl '(0 0 0))
(command "undo" "be")
(if (not *tl*) (setq *tl* 1.0))
(setq tl (getdist (strcat "\n Nhap he so ti le < " (rtos *tl* 2 2) " > : ")))
(if (not tl) (setq tl *tl*) (setq *tl* tl))
(if (setq sscir (ssget (list (cons 0 "CIRCLE"))))
(progn 
(setq n (sslength sscir) i 0)

(while (< i n)
(setq ent (ssname sscir i)
	cen (cdr (assoc 10 (entget ent)))
)

(if (= (cdr (assoc 0 (entget ent))) "CIRCLE")
(progn 
(setq lstp (traceCircle (setq ob (vlax-ename->vla-object ent))) )
(if (setq ss (ssget "cp" lstp (list(cons 0 "HATCH")) )) 
(command "scale" ss ent "" cen tl)
)
);progn
);if
(setq i (1+ i))
);while
(command "undo" "e")
(mapcar 'setvar vl ov) ; reset Sys Vars
);progn
(alert "\n Ban chua chon doi tuong nao ca")
);if
(princ)
)
thanks Tue NV nhìu nhá.Mình sẽ thử.Cadviet thật tuyệt vời vì trong 4rum toàn những người nhiệt tình. Thaks all.

(Ngoài lề 1chút sao mình vào phần trả lời nhanh ko gõ đc tiếng Việt nhỉ.Chỉ giúp mình nhá.hihì)

<<

Filename: 86841_sct.lsp

Tác giả: nguyenbd1
Bài viết gốc: 322639
Tên lệnh: cbl

nhờ viết lisp tạo mới một block và chèn vào bản vẽ

bạn hiểu nhầm ý tơ

Của bạn đây:
(defun c:cbl(/ tt diem )
(setq tt ...
>>
bạn hiểu nhầm ý tơ
Của bạn đây:
(defun c:cbl(/ tt diem )
(setq tt  (getfiled "\n Chon Blog: (.dwg)" "C:\\Program Files\\AutoCAD 2007\\Support\\Block\\" "dwg" 2))

(or *tyle* (setq *tyle* 1))
(setq tyle (getreal (strcat "\n Nhap Ty Le <"
			  (rtos *tyle* 2 2)
			 "> :"
		  )
	 )
)
(if (not tyle) (setq tyle *tyle*) (setq *tyle* tyle))	
(While 
(setq diem (getpoint "\n Chon Diem Insert Block :"))   
(command "insert" tt "s" tyle diem "")
))
Đầu tiên lập một thư mục Block theo đường dẫn : C:\\Program Files\\AutoCAD 2007\\Support\\Block. Nếu bạn dùng bản cad nào khác thì thay thế Autocad 2007 thành tương ứng.

Sau đó bạn tạo block bằng cách trên dòng lệnh comand gõ: Wblock và lưu vào thư mục Block ở trên (Nếu banh chưa rành về wblock thì có thể hỏi Mr. Google. :D)

Khi cần dùng bạn gõ lệnh cbl trên comand line và insert block vào điểm mình cần. Có thể dùng cách này với mọi bản vẽ cả mới lẫn cũ. Chúc bạn thành côn
cảm ơn bạn dã quan tam
bạn hiểu nhầm ý tớ roi. tớ muốn tất cả block tớ cần chèn nằm cùng 1 bản vẽ. vì có
rất nhiêu block. nếu có 1000 cái block dang wblok thì phải có 1000 cái bản vẽ a. tớ muốn 100 cái block dó nằm trong 1 bản vẽ mà vẫn chèn duoc. ban xem lai ho minh cái ..
<<

Filename: 322639_cbl.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 382323
Tên lệnh: test

Nhờ Chỉnh Sửa Lisp Nối Text Cao Độ

Mình có down lisp này từ diễn đàn, nội dung của nó là nối các cặp chữ số lại với nhau ngăn cách bởi dấu “.” tạo...
>>
Mình có down lisp này từ diễn đàn, nội dung của nó là nối các cặp chữ số lại với nhau ngăn cách bởi dấu “.” tạo thành các text cao độ, với điều kiện xét khoảng cách giữa 2 text ( insertion ) với tham số d do mình nhập vào, nhưng khi mình chọn = d thì thấy nó chạy không đúng, < d cũng đôi lúc chạy không đúng luôn. Mong các cao thủ sửa giúp ạ. Mình xin cảm ơn
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/65194-yeu-cau-lisp-noi-text-tu-dong/
(defun c:test(/ lstObj d ans ins! tObj tam isFound lstObj lstRs)
(setq lstObj (mapcar 'vlax-ename->vla-object (acet-ss-to-list (ssget (list (cons 0 "*TEXT")))))
  d (getdist "\nKhoang cach :")
  ans (getstring "\n<=d hay =d ?  :")
)
(defun ins!(e)(vlax-get e 'Insertionpoint))
(while (setq tObj (car lstObj))
(setq tam (ins! tObj))
(cond 
   ((setq isFound (vl-member-if '(lambda(x)(and (setq kc (- (distance (ins! x) tam) d))
                                                (if (wcmatch ans ",<")(not (minusp kc))(zerop kc)) )
                                 ) (setq lstObj (cdr lstObj))) )
   (setq isFound (vl-sort isFound '(lambda(x y)(< (distance (ins! x) tam)(distance (ins! y) tam))))
	lstObj (vl-remove (car isFound) lstObj)
	lstRs (vl-sort (list tobj (car isFound)) '(lambda(x y)(< (car (ins! x))(car (ins! y))))))
   (vla-put-textstring (car lstRs)
	(strcat
	(vla-get-textstring (car lstRs)) "."
	(vla-get-textstring (last lstRs))
	)
   )
   (vla-delete (last lstRs))
  )
)
)
)
Hề hề hề,

Hãy thử sửa lại :

(if (wcmatch ans ",<")(not (minusp kc))(zerop kc)) )

thành

(if (wcmatch ans "<")(not (minusp kc))(zerop kc)) )

<<
Download lisp
Filename: 382323_test.lsp

Tác giả: vantin_pro
Bài viết gốc: 68068
Tên lệnh: td

Xin Lisp xuat toa độ

;GHI TOA DO CAC DIEM VA THONG KE THANH BANG
----------------------------------------------
(defun C:td (/ diem PT1 PT2 PT3 tapx tapy 
	   x y xx yy h n di kc
	   C PT PTX PTY PTD PTC...
>>

;GHI TOA DO CAC DIEM VA THONG KE THANH BANG
----------------------------------------------
(defun C:td (/ diem PT1 PT2 PT3 tapx tapy 
	   x y xx yy h n di kc
	   C PT PTX PTY PTD PTC N
	   p1 p2 p3 p4 p11 p22 p33 L1 L2 L11 L22)
(setvar "cmdecho" 0 )
(command "Undo" "Begin")  
 (setq om (getvar "osmode"))
 (setq tapx '()
tapy '()
stt '()
k 0
h (getreal "\nnhap chieu cao chu:"))

(while
 (setq diem (getpoint "\nchon cac vi tri co toa do can ghi:"))
 (progn
(setq   PT1 (list(+ (* 3 h) (car diem))(+ (* 3 h) (cadr diem)))
	PT2 (list (car PT1) (- (cadr PT1)(+ 1 h) ) )
	 x (rtos(car diem) 2 4)
		 y (rtos (cadr diem) 2 4)
   tapx (append tapx (list x))
   tapy (append tapy (list y))
	 k (+ 1 k)
	 N (strcat "N" (rtos k 2 0))
	stt (append stt (list N))
  );setq
 (setvar "osmode" 0)
 (command "text" "j" "BL" PT1 h 0 x)
 (setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar PT1 0 (+ di h))
C  (polar PT3 0 (* 1.5 h))
  );setq
(command "text" PT2 h 0 y
	 "pline" diem PT1 PT3 ""
	 "circle" (polar PT3 0 (* 1.5 h)) (* 1.5 h)
	 "text" "m" (polar PT3 0 (* 1.5 h)) h 0 N )

(setvar "osmode" om)
);progn   
 );dong while

;tao bang thong ke
 (setq	kc (* 2 di)
	PT (getpoint"\nvi tri dat bang :")
PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
  p1 (list (car PT) (+ (cadr PT)(* 2 h)))
  p2 (list (car PTC) (+ (cadr PTC)(* 2 h)))
	  p3 (list (car p1) (+ (cadr p1)(* 2 h)))
	  p4 (list (car p2) (+ (cadr p2)(* 2 h)))
PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
PTY (list (+ kc (car PTX)) (cadr PTX))
  p11 (list (+ (/ di 2) (car p1))  (+ h (cadr p1)))
  p22 (list (+ di (/ di 2) (car p11)) (cadr p11))
  p33 (list (+ kc (car p22)) (cadr p22))
  L1 (list (+ di (car p3))(cadr p3))
  L2 (list (+ kc (car L1))(cadr L1))
 n (length tapx)
 k 0
);setq
(setvar "osmode" 0)
 (command "line" p1 p2 ""
   "text" "j" "m" p11 h 0 "STT" 
   "text" "j" "m" p22 h 0 "Täa ®é X" 
   "text" "j" "m" p33 h 0 "Täa ®é Y"
   "line" p3 p4 "")	

 (while (< k n) 
(setq xx (nth k tapx)
  yy (nth k tapy)
 tstt(nth k stt))
(command "text" "j" "m" PTD h 0 tstt 
		 "text" "j" "m" PTX h 0 xx 
	 "text" "j" "m" PTY h 0 yy 
	 "line" PT PTC "")	
(setq PT (list (car PT) (- (cadr PT)(* 2 h)))
	 PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
 PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
 PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
 PTY (list (+ kc (car PTX)) (cadr PTX))
  k (+ 1 k));setq
 );while
 (if (= k n)
(setq PT (list (car PT) (+ (cadr PT)(* 2 h)))
	  PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
  L11 (list (+ di (car PT))(cadr PT))
  L22 (list (+ kc (car L11))(cadr L11))
  );setq
);if
(command "line" p3 PT ""
	  "line" p4 PTC ""
  "line" L1 L11 ""
  "line" L2 L22 "")
(setvar "osmode" om )
(setvar "cmdecho" 1)
(prompt"\nxong\n")
 (command "Undo" "End")
 (princ)
);DONG toado

lisp này ghi tọa độ vào mỗi điểm bạn cần kiểm tra và xuất bảng thống kê tọa độ trực tiếp ra màn hình.

Nếu bạn muốn xuất ra file excel thì mình nghĩ có nhiều cách để làm việc đó khi đã có bảng tọa độ

<<

Filename: 68068_td.lsp

Tác giả: duyngoc
Bài viết gốc: 117894
Tên lệnh: gpmb

Bạn thử lại code này nhé:
(DEFUN C:gpmb(/ TH SS Index PtIns Ent PtM PtL PtR SSL SSR LenSSL LenSSR LstPtXL LstPtXR
	  XL XR YL YR I PtDimLine) 
(ACET-ERROR-INIT (LIST...
>>
Bạn thử lại code này nhé:
(DEFUN C:gpmb(/ TH SS Index PtIns Ent PtM PtL PtR SSL SSR LenSSL LenSSR LstPtXL LstPtXR
	  XL XR YL YR I PtDimLine) 
(ACET-ERROR-INIT (LIST (LIST "OSMODE" 0 "CLAYER" "DIM" "CMDECHO" 0) T))
(setq TH (getstring "\nChoòn trýõÌng hõòp: "))
(setq ss (ssget "X" '((0 . "INSERT") (2 . "Dau_co")))
  Index 0)
 (while (setq Ent (ssname ss Index))
(setq PtIns (cdr (assoc 10 (entget ent)))	
  PtM (polar PtIns (/ pi 2) -10))
(command "Zoom" "c" PtM 25)
(setq PtL (polar PtM pi 20);Dieu chinh cho nay cho phu hop
  PtR (polar PtM 0 20)
  PtM (polar PtM (/ pi 2) 1)
  SSL (ssget "c" PtM PtL '((0 . "LINE") (8 . "ENTTNTHIETKE")))
  SSR (ssget "c" PtM PtR '((0 . "LINE") (8 . "ENTTNTHIETKE")))
  Index (1+ Index))
(setq LenSSL (sslength SSL)
  I 0
  LstPtXL Nil)
(while (< I LenSSL)
  (Setq LstPtXL (append LstPtXL (list(cadr (assoc 10 (entget (ssname SSL I)))))) I (1+ I))
)
(Setq XL (nth 0 (vl-sort LstPtXL '<)))
(setq LenSSR (sslength SSR)
  I 0
  LstPtXR Nil)
(while (< I LenSSR)
  (Setq LstPtXR (append LstPtXR (list(cadr (assoc 10 (entget (ssname SSR I)))))) I (1+ I))
)
(Setq XR (nth 0 (vl-sort LstPtXR '>)))
(setq I 0)
(while (< I LenSSL)
  (if (= (cadr (assoc 10 (entget (ssname SSL I)))) XL)
(setq YL  (caddr (assoc 10 (entget (ssname SSL I)))))
  )
  (setq I (1+ I))
)
(setq I 0)
(while (< I LenSSR)
  (if (= (cadr (assoc 10 (entget (ssname SSR I)))) XR)
(setq YR  (caddr (assoc 10 (entget (ssname SSR I)))))
  )
  (setq I (1+ I))
)	
(setq PtL (polar (list XL YL 0.0) pi 1.5))
(if (= TH "1")
  (setq PtR (polar (list XR YR 0.0) 0 1.5))
  (setq PtR (list XR YR 0.0))
)
(command "Insert" "GPMB" PtL "" "" "" )
(command "Insert" "GPMB" PtR "" "" "")
(command "mirror" "l" "" PtR (polar PtR (/ pi 2) 5) "y")	
(setq PtM (polar PtM (/ pi 2) 5)
  PtL (list (car PtL) (cadr PtM) 0.0)
  PtR (list (car PtR) (cadr PtM) 0.0) 
  PtDimLine (polar PtM (/ Pi 2) 2))
(command "_dimlinear" PtL PtM PtDimLine)
(command "_dimlinear" PtM PtR PtDimLine)  
 )
 (command "zoom" "e")
 (acet-error-restore)
)
Có thay đổi: Bạn chỉ cần tạo một khối mốc lộ giới Trái với tên GPMB, tôi dx bổ sung chức năng Mirror để chuyển nó sang bên phải.

Lưu ý: - Điểm chèn (Insert Point) của Block đặt trong Block đừng để xa tít mù tắp như cái Block GPMB ban đầu cảu bạn. Vì rất khó xác định điểm chèn Block trên mặt đất tự nhiên nên tôi chỉ xác định được cao độ của chân đường đắp hoặc đỉnh đường đào thôi.

- Vùng chọn các đối tượng tôi tính từ tâm ra mỗi phía 20m nên nếu các trắc ngang có khoảng cách từ tim đến chân đường đắp hoặc đỉnh đường đào lớn hơn 20m thì sẽ ko xác định được, nếu có chỗ nào lớn hơn thì chuyển riêng trắc đó vào một file và chỉnh các dòng như chú thích trong code cho phù hợp, không chỉnh tổng thể vì sẽ dễ bị chọn nhầm sang các trắc khác.
các bác cho e hỏi lệnh dùng cho líp này là lệnh gì vậy? em đã sử dụng lệnh GPMB mà không được. thanks các bác nhiều nhieu

<<

Filename: 117894_gpmb.lsp

Tác giả: funnyzui
Bài viết gốc: 128662
Tên lệnh: tl

Lisp ghi chiều dài đoạn thẳng theo Scale factor của Dimstyle hiện thời

Chào bạn Thaistreetz,
Bạn dùng thử cái này nha:
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam...
>>
Chào bạn Thaistreetz,
Bạn dùng thử cái này nha:
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:TL( / ss L e)
(setq
ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
L 0.0
k (getvar "dimlfac")
)

(vl-load-com)
(while (setq e (ssname ss 0))
(setq L (* k (length1 e)))
(setq ans (getstring "\n Ban hay chon phuong an nhap ket qua "))
(if (= ans "1")
(progn
(setq te (entget(car(entsel "\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
)
(progn
(setq p (getpoint "\n Chon diem nhap ket qua" ))
(setq h (getreal "\n Nhap chieu cao text ket qua "))
(command "text" p h "0" (rtos L 2 2))
)
)
(ssdel e ss)
)
(princ)
)
;;;--------------------------------------------------------------------
Đoạn lisp này mình chỉnh sửa lại từ cái lisp của bác SSG và bác Tue_nv do mình nghĩ có thể bác Tue_NV hiểu nhầm ý bạn. Bạn muốn lấy các độ dài của từng đoạn chứ không phải lấy tổng độ dài, vả lại bạn cũng muốn kết quả ghi theo tỷ lệ của dimstyle hiện tại chứ không phải là kết quả đo được nữa. Ở lisp này mình cũng để bạn chọn phương án nhap kết quả , nhưng bạn lưu ý là khi lisp hỏi bạn chỉ cần gõ 1 hoặc enter là đủ bạn nhé. Bạn xài thử xem nhé. Nếu có gì trục trặc xin báo lại vì mình cũng chưa kiểm nghiệm nó do chưa có thời gian bạn ạ. Thực ra mình cũng chưa ưng ý với lisp này do nếu như bạn chọn khá nhiều đối tượng thì việc nhớ được trật tự khi lựa chọn đối tượng không hề dễ. Theo ý mình thì nên mỗi lần chỉ chọn một đối tượng và sau khi chạy xong thi lisp sẽ hỏi bạn có muốn tiếp tục hay không, nếu có thì chọn đối tượng tiếp, còn nếu không thì kết thúc sẽ thuận lợi cho việc chỉnh sửa trên bản vẽ của bạn hơn.

Không biết bạn nghĩ sao, nếu bạn đồng ý mình sẽ cải tạo lại đoạn lisp trên bạn nhé.

Chúc bạn vui.

@ Bác Tue_NV: Mạn phép bác sửa lại chút xíu cái lisp của bác cho gần với yêu cầu của bạn Thaistreetz hơn. Mong bác không giận.
Bác Tue_NV và bác phamthanhbinh có thể chỉnh sửa lisp này giúp funnyzui theo hướng: tính chiều dài từng đoạn thẳng mình pick rồi xuất ra file text (*.txt) được không? tất nhiên là theo thứ tự mình pick rồi.

<<

Filename: 128662_tl.lsp

Tác giả: dragontalon0802
Bài viết gốc: 149186
Tên lệnh: m2 4

Nhờ viết lisp chọn nhanh layer và move!

Của bạn :

(Defun c:m2 () (command ".move" (ssget) "" "D" (polar '(0.0 0.0 0.0) (getangle "\nGoc move :" ) 220))(princ)) 
(defun c:4()...
>>

Filename: 149186_m2_4.lsp

Tác giả: Lê Chuột
Bài viết gốc: 201148
Tên lệnh: chon

Lisp chọn tất cả các đối tượng thuộc 1 layer !

Tại sao những việc đó bạn phải cần đến lisp vậy ^^ Các công cụ qselect, fi làm tốt mà. Còn nếu bạn cần thì đây ^^ Mình vídụ chọn...
>>
Tại sao những việc đó bạn phải cần đến lisp vậy ^^ Các công cụ qselect, fi làm tốt mà. Còn nếu bạn cần thì đây ^^ Mình vídụ chọn layer 0
(defun c:chon()(sssetfirst nil (ssget "x" '((8 . "0")))))
Không biết lạ cad mình có vấn đề hay tại lisp, nhưng chỉ làm được 2 3 lần là lần sau có command mấy cũng trơ ra. :wacko:

<<

Filename: 201148_chon.lsp

Tác giả: Kieu Tan
Bài viết gốc: 409763
Tên lệnh: vtt

Lisp Tạo Text

Viết lisp bạn chạy thử được ko rồi mông má em nó sau:

Yêu cầu trong ban vẽ bạn có sẳn...
>>
Viết lisp bạn chạy thử được ko rồi mông má em nó sau:

Yêu cầu trong ban vẽ bạn có sẳn style text tên là ARI và style text này có font là arial (theo ý bạn) hoặc font unicode nào đó.

Lisp lệnh là vtt. sẽ viết ra 1 text có nội dung là MẶT BẰNG TÔN MÁI tại điểm pick. Nếu chạy được thì tính tiếp.
(defun c:vtt ()
(setq d (getpoint "Diem viet text"))
(entmake (list (cons 0 "TEXT")(cons 10 d)(cons 11 d)(cons 40 2)(cons 50 0)(cons 72 0)(cons 1 "M\U+1EB6T B\U+1EB0NG TÔN MÁI")(cons 7 "ARI")(cons 8 (getvar "Clayer"))(cons 62 256))) 
(princ)
)
thanks bạn duy782006 !

Nhờ bạn mà mình đã tìm ra được nguyên nhân bị lỗi font và mình cũng đã tạo được lsp này:
(DEFUN C:MB (/ TILE P)
  (IF (= (TBLOBJNAME "STYLE" "ARIAL") NIL)
  	(command ".STYLE" "ARIAL" "ARIAL TUR" "" "" "" "" "" "")
    )
  (SETQ
	tile (getint "\nTi le: ")
	p (getpoint "\nDiem dat text: ")
	)
  (COMMAND "TEXT" "S" "ARIAL" "J" "TL" P (* TILE 2) "0" "%%UM\U+1EB6T B\U+1EB0NG TÔN MÁI"
	   "TEXT" "S" "ARIAL" "J" "TL" (POLAR P (/ PI -2) (* 3.5 TILE )) (* TILE 1.5) "0" "%%UM\U+1EB6T B\U+1EB0NG MÓNG"
	   	   
           )
)
Và mình chưa hiểu các bỏ dấu kiểu này nên nhờ bạn chỉ mình cách bỏ dấu kiểu này với:
M\U+1EB6T B\U+1EB0NG : MẶT BẰNG
<<
Download lisp
Filename: 409763_vtt.lsp

Tác giả: ndtnv
Bài viết gốc: 40964
Tên lệnh: ptz

move point từ 2D thành 3D

lisp của bạn đây

tên lệnh là ptz

(defun C:ptz ( /  ss e et pt i s x y z)
(princ "Chon diem :")
(setq ss (ssget '((0 . "POINT")) ) i -1)
(repeat (sslength ss)
		(setq i (1+ i)	 e (entget (ssname ss i)) s (assoc 10 e ) pt (cdr s) )(setq x (car pt) y (cadr pt))
	  (if (setq et (ssget "_C" pt (list (1+ x ) (1+ y )) '((0 . "TEXT")) ))
			(progn
				(setq z (atof (cdr (assoc 1 (entget (ssname et 0)) ))))
				(entmod (subst (cons 10  (list x y z))...
>>

lisp của bạn đây

tên lệnh là ptz

(defun C:ptz ( /  ss e et pt i s x y z)
(princ "Chon diem :")
(setq ss (ssget '((0 . "POINT")) ) i -1)
(repeat (sslength ss)
		(setq i (1+ i)	 e (entget (ssname ss i)) s (assoc 10 e ) pt (cdr s) )(setq x (car pt) y (cadr pt))
	  (if (setq et (ssget "_C" pt (list (1+ x ) (1+ y )) '((0 . "TEXT")) ))
			(progn
				(setq z (atof (cdr (assoc 1 (entget (ssname et 0)) ))))
				(entmod (subst (cons 10  (list x y z)) s e))
			)
		)
)
(princ) 
)

<<

Filename: 40964_ptz.lsp

Tác giả: SƠN MÈO
Bài viết gốc: 412133
Tên lệnh: tt

Bóc Khối Lượng Block Dynamic Tích Hợp Nhiều Đối Tượng

Được voi đòi lung tung, cung may cái đòi lung tung đó không phải sửa nhiều, xài thử cái này.

>>

Được voi đòi lung tung, cung may cái đòi lung tung đó không phải sửa nhiều, xài thử cái này.

(defun c:tt (/ LM:al-effectivename LM:getdynprops blk blk_name ent i lst_blk pt row ss tblobj x y htxt)
 (defun LM:al-effectivename  (ent / blk rep)
  (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
   (if (and (setq rep (cdadr (assoc -3 (entget (cdr (assoc 330 (entget (tblobjname "block" blk)))) '("AcDbBlockRepBTag")))))
            (setq rep (handent (cdr (assoc 1005 rep)))))
    (setq blk (cdr (assoc 2 (entget rep))))))
  blk
 )
 
 (defun LM:getdynprops  (blk)
  (mapcar '(lambda (x) (cons (vla-get-propertyname x) (vlax-get x 'value)))
          (vlax-invoke blk 'getdynamicblockproperties)))
 
 (or (> (setq htxt (getvar 'TEXTSIZE)) 0) (setq htxt (setvar 'TEXTSIZE 250)))
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
  (progn (vl-load-com)
         (setq i -1)
         (while (setq ent (ssname ss (setq i (1+ i))))
          (setq blk (vlax-ename->vla-object ent))
          (setq blk_name
(if (= "*" (substr (cdr (assoc 2 (entget ent))) 1 1))
(strcat (LM:al-effectivename ent) ": " (cdar (LM:getdynprops blk)))
(LM:al-effectivename ent)
))
          (if (not (assoc blk_name lst_blk))
           (setq lst_blk (cons (cons blk_name 1) lst_blk))
           (setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk)))) (assoc blk_name lst_blk) lst_blk))))
         (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)))))
         (setq pt     (getpoint "\nSpecify insertion point: ")
               TblObj (vla-addtable (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
                                    (vlax-3d-point pt) (+ (length lst_blk) 2) 4 (* 1.5 htxt) (* 6 htxt)))
         (vla-SetColumnWidth TblObj 0 (* 4 htxt))
         (vla-SetColumnWidth TblObj 1 (* 12 htxt))
         (vla-put-vertcellmargin TblObj (* 0.2 htxt))
         (mapcar '(lambda (x y) (vla-setTextHeight TblObj x y))
                 (list acTitleRow acHeaderRow acDataRow)
                 (list htxt htxt (* 0.75 htxt)))
         (mapcar '(lambda (x) (vla-setAlignment TblObj x 8)) (list acTitleRow acHeaderRow acDataRow))
         (vla-MergeCells TblObj 0 0 0 2)
         (vla-setText TblObj 0 0 "Bang thong ke khoi luong")
         (vla-setText TblObj 1 0 "STT")
         (vla-setText TblObj 1 1 "Ten")
         (vla-setText TblObj 1 2 "Don vi")
         (vla-setText TblObj 1 3 "So luong")
         (setq row 2
               i   1)
         (foreach pt  lst_blk
          (vla-setText TblObj row 0 (itoa i))
          (vla-setText TblObj row 1 (car pt))
          (vla-setText TblObj row 2 "cai")
          (vla-setText TblObj row 3 (itoa (cdr pt)))
          (setq row (1+ row)
                i   (1+ i))))
  (vlax-release-object TblObj))
 (princ))

LISP BỊ LỖI HAY SAO VẬY BÁC AH, ĐÁNH LÊNH TT KO ĐC

<<

Filename: 412133_tt.lsp

Tác giả: quocmanh04tt
Bài viết gốc: 417481
Tên lệnh: cxt

Lisp Trích Xuất Giá Trị Trong Dimension Ra Mtext

Đây cơ mà Khi Pick, chú ý Pick vào đúng MTEXT của DIM nhé, thì LÍP mới hoạt động
(defun c:cxt(/...
>>
Đây cơ mà Khi Pick, chú ý Pick vào đúng MTEXT của DIM nhé, thì LÍP mới hoạt động
(defun c:cxt(/ dt ent p)
  (vl-load-com)
  (if (setq dt (car(nentsel "\Pick DIM")))
    (progn
      (setq ent (entget dt))
      
      (setq p (getpoint (dxf 10 ent) "\nChon diem moi"))
      (entmakex
	(append
	  (list
	    '(0 . "MTEXT")
	    '(100 . "AcDbEntity")
	    '(100 . "AcDbMText"))
	  (vl-remove-if-not '(lambda(x) (member (car x) '(8 7 1 62 40 41 42 43 50 70 71 72 73)))  ent)
	  (list (cons 10 p))
	  )
      )
      ))
  (princ))
Sao dài thế?!!! Làm cái ngắn hơn tý!

(defun c:cdt (/ ent poi)

(while (and (setq ent (car (nentsel "\nChon DIMTEXT: ")))

              (eq (cdr (assoc 0 (entget ent))) "MTEXT")

              (Setq poi (getpoint "\nPick diem dat Mtext: " (cdr (assoc 10 (entget ent))))))

    (entmake (subst (cons 10 poi) (assoc 10 (entget ent)) (entget ent))))

(princ))

<<
Download lisp
Filename: 417481_cxt.lsp

Tác giả: nokia
Bài viết gốc: 174872
Tên lệnh: nb

lisp đổi tên blog được chọn

Mình đã viết 1 cái rồi nhưng chưa nhớ link, post lại cho bạn. Có thể dùng cho cả Anon Block
;| Change Anonymous Block...
>>
Mình đã viết 1 cái rồi nhưng chưa nhớ link, post lại cho bạn. Có thể dùng cho cả Anon Block
;| Change Anonymous Block to normal with new Name
@ Ketxu 27 - 9 - 2011
|;
(defun c:nb( / blkObj blkName blkNew_Name fn pt)
(vl-load-com)
(defun ST:SS->List-Vla (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (vlax-ename->vla-object e) l))
 )
)
(defun change_block(old new)
(foreach blkObj (setq ss (ST:SS->List-Vla (ssget (list (cons 0 "INSERT")(cons 2 old)))))
(vla-put-name blkObj new);;change the name
(vla-update blkObj)
)
)
(grtext -1 "Free Lisp From Cadviet @Ketxu")
(setvar "cmdecho" 0)
(setq
blkObj (vlax-ename->vla-object (car(entsel "\nBlock Source :")))
blkName (vlax-get-property blkObj
(if (vlax-property-available-p blkObj 'EffectiveName) 'EffectiveName 'Name)
 )
blkNew_Name (getstring "\n New Name :")
 fn (strcat (getenv "TEMP") "\\" blkNew_Name ".dwg")
)
(command ".-wblock" fn "_Y" blkName "")
(command "._insert" (strcat blkNew_Name "=" fn) nil )
(if (wcmatch "`*" (substr blkName 1 1))(setq blkName (strcat "`*" (substr blkName 2))))
(change_block blkName blkNew_Name)
(vl-file-delete  fn)
)
Hề hề. Thick cái điệu cười của cái anh có cái nick xấu như con gấu KETXU này. Nhưng mà lisp a viết a chưa chạy thử rùi ?

Chẳng may chạy lisp 100 lần thì mới có lần nó đổi được tên. Và cái thứ 2 là em cần chọn 1 lúc nhiều đối tượng để đổi tên ý. Như thế cho nhanh ạ ? E đã post rõ trong yêu cầu rùi ạ. anh kiểm tra lại giúp em nhé. hí hí. CAD ko làm được mà lisp làm được thì thật là cao siêu.hè hè

<<

Filename: 174872_nb.lsp

Tác giả: dovansinh
Bài viết gốc: 270273
Tên lệnh: ha

đo chiều dài đường cong tại hai điểm bất kỳ


(defun C:HA( / obj p1)

(vl-load-com) ;toi moi them dong nay

(setq obj (car (entsel "\nChon duong cong:...
>>

Filename: 270273_ha.lsp

Tác giả: leejang
Bài viết gốc: 153715
Tên lệnh: dten

Đổi tên Block được chọn !

Bạn thử cái này xem
(defun c:dten(/ bl ten tm)
 (setq bl (car(entsel "\nChon block muon doi: "))
ten (cdr(assoc 2...
>>
Bạn thử cái này xem
(defun c:dten(/ bl ten tm)
 (setq bl (car(entsel "\nChon block muon doi: "))
ten (cdr(assoc 2 (entget bl)))
tm (getstring "\nNhap ten muon doi: ")
)
 (command "rename" "b" ten tm)
 )
hic. Không được rồi bác ơi. Em muốn chọn 1 lần cả trăm blog để đổi tên cơ ạ ? Cái này chỉ chọn từng cái 1. Mất thời gian lắm ạ. Bác chỉnh giúp em với !

<<

Filename: 153715_dten.lsp

Tác giả: quickandfine
Bài viết gốc: 206462
Tên lệnh: o2l

lisp chuyển các đối tượng về 1 layer

Lisp O2L (Object to layer) dưới đây sẽ giúp bạn. Nếu bạn muốn chuyển các đối tượng khác, bạn hãy copy rồi thêm dòng lệnh (cons...
>>
Lisp O2L (Object to layer) dưới đây sẽ giúp bạn. Nếu bạn muốn chuyển các đối tượng khác, bạn hãy copy rồi thêm dòng lệnh (cons "KIEUDOITUONG" "TENLAYER") vào cụm các lệnh cons phía dưới.
(defun c:o2l ( / ss pp lstoblayer)  (setq    lstoblayer 	(list   	(cons "DIMENSION" "DIM")		; chuyen doi tuong Dimension ve layer DIM        (cons "HATCH" "HATCH")   	(cons "INSERT" "BLOCK")		; BLOCK (la doi tuong insert) ve layer BLOCK   	(cons "*TEXT" "TEXT")		; TEXT va MTEXT ve layer text 	)      )  (foreach pp lstoblayer        (setq ss (ssget "X" (list (cons 0 (car pp)))))    (if (not (tblsearch "layer" (cdr pp)))      (command ".layer" "m" (cdr pp) "")    )    (command ".chprop" ss "" "la" (cdr pp) "")      )    (princ))
Em chào bác Hoành ạ.

Em muốn tìm một đoạn lisp chuyển các đối tượng của Block về cùng một Layer mà tìm chưa thấy được, Em thấy đoạn lisp này của bác là gần với mong muốn của em nhất. Ví dụ Em có một Block A, trong A có 2 đối tượng: 1 đối tượng B thuộc layer 1, 1 đối tượng C thuộc Layer 2. Bây giờ em muốn đối tượng B và đối tượng C chuyển về cùng một Layer là Layer Block. Em đã thử đoạn lisp trên của bác thì nó chuyển đối tượng A về layer Block (Còn B và C thì vẫn giữ nguyên layer của nó). Bác có thể giúp em chuyển luôn cả layer của B và C về layer BLock giống như A được không ạ. Em xin cảm ơn ạ

<<

Filename: 206462_o2l.lsp

Tác giả: nhatphong
Bài viết gốc: 290643
Tên lệnh: tkh

Lisp thống kê diện tích Hatch theo Layer

Mình không nhận các chữ pro của bạn được, vì mình không phải thế ^^.Và lisp viết theo yêu cầu của Hoangvu, vì vậy bạn không nên...
>>
Mình không nhận các chữ pro của bạn được, vì mình không phải thế ^^.Và lisp viết theo yêu cầu của Hoangvu, vì vậy bạn không nên nói như nào là pro hơn, mà đó chỉ là cách bạn cảm thấy tiện hơn cho công việc của bạn thôi.Mà việc đó bạn dùng Qselect cũng được

Lisp sửa lại theo yêu cầu của bạn ( cũng vì thế mà đã chọn là tính hết, khỏi chọn vùng luôn )
(defun c:tkh (/ lst msp pt ss lay ar txtsiz pt ent)
  (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
  (progn
  (vl-load-com)
  (acet-sysvar-set (list "cmdecho" 0))
  (grtext -1 "S\U+01A1n T\U+00F9ng' Lisp")  
  (if (setq ent (car (entsel "\nCh\U+1ECDn Hatch \U+0111i\U+1EC3n h\U+00ECnh : ")))
  (progn
   (setq ss (ssget "X" (list (cons 0 "HATCH")(cons 8 (vla-get-layer (vlax-ename->vla-object ent))))))    
      (foreach e (mapcar 'vlax-ename->vla-object (st-ss->ent ss))
		(setq lay (vlax-get-property e 'Layer)) 
        (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area (list e))))
(setq ar (*  0.000001 (vlax-get-property e 'Area)))
(progn
(setq ar 0)(princ (strcat "\nC\U+00F3 Hatch thu\U+1ED9c layer " lay " kh\U+00F4ng t\U+00EDnh \U+0111\U+01B0\U+1EE3c di\U+1EC7n t\U+00EDch.\n\U+0110\U+00E3 highlight v\U+00E0 t\U+00EDnh di\U+1EC7n t\U+00EDch b\U+1EB1ng 0"))
(redraw (vlax-vla-object->ename e) 3)
)
)
        (if (not (assoc lay lst))
          (setq lst (cons (cons lay ar) lst))
          (setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
                           (assoc lay lst) lst))))
      (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
		
            txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
            msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) i -1)
			
      (while (setq e (nth (setq i (1+ i)) lst)) 
        (wtxt_l (strcat (car e) " : " (rtos (cdr e) 2 2) "m2") '(0 0 0))
(setq pt (ACET-SS-DRAG-MOVE (ssadd (entlast)) '(0 0 0) (strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t ghi ch\U+00FA t\U+1ED5ng di\U+1EC7n t\U+00EDch Hatch thu\U+1ED9c layer " (car e))))
(command ".move" (entlast) "" '(0 0 0) pt)
)
(princ "\n\U+0110\U+00E3 th\U+1EF1c hi\U+1EC7n xong !")
)
    (alert "Kh\U+00F4ng c\U+00F3 Hatch n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn !"))
)
(alert "Phi\U+00EAn b\U+1EA3n CAD c\U+1EE7a b\U+1EA1n kh\U+00F4ng h\U+1ED7 tr\U+1EE3 t\U+00EDnh di\U+1EC7n t\U+00EDch Hatch !")
)
  (acet-sysvar-restore)(princ))
  (defun st-ss->ent (ss / n e l)
  (setq n -1)
  (while (setq e (ssname ss (setq n (1+ n))))
    (setq l (cons e l))
  )
)
(defun wtxt_l(txt p / sty d h1 h2 wf h);;;Write txt on graphic screen at p
(setq    sty (getvar "textstyle")
d (tblsearch "style" sty)
h1 (cdr (assoc 40 d))
h2 (cdr (assoc 42 d))
wf (cdr (assoc 41 d)))
(if (> h1 0) (setq h h1) (setq h h2))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 40 h) (cons 41 wf)(cons 72 1)(cons 11 p) (cons 1 txt) (cons 10 p))))
P/S : lisp có 2 biến txtsiz với msp thừa quên chưa xóa, mà để cũng không sao ^^
Bạn có thể sửa lại không ketxu lisp này có 2 cái bất tiện:

1.Điểm đặt text giá trị bị nhảy xa tí mù tắp (nếu mà bản vẽ nặng chắc mình kg biết nó ở đâu nữa)

2.Các vị trí đều nhảy về 1 điểm mà kg ra bảng thống kê,có theo tên layer nhưng kg phân tách rời mà gộp tất làm 1

<<

Filename: 290643_tkh.lsp

Tác giả: pphung183
Bài viết gốc: 365657
Tên lệnh: block01

Nhờ Sửa Lisp Insert Block

Nhờ ae sửa giúp Lisp gọi block từ thư viện tạo sẵn, nhưng khi chèn thì vẫn giữ các tính chất của block (block att, block...
>>
Nhờ ae sửa giúp Lisp gọi block từ thư viện tạo sẵn, nhưng khi chèn thì vẫn giữ các tính chất của block (block att, block động...). Do lisp này khi chèn thì các block att, block động... trở thành block thường. Mong ae giúp đỡ!
(defun c:block01 ()
(setq insertpt1 (getpoint "\nPick Lower Left Corner of the cabinet: "))
(command "_insert" "G:\\Block\\block01.dwg" insertpt1 "" "" "")
(princ)
) 
Khi bạn Insert một bản vê thì nó đã là 1Block roi . Nghĩa là bạn sẽ có Block trong Block.

Do đó chỉ cần thêm dòng này là OK :)

(defun c:block01 ()

.....

(Command "_.Explode" "l")

(princ)

)

<<
Download lisp
Filename: 365657_block01.lsp

Trang 251/330

251