Jump to content
InfoFile
Tác giả: chien_lv
Bài viết gốc: 404899
Tên lệnh: tt
Tập sửa lisp rải thép

Đối tượng chấm tròn bạn dùng là loại đối tượng nào? Block, Donut ...?

Lisp này giải quyết vấn đề trên.

Với...

>>

Đối tượng chấm tròn bạn dùng là loại đối tượng nào? Block, Donut ...?

Lisp này giải quyết vấn đề trên.

Với điều kiện:

1.  Đối tượng chấm tròn là Block.

2. Block chọn để rải có điểm chèn lùi vào 1 khoảng = bán kính hình tròn theo hướng rải.

(defun c:tt (/ bdt bro dem dia dst ent ept goc len lst obj p10 pmax pmin pt1 slg spt)

(vl-load-com)

(or #kc_rai_tt# (setq #kc_rai_tt# 150))

(if (and (setq ent (car (entsel "\nPick chon Block: ")))

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

(setq spt (getpoint "\nStart point:"))

(setq ept (getpoint "\nEnd point:" spt))

(not (initget 6))

(setq #kc_rai_tt# (cond ((getdist (strcat "\nKhoang cach a <" (itoa #kc_rai_tt#) ">: ")))

(#kc_rai_tt#))))

(progn (setq lst (vl-remove-if '(lambda (x) (member (car x) '(-1 5 10 330))) (entget ent))

p10 (cdr (assoc 10 (entget ent))))

(setq obj (vlax-ename->vla-object ent))

(or (eq (setq bro (vlax-get obj 'Rotation)) 0) (vlax-put obj 'Rotation 0))

(vla-getboundingbox obj 'pmin 'pmax)

(and (not (eq bro 0)) (vlax-put obj 'Rotation bro))

(setq pmin (vlax-safearray->list pmin)

pmax (vlax-safearray->list pmax)

dia (abs (- (car pmin) (car pmax))))

(setq goc (angle spt ept)

dst (- (distance spt ept) dia)

slg (fix (+ (/ dst #kc_rai_tt#) 0.5))

len (/ dst slg)

dem 0)

(while (< dem slg)

(setq bdt (* (setq dem (1+ dem)) len)

pt1 (polar p10 goc bdt))

(entmakex (append lst (list (cons 10 pt1)))))))

(princ))

 

 

 

Đối tượng mình dùng là Donut bạn ah? mình chạy lisp của bạn thì thấy như sau: load lần đầu tiên thì chạy được, lần thứ 2 thì không chạy được, mình phải mở bản vẽ mới ra và load lại thì ok tuy nhiên nó mặc định khoảng cách a sau lần chạy đầu tiên mình nghĩ cái này không nên để mặc định như thế. bạn có thể giúp mình chỉnh với đối tượng là donut không và mỗi lần chạy đề hỏi khoảng cách a=? sau khi mình chọn hai điểm đầu và cuối. 


<<

Filename: 404899_tt.lsp
Tác giả: tientracdia
Bài viết gốc: 322876
Tên lệnh: hskt2
chỉnh tên cạnh

Mình có liisp sưu tầm được mục đích chọn vào vùng tâm thửa chỉ ra điểm chèn, mình muốn thêm tên cạch vào bảng

(defun c:HSKT2( / ss lst fn fid lstEn)
(vl-load-com)
(command "-purge" "a" "" "N")
(command "attdisp" "ON")
  (styf)
  (Setq Tlebd (LM:GetXWithDefault getreal "\n Nhap ty le ban do: " '*Tlebd* (atof "1000")))
  (setq TLE (/ Tlebd 1000))
  (progn
	(setvar "hpgaptol" 0.5)
	(setq Olmode (getvar...
>>

Mình có liisp sưu tầm được mục đích chọn vào vùng tâm thửa chỉ ra điểm chèn, mình muốn thêm tên cạch vào bảng

(defun c:HSKT2( / ss lst fn fid lstEn)
(vl-load-com)
(command "-purge" "a" "" "N")
(command "attdisp" "ON")
  (styf)
  (Setq Tlebd (LM:GetXWithDefault getreal "\n Nhap ty le ban do: " '*Tlebd* (atof "1000")))
  (setq TLE (/ Tlebd 1000))
  (progn
	(setvar "hpgaptol" 0.5)
	(setq Olmode (getvar "OSMODE"))
	(setvar "OSMODE" 0)
	
	(setq Clor (getvar "CECOLOR"))
	(setq pt (getpoint "\n Pick diem trong vung can trich thua :"))
	(vl-cmdf  "-boundary" pt "")
        (setq Elast1 (entlast))
    	(dch (entget Elast1))
    	(setq Elast (entlast))
  	(setq en Elast
      	      ob (vlax-ename->vla-object  en)
               n (vlax-curve-getEndParam ob)
               i 0
        )
  	(setq Pd (vlax-curve-getPointAtParam ob 0)
	      Pc (vlax-curve-getPointAtParam ob n)
	     KCC (rtos (distance Pd Pc) 2 2)
	)
  	(setq P1dau (vlax-curve-getPointAtParam ob 0))
	(setq Xdau (rtos (car P1dau) 2 2))
  	(setq Ydau (rtos (cadr P1dau) 2 2))
  
  	(setq P_ddat (getpoint "\n Chon diem dat: "))
  	(setq P_a1 (polar P_ddat 0 (* TLE 207.0)))		; chieu dai rong khung
  	(setq P1 (polar P_a1 (/ pi 2) (* TLE 124.3)))

    
  	(command "insert" "HSKT" P_ddat TLE TLE  0 (rtos (Area Elast)  2 2) (rtos Tlebd  2 0)) ;; chen khung, dtich, ti le
  	(setq P2  (polar P1 0 (* TLE 20.0)))
  	(setq P3  (polar P1 0 (* Tle 43.0)))
  	(setq P4a (polar P1 0 (* TLE 62.0)))
  	(setq P4 (polar P4a (DTR 270) (* TLE 2.5)))
	;;
	(setq P5a (polar P1 0 (* TLE 82.0)))
  	(setq P5 (polar P5a (DTR 270) (* TLE 2.5)))
	;;
  	(setq P1DD (polar P1 (DTR 270) (* n (* TLE 5.0))))
  	(setq P2DD (polar P2 (DTR 270) (* n (* TLE 5.0))))
  	(setq P3DD (polar P3 (DTR 270) (* n (* TLE 5.0))))
  
  	(MakeText P1DD (rtos 1 2 0) (* TLE 2.5) 0 "C")
  	(MakeText P2DD Xdau         (* TLE 2.5) 0 "C")
  	(MakeText P3DD Ydau         (* TLE 2.5) 0 "C")
  	
	(while (< i n)
		(setq p (vlax-curve-getPointAtParam ob i))
	  	(setq p_2 (vlax-curve-getPointAtParam ob (+ i 1)))
		(setq X (rtos (car P) 2 2))
	  	(setq Y (rtos (cadr P) 2 2))
		
		;(setq TE ((vlax-curve-getPointAtParam ob i) "  -  " (vlax-curve-getPointAtParam ob (+ i 1))));;
	  	(setq KC (rtos (distance P P_2) 2 2))
		;;
		
		;;
	  	(setq P1_i (Polar P1 (DTR 270) (* i (* TLE 5.0))))
	  	(setq P2_i (Polar P2 (DTR 270) (* i (* TLE 5.0))))
	  	(setq P3_i (Polar P3 (DTR 270) (* i (* TLE 5.0))))
	  	(setq P4_i (Polar P4 (DTR 270) (* i (* TLE 5.0))))
	  	;;
		(setq P5_i (Polar P5 (DTR 270) (* i (* TLE 5.0))));;
		;;
	  	(MakeText P1_i (rtos (+ i 1) 2 0) (* TLE 2.5) 0 "C")	; viet stt
	  	(MakeText P2_i X (* TLE 2.5) 0 "C")						; viet tdo x
	  	(MakeText P3_i Y (* TLE 2.5) 0 "C")						; viet tdo y
		(MakeText P4_i (rtos (+ i 1) 2 0) (* TLE 2.5) 0 "C")	; viet stt
		(MakeText P5_i KC (* TLE 2.5) 0 "C")					; viet khoang cach
		
		(setq i (1+ i))											; lap lai cac diem
	)
)
;(setq P_a2 (polar P_ddat 0 (* TLE 138.3)))
(setq P_a2 (polar P_ddat 0 (* TLE 138.3)))				;; vi tri cat thua
(setq Pnt1 (polar P_a2 (/ pi 2) (* TLE 94.5)))
(command "copy" Elast "" (mid Elast) Pnt1 "")
(GKT Pnt1 TLE )


(setvar "OSMODE" Olmode)
(princ)
)
;;--------------------------------------------------------
(defun GKT (Pt TLE / lst fn fid lstEn);Ghi kich thuoc
(vl-load-com)
	(setvar "hpgaptol" 0.5)
	(setq Olmode (getvar "OSMODE"))
	(setvar "OSMODE" 0)
	(setq Clor (getvar "CECOLOR"))
	(vl-cmdf  "-boundary" Pt "")
        (setq Elast (entlast))
  	(dch (entget Elast))
  	(setq en Elast
      	      ob (vlax-ename->vla-object  en)
               n (vlax-curve-getEndParam ob)
               i 0
        )
  	
	(while (< i n)
		(setq P (vlax-curve-getPointAtParam ob i))
	  	(command "insert" "tron" p TLE TLE 0)			; chen diem vong tron
	  	(setq P_2 (vlax-curve-getPointAtParam ob (+ i 1)))
	  	(setq goc (angle P P_2))
	  	(setq KC_i  (distance P P_2) )
	  	(setq DG_i (polar P goc (/ KC_i 2)))
	  	(setq Pii (polar P (/ pi 2) (* TLE 2)))
	  	(MakeText Pii (rtos (+ i 1) 2 0) (* TLE 2.5) 0 "C")
	  	(setq PVi (Atan2 P P_2))
	  	(if (< (Rad_to_Do PVi) 180)
		  (progn
		    (setq PG_ia (polar DG_i (+ (/ pi 2) goc) 1.0))
	  	    (MakeText PG_ia (rtos KC_i 2 2) (* TLE 2.5) goc "C")
		  )
		  (progn
		    (setq PG_ib (polar DG_i (+ (/ pi 2) (angle P_2 P)) 1.0))
		    (MakeText PG_ib (rtos KC_i 2 2) (* TLE 2.5)  (angle P_2 P) "C")
		  )
		)
		(setq i (1+ i))
	)
(MakeText (mid Elast) (rtos (Area Elast)  2 2)  (* TLE 2.5)  0 "C")	; viet dtich tren thua cat
(entdel Elast)
(setvar "OSMODE" Olmode)
;;;(princ )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Area (ent)
(setvar "hpgaptol" 0.1)
(vla-get-area (vlax-ename->vla-object ent))
)
;;-----------
(defun mid (ent / p1 p2)
	(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
	(setq p1 (vlax-safearray->list p1)
				p2 (vlax-safearray->list p2)
				pt (mapcar '+ p1 p2)
				pt (mapcar '* pt '(0.5 0.5 0.5))
	)
	pt
)
;;--------
(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 4)(cons 11 p)(cons 62 4) (cons 1 txt) (cons 10 p)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun TD:Text-Base (ent)
  (setq Ma10  (cdr (assoc 10 (entget ent))))
  (setq Ma11  (cdr (assoc 11 (entget ent))))
  (setq X11 (car Ma11))
  (setq Ma71  (cdr (assoc 71 (entget ent))))
  (setq Ma72  (cdr (assoc 72 (entget ent))))
  (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
	  (and (= Ma71 0) (= Ma72 3) )
	  (and (= Ma71 0) (= Ma72 5) )
      )
    Ma10
    Ma11
   )
)

(defun DTR (Do / radian)
   (setq radian  (/ (* Do pi ) 180))
)
(defun LM:GetXWithDefault ( _function _prompt _symbol _default / _toString )
	(setq _toString
		(lambda ( x )
			(cond
				( (eq getangle _function) (angtos x) )
				( (eq 'REAL (type x)) (rtos x) )
				( (eq 'INT (type x)) (itoa x) )
				( x )
			)
		)
	)

	(set _symbol
	(
	(lambda ( input ) (if (or (not input) (eq "" input)) (eval _symbol) input))
	(_function (strcat _prompt "<" (_toString (set _symbol (cond ( (eval _symbol) ) ( _default )))) "> : "))
	)
	)
)

(defun MakeText (point string Height Ang justify     / Lst); Ang: Radial
	(setq Lst (list '(0 . "TEXT")
			(cons 8 (if Layer Layer (getvar "Clayer")))
			(cons 62 (if Color Color 256))
			(cons 10 point)
			(cons 40 Height)
			(cons 1 string)
			(cons 50 Ang)
		)
	justify (strcase justify)
      )
      (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
			((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
			((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
			((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
			((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
			((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))	
			((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
			((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
			((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
			((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
			((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
			((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
      )
     (entmakex Lst)
 )


;revlwpl
(defun dch (ent / eo el len)
(vl-load-com)
(setq eo ent)
(setq el (list(assoc 210 ent)))
(while (member (assoc 10 ent) ent)
  (if (= 0.0 (assoc 42 ent))
(setq el (cons (assoc 42 ent) el))
(setq el (cons (cons 42 (- (cdr (assoc 42 ent)))) el))
  )
  (setq el (cons (assoc 41 ent) el))
  (setq el (cons (assoc 40 ent) el))
  (setq el (cons (assoc 10 ent) el))
  (setq ent (member (assoc 10 ent) ent))
  (setq ent (cdr ent))
)
(setq len(- (LENGTH eo) (LENGTH (member (assoc 10 eo) eo)) 1))
(while (>= len 0)
  (setq el (cons (nth len eo) el))
  (setq len (- len 1))
)
(setq ent el)
(entmod ent)
(princ)
)

(defun Rad_to_Do(radian / Do)
   (setq Do (/ (* radian 180) pi))
)
(defun Do_to_Radian (Do / radian)
   (setq radian  (/ (* Do pi ) 180))
)
(defun R2DPG (gocR / DPG Toando Do Phut1 Phut Giay DPG)
  (setq DPG (list))
  (setq Toando (Rad_to_Do gocR))
  (setq Do (fix Toando))
  (setq Phut1  (* (- Toando Do) 60))
  (setq Phut (fix Phut1))
  (setq Giay   (atof (rtos (* (- phut1 phut) 60) 2 3)))
  (setq DPG (list Do  Phut giay))
  DPG
)
(defun DPG_to_DO (Goc)
(setq DD (nth 0 Goc))
(setq PP (/ (nth 1 Goc) 60))
(setq GG (/ (nth 2 Goc) 3600))
(setq DDD (+ DD PP GG))
DDD
)
(defun Dogoc2diem (P1 P2 /)
  (setq gocP12 (angle P1 P2))
  (setq gocP12_DPG (R2DPG gocP12))
  (setq Goc_12 (DPG_to_DO gocP12_DPG))
  Goc_12
)
(defun Do_to_DPG (Toando /)
  (setq Do (fix Toando))
  (setq Phut1 (* (- Toando Do) 60))
  (setq Phut (fix Phut1))
  (setq Giay   (atof (rtos (* (- phut1 phut) 60) 2 3)))
  (setq DPG (list Do  Phut giay))
  DPG
)

(defun Atan2 (P1 P2 / gocAtan b)
  (setq dx ( - (car P2) (car P1)))
  (setq dy ( - (cadr P2) (cadr P1)))
  (setq gocAtan (list))
  (cond
    ((and (= dx 0) (> dy 0) )
      (setq gocAtan 0)
    )
    ((and (= dx 0) (< dy 0) )
      (setq gocAtan pi)
    )
    ((and  (< dx 0) (= dy 0) )
      (setq gocAtan (/ (* 3 pi) 2))
    )
    ((and  (> dx 0) (= dy 0) )
      (setq gocAtan pi)
    )
    ((and  (= dx 0) (= dy 0) )
      (setq gocAtan 0)
    )
    ((/= dx 0)
     (progn
	(setq b (atan (/ dx dy)))
	(cond
	    ((and (> dx 0) (>= dy 0))
		  (setq gocAtan b)
	    )
	    ((and (< dx 0) (> dy 0))
		  (setq gocAtan (+ (* pi 2) b))
	    )
	    ((and (< dx 0) (< dy 0))
		  (setq gocAtan (+ pi b))
	    )
	    ((and (> dx 0) (< dy 0))
	          (setq gocAtan (+ pi b))
	    )
	)
      )
    )  
  )
  gocAtan
)
(defun styf (/ Oldtstyle Sttxt Userfont *error*)
  (defun *error* (s)
    (setvar "textstyle" oldtstyle)
  )
  (setq oldtstyle (getvar "textstyle"))
  (setq userfont "Times New Roman") 
  (setvar "textstyle" (cdr (assoc 2 (tblnext "style" T))))
  (command "._Style" "" userfont 2 1 0 "N" "N")
  (while
    (setq sttxt (cdr (assoc 2 (tblnext "style"))))
     (setvar "textstyle" sttxt)
     (command "._Style" "" userfont 2 1 0 "N" "N")
  )
  (setvar "textstyle" oldtstyle)
)


(defun daochieu (ss / count lwp ent obj oname sss revlwpl revln)
  (vl-load-com)
  (defun revlwpl(/ eo el len)
	(setq eo ent)
	(setq el (list(assoc 210 ent)))
	(while (member (assoc 10 ent) ent)
	  (if (= 0.0 (assoc 42 ent))
   (setq el (cons (assoc 42 ent) el))
   (setq el (cons (cons 42 (- (cdr (assoc 42 ent)))) el))
	  )
	  (setq el (cons (assoc 41 ent) el))
	  (setq el (cons (assoc 40 ent) el))
	  (setq el (cons (assoc 10 ent) el))
	  (setq ent (member (assoc 10 ent) ent))
	  (setq ent (cdr ent))
	)
	(setq len(- (LENGTH eo) (LENGTH (member (assoc 10 eo) eo)) 1))
	(while (>= len 0)
	  (setq el (cons (nth len eo) el))
	  (setq len (- len 1))
	)
	(setq ent el)
	(entmod ent)
  )
  (defun revln (/ pt1 pt2)
	(setq pt1 (cons 10 (cdr (assoc 11 ent))))
	(setq pt2 (cons 11 (cdr (assoc 10 ent))))
	(setq ent (subst pt1 (assoc 10 ent) ent))
	(setq ent (subst pt2 (assoc 11 ent) ent))
	(entmod ent)
  )
	 
;;;  (princ "\nSelect Lines & Polylines to reverse direction of:   ")
;;;  (setq ss (ssget '((0 . "POLYLINE,LWPOLYLINE,LINE"))))
  (setvar "CMDECHO" 0)
  (command "._UNDO" "_BEgin")
  (if ss
	(progn
	  (setq count 0 lwp 0)
	  (while (> (sslength ss) count)
		(setq ent (ENTGET (ssname ss count))
				  obj (vlax-ename->vla-object (ssname ss count))
				  oname (vlax-get-property obj 'ObjectName)
		)
		(cond
		  ((= oname "AcDb3dPolyline")(setq lwp(+ 1 lwp)))
		  ((= (cdadr ent) "LWPOLYLINE")(revlwpl))
		  ((= (cdadr ent) "POLYLINE")
			(progn
			  (setq sss (ssadd (ssname ss count)))
			  (vl-cmdf "convertpoly" "Light" sss "")
			  (setq ent (ENTGET (ssname sss 0)))
			  (revlwpl)
			)
		  )
		  ((= (cdadr ent) "LINE")(revln))
		)
		(setq count (+ count 1))
	  )
	)
  )
  (command "._UNDO" "_End")
  (if(> lwp 0)
	(if(> lwp 1)
	  (princ(strcat "\nCould not reverse " (itoa lwp) " 3dPolylines."))
	  (princ"\nCould not reverse the 3dPolyline.")
	)
  )
  (princ)
)

Nhưng xuất ra chỉ có một số thứ tụ, mình có file cad yêu cầu theo đó.

Mong được các bạn giúp

http://www.cadviet.com/upfiles/4/114381_hskt.rar


<<

Filename: 322876_hskt2.lsp
Tác giả: vetgo
Bài viết gốc: 162937
Tên lệnh: f
(Yêu cầu) lisp fillet. lấy một đối tuợng chọn làm chuân

Bạn thử xem :

(defun c:f(/ e1 e2 FR)
(or *FR* (setq *FR* (getvar "filletrad")))
(setq FR (getreal (strcat "\n Nhap ban kinh Fillet...
>>

Bạn thử xem :

(defun c:f(/ e1 e2 FR)
(or *FR* (setq *FR* (getvar "filletrad")))
(setq FR (getreal (strcat "\n Nhap ban kinh Fillet < " (rtos *FR*) " > :")))
(if FR (setq *FR* FR) (setq FR *FR*))
(setvar "filletrad" FR)

(setq e1 (car(entsel "Doi tuong 1 :")))(redraw e1 3)
(setq e2(car(entsel "Doi tuong 2 :")))(redraw e2 3)
(vl-cmdf ".MATCHPROP" e1 e2 "")
(command ".fillet" e1 e2 )
)

Cái này của bác chỉ giải quyết được lựa chọn bán kính, ý của bạn Doan van Ha là muốn lựa chọn tùy biến trong lệnh Fillter gốc của cad cơ.

Select first object or


<<

Filename: 162937_f.lsp
Tác giả: nguyentuyen6
Bài viết gốc: 123202
Tên lệnh: h
Viết lisp theo yêu cầu [phần 2]

Khi ta tạo lệnh tắt bằng lisp của lệnh hatch:

(defun c:h() (command "hatch")).

Giờ muốn khi nhấn h thì mặc định mẫu hatch sẽ là ANSI31 và scale là 10 thì phải viết...

>>
Khi ta tạo lệnh tắt bằng lisp của lệnh hatch:

(defun c:h() (command "hatch")).

Giờ muốn khi nhấn h thì mặc định mẫu hatch sẽ là ANSI31 và scale là 10 thì phải viết thêm gì.Mong các bác giúp đỡ.

Bạn sửa thế này nhé này nhé

(defun c:h() 
(command "-hatch" "p" "ANSI31" "10" "" pause)
)


<<

Filename: 123202_h.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 221575
Tên lệnh: xtpl
lisp xóa text trong 1 miền kín


;; free lisp from cadviet.com
;;; this lisp was downloaded from...
>>


;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=68051&pid=221519&st=0entry221519
(defun c:xtpl ()
(setq dt  (ssget '((0 . "LWPOLYLINE"))))
(setq n (sslength dt) i 0)
(while (< i n)
(setq dt1 (ssname dt i))
(command ".zoom" "o" dt1 "")
(setq SS (ssget "wp" (acet-geom-vertex-list dt1)  (list (cons 0 "text"))))
(command ".erase" ss "")
(command ".zoom" "p")
(setq i (+ i 1))
)
(setq sdt (sslength ss))
)

Cám ơn bạn nhiều lắm


<<

Filename: 221575_xtpl.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 221522
Tên lệnh: xt
lisp xóa text trong 1 miền kín

 

Mình tặng bạn lisp có tính năng xóa text trong vùng kín chỉ cần 1 pick Point. Hy vọng bạn hài lòng

>>

 

Mình tặng bạn lisp có tính năng xóa text trong vùng kín chỉ cần 1 pick Point. Hy vọng bạn hài lòng

(defun C:xt (/  p ss Tong ptLst cur L)
(setvar "hpgaptol" 50.0)
(command "_.undo" "_begin")
(setq  p (getpoint "\nPick vao vung can tinh: "))
(command ".boundary" "A" "B" "E" "I" "Y" "" p "")
(setq ss  (entlast))
  (setq ptLst	(GetPtLst (setq cur  (vlax-ename->vla-object  ss))))
  (setq ssInside (ssget "_WP" ptLst '((-4 . "<OR")  (0 . "TEXT")  (-4 . "OR>"))))
  (foreach itm (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside)))
(entdel itm)
  )
(command "_.undo" "_end")
(princ)
)

(defun getbound(p /)
(setq ent (entlast))
(command ".boundary" "A" "B" "E" "I" "Y" "" p "")
(setq ent1 (entlast))
(cond
 	((eq ent ent1) nil)
 	(t ent1)
)
 )
(defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)
 (defun ZClosed (lst)
(if (and (vlax-curve-isClosed obj)
  	(not (equal (car lst) (last lst) 1e-6)))
 	(append lst (list (car lst)))
 	lst)
 )
 (or (eq (type obj) 'VLA-OBJECT)
(setq obj (vlax-ename->vla-object obj)))
 (setq typ (vlax-get obj 'ObjectName))
 (if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
(progn
 	(setq param 0)
 	(while (< param (* pi 2))
(setq pt (vlax-curve-getPointAtParam obj param)
  	ptlst (cons pt ptlst)
  	param (+ (/ (* pi 2) 72) param)))
 	(reverse ptlst))
(progn
 	(setq param (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
anginc (* pi (/ 7.5 180.0)))
 	(setq tparam param)
 	(while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
(if (not (equal pt (car ptlst) 1e-12))
  (setq ptlst (cons pt ptlst)))
(if  (and (/= param endparam)
(setq blg (abs (vlax-invoke obj 'GetBulge param)))
(/= 0 blg))
  (progn
(setq delta (* 4 (atan blg))
inc (/ 1.0 (1+ (fix (/ delta anginc))))
             	arcparam (+ param inc))
(while (< arcparam (1+ param))
  	(setq pt (vlax-curve-getPointAtParam obj arcparam)
               	ptlst (cons pt ptlst)
               	arcparam (+ inc arcparam)))))
(setq param (1+ param)))
 	(if (and (apply 'and ptlst)
   	(> (length ptlst) 1))
(ZClosed (reverse ptlst)))))
 )

Không xử lý được những Text ko nhìn thấy


<<

Filename: 221522_xt.lsp
Tác giả: Hoan1111
Bài viết gốc: 238892
Tên lệnh: cr
(Yêu cầu) xin lisp copy, move đối tượng rồi xoay

 

Cho mình chung vui với :D

Thể theo nguyện vọng của Hoằn mình edit sang "thể loại" MOCORO:

(defun...
>>

 

Cho mình chung vui với :D

Thể theo nguyện vọng của Hoằn mình edit sang "thể loại" MOCORO:

(defun c:cr( / oldcm doituong goc dmoi)
(setq oldcm (getvar "cmdecho"))
(setvar "cmdecho" 0)
(prompt "\nChon doi tuong muon copy")
(setq doituong (ssget))
(setq dgoc (getpoint "\nChon diem goc:"))
(setq dmoi (getpoint dgoc "\nChon diem den moi:"))
(prompt "\nChon goc quay: ")
(command ".mocoro" doituong "" dgoc "c" dmoi "" "r" pause "")
(setvar "cmdecho" oldcm)
(princ)
)

 

:) :) chỉ có lợi cho anh Hiệp tập viết lisp thôi!

Command: Ap APPLOAD Hiepcr.lsp successfully loaded.

Command:

Command:

Command: CR

Chon doi tuong muon copy

Select objects: Specify opposite corner: 2 found

Select objects:

Chon diem goc:

Chon diem den moi:

Chon goc quay: 30

 

 

Tính chi ly thì dùng lisp chậm hơn, hao tổn nhiều nơtron hơn là dùng mocoro, nhớ tên người người yêu sướng hơn là phải nhớ cái tên CR lạ hoắc là cái chắc rồi!

 

Command: MOCORO  (AutoCAD2013 chỉ cần gõ 3 ký tự: MOC)

Select objects: Specify opposite corner: 2 found

Select objects:

Base point:

<eXit>: c

Second point of displacement/Undo/<eXit>:

Second point of displacement/Undo/<eXit>:

<eXit>: r

Second Point or Rotation angle: 30

<eXit>:

 

 


<<

Filename: 238892_cr.lsp
Tác giả: Kieu Tan
Bài viết gốc: 408337
Tên lệnh: mac
Xoay text thuộc tính trong block

 

Ok, nếu thử lisp thì nghịch tí nào. Thêm cả 2 cách Autolisp và Visual lisp.

 

Autolisp này: ^_^

>>

 

Ok, nếu thử lisp thì nghịch tí nào. Thêm cả 2 cách Autolisp và Visual lisp.

 

Autolisp này: ^_^

(defun c:test (/ blk ss n name ins lst value)
  (if (setq blk (car (entsel "\nChon block: ")))
    (progn
      (setq
	ss (ssget "_X" (list '(0 . "INSERT") (assoc 2 (entget blk))))
      )
      (command "_justifytext" ss "" "MC")
      (setq name (cdr (assoc 2 (entget (ssname ss 0)))))
      (setq lst (get-block-entities name))
      (foreach ob lst
	(if (eq (cdr (assoc 0 (entget ob))) "CIRCLE")
	  (setq center (trans (cdr (assoc 10 (entget ob))) 1 0))
	  )
	);foreach
      (foreach ob lst
	(if (eq (cdr (assoc 0 (entget ob))) "ATTDEF")
	  (progn
	    (setq value (cdr (assoc 1 (entget ob))))
	    (entmod (subst (cons 11 center) (assoc 11 (entget ob)) (entget ob)))
	    )
	  )
	);foreach
      (entupd (ssname ss 0))
      (setq n 0)
      (repeat (sslength ss)
	(setq ins (cdr (assoc 10 (entget (ssname ss n)))))
	(setq value (cdr (assoc 1 (entget (entnext (ssname ss n))))))
	(command "_-insert" name "_none" ins 1 1 0 value
		 "_erase" (ssname ss n) "")
	(setq n (1+ n))
	)
      )
    )
  )
(defun get-block-entities ( blk / ent lst )
    (if (setq ent (tblobjname "block" blk))
      (while (setq ent (entnext ent))
	(setq lst (cons ent lst))
        ) ;; end WHILE
    ) ;; end IF
    (reverse lst) ;; Return the list
) ;; end DEFUN
;;;END CODE AUTOLISP HERE


 

 

Thử cả VL xem nào ^_^ Ah tất nhiên dùng lisp trong trường hợp này là các block trục không nằm trong block tổng nữa nhé. :D

(defun c:MAC (/ acdoc mspace blk center temp)
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  (setq mspace (vla-get-modelspace acdoc))
  (if (setq blk (car (entsel "\nChon block: ")))
    (progn
      (vlax-for	blks (vla-get-blocks acdoc)
	(if (wcmatch (vla-get-Name blks) (cdr (assoc 2 (entget blk))))
	  (progn
	    (vlax-for obj blks
	      (if (= (vla-get-ObjectName obj) "AcDbCircle")
		(setq center (vlax-get obj 'Center))
	      )
	    )
	    (vlax-for obj blks
	      (if
		(= (vla-get-ObjectName obj) "AcDbAttributeDefinition")
		 (progn
		   (vla-put-Rotation obj 0.0)
		   (vla-put-Alignment obj acAlignmentMiddleCenter)
		   (vla-put-TextAlignmentPoint
		     obj
		     (vlax-3d-point center)
		   )
		 )			;progn
	      )				;if
	    )				;vlax-for obj
	  )				;progn then
	)				;if
      )					;vlax-for blks
      (setq temp (vla-insertblock
		   mspace
		   (vlax-3d-point '(0. 0. 0.))
		   (cdr (assoc 2 (entget blk)))
		   1
		   1
		   1
		   0
		 )
      )
      (vla-sendcommand
	acdoc
	(strcat	"ATTSYNC\n"
		"Name\n"
		""
		(cdr (assoc 2 (entget blk)))
		"\n"
		""
	)
      )
      (vla-delete temp)
    )					;progn
  )					;if
  (princ)
)					;defun

;;;END CODE VISUAL LISP HERE

Cả 2 lsp đều bị lỗi hết rồi bạn ơi! 


<<

Filename: 408337_mac.lsp
Tác giả: Phamdung01
Bài viết gốc: 431490
Tên lệnh: td1
Lisp thêm đỉnh cho PL

(defun C:td1 ()
(vl-load-com)
(setq d (vlax-ename->vla-object (car (entsel))))

(cond

((=(vla-get-ObjectName d) "AcDbPolyline")
(progn
(while (setq e (getpoint))
(setq e (vlax-curve-getClosestPointTo d e))
(setq param (vlax-curve-getParamAtPoint d e))
(setq param (+ (fix param) 1))
(setq e (vl-remove (last e) e))
(vlax-invoke d 'AddVertex Param e)
)))



((=(vla-get-ObjectName d) "AcDb3dPolyline")
(progn
(while...
>>
(defun C:td1 ()
(vl-load-com)
(setq d (vlax-ename->vla-object (car (entsel))))

(cond

((=(vla-get-ObjectName d) "AcDbPolyline")
(progn
(while (setq e (getpoint))
(setq e (vlax-curve-getClosestPointTo d e))
(setq param (vlax-curve-getParamAtPoint d e))
(setq param (+ (fix param) 1))
(setq e (vl-remove (last e) e))
(vlax-invoke d 'AddVertex Param e)
)))



((=(vla-get-ObjectName d) "AcDb3dPolyline")
(progn
(while (setq e (getpoint))
(setq endparam (vlax-curve-getEndParam d))
(setq dsparam nil)
(while (>= endparam 0)
(setq dsparam (append dsparam (list endparam)))
(setq endparam (1- endparam))
)
(setq e (vlax-curve-getClosestPointTo d e))
(setq param (vlax-curve-getParamAtPoint d e))
(setq dsparam (append dsparam (list param)))
(setq dsparam (vl-sort dsparam '>))
(setq dspoint nil)
(foreach tam dsparam
(setq e (vlax-curve-getPointAtParam d tam))
(setq dspoint (append e dspoint))
);foreach
(vlax-put d 'coordinates dspoint)
)))



((=(vla-get-ObjectName d) "AcDbSpline")
(progn
(while (setq e (getpoint))
(setq e (vlax-curve-getClosestPointTo d e))
(setq dsfit (vlax-get d 'fitpoints))
(setq dsfit2 nil)
(while dsfit
(setq dsfit2 (cons (list (car dsfit) (cadr dsfit) (caddr dsfit)) dsfit2))
(setq dsfit (cdddr dsfit))
)
(setq dsparam (mapcar '(lambda (a) (vlax-curve-getparamatpoint d a)) dsfit2))
(setq dsparam (cons (vlax-curve-getparamatpoint d e) dsparam))
(setq dsparam (vl-sort dsparam '>))
(setq n (length (member (vlax-curve-getparamatpoint d e) dsparam)))
(vlax-invoke-method d 'addfitpoint (- n 1) (vlax-3d-point e))
)))
(t nil)
);cond
)

dùng cho polyline, 3dpolyline, spline


<<

Filename: 431490_td1.lsp
Tác giả: Phiphi-
Bài viết gốc: 96083
Tên lệnh: ls2f
Viết lisp theo yêu cầu [phần 2]

Vậy thì xuất lqua Excel luôn. Phiphi hãy thử code này :

(defun c:LS2F (/ fname tbl_lst); Layer and Status to File
;;  By : Tue_NV, tue_nvcc@yahoo.com
 (vl-load-com)
 (setq...
>>
Vậy thì xuất lqua Excel luôn. Phiphi hãy thử code này :

(defun c:LS2F (/ fname tbl_lst); Layer and Status to File
;;  By : Tue_NV, tue_nvcc@yahoo.com
 (vl-load-com)
 (setq doc (vla-get-activedocument (vlax-get-acad-object))
La (vla-get-layers doc) i -1 tbl_lst '())
 (vlax-for ob La
   	(setq tbl_lst (append tbl_lst (list
		      (list (vla-get-name ob)
			    (status(vla-get-layeron ob))
			    (status(vla-get-freeze ob))
			    (status(vla-get-lock ob)) )) ))
 )
   (if (setq fName (getfiled "Ten file xuat Layer" (getvar "dwgprefix") "xls" 1))
   (progn
     (setq fName (open fName "a"))
     	(write-line (strcat "Danh sach Layer trong file : " (getvar"dwgname"))fName)
  	(write-line "Name\tLAYON\tFreeze\tLOCK" fname)
     (foreach pt (vl-sort tbl_lst '(lambda (x y) (< (car x) (car y))))
(write-line (strcat (nth 0 pt) "\t" (nth 1 pt) "\t"
		    (nth 2 pt) "\t" (nth 3 pt)) fName)
     )
     (close fName)))

 (princ)
 )
(defun status(a)
 (if (= a :vlax-true)
   (setq a "ON")
   (setq a "OFF")
 )
)

Cám ơn bác Tue_NV nhưng đoạn code trên hình như còn thiếu đoạn cuối...nên chưa chạy được.

Nhớ Bác check lại nhé.

 

Command: ap

APPLOAD LS2F.lsp successfully loaded.

Command: ; error: bad argument type: numberp: nil

Command:


<<

Filename: 96083_ls2f.lsp
Tác giả: gia_bach
Bài viết gốc: 110501
Tên lệnh: filtertxt
Viết lisp theo yêu cầu [phần 2]
Xin chào các anh chị em!

Hôm nay em muốn nhờ viết một lisp như sau:

Bản vẽ em nhận được (bản vẽ chi tiết phường Đằng Lâm - quận Hải An - thành phố Hải...

>>
Xin chào các anh chị em!

Hôm nay em muốn nhờ viết một lisp như sau:

Bản vẽ em nhận được (bản vẽ chi tiết phường Đằng Lâm - quận Hải An - thành phố Hải Phòng) không hiểu vì sao xuất hiện rất nhiều text có cùng nội dung "UBND" và "phường Đằng Lâm" như hình minh họa sau:

 

ubnd.jpg

.................

Vậy có cách nào tìm các đối tượng theo 2 điều kiện của cả text "UBND" và text "phường Đằng Lâm" (dùng lệnh fi cho cả 2 text này không được).

Xin gửi kèm file mô tả

Nhờ mọi người giải đáp giùm! Xin chân thành cảm ơn!

Chào svba1608

Bạn thử chạy LISP filterTxt .

Kết quả sẽ lọc các cặp TEXT "UBND" và "Phường Đằng Lâm" ra Layer có tên LayerFilter.

(defun c:filterTxt (/ ent ent1 i p1 p2 ss ss1 text1 text2)
 (if (not(tblsearch "layer" "LayerFilter") )    
   (command "-layer" "n" "LayerFilter" "") )
 (setq	text1 "UBND"
text2 "Ph??ng §?ng L?m")  
 (setq	ss (ssget (list '(0 . "Text") (cons 1 text1) (cons 8 "TT_CHU") (cons 40 0.7)))
i -1 )
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq p1 (cdr (assoc 10 (entget ent)))
  p2 (polar p1 -1.4 1.6))
   (if (and
  (setq ss1 (ssget "c" p1 p2 (list(cons 0  "Text") (cons 1 text2) (cons 8 "TT_CHU") (cons 40 0.7))))
  (=(sslength ss1) 1))
     (progn
(setq ent1 (ssname ss1 0))
(entmod (subst (cons 8 "LayerFilter") (assoc 8 (entget ent)) (entget ent)))
(entmod (subst (cons 8 "LayerFilter") (assoc 8 (entget ent1)) (entget ent1)))	)  ))
 (princ))


<<

Filename: 110501_filtertxt.lsp
Tác giả: bebicualo
Bài viết gốc: 404628
Tên lệnh: tinh
lisp cộng trừ nhân chia text

Cái này bổ sung thêm phần ghi kết quả vào 1 text có sẵn .

 

(defun c:tinh()
(vl-load-com)
(initget 1 "+ - *...
>>

Cái này bổ sung thêm phần ghi kết quả vào 1 text có sẵn .

 

(defun c:tinh()
(vl-load-com)
(initget 1 "+ - * /")
(setq ptinh (getkword "Chon phep tinh <+ - * />: "))

(cond ((= ptinh "+") ;;; cong
(prompt "\nChon text de cong:")
(setq ss (ssget '((0 . "TEXT")))
kqua 0)
(while (and ss (> (sslength ss) 0))
(setq kqua (+ kqua (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))
(ssdel ent ss))
(princ kqua))

((= ptinh "*") ;;;nhan
(prompt "\nChon text de nhan:")
(setq ss (ssget '((0 . "TEXT")))
kqua 1)
(while (and ss (> (sslength ss) 0))
(setq kqua (* kqua (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))
(ssdel ent ss))
(princ kqua))

((= ptinh "-") ;;;tru
(setq sobitru (car (entsel "\nChon so bi tru:"))
sotru (car (entsel "\nChon so tru:\n"))
kqua (- (atof (cdr (assoc 1 (entget sobitru))))
(atof (cdr (assoc 1 (entget sotru))))))
(princ kqua))

((= ptinh "/") ;;;chia
(setq sobichia (car (entsel "\nChon so bi chia:"))
sochia (car (entsel "\nChon so chia:\n"))
kqua (/ (atof (cdr (assoc 1 (entget sobichia))))
(atof (cdr (assoc 1 (entget sochia))))))
(princ kqua))
)
(if (not ssle) (setq ssle 0))
(setq obj (vlax-ename->vla-object (car (entsel "\nChon text de ghi ket qua:")))
ssle1 (getint (strcat "\nSo so le <" (itoa ssle) ">: ")))
(if ssle1 (setq ssle ssle1))
(vla-put-TextString obj (rtos kqua 2 ssle))
(princ)
)

Cái này tốt rồi nhưng bạn làm sao để mỗi lần mình làm nhiều lần nó có thể nhớ được thao tác mình làm trc đó làm mặc định được không? Cứ mỗi lần bấm 1 phép tính là cứ phải chọn lại phép tính " cộng, trừ, nhân, chia" thì hơi bất tiện xíu, thanks


<<

Filename: 404628_tinh.lsp
Tác giả: t031285
Bài viết gốc: 160207
Tên lệnh: bb
Nhờ sửa lisp đếm block

Sửa lại cho bạn :

(Defun c:bb (/ dynm dynp DT STNAME SS SL) 
(setq dynm (getvar "dynmode"))
(setq dynp (getvar "dynprompt"))
(mapcar...
>>

Sửa lại cho bạn :

(Defun c:bb (/ dynm dynp DT STNAME SS SL) 
(setq dynm (getvar "dynmode"))
(setq dynp (getvar "dynprompt"))
(mapcar 'setvar '("dynmode" "dynprompt") '(1 1))
(prompt "\nChon BLOCK mau.")
(setq DT (car (entsel)))
(setq DT (entget DT))
(setq STNAME (cdr (assoc 2 DT)))
(Princ "\nHay chon vung :")
(setq SS (ssget (list (cons 0 "insert")
(cons 2 STNAME)
)
) 
)
(if (Null ss)
(princ "\nKhong tim thay doi tuong nao")
)
(IF (/= NIL SS) (PROGN
(setq Sl (SSLength SS))
(getstring (strcat "\nTim thay: <" (itoa sl) "> doi tuong la BLOCK co ten: <" STNAME ">"))
)
)
(princ)
(mapcar 'setvar '("dynmode" "dynprompt") ( list dynm dynp))
)

 

 

Bạn Nên set và trả lại biến hệ thống DYNMODE và DYNPROMPT trong Lisp

Nhờ bác chỉnh sao cho CHỌN BLOCK MẪU và HÃY CHỌN VÙNG hiện lên màn hình luôn giùm e với.Thanks.


<<

Filename: 160207_bb.lsp
Tác giả: vanhuyou
Bài viết gốc: 405771
Tên lệnh: tinh
lisp cộng trừ nhân chia text

 

Bạn thử cái này xem sao.

Đối với phép + và * bạn có thể chọn 1 lúc nhiều số, còn - và / thì chỉ có 2 số...

>>

 

Bạn thử cái này xem sao.

Đối với phép + và * bạn có thể chọn 1 lúc nhiều số, còn - và / thì chỉ có 2 số thôi.

 

 

(defun c:tinh()
  (initget 1 "+ - * /")
  (setq ptinh (getkword "Chon phep tinh : "))
  
  (cond ((= ptinh "+")  ;;; cong
	 (prompt "\nChon text de cong:")
	 (setq ss (ssget '((0 . "TEXT")))
	       tong 0)
	 (while (and ss (> (sslength ss) 0))
	   (setq tong (+ tong (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))
	   (ssdel ent ss))
	 (princ tong))
	
	((= ptinh "*")  ;;;nhan
	 (prompt "\nChon text de nhan:")
	 (setq ss (ssget '((0 . "TEXT")))
	       tong 1)
	 (while (and ss (> (sslength ss) 0))
	   (setq tong (* tong (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))
	   (ssdel ent ss))
	 (princ tong))

	((= ptinh "-")  ;;;tru
	 (setq sobitru (car (entsel "\nChon so bi tru:"))
	       sotru (car (entsel "\nChon so tru:\n"))
	       kq (- (atof (cdr (assoc 1 (entget sobitru))))
		     (atof (cdr (assoc 1 (entget sotru))))))	  
	 (princ kq))

	((= ptinh "/")  ;;;chia
	 (setq sobichia (car (entsel "\nChon so bi chia:"))
	       sochia (car (entsel "\nChon so chia:\n"))
	       kq (/ (atof (cdr (assoc 1 (entget sobichia))))
		     (atof (cdr (assoc 1 (entget sochia))))))	  
	 (princ kq))	
  )  
  (princ)	       
)

<<

Filename: 405771_tinh.lsp
Tác giả: PrettyBoy_231988
Bài viết gốc: 306669
Tên lệnh: coo
Nhờ các anh chị giúp 1 đoạn LISP!

 

Bạn thử cái này. Tôi chỉ sửa hàm xulytext thôi , còn chỗ khác để nguyên.

 

(defun ketthuc ()
 ...
>>

 

Bạn thử cái này. Tôi chỉ sửa hàm xulytext thôi , còn chỗ khác để nguyên.

 

(defun ketthuc ()
  (setvar "cmdecho" luuecho)
  (setq *error* luu
luu nil
luuecho nil
  ) 
  (princ)
)
 
(defun modau ()
  (setq luu *error
luuecho (getvar "cmdecho")
*error (ketthuc)
  )
)
 
(defun xulytext (text / sokt  )
  (setq sokt (last (read (strcat "(" (vl-list->string (mapcar '(lambda(x) (if (or (< x 48) (> x 57)) 32 x)) (vl-string->list text))) ")")))
luusokt (1+ sokt))  
  (if (> luusokt 1000)
    (setq luusokt 1)
  )
  (setq text (vl-string-subst (rtos luusokt 2 0) (rtos sokt 2 0) text ))
)
 
(defun doitext (tendoituong     /       chuoi doituong
thoat   tam     dsach     kieu text
vitri10   vitri11   dem       canle
      )
 
  (setq doituong (entget tendoituong)
kieu  (cdr (assoc 0 doituong))
canle  (cdr (assoc 72 doituong))
  )
  (if (or (= kieu "TEXT")
 (= kieu "MTEXT")
      )
    (progn
      (setq textxl  (xulytext textxl)
   text    (cons 1 textxl)
   vitri10 (cdr (assoc 10 doituong))
   vitri10 (list (+ (car vitri10) (car vitrilech))
 (+ (nth 1 vitri10) (nth 1 vitrilech))
   )
   vitri10 (cons 10 vitri10)
   vitri11 (cdr (assoc 11 doituong))
   vitri11 (list (+ (car vitri11) (car vitrilech))
 (+ (nth 1 vitri11) (nth 1 vitrilech))
   )
   vitri11 (cons 11 vitri11)
   dem     0
   dsach   nil
      )
      (foreach tam doituong
(cond
 ((= (car tam) 1) (setq dsach (append dsach (list text))))
 ((= (car tam) 10)
  (setq dsach (append dsach (list vitri10)))
 )
 ((= (car tam) 11)
  (setq dsach (append dsach (list vitri11)))
 )
 ((setq dsach (append dsach (list tam))))
)
      )
      (entmake dsach)
    ) ;progn
  ) ;if
) ;
;*********************************************************************
;sao doi tuong cu sang vi tri moi
 
(defun copy_dt (tendoituong)
  (command "copy" tendoituong "" goc toi)
) ;defun
 
;*********************************************************************
(defun c:coo (/ cumdt dodai thoat dem ten doituong textxl dem goc toi)
; Khoi dau cua chuong trinh
  (princ "\nCopy Inteligent...\n")
  (setq luuecho (getvar "cmdecho")
luu *error*
*error* ketthuc
cumdt (ssget)
dodai (sslength cumdt)
goc (getpoint "\nSelect base point:")
thoat nil
dem 0
textxl nil
  ) ;
  (setvar "cmdecho" 0)
; Loc ra duoc ong text de xu ly
  (while (and (= thoat nil)
     (< dem dodai)
)
    (setq ten    (ssname cumdt dem)
 dem    (1+ dem)
 doituong (entget ten)
 kieu    (cdr (assoc 0 doituong))
    )
 
    (if (or (= kieu "TEXT")
   (= kieu "MTEXT")
)
      (setq thoat  T
   textxl (cdr (assoc 1 doituong))
      )
    )
  ) ;
  (while T
    (setq toi     (getpoint "\nSelect next point: " goc)
 vitrilech (list (- (car toi) (car goc))
 (- (nth 1 toi) (nth 1 goc))
   )
 dem     0
    )
    (while (< dem dodai)
      (setq ten      (ssname cumdt dem)
   dem      (1+ dem)
   doituong (entget ten)
   kieu     (cdr (assoc 0 doituong))
      )
 
      (if (or (= kieu "TEXT")
     (= kieu "MTEXT")
 )
(doitext ten)
(copy_dt ten)
 
      ) ;if
    )
  ) ;while
  (ketthuc)
) ;defun
(princ "Type \"DG\" to start")

Đúng như ý mình , Thank you !


<<

Filename: 306669_coo.lsp
Tác giả: 18011985
Bài viết gốc: 123353
Tên lệnh: trai giua phai
Căn lề text + Mtext, Căn lề đối tượng
Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật...
>>
Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật Bổn, mót được cái này,e liền làm thử bài đánh giá, thấy tốc độ khá tốt, các bác thử chém gió xem sao, và vì code dài nên e cũng chẳng hiểu tại sao ^^

 

Mạn phép bác Thái,E xin post lại lisp ft của bác, thêm dòng check time :

 

(defun c:ft()
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq ollay (getvar "Clayer"))
(setq olstyle (getvar "textstyle"))
(setq TB  (textbox mau) LC  (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq h (cdr(assoc 40 mau)))
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))
(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le <" canle ">"))) (canle)))
(setq oldang (getvar "Angbase"))
(command "angbase" 0 "ucs" "w")

(setq time (getvar "MILLISECS"))

(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" 0 txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "angbase" oldang)
(setvar "Clayer" ollay)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")

(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))

(prompt"\nText da duoc sap xep lai\n")
(command "undo" "end")
);defun

 

Bên dưới là code khác,dài hơn,cũng với chức năng tương tự (và đổi Insert point của text) :


(defun c:trai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Left and align to Left")					
(setq Value72_73_71  '(0 0 7))
(setq AssocL '(10 10))
(Procedure)
(princ)
)

(defun c:giua ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Center and align to Center")							
(setq Value72_73_71 '(1 0 8))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

(defun c:phai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)
(princ "\n Change Insetion point to Right and align to Right")							

(setq Value72_73_71 '(2 0 9))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

;***************************************************
(defun Procedure ()
(while (= ObjSet nil)
	(setq ObjSet (ssget '((-4 . ""))))
)
(setq ObjName0 (car (entsel "\n")))	
(setq i 0)
(setq time (getvar "MILLISECS"))
(repeat (sslength ObjSet)
	(setq ObjName (ssname ObjSet i))
	(setq Data (entget	ObjName))
	(cond 	((= (cdr(assoc 0 Data)) "TEXT")
				(TextInsP_Text ObjName Value72_73_71)	
				(setq Co (car AssocL))
			)
			(	(= (cdr(assoc 0 Data)) "MTEXT")		
				(TextInsP_MText ObjName Value72_73_71)	
				(setq Co (cadr AssocL))
			)
	)
	(setq i (1+ i))
)


(setq Data0 (entget ObjName0))
(setq Ang1 (angle '(0 0) (getvar "UCSXDIR")))
(cond 	((= (cdr(assoc 0 Data0)) "TEXT")
		(setq AngT (cdr(assoc 50 Data0)))				
		(setq Ang2 (- AngT Ang1))					
		(setq Co (car AssocL))
		)
		((= (cdr(assoc 0 Data0)) "MTEXT")
		(setq Ang2 (cdr(assoc 50 Data0)))			
		(setq AngT (+ Ang1 Ang2))					
		(setq Co (cadr AssocL))
		)
)
(setq Pt0 (cdr (assoc Co Data0)))		
(setq Pt0_U (trans Pt0 0 1))			
(setq Pt0_O (SD1862 Pt0_U Ang2))	

(setq i 0)
(repeat (sslength ObjSet)
	(setq Data (entget (setq ObjName (ssname ObjSet i))))
	(cond 	((= (cdr(assoc 0 Data)) "TEXT")(setq Co (car AssocL)))
			((= (cdr(assoc 0 Data)) "MTEXT")(setq Co (cadr AssocL)))
	)
	(setq Pt1 (cdr (assoc Co Data)))				
	(setq Pt1_U (trans Pt1 0 1))				
	(setq Pt1_O (SD1862 Pt1_U Ang2))		
	(setq Delta_O (- (car Pt0_O) (car Pt1_O)))		
	(setq Delta_U (SD8446 (list Delta_O 0) '(0 0) AngT))	
	(setq Data (subst (cons Co (mapcar '+ Pt1 Delta_U))(assoc Co Data) Data))		
	(entmod Data)
	(setq i (1+ i))
)
(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))	
(princ)
)
(defun TextInsP_Text ( ObjName Value72_73_71 / Data OrgPosition NewPosition Org_11 New_11 )

	(setq Data (entget	ObjName))				
	(setq OrgPosition (cdr (assoc 10 Data)))		
	(setq Org_11 (cdr (assoc 11 Data)))			,0,0j
	(setq Data (subst (cons 72 (car Value72_73_71)) (assoc 72 Data) Data))
	(setq Data (subst (cons 73 (cadr Value72_73_71)) (assoc 73 Data) Data))
	(entmod Data)

	(setq NewPosition (cdr (assoc 10 (entget  ObjName))))	
	(setq Delta (mapcar '- OrgPosition NewPosition))				
	(setq New_11 (mapcar '+ Org_11 Delta))		
	(setq Data (entget	ObjName))					
	(setq Data (subst (cons 11 New_11) (assoc 11 Data)	Data))	
	(entmod Data)
)
(defun TextInsP_MText ( ObjName Value72_73_71 / Data X_Old X_New Y_Old Y_New Scale Base0 W_42 Ang_50 Delta )
	(setq Data (entget	ObjName))
	(setq InsP (cdr (assoc 10 Data)))
	(setq W_42	(cdr (assoc 42 (entget ObjName))))
	(setq H_43	 	(cdr (assoc 43 (entget ObjName))))
	(setq Ang (cdr (assoc 50 Data)))		
	(setq AngU (angle '(0 0) (getvar "UCSXDIR")))	
	(setq OldIP (cdr (assoc 71 Data)))			
	(setq NewIP (caddr Value72_73_71))		

	(setq Data (subst (cons 71 NewIP) (assoc 71 Data) Data))
	(entmod Data)


	(setq X_Old (- (+ OldIP 2) (* (fix ( / (+ OldIP 2) 3)) 3)))
	(setq X_New (- (+ NewIP 2) (* (fix ( / (+ NewIP 2) 3)) 3)))


	(setq Y_Old (fix ( / (- OldIP 1) 3)))
	(setq Y_New (fix ( / (- NewIP 1) 3)))

	(setq IncUnit (list (- X_New X_Old)(- Y_Old Y_New )))
	(setq Delta (mapcar '* IncUnit (list (* 0.5 W_42)(* 0.5 H_43))))

	(setq Delta (SD8446 Delta '(0 0) Ang))

·
	(setq Delta (SD1862 Delta (* -1.0 AngU)))

	(setq Data (subst (cons 10 (mapcar '+ InsP Delta))(assoc 10 Data) Data))
	(entmod Data)

)

(defun SD1862 (OldPt Ang / NewCs)
(setq NewCs (SD8446 '(1 0) '(0 0) Ang))
(setq NewPt (trans OldPt 0 NewCs))
(setq NewPt (list (nth 2 NewPt)(nth 0 NewPt)))
NewPt
)

(defun SD8446 ( PointA PointB Ang / XA YA XB YB PointC)
(setq	XA2(- (car PointA) (car PointB))
		YA2(- (cadr PointA) (cadr PointB))
)
(setq PointC (list (- (* XA2 (cos Ang))(* YA2 (sin Ang))) (+ (* XA2 (sin Ang))(* YA2 (cos Ang)))))
(setq PointC (mapcar '+ PointC PointB))
PointC
)

 

Tiếp theo, thực hiện test so sánh :

Lần 1: với 100 text và sắp xếp bên trái :

 

-> gần như là ngay tức thì

 

Lần 2, e chơi sang làm hẳn 1000 text + Mtext đi .Lần này thì :

 

- > :undecided:

 

Vậy là tương quan,2 lisp chênh nhau về thời gian xử lý khoảng 50 lần.Tất nhiên, ngoài thực tế ít khi ta gặp 1 đoạn văn bản CAD dài như vậy, nhưng nhiều khi, 1 vấn đề đã cũ,mà vẫn có nhiều lựa chọn giải quyết.

 

PS :Còn đoạn code FIT + code sắp xếp Đối tượng cũng khù khoằm như vậy,tí rỗi e post típ ^^

 

P/S 2 : hình như 4room lại trục trặc, e post file lisp đây

Lisp

hì hì các bác cho em tham gia thử với http://www.cadviet.com/forum/index.php?showtopic=24188


<<

Filename: 123353_trai_giua_phai.lsp
Tác giả: tomboy
Bài viết gốc: 111721
Tên lệnh: tdd
Viết lisp theo yêu cầu [phần 2]
Chào Bác Bình, Chào bạn hdt4151!!

Mình nói thì là nói vậy thôi chứ thực ra mình vẫn tiếp tục nghiên cứu tiếp yêu cầu của bạn.

Cuối cùng thì cũng có...

>>
Chào Bác Bình, Chào bạn hdt4151!!

Mình nói thì là nói vậy thôi chứ thực ra mình vẫn tiếp tục nghiên cứu tiếp yêu cầu của bạn.

Cuối cùng thì cũng có giải pháp cho bạn. Đúng với mọi trường hợp dùng line và pline thẳng.

Bác Bình thử xem code rất đơn giản mà mình không nghĩ ra sớm. Code này đang bị chậm phần repeat do chưa biết đặt điều kiện gì cho hợp lý.

Bạn hdt4151 và các bác test thử code rồi cho ý kiến.


(defun pro ()
(setq ss (ssget "x" '((0 . "line,lwpolyline"))))
(repeat (sslength ss)
(setq i 0)
(while (< i (sslength ss))
(setq name (ssname ss i)
ent (entget name)
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent))
j 0
)
(while (< j (sslength ss))
(setq name1 (ssname ss j)
ent1 (entget name1)
p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1))
giao (inters p1 p2 p3 p4 T)
)
(if (not (eq name name1))
(progn
(if (and (/= giao nil) (not (equal giao p1 0.01)) (not (equal giao p2 0.01)) 
          (not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (or (equal giao p1 0.01) (equal giao p2 0.01)) 
          (not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(setq ss (ssget "x" '((0 . "*line"))))
)
(command "region" ss "")
(setq ss (ssget "x" '((0 . "region"))))
(setq i 0)
(setq list_pl (ssadd))
(while (< i (sslength ss))
(setq reg (ssname ss i))
(command "explode" reg)
(setq plp (ssget "p"))
(command "pedit" "l" "" "j" plp "" "")
(setq boun (entlast))
(setq list_pl (ssadd boun list_pl))
(setq i (1+ i))
)
)

(defun c:tdd ()
(command "undo" "be")
(pro)
(setq dlst (list (strcat "X" "\t" "\t" "Y" "\n"))
oldos (getvar "osmode")
pg (getvar "ucsorg")
file (strcat (getvar "DWGPREFIX") (substr (getvar "DWGNAME") 1 
              (- (strlen (getvar "DWGNAME")) 4)) ".txt")
pw (getpoint "\n Chon goc toa do ")
k 0 id 1
ptlst nil
dlst1 nil
)
(setvar "osmode" 0)
(if (= pw nil) (setq pW (list 0 0 0)))
(setq p 0)
(while (< p (sslength list_pl))
(setq name (ssname list_pl p) 
i 0
ptlst nil
obj (vlax-ename->vla-object name)
dlst1 (append (list (strcat "hinh thu: " (rtos id 2 0))) dlst1))
(while (/= (vlax-curve-getPointAtParam obj (1+ i)) nil)
(setq p1 (vlax-curve-getPointAtParam obj i))
(setq dlst1 (append (list (strcat (rtos (- (car p1) (car pw) (car pg)) 2 3) 
"\t"
"\t"
(rtos (- (cadr p1) (cadr pw) (cadr pg)) 2 3)
)
)
dlst1))
(setq ptlst (append (list p1) ptlst))
(setq i (1+ i))
)
(if (/= (ssget "WP" ptlst) nil)
(progn 
(command "erase" name "")
(setq id (1- id))
(repeat (+ i 2)
(setq dlst1 (cdr dlst1))
)
)
)
(setq p (1+ p))
(setq dlst1 (append (list "\n") dlst1))
(setq dlst (append dlst1 dlst))
(setq dlst1 nil)
(setq id (1+ id))
)
(setq dlst (reverse dlst))
(setq opw (open file "w"))
(foreach n dlst (write-line n opw))
(close opw)
(setvar "osmode" oldos)
(command "undo" "e")
)

Chào bạn phamngoctukts mình đã nghiên cứu kỹ lip của bạn rồi, bạn viết ngắn gọn rất hay, nhưng mình thấy bạn còn thiếu 1 điều kiện nữa đấy, thực ra bạn sử dụng Command Region cho một tập hợp chọn thì nó sẽ sinh ra rất nhiều đa giác đấy, nếu như vậy bạn phải thêm 1 đoạn mã để lọc các đa giác thừa ra nữa, để lọc được đa giác thừa thì phức tạp đây và nó sẽ làm cho chương trình của bạn kồng kềnh hơn nhiều. Cái thứ hai nữa theo mình nghĩ bạn không nên để chế độ bắt đối tượng một cách tự động được mà phải làm thủ công thì hay hơn vì nhiều khi bản vẽ lớn sẽ làm cho chương trình của ban chạy chậm, mình chạy thử của bạn rồi, bản vẽ của mình có tổng cộng 451 line thế mà mình không kiên nhẫn đợi nó chạy xong được. Cái thứ 3 là bạn nên thêm 1 dòng thông báo cho người dùng biết chương trình đã chạy xong và kết quả được lưu ở đâu. Bạn tiếp tục hoàn chỉnh đi nhé.Chúc bạn vui.


<<

Filename: 111721_tdd.lsp
Tác giả: tuanlongtl
Bài viết gốc: 40330
Tên lệnh: cot00 dc
Đánh cốt tự động bằng lisp DC
Bạn đã bao giờ mệt vì phải tính toán để đánh cốt cao độ của mặt cắt và mặt đứng hay chưa?

vừa phải tính xem từ điểm cần tính đến cốt 0.00 có khoảng...

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

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

 

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

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

 

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

 

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

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

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

 

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

 

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

Cảm ơn.

trong kiến trúc các bạn dùng cos 0.00 làm mức so sánh. Nhưng trong giao thông và thuỷ lợi thì không dùng như thế.Theo tôi hiểu thì trong lsp của anh khi đánh lệnh cot00 thì nó hiểu điểm đó là cao độ 0.00. Khi đánh lệnh dc thì nó sẽ cộng khoảng cách theo phương đứng với 0.00? Anh có cách nào để thay cos 0.00 bằng cos bất kỳ không? Sau đó khi dùng lệnh dc thì nó sẽ cộng từ cos bất kỳ đó chứ không phải là cộng với 0.00?


<<

Filename: 40330_cot00_dc.lsp
Tác giả: ketxu
Bài viết gốc: 431613
Tên lệnh: sum
Xin Lisp cộng Text

Quick code khỏi quên ^^

(defun c:sum(/ s e i z)
(setq     s     (ssget '((0 . "*TEXT")))
        s    (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
        z    0
)
(or *ssl* (setq *ssl* 2))
(setq *ssl* (cond ((getint (strcat "S\U+1ED1 s\U+1ED1 l\U+1EBB <" (itoa *ssl*) ">:")))(*ssl*)))
(while (not (setq e (ssget "_+.:E:S" '((0 . "*TEXT"))))))
(vlax-map-collection s
    '(lambda(x)
  ...
>>

Quick code khỏi quên ^^

(defun c:sum(/ s e i z)
(setq     s     (ssget '((0 . "*TEXT")))
        s    (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
        z    0
)
(or *ssl* (setq *ssl* 2))
(setq *ssl* (cond ((getint (strcat "S\U+1ED1 s\U+1ED1 l\U+1EBB <" (itoa *ssl*) ">:")))(*ssl*)))
(while (not (setq e (ssget "_+.:E:S" '((0 . "*TEXT"))))))
(vlax-map-collection s
    '(lambda(x)
        (and 
            (setq i (distof (vla-get-textstring x)))
            (setq z (+ z i))
            (vla-delete x)
        )
    )
)
(vla-delete s)
(if (not (zerop z))(vla-put-textstring (vlax-ename->vla-object (ssname e 0)) (rtos z 2 *ssl*)))
)
(vl-load-com)


<<

Filename: 431613_sum.lsp
Tác giả: Kieu Tan
Bài viết gốc: 406493
Tên lệnh: tkt1
Không Thống Kê Được Text Và Mtext Có Font Tiếng Việt
(defun c:tkt1 (/ make-Text hei lst pt ss str sty)

(defun make-Text (pt hgt str sty)

(entmakex (list (cons 0...
>>
(defun c:tkt1 (/ make-Text hei lst pt ss str sty)

(defun make-Text (pt hgt str sty)

(entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))

(and (vl-load-com)

(princ "\nQuet chon Text, Mtext de thong ke...!")

(setq ss (ssget (list (cons 0 "*TEXT"))))

(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))

(setq str (LM:UnFormat (cdr (assoc 1 (entget e))) nil)

hei (cdr (assoc 40 (entget e))))

(if (not (assoc str lst))

(setq lst (cons (cons str (list (cons 1 e))) lst))

(setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))

(setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))

(hei)))

(setq pt (getpoint "\nDiem dat Bang: "))

(foreach e (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))

(make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))

(make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)

(setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))

(princ))



(defun LM:UnFormat (str mtx / _replace rx)
(defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
(if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
(progn (setq str (vl-catch-all-apply
(function
(lambda ()
(vlax-put-property rx 'global actrue)
(vlax-put-property rx 'multiline actrue)
(vlax-put-property rx 'ignorecase acfalse)
(foreach pair '(("\032" . "\\\\\\\\")
(" " . "")
("" . "\\\\(\\\\);]*;|\\\\")
("$1$2/$3" . "()\\\\S(*)(*);")
("$1$2" . "\\\\(\\\\S)|(})|}")
("$1" . "({)|{"))
(setq str (_replace (car pair) (cdr pair) str)))
(if mtx
(_replace "\\\\" "" (_replace "" "(\\\\)|({)|(})" str))
(_replace "" "" str))))))
(vlax-release-object rx)
(if (null (vl-catch-all-error-p str))
str)))) 

Post cái lisp bạn đã sửa lên, tôi sẽ chỉ cho bạn chỗ không đúng theo hướng dẫn.

Hoặc copy cái này rồi chạy và so sánh:

(defun LM:UnFormat  (str mtx / _replace rx)

 (defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))

 (if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))

  (progn (setq str (vl-catch-all-apply

                    (function

                     (lambda ()

                      (vlax-put-property rx 'global actrue)

                      (vlax-put-property rx 'multiline actrue)

                      (vlax-put-property rx 'ignorecase acfalse)

                      (foreach pair  '(("\032" . "\\\\\\\\")

                                       (" " . "\\\\P|\\n|\\t")

                                       ("$1" . "\\\\(\\\\)|\\\\*;|\\\\")

                                       ("$1$2/$3" . "()\\\\S(*)(*);")

                                       ("$1$2" . "\\\\(\\\\S)|(})|}")

                                       ("$1" . "({)|{"))

                       (setq str (_replace (car pair) (cdr pair) str)))

                      (if mtx

                       (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\)|({)|(})" str))

                       (_replace "\\" "\032" str))))))

         (vlax-release-object rx)

         (if (null (vl-catch-all-error-p str))

          str))))

(defun c:tkt  (/ make-Text hei lst pt ss str sty)

 (defun make-Text  (pt hgt str sty)

  (entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))

 (and (vl-load-com)

      (princ "\nQuet chon Text, Mtext de thong ke...!")

      (setq ss (ssget (list (cons 0 "*TEXT"))))

      (foreach e  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))

       (setq str (LM:UnFormat (cdr (assoc 1 (entget e))) nil)

             hei (cdr (assoc 40 (entget e))))

       (if (not (assoc str lst))

        (setq lst (cons (cons str (list (cons 1 e))) lst))

        (setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))

      (setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))

                      (hei)))

      (setq pt (getpoint "\nDiem dat Bang: "))

      (foreach e  (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))

       (make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))

       (make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)

       (setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))

 (princ))

Coppy cái của bạn về cũng không ổn

Và cái của mình đây và nó cũng không được luôn:

 

(defun c:tkt1 (/ make-Text hei lst pt ss str sty)
 
(defun make-Text (pt hgt str sty)
 
(entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))
 
(and (vl-load-com)
 
(princ "\nQuet chon Text, Mtext de thong ke...!")
 
(setq ss (ssget (list (cons 0 "*TEXT"))))
 
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
 
(setq str (LM:UnFormat (cdr (assoc 1 (entget e))) nil)
 
hei (cdr (assoc 40 (entget e))))
 
(if (not (assoc str lst))
 
(setq lst (cons (cons str (list (cons 1 e))) lst))
 
(setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))
 
(setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))
 
(hei)))
 
(setq pt (getpoint "\nDiem dat Bang: "))
 
(foreach e (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))
 
(make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))
 
(make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)
 
(setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))
 
(princ))
 
 
 
(defun LM:UnFormat (str mtx / _replace rx)
(defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
(if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
(progn (setq str (vl-catch-all-apply
(function
(lambda ()
(vlax-put-property rx 'global actrue)
(vlax-put-property rx 'multiline actrue)
(vlax-put-property rx 'ignorecase acfalse)
(foreach pair '(("\032" . "\\\\\\\\")
(" " . "")
("" . "\\\\(\\\\);]*;|\\\\")
("$1$2/$3" . "()\\\\S(*)(*);")
("$1$2" . "\\\\(\\\\S)|(})|}")
("$1" . "({)|{"))
(setq str (_replace (car pair) (cdr pair) str)))
(if mtx
(_replace "\\\\" "" (_replace "" "(\\\\)|({)|(})" str))
(_replace "" "" str))))))
(vlax-release-object rx)
(if (null (vl-catch-all-error-p str))
str))))

<<

Filename: 406493_tkt1.lsp

Trang 281/330

281