Jump to content
InfoFile
Tác giả: ketxu
Bài viết gốc: 435490
Tên lệnh: chabietattengi
Nhờ sửa lisp chặt đoạn thằng và xin Linetype đường hàn
23 giờ trước, 888x888x888 đã nói:

Cảm ơn...

>>
23 giờ trước, 888x888x888 đã nói:

Cảm ơn bác

2. Đường hàn mình cũng dùng make linetype mà nó toàn ra dấu chấm thế này ............................. ( ko biết bị lỗi gì)

3. Chỉ cần phương thẳng đứng thôi, Mình vẽ trắc dọc ấy mà :D 

2. Chắc thao tác sai :)) 
3. Bạn đã đưa yêu cầu kiểu thế nào cũng được thì code cũng nhanh thôi :D
 

(defun c:chabietattengi(/ d p)
(and 
	(setq d (distof (vl-string-translate "," "." (cdr (assoc 1 (entget (car(entsel "Chon DText nhe, dung chon gi khac"))))))))
	(setq p (getpoint "\nPick diem ben duoi nhe, dung pick diem ben tren :"))
	(entmake (list (cons 0 "LINE")(cons 10 p) (cons 11 (polar p (* pi 0.5) d))))
))

 


<<

Filename: 435490_chabietattengi.lsp
Tác giả: PHAMDUNG77
Bài viết gốc: 186098
Tên lệnh: mtxtc
Lisp đếm đối tượng Mtext lập thành bảng

<p></p>

<p>hề hề hề,</p>

<p>Bạn dùng thử cái này coi sao nhé.</p>

<p>

>>

<p></p>

<p>hề hề hề,</p>

<p>Bạn dùng thử cái này coi sao nhé.</p>

<p>

</p>
<p> </p>
<div>(defun c:mtxtc ()</div>
<div>(command "undo" "be" )</div>
<div>(setq oldos (getvar "osmode" ) )</div>
<div>(setvar "osmode" 0 )</div>
<div>(alert "\n Chon cac vung khung ten tung ban ve" )</div>
<div>(setq ssmt (ssget (list (cons 0 "*text") (cons 8 "TEN BAN VE,STT BAN VE" )))</div>
<div>          n (sslength ssmt) i 0 lst1 (list) lst2 (list) )</div>
<div>(while (< i n)</div>
<div>    (setq e (ssname ssmt i))</div>
<div>    (if (= (cdr (assoc 8 (entget e))) "TEN BAN VE")</div>
<div>        (setq lst1 (append lst1 (list (cdr (assoc 1 (entget e))))))</div>
<div>        (setq lst2 (append lst2 (list (cdr (assoc 1 (entget e))))))</div>
<div>    )</div>
<div>    (setq i (1+ i))</div>
<div>)</div>
<div>(styleset)</div>
<div>(setq h (getreal "\n Nhap chieu cao text trong bang: ")</div>
<div>          p (getpoint "\n Chon diem dat bang " )  )</div>
<div>(command "line" p (setq p1 (polar p 0 (* 40 h))) (setq p2 (polar p1 (* 1.5 pi) (* (1+ (/ n 2)) 3 h))) (setq p3 (polar p2 pi (* 40 h))) "c" )</div>
<div>(command "line" (setq p5 (Polar p 0 (* 5 h))) (polar p5 (* 1.5 pi) (* (1+ (/ n 2)) 3 h)) "" )</div>
<div>(command "line" (setq p6 (Polar p 0 (* 33 h))) (polar p6 (* 1.5 pi) (* (1+ (/ n 2)) 3 h)) "" )</div>
<div>(command "text" "j" "mc" (list (+ (car p) (* 2.5 h)) (- (cadr p) (* 1.5 h))) h 0 "STT" )</div>
<div>(command "text" "j" "mc" (list (+ (car p) (* 19 h)) (- (cadr p) (* 1.5 h))) h 0  "TÊN B\\U+1EA2N V\\U+1EBC" )</div>
<div>(command "text" "j" "mc" (list (+ (car p) (* 36.5 h)) (- (cadr p) (* 1.5 h))) h 0 "KÍ HI\\U+1EC6U")</div>
<div>(setq  j 1)</div>
<div>(repeat (/ n 2)</div>
<div>      (command "line" (setq p0 (polar p (* 1.5  pi) (* j 3 h))) (polar p0 0 (* 40 h)) "" ) </div>
<div>      (command "text" "j" "mc" (list (+ (car p0) (* 2.5 h)) (- (cadr p0) (* 1.5 h))) h 0 (rtos j 2 0))</div>
<div>      (command "text" "j" "mc" (list (+ (car p0) (* 19 h)) (- (cadr p0) (* 1.5 h))) h 0  (nth (1- j) lst1))</div>
<div>      (command "text" "j" "mc" (list (+ (car p0) (* 36.5 h)) (- (cadr p0) (* 1.5 h))) h 0 (nth (1- j) lst2))</div>
<div>      (setq j (1+ j))</div>
<div>)</div>
<div>(setvar "osmode" oldos)</div>
<div>(command "undo" "e" )</div>
<div>(princ)</div>
<div>)        </div>
<div> </div>
<div>(defun styleset ()</div>
<div>(setq stl (getvar "textstyle")</div>
<div>     	h (getvar "textsize"))</div>
<div>(if (/= h 0) (command "style" stl "" 0 "" "" "" "" ""))</div>
<div>) </div>
<div>

</div>

 

<p></p>

<p>hề hề hề,</p>

<p>Bạn dùng thử cái này coi sao nhé.</p>

<p>

</p>
<p> </p>
<div>(defun c:mtxtc ()</div>
<div>(command "undo" "be" )</div>
<div>(setq oldos (getvar "osmode" ) )</div>
<div>(setvar "osmode" 0 )</div>
<div>(alert "\n Chon cac vung khung ten tung ban ve" )</div>
<div>(setq ssmt (ssget (list (cons 0 "*text") (cons 8 "TEN BAN VE,STT BAN VE" )))</div>
<div>          n (sslength ssmt) i 0 lst1 (list) lst2 (list) )</div>
<div>(while (< i n)</div>
<div>    (setq e (ssname ssmt i))</div>
<div>    (if (= (cdr (assoc 8 (entget e))) "TEN BAN VE")</div>
<div>        (setq lst1 (append lst1 (list (cdr (assoc 1 (entget e))))))</div>
<div>        (setq lst2 (append lst2 (list (cdr (assoc 1 (entget e))))))</div>
<div>    )</div>
<div>    (setq i (1+ i))</div>
<div>)</div>
<div>(styleset)</div>
<div>(setq h (getreal "\n Nhap chieu cao text trong bang: ")</div>
<div>          p (getpoint "\n Chon diem dat bang " )  )</div>
<div>(command "line" p (setq p1 (polar p 0 (* 40 h))) (setq p2 (polar p1 (* 1.5 pi) (* (1+ (/ n 2)) 3 h))) (setq p3 (polar p2 pi (* 40 h))) "c" )</div>
<div>(command "line" (setq p5 (Polar p 0 (* 5 h))) (polar p5 (* 1.5 pi) (* (1+ (/ n 2)) 3 h)) "" )</div>
<div>(command "line" (setq p6 (Polar p 0 (* 33 h))) (polar p6 (* 1.5 pi) (* (1+ (/ n 2)) 3 h)) "" )</div>
<div>(command "text" "j" "mc" (list (+ (car p) (* 2.5 h)) (- (cadr p) (* 1.5 h))) h 0 "STT" )</div>
<div>(command "text" "j" "mc" (list (+ (car p) (* 19 h)) (- (cadr p) (* 1.5 h))) h 0  "TÊN B\\U+1EA2N V\\U+1EBC" )</div>
<div>(command "text" "j" "mc" (list (+ (car p) (* 36.5 h)) (- (cadr p) (* 1.5 h))) h 0 "KÍ HI\\U+1EC6U")</div>
<div>(setq  j 1)</div>
<div>(repeat (/ n 2)</div>
<div>      (command "line" (setq p0 (polar p (* 1.5  pi) (* j 3 h))) (polar p0 0 (* 40 h)) "" ) </div>
<div>      (command "text" "j" "mc" (list (+ (car p0) (* 2.5 h)) (- (cadr p0) (* 1.5 h))) h 0 (rtos j 2 0))</div>
<div>      (command "text" "j" "mc" (list (+ (car p0) (* 19 h)) (- (cadr p0) (* 1.5 h))) h 0  (nth (1- j) lst1))</div>
<div>      (command "text" "j" "mc" (list (+ (car p0) (* 36.5 h)) (- (cadr p0) (* 1.5 h))) h 0 (nth (1- j) lst2))</div>
<div>      (setq j (1+ j))</div>
<div>)</div>
<div>(setvar "osmode" oldos)</div>
<div>(command "undo" "e" )</div>
<div>(princ)</div>
<div>)        </div>
<div> </div>
<div>(defun styleset ()</div>
<div>(setq stl (getvar "textstyle")</div>
<div>     	h (getvar "textsize"))</div>
<div>(if (/= h 0) (command "style" stl "" 0 "" "" "" "" ""))</div>
<div>) </div>
<div>

</div>

A phamthanhbinh thức sáng đêm viết lisp cho e ha.

E không biết cảm ơn a phamthanhbinh như thế nào đây.

Khi nào có dịp a vô đà nẵng a,e mình làm một chầu nhé.

Ừ mà a sao lisp của a e download về rùi apload lên nhưng đánh dòng lệnh mtxtc thì chương trình cad lại kô nhận và báo F1 a.

A xem lại dùm cho e nhé.


<<

Filename: 186098_mtxtc.lsp
Tác giả: jangboko
Bài viết gốc: 434008
Tên lệnh: v1 v2 v3
Nhờ sửa lisp replace

lisp này mình down được trên diễn đàn: 

(defun C:v1 ( / ENT1 ENT2 LST1 LST2)
  (while (not ent1)
    (while (not (setq ent1 (car (nentsel "\nSelect source object: ")))))
    (if (not (assoc 1 (entget ent1))) (setq ent1 nil))
    )
  (while (not ent2)
    (while (not (setq ent2 (car (nentsel "\nSelect destination object: ")))))
    (if (not (assoc 1 (entget ent2))) (setq ent2 nil))
    )
  (setq...
>>

lisp này mình down được trên diễn đàn: 

(defun C:v1 ( / ENT1 ENT2 LST1 LST2)
  (while (not ent1)
    (while (not (setq ent1 (car (nentsel "\nSelect source object: ")))))
    (if (not (assoc 1 (entget ent1))) (setq ent1 nil))
    )
  (while (not ent2)
    (while (not (setq ent2 (car (nentsel "\nSelect destination object: ")))))
    (if (not (assoc 1 (entget ent2))) (setq ent2 nil))
    )
  (setq lst1 (entget ent1))
  (setq lst2 (entget ent2))
  (setq lst2 (subst (assoc 1 lst1) (assoc 1 lst2) lst2))
  (entmod lst2)
  (entupd ent2)
  (print)
  )

(defun C:v2 ( / DYN ELST ENT LST LST1 LST2 LST_DYN STR)
  (while (not (setq lst_dyn (dyn_get (setq ent (ent_pick "INSERT" "\nSelect source block: "))))))
  (setq lst_dyn (vl-remove (assoc "Origin" lst_dyn) lst_dyn))
  (setq lst1 (mapcar 'car lst_dyn))
  (setq lst2 (mapcar '(lambda (str) (while (vl-string-search " " str) (setq str (vl-string-subst "" " " str))) str) lst1))
  (setq dyn (keyword lst2 (car lst2) "Select dynamic"))
  (setq dyn (nth (vl-position dyn lst2) lst1))
  (setq elst (acet-ss-to-list (ssget (list (cons 0 "INSERT")))))
  (foreach ent elst
    (if (setq lst (dyn_get ent))
      (if (assoc dyn lst)
	(dyn_set ent dyn (cdr (assoc dyn lst_dyn)))
	)
      )
    )
  (print)
  )

(defun C:v3 ( / DYN ELST ENT LST LST_DYN VAL)
  (while (not (setq lst_dyn (dyn_get (setq ent (ent_pick "INSERT" "\nSelect source block: "))))))
  (setq lst_dyn (vl-remove (assoc "Origin" lst_dyn) lst_dyn))
  (setq elst (acet-ss-to-list (ssget (list (cons 0 "INSERT")))))
  (foreach ent elst
    (if (setq lst (dyn_get ent))
      (foreach lst1 lst
	(setq dyn (car lst1))
	(if (setq val (cdr (assoc dyn lst_dyn)))
	  (dyn_set ent dyn val)
	  )
	)
      )
    )
  (print)
  )

;CHON DOI TUONG
(defun ent_pick (typ promp / ent)
  (if (not (listp typ)) (setq typ (list typ)))
  (setq typ (mapcar 'list typ))
  (while (not ent)
    (while (not (setq ent (car (entsel (strcat "\n" promp))))))
    (if (not (assoc (cdr (assoc 0 (entget ent))) typ)) (setq ent nil))
    )
  ent
  )

;THONG KE DYN
(defun dyn_get (ent)
  (mapcar '(lambda (dyn) (cons (vla-get-propertyname dyn) (vlax-get dyn 'value)))
	  (vlax-invoke (vlax-ename->vla-object ent) 'getdynamicblockproperties)
	  )
  )

;SUA DYN THEO PRP
(defun dyn_set (ent prp val)
  (setq prp (strcase prp))
  (vl-some
    '(lambda (x)
       (if (= prp (strcase (vla-get-propertyname x)))
	 (progn
	   (vla-put-value x (vlax-make-variant val (vlax-variant-type (vla-get-value x))))
	   (cond (val) (t))
	   )
	 )
       )
    (vlax-invoke (vlax-ename->vla-object ent) 'getdynamicblockproperties)
    )
  )

;NHAP KEYWORD
(defun keyword (key default promp / str1 str2 str3 str4)
  (setq str1 (apply 'strcat (mapcar (function (lambda (x) (strcat x " "))) key)))
  (setq str2 (apply 'strcat (mapcar (function (lambda (x) (strcat x "/"))) key)))
  (setq str1 (substr str1 1 (1- (strlen str1))))
  (setq str2 (substr str2 1 (1- (strlen str2))))
  (initget str1)
  (setq str3 (strcat "\n" promp "  <" default "> "))
  (if (not (setq str4 (getkword str3)))
    default
    str4
    )
  )

Nhờ các bác sửa hộ mình. Lisp trên hoạt động là chọn 1 đối tượng mẫu rồi matchprop được 1 đối tượng đích. Mình muốn lisp có thể matchprop được nhiều đối tượng đích. Cảm ơn các bác nhiều


<<

Filename: 434008_v1_v2_v3.lsp
Tác giả: khaosat2009
Bài viết gốc: 74550
Tên lệnh: trichthua
trích do
Chào khaosat2009, Lisp cwb của bác Gia_bach viết rất tuyệt vời khi copy, xóa, move các đối tượng trong ngoài 1 vùng kín, hay giữa 2 vùng kín. Tuy nhiên, các đối tượng gốc bị...
>>
Chào khaosat2009, Lisp cwb của bác Gia_bach viết rất tuyệt vời khi copy, xóa, move các đối tượng trong ngoài 1 vùng kín, hay giữa 2 vùng kín. Tuy nhiên, các đối tượng gốc bị bẻ gãy hết. Lisp Thiep viết sau đây sẽ trích thửa bản đồ, theo 1 ô vuông có kích thước cạnh do user tự chọn.

Sau khi tạo ô vuông xong, user rê ô vuông này vào khu vực cần trích thửa, nó sẽ copy các đối tượng bên trong và giao với ô vuông (ô vuông giống như 1 nam châm). Sau đó, user rê các đối tượng này đến vị trí cần đặt, ví dụ đặt ở giữa bản vẽ TRÍCH ĐO ĐỊA CHÍNH THỬA ĐẤT. Lisp sẽ cắt bỏ những đường bên ngoài ô vuông.

;;;-----------------------
(defun SS-enlst	(ss / c L)
 (setq c -1)
 (repeat (sslength ss)
   (setq L (cons (ssname ss (setq c (1+ c))) L))
 )
 (reverse L)
)
;;;====================================================================
(defun break_with (Lstent 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)
    )
   (if	(not (or (eq (dxf 0 obj2break) "TEXT")
	 (eq (dxf 0 obj2break) "MTEXT")
     )
)
     (setq 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	(and brkptlst
     (not (or (eq (dxf 0 obj2break) "TEXT")
	      (eq (dxf 0 obj2break) "MTEXT")
	  )
     )
)
     (progn
(setq brkptlst
       (mapcar
	 '(lambda (x)
	    (list
	      x
	      (vlax-curve-getdistatparam
		obj2break
		(cond
		  ((vlax-curve-getparamatpoint obj2break x)
		  )
		  ((vlax-curve-getparamatpoint
		     obj2break
		     (vlax-curve-getclosestpointto
		       obj2break
		       x
		     )
		   )
		  )
		)
	      )
	    )
	  )
	 brkptlst
       )
)

(setq
  brkptlst (vl-sort brkptlst
		    '(lambda (a1 a2) (< (cadr a1) (cadr a2)))
	   )
)

(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
  (if (not (or (eq (dxf 0 obj2break) "TEXT")
	       (eq (dxf 0 obj2break) "MTEXT")
	   )
      )
    (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

  ;; (if (null brkptE) (princ)) ; debug
  (setq LastEnt (GetLastEnt))
  (if (not (or (eq (dxf 0 obj2break) "TEXT")
	       (eq (dxf 0 obj2break) "MTEXT")
	   )
      )
    (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
     );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 Lstent enL)
   (progn
     ;; CREATE a list of entity & it's break points
     (foreach en Lstent
				; check each object in Lstent
(if (not (acet-layer-locked (dxf 8 en)))
  (progn
    (setq lst nil)
    ;; check for break pts with other objects in Lstentwith
    (if	(and (not (equal en enint))
	     (setq intpts (acet-geom-intersectwith en enL 0))
	)
      (setq lst (append intpts lst))
				; entity w/ break points
    )
    (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
)
;;;------------------------------------------------
(defun LWP (Lpoint *Model* / PntArr)
 (setq	PntArr (vlax-make-safearray
	 vlax-vbDouble
	 (cons 0 (1- (length Lpoint)))
       )
 )
 (vlax-safearray-fill PntArr Lpoint)
 (vla-AddLightWeightPolyline *Model* PntArr)
)
;;;------------------------------------------------
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;============================================================
;;;=======================MAIN LISP============================
;;;============================================================
(defun c:trichthua (/ ss p2 encur lstss1 emin emax p3 LenssBR)
 (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
*Model*	(vla-get-ModelSpace ActDoc)
 )
 (vla-StartUndoMark ActDoc)
 (setq	a (cond	(a)
	(50)
  )
 )
 (setq olda a)
 (setq	a (getreal (strcat "\nChon kich thuoc cat hinh vuong cat <"
			   (rtos olda 2 1)
			   "> : ")))
 (if (null a) (setq a olda))
 (setq	emin (list (car (getvar "extmin")) (cadr (getvar "extmin"))))
 (setvar "cecolor" "104")
 (setq	lstp (list (car emin)
	   (cadr emin)
	   (+ (car emin) a)
	   (cadr emin)
	   (+ (car emin) a)
	   (+ (cadr emin) a)
	   (car emin)
	   (+ (cadr emin) a)
     )
 )
 (vla-put-closed (LWP lstp *Model*) :vlax-True)
 (setq ss (ssadd (entlast) (ssadd)))
 (setq	p2 (ACET-SS-DRAG-MOVE
     ss
     (list (car emin) (cadr emin))
     "Chon vi tri bat dau trich thua: "
   )
 )
 (command ".move" ss "" emin p2)
 (setq encur (entlast)
lstp (acet-geom-VERTEX-LIST encur))
 (setq ss (ssdel encur (ssget "_CP" lstp)))
 (command ".copy" ss "" p2 p2)
 (setq	p3 (ACET-SS-DRAG-MOVE
     (ssadd encur ss)
     p2
     "Chon vi tri dat ban do trich thua: "
   )
 )
 (command ".move" ss encur "" p2 p3)
 (setvar "cecolor" "0")
 (setq encur (ssname (ssget "X" '((62 . 104))) 0))
 (setq	lstobj1	(vl-remove encur (gettouching encur))
ss	(acet-list-to-ss lstobj1)
 )
 (acet-ss-zoom-extents ss)
 (break_with  lstobj1 encur)
 (vlax-invoke-method ActDoc 'Regen acActiveViewport)
 (vla-offset (vlax-ename->vla-object encur) (* (getvar "viewsize") 0.002))
 (setq lst3 (acet-geom-vertex-list (entlast)))
 (entdel (entlast))
 (setq	LenssBR	(SS-enlst (ssget "F" lst3)))
 (foreach x LenssBR
   (if	(or (not (eq (dxf 0 x) "TEXT"))
    (not (eq (dxf 0 x) "MTEXT"))
)
     (entdel x)
   )
 )
 (vla-EndUndoMark ActDoc)
 (princ "\nChuc cac ban gat hai nhieu thanh cong. Thiep")
)

Anh Thiep ơi.

Qua Lisp của anh đã viết, anh giúp em thêm việc này nha:

Dựa vào bản đồ DC , mình chọn vào vị trí thửa thì nó trích ra thửa đó, cắt vùng bao quanh, ghi tọa độ , cạnh và chèn vào mẫu khung.

như file mẫu:

Rất mong được anh giúp


<<

Filename: 74550_trichthua.lsp
Tác giả: TRUNGNGAMY
Bài viết gốc: 204863
Tên lệnh: ha
Viết Lệnh tạo đường bao tương tự lệnh boundary của Cad

Kể ra thì cũng vất vả khi phải giải bài toán của bác Trung_Nga_Mỹ(???).

Tôi không có bản vẽ lớn để kiểm tra nhiều, do...

>>

Kể ra thì cũng vất vả khi phải giải bài toán của bác Trung_Nga_Mỹ(???).

Tôi không có bản vẽ lớn để kiểm tra nhiều, do đó bác test xem sao nhé, nhất là khoản tốc độ.

Lisp: tạo danh sách các giao điểm của tập hợp chọn, kèm Handle của các đối tượng giao tương ứng tại từng điểm.

;Doan Van Ha - CADViet.com - Ngay 04/7/2012
;Muc dich: List c¸c giao ®iÓm cña Set, kÌm Handle cña c¸c ®èi t­îng giao t­¬ng øng t¹i tõng ®iÓm.
(defun C:HA()
(setq ss (ssget))
(HA:LstInterSet ss))
;-----
(defun HA:LstInterSet (ss / obj1 obj2 i j lst)
(setq i (sslength ss))
(while (>= (setq j (1- i) i (1- i)) 0)
 (setq obj1 (vlax-ename->vla-object (ssname ss i)))
 (while (>= (setq j (1- j)) 0)
  (setq obj2 (vlax-ename->vla-object (ssname ss j))
    		lst (cons (HA:LstInter2Obj obj1 obj2) lst))))
(setq lst (apply 'append lst))
(foreach x (setq z lst)
 (foreach y (setq z (cdr z))
  (if (equal (car x) (car y) 1E-8)
(progn
(setq lst (subst (LM:Unique (append x (cdr y))) x lst))
(setq x (LM:Unique (append x (cdr y))))
(setq lst (vl-remove y lst))))))
lst)
;----- List c¸c giao ®iÓm cña 2 Objs.
(defun HA:LstInter2Obj (obj1 obj2 / lst1 lst2 h1 h2)
(setq h1 (vla-get-handle obj1) h2 (vla-get-handle obj2))
(setq lst1 (vlax-invoke obj1 'IntersectWith obj2 acExtendNone))
(while lst1
 (setq lst2 (cons (list (list (car lst1) (cadr lst1) (caddr lst1)) h1 h2) lst2))
 (setq lst1 (cdddr lst1)))
(reverse lst2))
;----- List gåm c¸c phÇn tö kh¸c nhau.
(defun LM:Unique (l) (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))))

Cám ơn bác Doan Van Ha đã hỗ trợ nhưng bác cần kết hợp với PP chia ô của bác Thái. Nếu kg có những giải pháp rút ngắn thời gian thì kg thể đặt vđ này đc. Hiện code của bác chạy trên bv khoảng 1000 line (chưa nói đến các đối tượng khác như đg tròn, elip ...) mất khoảng 80''. Mình nghĩ nếu bác kết hợp PP chia ô sẽ mất dưới 5''. Nếu bác bận để mình cố gắng lồng PP chia ô vào nhưng hơi lâu, tại mình kg quen các hàm vl lắm. Mình nghĩ ngoài PP chia ô còn phải sd PP phân mảnh biến nữa, nó tương tự như biến động


<<

Filename: 204863_ha.lsp
Tác giả: leejang
Bài viết gốc: 154230
Tên lệnh: kk
viết 1 lisp dạng copyarray theo phương định trước !

Xin chào các anh cadviet, em là lính mới.Thấy và đọc bài của bạn leejang nên gửi bài code này không biết đã đúng y cua ban...

>>

Xin chào các anh cadviet, em là lính mới.Thấy và đọc bài của bạn leejang nên gửi bài code này không biết đã đúng y cua ban chưa?

(defun c:kk ()
(princ "\nChon doi tuong can array: ")
 (setq ss (ssget)
p1 (getpoint "\nChon diem thu nhat: ")
p2 (getpoint p1 "\nChon diem thu hai: ")
a (getdist "\nNhap khoang cach array: ")
kc (distance p1 p2)
sl (fix(/ kc a))
ang (angle p1 p2)
index 0
 )
 (repeat sl
 (setq index (1+ index))
 (setq vbt (getvar "osmode"))
 (setvar "osmode" 0)
 (command ".copy" ss "" p1 (polar p1 ang (* a index)))nil
 (setvar "osmode" vbt)
 )
(princ))

Hic ! tối hôm qua em mò mẫm mãi mới bit. Cái lisp của em không chạy và một số lisp khác của các bác viết cho em em tải về dùng bị lỗi là do em đã load quá nhiều lisp cùng autocad. ( khoảng >100 lisp), chính vì thế mà bị xung đột lẫn nhau, khi load 1 mình 1 lisp đó thì nó chạy ok. Bi h phải làm sao để nó ko xung đột mà mình ko mất công load thủ công mỗi khi dùng ạ ?


<<

Filename: 154230_kk.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435657
Tên lệnh: ctx
Lisp tách chữ số trong block & gán lên text !
(defun c:ctx (/ lst i ent txt n sel)
  (setq lst (list)
	i 1
>>
(defun c:ctx (/ lst i ent txt n sel)
  (setq lst (list)
	i 1
	Sel (strcat "\nPick text ngu\U+1ED3n s\U+1ED1 " (itoa i)))
  (while (setq ent (car (nentsel sel)))
   (if (/= (cdr (assoc 0 (entget ent))) "ATTRIB") (Alert "\nKh\U+00F4ng ph\U+1EA3i Attribute!!!") (progn
										      
    (setq txt (cdr (assoc 1 (entget ent))))
    (if (setq n (vl-string-search ":" txt)) (progn
	(setq i (1+ i)
	Sel (strcat "\nPick text ngu\U+1ED3n s\U+1ED1 " (itoa i) "-ho\U+1EB7c pick kho\U+1EA3ng tr\U+1EAFng \U+0111\U+1EC3 d\U+1EEBng") )
      (setq txt (substr txt (+ n 2)))
    (setq lst (append lst (list txt))) ) (Alert "\nKh\U+00F4ng c\U+00F3 gi\U+00E1 tr\U+1ECB t\U+00ECm ki\U+1EBFm"))
	)))
  (setq i 0)
 (while (setq txt (nth i lst))
   (if (and (setq ent (car (entsel (strcat "\nPick Text \U+0111\U+00EDch s\U+1ED1 " (itoa (1+ i))))))
	    (vl-string-search "TEXT" (cdr (assoc 0 (entget ent))))) (progn
    (setq i (1+ i))
    (entmod (subst (cons 1 txt) (assoc 1 (entget ent)) (entget ent)))
    ) (Alert "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng kh\U+00F4ng ph\U+1EA3i TEXT"))
    )
  )
     

Nghỉ lễ mà anh em vẫn làm việc chăm chỉ quá nhỉ! Món quà nhỏ tặng bạn!


<<

Filename: 435657_ctx.lsp
Tác giả: dinhgia35
Bài viết gốc: 115923
Tên lệnh: tinhthang
Vẽ thang bằng lisp
Bạn mệt mỏi khi phải dóng để vẽ mặt đứng thang phức tạp?

 

Hãy để lisp tính thang của CADViet giúp bạn phần nào. Bạn copy đoạn code dưới đây vào file...

>>
Bạn mệt mỏi khi phải dóng để vẽ mặt đứng thang phức tạp?

 

Hãy để lisp tính thang của CADViet giúp bạn phần nào. Bạn copy đoạn code dưới đây vào file một file lisp rồi appload lên và dùng lệnh tinhthang.

 

(defun c:tinhthang()
(defun l2bac(ent)
(setq
tt (entget ent)
p1 (cdr (assoc 10 tt))
p2 (cdr (assoc 11 tt))
)
(list p1 p2)
)
(setq
ssbac (ssget '((0 . "LINE")))
hbac (getdist "\nChieu cao bac")
lstent (ss2ent ssbac)
ttbac (mapcar 'l2bac lstent)
index 0.0
)
(command ".3dmesh")
(command (* 2 (length lstent)) 2)
(foreach pp ttbac
(setq
caoht (* index hbac)
index (+ index 1.0)
p1 (car pp)
p2 (cadr pp)
x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
za caoht
zb (+ caoht hbac)
p1a (list x1 y1 za)
p1b (list x1 y1 zb)
p2a (list x2 y2 za)
p2b (list x2 y2 zb)
)
(command p1a p2a p1b p2b)
)
)
(defun ss2ent(ss / sodt index lstent)
(setq
sodt (if ss (sslength ss) 0)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)

 

Đầu tiên là mặt bằng của bạn:

Thang01.gif

 

bạn đổi viewport để xem dạng phối cảnh:

thang02.gif

 

dùng lệnh tinhthang để vẽ 3d của bậc thang:

thang03.gif

 

dùng lệnh shade để xem thang dạng có diện:

thang04.gif

 

Xoay để lấy mặt đứng biên:

thang05.gif

 

Lệnh tính thang không thể vẽ kỹ được thang cho bạn, nhưng chắc chắn nó sẽ giúp bạn làm những thao tác cơ bản để có được những nét phôi của thang. Từ đó bạn sẽ thêm nét để trở thành mặt chiếu hay phối cảnh của thang.

 

Rất mong có được sự hồi âm sau khi sử dụng Lisp.

DOWNLOAD VỀ SỬ DỤNG ĐƯỢC ĐÚNG MỘT LẦN, CÒN CÁC LẦN SAU VÀO LỆNH NHƯ VẬY NÓ RA HÌNH CHI CHI ẤY. CÓ BÁC NÀO GẶP PHẢI LỖI NHƯ TÔI CHƯA, CHIA SẺ VỚI :)
<<

Filename: 115923_tinhthang.lsp
Tác giả: quan08
Bài viết gốc: 166418
Tên lệnh: b2
Lisp tạo Boundary ra Polyline với Layer tùy chọn

Có thể nên làm như thế này :

(defun c:b2 (/ elast lay) (setq elast (entlast) lay (cdr (assoc 8 (entget (car (entsel "\nPick an...
>>

Có thể nên làm như thế này :

(defun c:b2 (/ elast lay) (setq elast (entlast) lay (cdr (assoc 8 (entget (car (entsel "\nPick an entity to gap Layer :"))))))
(command ".boundary")
(while (= (logand (getvar "CMDACTIVE") 1) 1) (command pause))
(while (setq elast (entnext elast))(vla-put-Layer (vlax-ename->vla-object elast) lay)))

Thí dụ hình chữ nhật được tạo bởi 4 đoạn thẳng,3 đoạn liền nhau cùng là NETBAO còn 1 đoạn là NETTHEP thì lisp của bác sẽ đưa về cùng 1 layer,Bác có thể sửa lại giùm e nếu nhiều đoạn thẳng cùng 1 layer liền nhau thì nối lại thành BOUNDARY nét khác layer thì không?Thanks.


<<

Filename: 166418_b2.lsp
Tác giả: ketxu
Bài viết gốc: 417270
Tên lệnh: foo
Mã Dxf Của Điểm Gốc Chèn Hatch ( Tọa Độ Điểm Màu Xanh Trong Ctrl+1)
(defun c:foo()
(vla-getboundingbox (vlax-ename->vla-object (car(entsel))) 'p1 'p2)
(entmake (list (cons 0 "CIRCLE")(cons 10
(mapcar '* (mapcar '+ (vlax-safearray->list p1) (vlax-safearray->list p2)) '(0.5 0.5 0.5))
)(cons 40 100)
)))

^^ Là tâm boundingbox


Filename: 417270_foo.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435869
Tên lệnh: 00
6 phút trước, anhGeodesy đã nói:
6 phút trước, anhGeodesy đã nói:

@Doan Nguyen Van Cái khung bao này mặc định là Layer Defpoints bác nhé. bác xem cho quét 1 phát thì ngon.

 

(vl-load-com)
(defun c:00 (/ ent ss lst lst1 mn mx p1 p2 ss1 ss2 x y str str1 )
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 8 "Defpoints")))))
  (setq ss (vl-sort ss '(lambda (x y) (< (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y)))))))
  (setq lst (list))
  (foreach ent ss
    (vla-getboundingbox (vlax-ename->vla-object ent) 'mn 'mx)
                (setq p1 (vlax-safearray->list mn)
                      p2 (vlax-safearray->list mx))
    (setq ss1 (acet-ss-to-list (ssget "_C" p1 p2 (list (cons 0 "TEXT"))))
	  ss2 (acet-ss-to-list (ssget "_C" p1 p2 (list (cons 0 "DIMENSION")))))
    (setq ss1 (vl-sort ss1 '(lambda (x y) (< (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y))))))
	  ss2 (vl-sort ss2 '(lambda (x y) (< (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))) )
    (setq lst1 (VL-string->list (cdr (assoc 1 (entget (nth 0 ss1)))))
	  lst1 (reverse (cdr (reverse (cdr lst1)))))
    (setq str1 (vl-list->string lst1))
    (setq str (strcat str1 " " (rtos (vla-get-measurement (vlax-ename->vla-object (nth 0 ss2))) 2 0) " "
		      (rtos (vla-get-measurement (vlax-ename->vla-object (nth 1 ss2))) 2 0) " "
		      (if (vl-string-search "%%U" (cdr (assoc 1 (entget (nth 1 ss1)))))(substr (cdr (assoc 1 (entget (nth 1 ss1)))) 4) (cdr (assoc 1 (entget (nth 1 ss1)))))
		      ))
    (setq lst (append lst (list str)))
    )
  
  )
   

Theo ý của bạn thôi.


<<

Filename: 435869_00.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435918
Tên lệnh: bg
LISP AUTO CONVERT GROUP TO BLOCK
23 giờ trước, AhN đã nói:

Chào mọi người, mình gặp 2 vấn...

>>
23 giờ trước, AhN đã nói:

Chào mọi người, mình gặp 2 vấn đề như sau: 

Vấn đề 1: Bản vẽ lắp mình xuất từ Inventor sang Autocad thì các line thuộc cùng 1 PART chỉ có thể group lại với nhau thôi nên mình cần lisp để có thể chuyển đổi GROUP thành BLOCK. Mình cũng có viết 1 lisp như thế nhưng chỉ có thể BLOCK thủ công từng GROUP khá là mất thời gian đối với bản vẽ lớn và đôi khi bị out khỏi cad giữa chừng, nên mình muốn nhờ các bạn giúp mình 1 lisp có thể tự động chọn 1 GROUP bất kỳ và chuyển nó thành BLOCK có cùng tên và cứ như thế cho đến hết.

Vấn để 2: Merge các layer theo tên. Bản vẽ sau khi mình xuất ra autocad sẽ có hàng loạt layer như hình dưới với cấu trúc là Partname - tên đường nét được định nghĩa trước đó (A) mình muốn merge các layer có cùng (A) về (A).

Mình không biết 2 yêu cầu trên có khả thi không vì mình chỉ mới tìm hiểu để viết lisp gần đây thôi nên mong mọi người giúp đỡ. Dưới đây là file để test và lisp mình viết. Cảm ơn mọi người!

block.lsp

TEST.dwg

Vấn đề 1: Đã viết cho bạn 1 Lisp block lại các Group hiện có. Tên block là tên group (Trong lisp của bạn viết bạn lấy tên Layer)

Vấn đề 2: Chưa hiểu bạn muốn merge thế nào? Cùng (A) về (A) là sao ?


(defun c:bg (/ block gnames ReplaceString old_str new_str ename strr nbl grname p ss lst_gr ent namegr ptpoint namebl)
  (defun block (nbl grname p )
	(vl-cmdf "_.-Block" nbl "_non" p "g" grname "")
	(vl-cmdf "_.-insert" nbl "non" p "" "" "")
	(princ))
   (defun gnames (ename / key dct rtn)
(setq key (cons 340 ename)
dct (dictsearch (namedobjdict) "acad_group"))
(while (setq dct (member (assoc 3 dct) dct))
(if (member key (entget (cdadr dct)))
(setq rtn (cons (cdar dct) rtn)))
(setq dct (cddr dct)))
(reverse rtn)
) 
(defun ReplaceString (old_str new_str strr / m n)
(setq m 0 n (strlen new_str))
(while (setq m (vl-string-search old_str strr m))
(setq strr (vl-string-subst new_str old_str strr m))
(setq m (+ n m))
)strr)
  (setq ss (acet-ss-to-list (ssget)))
  (setq lst_gr (list))
  (foreach ent ss
    (setq namegr (gnames ent))
    (if (and namegr
   (not (vl-position (car namegr) lst_gr)) )
      (setq lst_gr (append lst_gr (list (car namegr )))))    )
  (foreach ent lst_gr
    (if (vl-string-search "*" ent) (setq namebl (replacestring "*" "" ent))(setq namebl  ent))
   (setq ptpoint (cdr (assoc 10 (entget (cdr (assoc 340 (dictsearch (cdr (assoc -1 (dictsearch (namedobjdict) "ACAD_GROUP"))) ent)))))))
    (block namebl ent ptpoint))
    )

 


<<

Filename: 435918_bg.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435936
Tên lệnh: megla
LISP AUTO CONVERT GROUP TO BLOCK
38 phút trước, AhN đã nói:

- Cảm ơn Anh Doan Nguyen...

>>
38 phút trước, AhN đã nói:

- Cảm ơn Anh Doan Nguyen Van nhiều nhé, nhờ lisp của anh mà mình tiết kiệm được rất nhiều thời gian cho việc xử lý bản vẽ.

- Về vấn đề 2 thì mình ví dụ cụ thể như thế này: mình muốn merge tất cả các layer có đuôi là A_0 vào layer A_0, tương tự có đuôi A_1 vào A_1, ...

(defun c:megla (/ getlayerlist lay truelay ss)
  (defun getlayerlist (/ kieu nl lkq)
(setq lkq'())
(setq nl (tblnext "layer" T))
(while nl
(setq lkq (append lkq (list (cdr (assoc 2 nl)))))
(setq nl (tblnext "layer"))
)
(cond
((= kieu "layer") (setq lstthem (list  (getvar "CLAYER"))) (setq lkq (append lstthem lkq)) )
((/= kieu "layer") )
)
lkq)
  (foreach lay (getlayerlist)
    (if (and (> (strlen lay) 3)
	     (vl-string-search "A_" lay))
       (progn

	(setq truelay (substr lay (- (strlen lay) 3)))
	(if (vl-string-search "-" truelay)(setq truelay (substr truelay 2)))
	(if (tblsearch "layer" truelay) (progn
	(setq ss (ssget "_X" (list (cons 8 lay))))
	(command "change" ss "" "p" "LA" truelay "")
	(Command "-PURGE" "Layer" lay "" "y")
	) (command "-rename" "LAyer" lay truelay "")
	  ))))
  )

Mới viết thử thế này, bạn test xem đúng ý chưa?

Thao tác trước khi block các group mới được


<<

Filename: 435936_megla.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435891
Tên lệnh: te
Trợ giúp về chỉnh thông số PSLTSACLE trong Autocad
(defun c:te (/ layout layoutname)
(vlax-for layout (vla
>>
(defun c:te (/ layout layoutname)
(vlax-for layout (vla-get-Layouts (vla-get-ActiveDocument (vlax-get-Acad-Object)))
		(setq LayoutName (vla-get-Name layout))
	   (if (/= "Model" LayoutName) (progn
	     (vla-put-activelayout (vla-get-ActiveDocument (vlax-get-Acad-Object)) layout)
	     (setvar 'PSLTSCALE 0)
	     (vla-regen (vla-get-ActiveDocument (vlax-get-Acad-Object)) acallviewports)
	     ))
  )
  )

  

Bạn test thử cái này


<<

Filename: 435891_te.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435862
Tên lệnh: 00
(vl-load-com)
(defun c:00 (/ ent lay ss lst lst1 i mn mx p1 p2 ss1 ss2 x...
>>
(vl-load-com)
(defun c:00 (/ ent lay ss lst lst1 i mn mx p1 p2 ss1 ss2 x y str str1 )
  (if (setq ent (car (entsel "Pick khung bao"))) (progn
  (setq lay (cdr (assoc 8 (entget ent))))
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 8 lay)))))
  (setq ss (vl-sort ss '(lambda (x y) (< (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y)))))))
  (setq lst (list))
  (setq i 0)
  (foreach ent ss
    (setq i (1+ i))
    (vla-getboundingbox (vlax-ename->vla-object ent) 'mn 'mx)
                (setq p1 (vlax-safearray->list mn)
                      p2 (vlax-safearray->list mx))
    (setq ss1 (acet-ss-to-list (ssget "_C" p1 p2 (list (cons 0 "TEXT"))))
	  ss2 (acet-ss-to-list (ssget "_C" p1 p2 (list (cons 0 "DIMENSION")))))
    (setq ss1 (vl-sort ss1 '(lambda (x y) (< (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y))))))
	  ss2 (vl-sort ss2 '(lambda (x y) (< (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))) )
    (setq lst1 (VL-string->list (cdr (assoc 1 (entget (nth 0 ss1)))))
	  lst1 (reverse (cdr (reverse (cdr lst1)))))
    (setq str1 (vl-list->string lst1))
    (setq str (strcat str1 " " (rtos (vla-get-measurement (vlax-ename->vla-object (nth 0 ss2))) 2 0) " "
		      (rtos (vla-get-measurement (vlax-ename->vla-object (nth 1 ss2))) 2 0) " "
		      (if (vl-string-search "%%U" (cdr (assoc 1 (entget (nth 1 ss1)))))(substr (cdr (assoc 1 (entget (nth 1 ss1)))) 4) (cdr (assoc 1 (entget (nth 1 ss1)))))
		      ))
    (setq lst (append lst (list str)))
    )
  ))
  )
   

Bạn test thử xem, kết quả là 1 list như yêu cầu, do không nói xuất ra text hay gì nên mình để list đấy


<<

Filename: 435862_00.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435966
Tên lệnh: t1 t2
Nhờ các anh giúp

(defun c:t1 (/ ssn i)
(if (setq ssn (getint 
>>
(defun c:t1 (/ ssn i)
(if (setq ssn (getint "\nNh\U+1EADp s\U+1ED1 l\U+01B0\U+1EE3ng th\U+1EEDa \U+0111\U+1EA5t :")) (progn
(setq i 0)
(repeat ssn
  (setq i (1+ i))
  (if (not (tblsearch "layer" (itoa i)))
 (COMMAND "-LAYER" "M" (itoa i) "" "" "") )
  )
  )))
(defun c:t2 (/ ss ent ent2 pt tsz h pt2 ss2 ss3 txt1 )
  (setq ent2 (car (entsel "\nPick Text th\U+1EEDa \U+0111\U+1EA5t")))
  (setq tsz (cdr (assoc 40 (entget ent2))))
  (prompt "\nQu\U+00E9t ch\U+1ECDn v\U+00F9ng ch\U+1EE9a text ")
  (if (setq ss (acet-ss-to-list (ssget (list (cons 0 "POINT"))))) (progn
(setq i 0)								    
(while (setq ent (nth i ss))
  (setq i (1+ i))
  (setq pt (cdr (assoc 10 (entget ent)))
	h (* tsz 6.6)
	pt2 (polar pt (- 0 (/ pi 2.67)) h))
  (if (setq ss2 (acet-ss-to-list(ssget "_C"  pt pt2 (list (cons 0 "MTEXT") (cons 40 tsz)))))(progn
  
  (setq ss2 (vl-sort ss2 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y))))) ))
  (setq txt1 (cdr (assoc 1 (entget (nth 0 ss2)))))
  (if (< (atoi txt1) 1) (Prompt "\nDoi tuong khong phai So") (progn
  (setvar 'cmdecho 0)
  (setq ss2 (acet-list-to-ss ss2))
  (if (tblsearch "layer" txt1)
  (command "change" ss2 "" "p" "LA" txt1 ""))))))
  ))))

Mình mới viết thử được như này.

Lệnh t1: nhập số lượng thửa đất tối đa có trong bản vẽ (vd: số thửa từ 1 - n thì nhập n)

Lệnh t2: Pick vào text thửa đất rồi quét chọn vùng chứa các text 

              - để tránh chọn nhầm các text khác có trong vùng chọn

              - nên quét chọn từng vùng nhỏ để tránh bị lỗi


<<

Filename: 435966_t1_t2.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435983
Tên lệnh: t2 retsz
Nhờ các anh giúp
26 phút trước, Black_Cat_ đã nói:

Mình cảm ơn bạn rất nhiều...

>>
26 phút trước, Black_Cat_ đã nói:

Mình cảm ơn bạn rất nhiều vì đã viết lisp cho mình nhưng mà hình như lúc mình đưa ra yêu cầu không rõ ràng nên bạn hiểu sai ý mình, mình chân thành xin lỗi bạn, cái mục đích là mình muốn là số thửa theo layer thửa mã sử dụng theo layer mã sử dụng, địa chỉ theo layer địa chỉ..... mình muốn lấy từng loại thông tin một lúc....ví dụ mình muốn lấy toàn bộ thông tin của số thửa của bản vẽ vậy á. nố giống như ví dụ của bạn @Ngokiet chat ở trên... mà do lisp đó mình không thể sài trên bản cad nên mình mới nhờ giúp. Cảm ơn bạn rất nhiều, trình diễn đạt mình còn kém nên có gì mong bạn bỏ qua cho...


(defun c:t2 (/ ss ent ent2 pt h pt2 ss2 ss3 txt1 )
  (if (not (tblsearch "layer" "So Thua"))
 (COMMAND "-LAYER" "M" "So Thua" "c" "1" "" "" "") )
  (if (not (tblsearch "layer" "Ma Dat"))
 (COMMAND "-LAYER" "M" "Ma Dat" "c" "2" "" "" "") )
  (if (not (tblsearch "layer" "Chu Dat"))
 (COMMAND "-LAYER" "M" "Chu Dat" "c" "3" "" "" "") )
  (if (not (tblsearch "layer" "Dia Chi"))
 (COMMAND "-LAYER" "M" "Dia Chi" "c" "4" "" "" "") )
  (if (not (tblsearch "layer" "Dien Tich"))
 (COMMAND "-LAYER" "M" "Dien Tich" "c" "5" "" "" "") )
  (setq lst (list "So Thua" "Ma Dat" "Chu Dat" "Dia Chi" "Dien Tich"))
  (if (not tsz) (progn (setq ent2 (car (entsel "\nPick Text th\U+1EEDa \U+0111\U+1EA5t")))
  (setq tsz (cdr (assoc 40 (entget ent2))))))
  (prompt "\nQu\U+00E9t ch\U+1ECDn v\U+00F9ng ch\U+1EE9a text ")
  (if (setq ss (acet-ss-to-list (ssget (list (cons 0 "POINT"))))) (progn								    
(foreach ent ss
  (setq pt (cdr (assoc 10 (entget ent)))
	h (* tsz 6.6)
	pt2 (polar pt (- 0 (/ pi 2.67)) h))
  (if (and (setq ss2 (acet-ss-to-list(ssget "_C"  pt pt2 (list (cons 0 "MTEXT") (cons 40 tsz)))))
	(> (length ss2 ) 4))
	   (progn
  (setq ss2 (vl-sort ss2 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y))))) ))
(setq i 0)
  (while (setq lay (nth i lst))
    (setq txt (nth i ss2)
	  i (1+ i))
    (vla-put-layer (vlax-ename->vla-object txt) lay))
  ))
  ))))
(defun c:retsz (/ ent2)
  (if(setq ent2 (car (entsel "\nPick Text th\U+1EEDa \U+0111\U+1EA5t")))
  (setq tsz (cdr (assoc 40 (entget ent2))))))
      

Hy vọng đúng ý bạn

1783727747_ezgif.com-video-to-gif(1).gif.5c0ec453adbdc5f2f6bf6d1d17900ca0.gif


<<

Filename: 435983_t2_retsz.lsp
Tác giả: anhGeodesy
Bài viết gốc: 435849
Tên lệnh: 00
(defun c:00 (/ lst);( / ss Lst_Dim); Doc DIMENSION tao...
>>
(defun c:00 (/ lst);( / ss Lst_Dim); Doc DIMENSION tao List
  ;(setq content (acet-str-replace ")" ""(acet-str-replace "(" "" (cdr(assoc 1 (entget(car(entsel "Chon Text Ten Dam\n"))))))))
  (setq Lst_Dim (list))
  (if (setq ss (ssget  '((0 . "DIMENSION"))))
    (foreach x (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
      (setq Lst_Dim (append Lst_Dim
            (list (cond ((distof (cdr (assoc 1 (entget x)))))
            ((cdr (assoc 42 (entget x))))
           ))
        )
      )
      
    )
  )
)

Nhờ các cao thủ ra tay giúp em Thống kê quy cách dầm theo file đính kèm,.  

Cho ra List Như sau:   ((18DY01 400 600 1-1) (18DY01 400 600 2-2)(18DY01 400 600 3-3)(18DY01 400 600 4-4)(18DY01 400 700 5-5) (18DY01 400 700 6-6))

Hoi CV_ Thong ke quy cach dam.dwg

 

image.thumb.png.c318f6b18b0e1947177df682a5c1ab18.png


<<

Filename: 435849_00.lsp
Tác giả: anhGeodesy
Bài viết gốc: 436074
Tên lệnh: xtd
nhờ sửa lisp
;https://www.cadviet.com/forum/topic/176116-nh%E1%BB%9D-s%E1%BB%ADa-lisp/
;;;;;;;;;;;;;;;;;
(defun styleset	(/ h0 stl)
  (setq	stl (getvar "textstyle")
	h0  (getvar "textsize")
  )
  (if (/= h0 0)
    (command "style" stl "" 0 "" "" "" "" "")
  )
)
;;;;;;;;;;;;;;;;;;
(defun c:XTD (/ h p0 p1 p2 p3 p4 p5 p6 p7 tendiem sbd ktt i tdx tdy)
  (setvar "cmdecho" 0)
  (princ
    "\nLisp \U+0111\U+01B0\U+1EE3c ph\U+00E1t tri\U+1EC3n b\U+1EDFi Nguyenbg"
  )
  (setq olds (getvar...
>>
;https://www.cadviet.com/forum/topic/176116-nh%E1%BB%9D-s%E1%BB%ADa-lisp/
;;;;;;;;;;;;;;;;;
(defun styleset	(/ h0 stl)
  (setq	stl (getvar "textstyle")
	h0  (getvar "textsize")
  )
  (if (/= h0 0)
    (command "style" stl "" 0 "" "" "" "" "")
  )
)
;;;;;;;;;;;;;;;;;;
(defun c:XTD (/ h p0 p1 p2 p3 p4 p5 p6 p7 tendiem sbd ktt i tdx tdy)
  (setvar "cmdecho" 0)
  (princ
    "\nLisp \U+0111\U+01B0\U+1EE3c ph\U+00E1t tri\U+1EC3n b\U+1EDFi Nguyenbg"
  )
  (setq olds (getvar "osmode"))
  (or *h* (setq *h* 1))
  (setq	h (getreal
	    (strcat "\nCh\U+1ECDn cao text: < " (rtos *h* 2 2) " >: ")
	  )
  )
  (if (not h)
    (setq h *h*)
    (setq *h* h)
  )
  (or *sbd* (setq *sbd* 1))
  (setq	sbd
	 (getint
	   (strcat "\nCh\U+1ECDn s\U+1ED1 b\U+1EAFt \U+0111\U+1EA7u  < "
		   (itoa *sbd*)
		   " >: "
	   )
	 )
  )
  (if (not sbd)
    (setq sbd *sbd*)
    (setq *sbd* sbd)
  )
  (or *sole* (setq *sole* 2))
  (setq	sole
	 (getint
	   (strcat
	     "\nNh\U+1EADp s\U+1ED1 l\U+1EBB th\U+1EADp ph\U+00E2n sau d\U+1EA5u ch\U+1EA5m   < "
	     (itoa *sole*)
	     " >: "
	   )
	 )
  )
  (if (not sole)
    (setq sole *sole*)
    (setq *sole* sole)
  )

  (setq	ktt
	 (strcase
	   (getstring
	     "\nNh\U+1EADp k\U+00FD t\U+1EF1 ph\U+00EDa tr\U+01B0\U+1EDBc: "
	   )
	 )
  )
  (if (null ktt)
    (setq ktt "")
  )
  (setq i sbd)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (initget 1 "C K")
  (or *Luachon* (setq *Luachon* "C"))
  (setq	Luachon
	 (cond
	   ((getkword
	      (strcat
		"\nB\U+1EA1n c\U+00F3 mu\U+1ED1n xu\U+1EA5t ra File CSV kh\U+00F4ng?  ? <"
		*Luachon*
		">: "
	      )
	    )
	   )
	   (*Luachon*)
	 )
  )
  (if (not Luachon)
    (setq Luachon *Luachon*)
    (setq *Luachon* Luachon)
  )
					;Luu File   
  (cond
    ((= Luachon "C")
     (progn
       (setq fn (getfiled "Select a File" "" "csv" 1))
       (setq f (open fn "w"))
       (write-line " TEN DIEM, TOA DO X, TOA DO Y" f)
     )
    )
  )
					;
;;;Tao bang
  (setq
    p0 (getpoint
	 "\nCh\U+1ECDn \U+0111i\U+1EC3m \U+0111\U+1EB7t b\U+1EA3ng"
       )
  )
  (styleset)
  (command "osmode" 0)
  (command "text"
	   "j"
	   "mc"
	   (list (+ (car p0) (* 20 h)) (+ (cadr p0) (* 5 h)))
	   (* 2 h)
	   0
	   "B\U+1EA2NG T\U+1ECCA \U+0110\U+1ED8"
  )
  (command "text"
	   "j"
	   "mc"
	   (list (+ (car p0) (* 5 h)) (- (cadr p0) (* 1.5 h)))
	   h
	   0
	   "T\U+00EAn \U+0111i\U+1EC3m"
  )
  (command "text"
	   "j"
	   "mc"
	   (list (+ (car p0) (* 17.5 h)) (- (cadr p0) (* 1.5 h)))
	   h
	   0
	   "T\U+1ECDa \U+0111\U+1ED9 X"
  )
  (command "text"
	   "j"
	   "mc"
	   (list (+ (car p0) (* 32.5 h)) (- (cadr p0) (* 1.5 h)))
	   h
	   0
	   "T\U+1ECDa \U+0111\U+1ED9 Y"
  )
  (setq	p1 (list (+ (car p0) (* 10 h)) (cadr p0))
	p2 (polar p0 0 (* 25 h))
	p3 (polar p0 0 (* 40 h))
	p4 (polar p3 (* 1.5 pi) (* 3 h))
	p5 (polar p2 (* 1.5 pi) (* 3 h))
	p6 (polar p1 (* 1.5 pi) (* 3 h))
	p7 (polar p0 (* 1.5 pi) (* 3 h))
  )
  (command "pline" p0 p3 p4 p7 "c")
  (command "pline" p1 p6 "")
  (command "pline" p2 p5 "")
  (setq p0 p7)
  (setvar "osmode" olds)
;;;;;;;;;;;;;;;;;;;;;;
  (while (setq diem
		(getpoint
		  "\nCh\U+1ECDn \U+0111i\U+1EC3m c\U+1EA7n l\U+1EA5y t\U+1ECDa \U+0111\U+1ED9"
		)
	 )
    (setq tdx (rtos (cadr diem) 2 sole))
    (setq tdy (rtos (car diem) 2 sole))
    (setq tendiem (strcat ktt (itoa i)))
    (command "text" diem h 0 tendiem)
    (setvar "osmode" olds)
;;;;;;;;;;;;Ghi tiep
    (command "osmode" 0)
    (command "text"
	     "j"
	     "mc"
	     (list (+ (car p0) (* 5 h)) (- (cadr p0) (* 1.5 h)))
	     h
	     0
	     tendiem
    )
    (command "text"
	     "j"
	     "mc"
	     (list (+ (car p0) (* 17.5 h)) (- (cadr p0) (* 1.5 h)))
	     h
	     0
	     tdx
    )
    (command "text"
	     "j"
	     "mc"
	     (list (+ (car p0) (* 32.5 h)) (- (cadr p0) (* 1.5 h)))
	     h
	     0
	     tdy
    )
    (setq p1 (list (+ (car p0) (* 10 h)) (cadr p0))
	  p2 (polar p0 0 (* 25 h))
	  p3 (polar p0 0 (* 40 h))
	  p4 (polar p3 (* 1.5 pi) (* 3 h))
	  p5 (polar p2 (* 1.5 pi) (* 3 h))
	  p6 (polar p1 (* 1.5 pi) (* 3 h))
	  p7 (polar p0 (* 1.5 pi) (* 3 h))
    )
    (command "pline" p0 p3 p4 p7 "c")
    (command "pline" p1 p6 "")
    (command "pline" p2 p5 "")
    (setq p0 p7)
    (cond
      ((= Luachon "C")
       (write-line (strcat tendiem (chr 44) tdx (chr 44) tdy) f)
      )
    )
    (setq i (+ i 1))
    (setvar "osmode" olds)
;;;;;;;;;;;;
  )
  ;;dong while
  (close f)
  (princ)
);;dong defun
(prompt "\nLoad Th\U+00E0nh c\U+00F4ng!
L\U+1EC7nh:  XTD")

@HVQ01 Của bạn đây, hi vọng làm bạn hài lòng , đừng quên Like (Vote tăng)


<<

Filename: 436074_xtd.lsp
Tác giả: bach1212
Bài viết gốc: 197006
Tên lệnh: knut gn
Lisp xuất thông số của đường ra block thuộc tính
Sửa như vậy xem sao.
 ;; free lisp from cadviet.com ;;; this lisp was downloaded from...
>>
Sửa như vậy xem sao.
 ;; free lisp from cadviet.com ;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=47442&pid=196822&st=0entry196822 ;Khëi t¹o mét sè th«ng sè cho vÏ nót ;------------------------------------------------------ (defun C:knut () (setq hf (getreal "\nChieu cao text: ")) (command "dimstyle" "s" "Dimn" "dimstyle" "s" "Dran") (command "-Style" "hoatfon" "hoatfon" hf "" "" "" "" "") (command "-Layer" "n" "Text" "c" "4" "Text" "") (command "-Layer" "n" "Dim" "c" "1" "DIm" "") (command "-Layer" "n" "Khuat" "c" "4" "Khuat" "l" "Dashed" "Khuat" "") (Princ) ) ;;;Chuong trinh chinh (Ve va thong ke cac yeu to cua duong cong) (setq tlv (getint "\nNhap ty le ban ve nut 1/... :")) (defun c:GN () (setq cmd (getvar "cmdecho")) (setvar "cmdecho" 0) (setq sttdinh (getint "\nNhap so thu tu dinh :")) (setq es (entsel "\nChon cung tron can ve:")) (setq dbang (getpoint "\nChon vi tri dat bang thong ke:")) (setq osm (getvar "osmode")) (setvar "osmode" 0) (setq tdt (car es) dra (cadr es) ent (entget tdt) cen (cdr (assoc 10 ent)) goc1 (cdr (assoc 50 ent)) goc2 (cdr (assoc 51 ent)) bk (cdr (assoc 40 ent)) ) (setq td1 (polar cen goc1 bk) td2 (polar cen goc2 bk) ) (setq mid (list (/ (+ (car td1) (car td2)) 2) (/ (+ (cadr td1) (cadr td2)) 2) (caddr td1))) (setq goc (angle cen mid)) (setq goctam (abs (- goc2 goc1))) (if (< goctam pi) (setq goct goctam) (setq goct (- (* 2 pi) goctam)) ) (setq dtam (/ bk (cos (/ goct 2)))) (setq dinh (polar cen goc dtam)) (setq T (rtos (/ (* (distance dinh td1) tlv) 1000) 2 2) P (rtos (/ (* (- dtam bk) tlv) 1000) 2 2) K (rtos (/ (* (* goct bk) tlv) 1000) 2 2) Ssbk (rtos (/ (* bk tlv) 1000) 2 2) ) (command "-layer" "s" "khuat" "" ".line" td1 dinh td2 "") (command "-layer" "s" "DIM" "" "Dimstyle" "" "Dimn") (setq kckt (* 2.2 (getvar "dimtxt")) dkt1 (polar td1 goc1 kckt)) (command "DIMALIGNED" dinh td1 dkt1) (setq dkt2 (polar td2 goc2 kckt)) (command "DIMALIGNED" dinh td2 dkt2) (command "Dimstyle" "" "Dran" "DIMRADIUS" tdt dra "") ;VÏ khung thèng kª nut ;-------------------------------- (setq xb (+ (car dbang) (* 9 (getvar "textsize"))) yb (- (cadr dbang) (* 10.25 (getvar "textsize"))) dbang2 (list xb yb (caddr dbang)) odbang (polar dbang (/ (* 3 pi) 4) (/ (getvar "textsize") 5)) odbang2 (polar dbang2 (- (* 2 pi) (/ pi 4)) (/ (getvar "textsize") 5))) (command ".layer" "s" "text" "" ".rectang" odbang odbang2 ".rectang" dbang dbang2) (command "change" "l" "" "p" "c" "1" "") ;Xö lý b¶ng thèng kª ;----------------------------- (setq gockep (angtos (- pi goct) 1 4)) (setq Kiem1 (substr gockep 2 1) kiem2 (substr gockep 3 1) kiem3 (substr gockep 4 1)) (cond ((= kiem1 "d") (setq dau (substr gockep 1 1) cuoi (substr gockep 3))) ((= kiem2 "d") (setq dau (substr gockep 1 2) cuoi (substr gockep 4))) ((= kiem3 "d") (setq dau (substr gockep 1 3) cuoi (substr gockep 5))) ) (setq gockep (strcat (strcat dau "%%d") cuoi)) ;---------------------------- (setq nhan (rtos sttdinh 2 0)) (setq chugoc (strcat (strcat "A" nhan) (strcat "=" gockep))) (setq chubk (strcat (strcat (strcat "R" nhan) (strcat "=" ssbk)) "m")) (setq chutt (strcat (strcat (strcat "T" nhan) (strcat "=" T)) "m")) (setq chup (strcat (strcat (strcat "P" nhan) (strcat "=" P)) "m")) (setq chucd (strcat (strcat (strcat "K" nhan) (strcat "=" K)) "m")) (setq dong1 (polar dbang (- (* 2 pi) (/ (* 9 pi) 24)) (* 1.75 (getvar "textsize"))) dong2 (polar dong1 (+ pi (/ pi 2)) (* 2 (getvar "textsize"))) dong3 (polar dong2 (+ pi (/ pi 2)) (* 2 (getvar "textsize"))) dong4 (polar dong3 (+ pi (/ pi 2)) (* 2 (getvar "textsize"))) dong5 (polar dong4 (+ pi (/ pi 2)) (* 2 (getvar "textsize"))) ) (command "-layer" "s" "Text" "" ".text" dong1 "" chugoc ".text" dong2 "" chubk ".text" dong3 "" chutt ".text" dong4 "" chup ".text" dong5 "" chucd) (setq tendinh (strcat "A" nhan)) (command ".text" dinh "" "" tendinh "") (command "insert" "nut" dinh "" "" "" ) (setvar "osmode" osm) (setvar "cmdecho" cmd) (princ) ) 

iem A điền ở đỉnh của 2 đường gióng này chạy đi đâu không thấy ra í bác Ha ah: Các thông số khác thì đều đã oki

A.jpg


<<

Filename: 197006_knut_gn.lsp

Trang 290/330

290