Jump to content
InfoFile
Tác giả: Tue_NV
Bài viết gốc: 164317
Tên lệnh: cen
Lisp xác định tâm của 1 hình bất kỳ

(defun centre(dt / cen)
;;copyright by Tue_NV
 (vl-load-com)
 (if (or (= (cdr(assoc 0 (entget dt))) "REGION") 
     	(and (wcmatch (cdr(assoc 0...
>>

(defun centre(dt / cen)
;;copyright by Tue_NV
 (vl-load-com)
 (if (or (= (cdr(assoc 0 (entget dt))) "REGION") 
     	(and (wcmatch (cdr(assoc 0 (entget dt))) "*POLYLINE")
      (= (cdr(assoc 70 (entget dt))) 1)
        )
     )
      (if (and (wcmatch (cdr(assoc 0 (entget dt))) "*POLYLINE")
      (= (cdr(assoc 70 (entget dt))) 1)
          )
 (Progn
   (setq cen (vlax-get (car (vlax-invoke (vla-get-modelspace (vla-get-activedocument(vlax-get-acad-object)))
     		'addregion (list (vlax-ename->vla-object dt)))) 'Centroid))
   (entdel (entlast))
 )
 (setq cen (vlax-get (vlax-ename->vla-object dt) 'Centroid))
       )

 )    
 cen
)
(defun c:cen() (centre (car(entsel "\n Pick chon doi tuong lay trong tam :"))))

Lisp của bác khi e chạy nó báo Pick chon doi tuong lay trong tam :nil,tiện thể nhờ bác sửa khi xác định của tâm hình bất kỳ nó vẽ 1 point giống như lisp của ketxu luôn giùm e.Thanks.

Sử dụng lệnh Point:

Command: point

Current point modes: PDMODE=0 PDSIZE=0.0000

Specify a point: 'cen-> Gõ 'CEN

Pick chon doi tuong lay trong tam : -> Pick vào đối tượng kín

(572196.0 339095.0) -> Đây là trọng tâm

 

-> Lệnh point sẽ vẽ 1 point ngay tại trọng tâm của đối tượng kín -> OK


<<

Filename: 164317_cen.lsp
Tác giả: t031285
Bài viết gốc: 164392
Tên lệnh: tt
Lisp xác định tâm của 1 hình bất kỳ

Ô, ừ nhỉ. Mình dùng hàm con này định lượng cho các hình không kín thấy tạm tạm ổn nên từ trước giờ cứ dùng mà chẳng kiểm tra gì....

>>

Ô, ừ nhỉ. Mình dùng hàm con này định lượng cho các hình không kín thấy tạm tạm ổn nên từ trước giờ cứ dùng mà chẳng kiểm tra gì. Thôi thì bạn dùng tạm thằng này : yêu cầu : các đối tượng phải kín và không phải region. Nếu có gì sai nhờ các bác khác sửa hộ nhé :wub:

(defun c:tt (/ ST:Geom-Center ST:Ss->ListEnt ST:Entmake-Point)
;;;; Local Functions 
(defun ST:Region-Center (ent / rt)
(cond ;((wcmatch (cdadr (entget ent)) "REGION") (setq rt (vlax-get (vlax-ename->vla-object ent)'Centroid)) )
((not (wcmatch (cdadr (entget ent)) "REGION"))  (command "region" ent "")
(setq rt (vlax-get (vlax-ename->vla-object (entlast))'Centroid)) 
(command "undo" ""))
) rt
)
(defun ST:Ss->ListEnt (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
   (setq l (cons e l))
 )  
)
(defun ST:Entmake-Point (pt)(entmakex (list (cons 0 "POINT")(cons 10 pt))))
;;;;Start here :
(vl-load-com)
(prompt "Ch\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng c\U+1EA7n x\U+00E1c \U+0111\U+1ECBnh t\U+00E2m :")
(foreach obj (ST:Ss->ListEnt (ssget)) (ST:Entmake-Point (ST:Region-Center obj))))

Cảm ơn bác,bác thêm cho tính tâm của các đối tượng được chọn luôn giùm e luôn nhe.


<<

Filename: 164392_tt.lsp
Tác giả: quickandfine
Bài viết gốc: 206792
Tên lệnh: clb
lisp chuyển các đối tượng về 1 layer

Hề hề hề,

Dùng thử cái này coi sao nhé


(defun c:clb (/ bls)
(vl-load-com)
(if (not (tblsearch "layer"...
>>

Hề hề hề,

Dùng thử cái này coi sao nhé


(defun c:clb (/ bls)
(vl-load-com)
(if (not (tblsearch "layer" "BLOCK"))
   (command "layer" "m" "Block" "")
)
(alert "\n Chon tap hop cac block muon chuyen layer")
(setq bls (acet-ss-to-list (ssget (list (cons 0 "insert")))))
(foreach b bls
	(cblc B)      
)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun cblc (bl / els a els1)

(setq els (entget bl)
          	els (subst (cons 8 "block") (assoc 8 els) els)
               a (entnext bl)  )
	(entmod els)
	(while (/= (cdr (assoc 0 (entget a))) "SEQEND")
           (if (/= (cdr (assoc 0 (entget a))) "INSERT")
               (progn
                	(setq els1 (entget a)
                         els1 (subst (cons 8 "block") (assoc 8 els1) els1) )
                   (entmod els1)
               )
               (cblc a)
        	)
        	(setq a (entnext a))
     )
)

Chào bác phamthanhbinh.

Em dùng thử đoạn lisp trên thì cũng thấy báo lỗi là:

 

Command: clb

Select objects: 1 found

Select objects: ; error: bad argument type: lentityp nil

 

Bác xem giúp em bị lỗi ở chỗ nào nhé. Với lại em thấy đoạn này cũng đang chỉ chuyển Block về layer "Block" còn các đối tượng trong block đó vẫn là layer "cũ" của nó. Chắc do em diễn đạt chưa được rõ. Em gửi kèm File lên đây bác xem có rõ hơn không và giúp em với nhé!

http://www.cadviet.com/upfiles/3/110072_block_layer_1.dwg


<<

Filename: 206792_clb.lsp
Tác giả: tamkt
Bài viết gốc: 113612
Tên lệnh: tdt
Viết lisp theo yêu cầu [phần 2]
Của bạn đây. Mình làm theo đúng nội dung trong file bạn gửi lên.

(defun c:tdt ()
(vl-load-com)
(setq ss (ssget '((0 . "TEXT,MTEXT"))))
(setq sslist...
>>
Của bạn đây. Mình làm theo đúng nội dung trong file bạn gửi lên.

(defun c:tdt ()
(vl-load-com)
(setq ss (ssget '((0 . "TEXT,MTEXT"))))
(setq sslist (acet-ss-to-list ss))
(setq sslist (vl-sort sslist 
'(lambda (x y)
(and
(= (cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget y)))))
(> (car (cdr (assoc 10 (entget x)))) (car (cdr (assoc 10 (entget y)))))
)
)
)
)
(setq i 0)
(setq sslist (reverse sslist))
(while (< i (length sslist))
(setq ent (entget (nth i sslist)))
(entmod (subst (cons 1 (rtos (1+ i) 2 0)) (assoc 1 ent) ent))
(setq i (1+ i))
)
(setq sy (getstring "Ban cos muon them ky tu vao khong Yes/No:  : "))
(if (or (= sy "y") (= sy ""))
(progn
(setq tt (getstring "ky tu muon them vao: "))
(addsym sslist tt)
)
)
(if (= sy "n") (setq sy nil))
)

(defun addsym (sst sym /)
(foreach n sst
(setq txt (cdr (assoc 1 (entget n))))
(entmod (subst (cons 1 (strcat sym txt)) (assoc 1 (entget n)) (entget n)))
)
)

Quá tuyệt vời luôn anh, anh xử lý quá gọn nhẹ, hihi, thật tuyệt, em cám ơn anh Tú nhiều lắm lắm.


<<

Filename: 113612_tdt.lsp
Tác giả: minhhieuthanh
Bài viết gốc: 300268
Tên lệnh: trichbd
Kính gửi các chuyên gia về lisp

Mình thực hiện trên file của bạn luôn nhé.Lisp này của bác thiệp mà bác thanhduan đã nói.Thực hiện được ý đồ của bạn rồi đó.Bạn...

>>

Mình thực hiện trên file của bạn luôn nhé.Lisp này của bác thiệp mà bác thanhduan đã nói.Thực hiện được ý đồ của bạn rồi đó.Bạn xem video nhé

http://www.youtube.com/watch?v=UnQZYP3eAtU

Mình muốn xin bộ lisp về thiết kế nút của bạn được không.Bạn có thể gửi lên đây hoặc gửi mail cho mình:anhtuan011185@gmail.com.Cảm ơn bạn rất nhiều vì mình cũng đang cần tiện ích này

;;;-----------------------
(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 Text (model str po h ang / obj)
  (setq obj (vla-AddText
   	*Model*
   	str
   	(vlax-3d-point po)
   	h
 	)
  )
  (vla-put-Alignment obj acAlignmentTopCenter)
  (vla-put-TextAlignmentPoint obj (vlax-3d-point po))
)
;;;====================================================================
(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
 	)
	)
	<img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/wink.png' class='bbc_emoticon' alt=';)' />
	(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
 	(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
(progn
   (acet-ui-progress "hoan thanh %" (length masterlist))
   (foreach obj2brk masterlist
 	(break_obj (car obj2brk) (cdr obj2brk))
 	(acet-ui-progress -1)
   )
   (acet-ui-progress)
)
  	)
	)
  )
);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:trichBD (/ ActDoc *Model* ss encur lsten p1 p2 p3 LenssBR lstp objCE)
  (setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object))
*Model* (vla-get-ModelSpace ActDoc)
  )
  (setq bit1 (cond (bit1)
	("Rectangle")
 	)
  )
  (initget "Square Rectangle Circle Ellipse Different")
  (setq tmp (strcat "\nChon duong bao:  <" bit1 ">: ")
bit1	(cond ((getkword tmp))
   	(bit1)
    	)
  )
  (vla-StartUndoMark ActDoc)
  (setvar "cecolor" "104")
  (setq p1 (list (car (getvar "extmin")) (cadr (getvar "extmin"))))
  (cond ((eq bit1 "Square")
  (setq a (cond (a)
     	(50)
   )
  )
  (setq olda a)
  (setq a (getreal (strcat "\nChon kich thuoc canh Square <"
  	(rtos olda 2 1)
  	"> : "
 	)
   )
  )
  (if (null a)
	(setq a olda)
  )
  (setq lstp (list (list (car p1) (cadr p1) 0)
 	(list (+ (car p1) a) (cadr p1) 0)
 	(list (+ (car p1) a) (+ (cadr p1) a) 0)
 	(list (car p1) (+ (cadr p1) a) 0)
 	(list (car p1) (cadr p1) 0)
  	)
  )
)
((eq bit1 "Rectangle")
  (setq a (cond (a)
     	(50)
   )
  )
  (setq olda a)
  (setq a (getreal (strcat "\nChon chieu dai Rectangle <"
  	(rtos olda 2 1)
  	"> : "
 	)
   )
  )
  (if (null a)
	(setq a olda)
  )
  (setq b (cond (<img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />
     	(50)
   )
  )
  (setq oldb <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />
  (setq b (getreal (strcat "\nChon chieu rong Rectangle <"
  	(rtos oldb 2 1)
  	"> : "
 	)
   )
  )
  (if (null <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />
	(setq b oldb)
  )
  (setq lstp (list (list (car p1) (cadr p1) 0)
 	(list (+ (car p1) a) (cadr p1) 0)
 	(list (+ (car p1) a) (+ (cadr p1) <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' /> 0)
 	(list (car p1) (+ (cadr p1) <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' /> 0)
 	(list (car p1) (cadr p1) 0)
  	)
  )
)
((eq bit1 "Circle")
  (setq a (cond (a)
     	(50)
   )
  )
  (setq olda a)
  (setq a (getreal (strcat "\nChon ban kinh Circle <"
  	(rtos olda 2 1)
  	"> : "
 	)
   )
  )
  (if (null a)
	(setq a olda)
  )
  (setq objCE (vla-addCircle *Model* (vlax-3d-point p1) a))
  (setq cir (entlast))
  (setq cv   (* a 2 pi)
    	lstp (list (vlax-curve-getStartPoint cir))
    	d	(/ cv 160)
    	l	0.0
  )
  (repeat 160
	(setq l	(+ l d)
   p	(vlax-curve-getPointAtDist cir l)
   lstp (append lstp (List p))
	)
  )
);end bit1 "Circle"

;;; ((eq bit1 "Ellipse")
;;;  (setq a (getpoint p1 "\nPick diem ban kinh lon cua Ellipse"))
;;;  (vl-cmdf ".Ellipse" pause pause pause); erro ttuc
;;;  (setq objCE (entlast)
;;;  p1 (vlax-curve-getStartPoint objCE))
;;;  (command ".LENGTHEN" objCE "")
;;;  (setq cv   (getvar "perimeter")
;;;    	lstp (list p1)
;;;    	d	(/ cv 160)
;;;    	l	0.0
;;;  )
;;;  (repeat 160
;;;	(setq l	(+ l d)
;;;   p	(vlax-curve-getPointAtDist objCE l)
;;;   lstp (append lstp (List p))
;;;	)
;;;  )
;;; );end bit1 "Ellipse"
;;; ((eq bit1 "Different")
;;;  (prompt "\nchon 1 curve kin:")
;;;  (setq ss (ssget)
;;;    	encur (ssname ss 0)
;;;    	objCE (vlax-ename->vla-object encur)
;;;    	p1 (vlax-curve-getStartPoint encur))
;;;  (if (or (eq (dxf 0 encur) "LWPOLYLINE")
;;;   (eq (dxf 0 encur) "POLYLINE")
;;;  	)
;;;	(setq lstp (acet-geom-VERTEX-LIST encur))
;;;	(progn
;;;  	(command ".LENGTHEN" encur "")
;;;  	(setq cv (getvar "perimeter")
;;; 	lstp (list p1)
;;; 	d (/ cv 160)
;;; 	l 0.0
;;;  	)
;;;  	(repeat 160
;;;    	(setq l   (+ l d)
;;;   	p   (vlax-curve-getPointAtDist encur l)
;;;   	lstp (append lstp (List p))
;;;    	)
;;;  	)
;;;	)
;;;  )
;;;  )
  );end cond
  (vla-ZoomExtents (vlax-get-acad-object))
  (ACET-LWPLINE-MAKE (list lstp))
  (setq ss (ssadd (entlast) (ssadd)))
  (setq p2 (ACET-SS-DRAG-MOVE
  	ss
  	(list (car p1) (cadr p1))
  	"Chon vi tri bat dau trich thua: "
	)
  )
  (command ".move" ss "" p1 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 lsten (vl-remove encur (gettouching encur)))
  (break_with  lsten encur)
  (vlax-invoke-method ActDoc 'Regen acActiveViewport)
  (vla-offset (vlax-ename->vla-object encur) (* (getvar "viewsize") 0.0001))
  (setq lstp (acet-geom-vertex-list (entlast)))
  (entdel (entlast))
  (if (equal (vlax-curve-getEndParam encur) 160 1) (entdel encur))
  (setq LenssBR (SS-enlst (ssget "F" lstp)))
  (mapcar '(lambda (x)
  	(if (or (not (eq (dxf 0 x) "TEXT"))
   	(not (eq (dxf 0 x) "MTEXT"))
   )
    	(entdel x)
  	)
	)
   LenssBR
  )
  (if objCE (vla-move objCE (vlax-3d-point p1) (vlax-3d-point p3)))
  (vla-EndUndoMark ActDoc)
  (princ "\nChuc cac ban gat hai nhieu thanh cong. Thiep")
  (princ)
)

Anh cd2k44 ơi cho em hỏi chút, cái lisp này lệnh là trichbd phải ko ạ? em laod về, ap vô cad mà nó unknown. giúp em với ạ

thanks anh


<<

Filename: 300268_trichbd.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 101476
Tên lệnh: exptxt
export tập điểm text thành file đuôi .txt
lệnh là EXPTXT

(defun c:exptxt()
 (setq
   ss (ssget '((0 . "TEXT")))
   fn (getfiled "Ten file: " "" "txt" 1)
f (open fn "w")
   lst (ss2ent ss)
 )
 (foreach e lst
   ...
>>
lệnh là EXPTXT

(defun c:exptxt()
 (setq
   ss (ssget '((0 . "TEXT")))
   fn (getfiled "Ten file: " "" "txt" 1)
f (open fn "w")
   lst (ss2ent ss)
 )
 (foreach e lst
    (setq tt (entget e)
   p (cdr (assoc 10 tt))
   x (rtos (car p))
   y (rtos (cadr p))
   z (cdr (assoc 1 tt))

    )
    (write-line (strcat x " " y " " z) f)
 )
 (close f)
 (princ)
)

(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)
)

 

Qủa thực lisp này rất hay bác Hoành. Chi có điều em muốn file .txt xuất ra có dạng như sau :

 

TT X Y Z

01 21.3 22.4 0.3

 

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

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

 

Em đã thử sửa code nhưng chưa được. Bác có thể giúp em không ? Cám ơn Bác

Chúc bác luôn khoẻ !


<<

Filename: 101476_exptxt.lsp
Tác giả: bach1212
Bài viết gốc: 192158
Tên lệnh: ytc
Lisp lập bảng các thông số kỹ thuật của đường cong tròn (Dùng cho giao thông)

Mình viết tạm cho bạn thế này thôi. ngại viết code lập bảng lắm.

Khi dùng, Chọn xong đường tròn thì nhấn tiếp Ctrl+V là...

>>

Mình viết tạm cho bạn thế này thôi. ngại viết code lập bảng lắm.

Khi dùng, Chọn xong đường tròn thì nhấn tiếp Ctrl+V là được. Cũng không khác việc lập bảng là mấy..

(defun c:ytc (/ SetClipBoardText ytc-g i a r en ent)
(defun SetClipBoardText (text / htmlfile result ) ; By XShrimp
(if (= 'STR (type text))
(progn
(setq htmlfile (vlax-create-object "htmlfile")
result (vlax-invoke(vlax-get(vlax-get htmlfile'ParentWindow)'ClipBoardData)'SetData "Text" text ))
(vlax-release-object htmlfile) text)))
(defun ytc-g (goc / gd gp gs )
(setq Gd (fix Goc)
Gp (fix (* (- Goc Gd) 60))
Gs (* (- (* (- Goc Gd) 60) Gp) 60))
(strcat (if (< Gd 10) (strcat "0" (rtos Gd 2 0)) (rtos Gd 2 0)) "d"
(if (< Gp 10) (strcat "0" (rtos Gp 2 0)) (rtos Gp 2 0)) "'"
(if (< Gs 9.5) (strcat "0" (rtos Gs 2 0)) (rtos Gs 2 0)) "''"))
(and
(setq i (getint "nhap ten duong cong (nhap so):"))
(setq i (itoa i))
(not (while (not (and (setq en (car (entsel "\n chon duong can lay yeu to cong:\n")))
(wcmatch (cdr (assoc 0 (setq ent (entget en)))) "ARC")))))
(setq a (* (vlax-get-property (vlax-ename->vla-object en) 'TotalAngle) 0.5))
(SetClipBoardText (princ (strcat "A" i " = " (ytc-g (+ (/ (* (- pi a a) 180.) pi) 0.00002))
"\nR" i " = " (rtos (setq R (cdr (assoc 40 ent)))) "m"
"\nT" i " = " (rtos (/ (* R (sin a)) (cos a)) 2 2) "m"
"\nP" i " = " (rtos (- (/ R (cos a)) R) 2 2) "m"
"\nK" i " = " (rtos (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)) 2 2) "m"))))
(princ))

e cám ơn bác. cho e hỏi, làm thế nào để rút bớt số chữ số thập phân sau dấu phẩy của thông số bán kính R khi dùng lisp này từ 4 về 2 con số thui ah?


<<

Filename: 192158_ytc.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 422488
Tên lệnh: ltd
Lisp xuất tọa độ của Polyline trong CAD theo ý mong muốn
10 giờ trước, doantuangt đã nói:

Mình muốn xin lisp xuất tọa...

>>
10 giờ trước, doantuangt đã nói:

Mình muốn xin lisp xuất tọa độ của polyline trong CAD theo thứ tự điểm mình mong muốn. Theo hình đính kèm. Cám ơn nhiều!

image.png.556bbbf3b9ef2b219d1ff89e2fb35654.png

Hàm để lấy tọa độ polyline

(defun laytoado (sset / lsttd toado)
			(setq hnd (car sset))
            (setq ent (entget hnd))
            (setq obj (cdr (assoc 0 ent)))
            (cond
              ((= obj "LWPOLYLINE")
                (foreach rec ent
                  (if (= (car rec) 10)
                    (progn
                      (setq pnt (cdr rec))
                      (setq toado (list (car pnt) (cadr pnt)))
					  (setq lsttd (cons toado lsttd))
					)
                  )
                )
              )
            )
lsttd
)
(defun C:LTD (/ dtpl toadopl)
(setq dtpl (entsel "\nChon pl"))
(setq toadopl (laytoado dtpl))
)

 


<<

Filename: 422488_ltd.lsp
Tác giả: codered8x
Bài viết gốc: 94125
Tên lệnh: batter b1
Lisp rải taluy trên đường cong
Help me. Đây là Lisp dùng để rãi taluy của đường. Nó rất tiện lợi cho việc thể hiện mái dốc của đường đào hoặc đắp, nhưng có một khó khăn với tôi đó là nó...
>>
Help me. Đây là Lisp dùng để rãi taluy của đường. Nó rất tiện lợi cho việc thể hiện mái dốc của đường đào hoặc đắp, nhưng có một khó khăn với tôi đó là nó chỉ rãi được trên đường thẳng và trên đường pline và cung tròn còn trên đường spline thì bó tay.

Xin các Bác chỉnh sửa dùng cho với. Cám ơn trước nghe.

TL1: dùng để rãi trên đường thẳng và pline.

TL2: dùng để rãi trên cung tròn.

http://www.cadviet.com/upfiles/TALUY.lsp

Cái này chỉ vẽ được taluy trên đường line, pline mình thấy không có tác dụng, circle thì thấy yêu cầu lằng nhằng quá mà toàn viết tắt nên chả hiểu(PT1,PT2 là gì?).Ưu điểm là chọn được phía đặt taluy

 

 

--------------------------------

Đây là lisp tôi sưu tầm và chỉnh sửa lại chút ít, có thể rải taluy cho các loại line, pline, spline, arc, circle ...

(Mới dừng ở việc vẽ taluy cho 1 đường, phần vẽ mái taluy giữa 2 đường tôi chưa sửa xong)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;vtl;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun nsl ()
 (if (/= scale nil)
   (progn
     (setq thongbao (strcat "Ty le ban ve ?, <1/" (itoa scale) ">:"))
     (if (not (setq scaletmp (getint thongbao)))
(setq scaletmp scale)
     )
   )
   (progn
     (setq thongbao "Ty le ban ve ? <1/1000>:")
     (if (not (setq scaletmp (getint thongbao)))
(setq scaletmp 1000)
     )
   )
 )

 (setq scale scaletmp)

 (setq Defaultdist (* (* scale 2) 0.002))
 (if (setq tg (getreal	(strcat	"\nKhoang cach ky hieu ta luy <"
			(rtos Defaultdist 2 2)
			">:"
		)
       )
     )
   (setq Defaultdist tg)
 )

 (setq	chieutaluy1
 1
sodoan 0
 )
)

(defun nsl1 ()

 (setq
   ktdoantaluy1 2
   tg		 (getreal (strcat "\nChieu dai doan ngan<"
			  (rtos ktdoantaluy1 2 2)
			  ">:"
		  )
	 )
 )
 (if tg
   (setq ktdoantaluy1 tg)
 )
 (setq
   ktdoantaluy2 6
   tg		 (getreal (strcat "\nChieu dai doan dai<"
			  (rtos ktdoantaluy2 2 2)
			  ">:"
		  )
	 )
 )
 (if tg
   (setq ktdoantaluy2 tg)
 )
 (setq
   khoangcachtl 2
   tg		 (getreal (strcat "\nKhoang cach giua cac doan<"
			  (rtos khoangcachtl 2 2)
			  ">:"
		  )
	 )
 )
 (if tg
   (setq khoangcachtl tg)
 )
 (setq
   sodoanngan 3
   tg	       (getint (strcat "\nSo doan ngan trong 1 doan dai<"
		       (rtos sodoanngan 2 0)
		       ">:"
	       )
       )
 )
 (if tg
   (setq sodoanngan tg)
 )

)
(Defun PlMake (Plist)			;  Create polyline entities
 (entmake '((0 . "POLYLINE")))
 (setq	n  (length Plist)
ic 0
 )
 (while (< ic n)
   (entmake (list (cons 0 "VERTEX") (cons 10 (nth ic Plist))))
   (setq ic (1+ ic)
   )
 )
 (entmake '((0 . "SEQEND")))

)
;;;----------------------------------------------------------------
(defun ve1doantaluy (p1 p2 / pvt diemcu ktdoantaluy ketthuc)
 (setq pvt (+ (angle p1 p2) (* (/ pi 2) chieutaluy)))
 (setq ketthuc 1)
 (if (< sodoan sodoanngan)
   (progn
     (setq ktdoantaluy ktdoantaluy1)
     (setq sodoan (1+ sodoan))
   )
   (progn
     (setq ktdoantaluy ktdoantaluy2)
     (setq sodoan 0)
   )
 )
 (setq p2 (polar p1 pvt ktdoantaluy))
 (plmake (list p1 p2))
 (setq dem (1+ dem))
)

(Defun xddsd (com epl kc / e0 e p dsd)
 (setq e0 (entlast))
 (while e0
   (setq e e0)
   (setq e0 (entnext e0))
 )
 (command com epl kc)
 (setq e (entnext e))
 (while e
   (setq p (cdr (assoc 10 (entget e))))
   (if	p
     (setq dsd (cons p dsd))
   )
   (setq e (entnext e))
 )
 (command "_.Undo" 1)
 (setq dsd dsd)
)
				; ve ta luy cho 1 doi tuong
(Defun vetaluy (ep / le e ketthuc them dsd thutu)
 (setq dem 0)
 (setq e (entget (car ep)))
 (if (or (= (cdr (assoc 0 e)) "LWPOLYLINE")
  (= (cdr (assoc 0 e)) "POLYLINE")
  (= (cdr (assoc 0 e)) "SPLINE")
  (= (cdr (assoc 0 e)) "LINE")
  (= (cdr (assoc 0 e)) "ARC")
  (= (cdr (assoc 0 e)) "CIRCLE")
     )

   (setq ketthuc 1)
   (prompt "\nDoi tuong duoc chon khong hop le")
 )
 (if ketthuc
   (progn
     (setq thutu 0)
     (setq dsd (xddsd "_.Measure" ep khoangcachtl))
     (setq p1 (car dsd))
     (repeat (1- (length dsd))
(setq thutu (1+ thutu))
(setq p2 (nth thutu dsd))
(ve1doantaluy p1 p2)
(setq p1 p2)
     )
   )
 )
 (setq dem dem)
)

;;;==================================================
(Defun C:vtl1 (/ ep chon lai solan chon)

 (setvar "cmdecho" 0)
 (setvar "blipmode" 0)
 (command "undo" "g")
 (nsl)

 (setq ep 1)
 (while ep
   (setq solan	0
  chieutaluy 1
   )
   (setq ep (entsel "\nChon doi tuong ve ta luy..."))

   (if	ep
     (progn
(nsl1)
(setq solan (vetaluy ep))
(initget "Undo Change")
(while
  (setq chon (getkword "Undo/Change : "))
   (if (= chon "Undo")
     (command "_.Undo" solan)
   )
   (if (= chon "Change")
     (progn
       (nsl1)

       (setq chieutaluy -1)
       (command "_.Undo" solan)
       (setq solan (vetaluy ep))

     )
   )

  (initget "Undo Change")
)

     )
   )
 )
 (command "undo" "e")
)

Cái này vẽ được taluy trên cả line,spline,pline và cung tròn.Nhưng nhược điểm là không chọn được chiều đặt taluy.

-----------------------------------------------------------------

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

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




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

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

Cái này phải vẽ 2 đường giới hạn đỉnh và chân của đường vẽ nét taluy, rất bất tiện

 

==>> Túm lại cái của snowman là ngon nhất nhưng làm sao thêm chức năng chọn chiều đặt taluy thì perfect!

 

Hàng về rồi...hihi

 

http://www.cadviet.com/upfiles/VTLW1.lsp

 

Thử nghiên cứu cái này đi.

 

1. Load vào CAD

2. Lệnh TL0 để khai báo tham số

3. Lệnh TL1 để vẽ đường taluy đơn

4. Lệnh TL2 để vẽ đường taluy đôi

Thêm cái này,vẽ pline tốt nhưng cũng k chọn được chiều.


<<

Filename: 94125_batter_b1.lsp
Tác giả: namhai
Bài viết gốc: 74003
Tên lệnh: np
Lisp vẽ nối tiếp đường thẳng?
Tuyệt! Cám ơn anh Hoành nhiều!

Chương trình NP sửa lại đơn giản như sau:

 

(defun C:NP( / p ss e1 e2) ;;;Noi tiep pline
(setq
 p (getpoint "\nChon diem cuoi...
>>
Tuyệt! Cám ơn anh Hoành nhiều!

Chương trình NP sửa lại đơn giản như sau:

 

(defun C:NP( / p ss e1 e2) ;;;Noi tiep pline
(setq
 p (getpoint "\nChon diem cuoi line, pline hoac arc:")
 ss (ssget "c" p p '((0 . "LINE,LWPOLYLINE,ARC")))
 e1 (ssname ss 0)
)
(command "pline" p)
(while (< 0 (getvar "CMDACTIVE")) (command pause))
(setq e2 (entlast))
(if (= (cdr (assoc 0 (entget e1))) "LWPOLYLINE")
 (command "pedit" e1 "j" e2 "" "")
 (command "pedit" e1 "y" "j" e2 "" "")
)
(princ)
)

 

Ssg hỏi thêm anh Hoành cái này nữa. Ssg thường dùng dấu móc nhọn <...> để gán các giá trị mặc định trong các dòng nhắc lệnh. Ví dụ:

mocnhon2.jpg

với hàm ý nếu user không muốn nhập điểm nữa thì Enter để kết thúc vòng lặp. Kiểu này đúng như phong cách của chính AutoCAD. Ví dụ:

Command: OFFSET

Specify offset distance or <5.0000>:

Nếu user Enter sẽ chấp nhận giá trị offset distance trong cặp móc nhọn là 5.0 mà không cần nhập số.

Tuy nhiên, khi cho vào trong codebox của diễn đàn, dấu móc nhọn bị mã hoá khác đi, không giữ được nguyên trạng nữa. Anh Hoành có thể xử lý chỗ này được không?

Tuyệt vời quá!!thanks bác nhiều nha!!


<<

Filename: 74003_np.lsp
Tác giả: emhn
Bài viết gốc: 1262
Tên lệnh: exppnt imppnt
AutoCAD với Excel
Tại trang tin cũng đã có 1 ví dụ về chương trình LISP nhập xuất dữ liệu giữa AutoCAD và Excel.

>>
Tại trang tin cũng đã có 1 ví dụ về chương trình LISP nhập xuất dữ liệu giữa AutoCAD và Excel.

http://www.cadviet.com/content/view/20/1/

 

Đó là chương trình eiPoint (Export Import Point), là chương trình khá đơn giản và cơ bản. Chúng ta có thể cải tiến nó để đáp ứng được từng mục đích riêng của mình.

 

Dưới đây là mã lệnh của chương trình eiPoint (lấy từ trang tin):

(defun c:exppnt	(/ fn fid i sdt tp ent p x y z)
 (princ "\neiPoint © 2007 Cadviet.com")
 (setq
   ssp	(ssget '((0 . "POINT")))
   fn	(getfiled "Ten tep de xuat toa do x y z"
	  (getvar "dwgprefix")
	  "txt"
	  1
)
   i	0
   sdt	(cond (ssp (sslength ssp))
      (t 0)
)
   tp	nil
   fid	(open fn "w")
 )

 (repeat sdt
   (setq ent (ssname ssp i)
  i   (1+ i)
  p   (cdr (assoc 10 (entget ent)))
  x   (car p)
  y   (cadr p)
  z   (caddr p)
   )
   (princ (strcat (rtos x) "\t" (rtos y) "\t" (rtos z) "\n")
   fid
   )
 )
 (close fid)
 (princ)
)

(defun c:imppnt	( / fn fid strht vt x y z)
 (defun pos (sub st / l1 l2 index)
   (setq index	1
  l1	(strlen sub)
  l2	(strlen st)
   )
   (while
     (and (<= (+ index l1 -1) l2) (/= sub (substr st index l1)))
      (setq index (1+ index))
   )
   (if	(= sub (substr st index l1))
     index
     nil
   )
 )
 (princ "\neiPoint © 2007 Cadviet.com")
 (setq	fn  (getfiled "Ten tep de nhap toa do x y z"
	      (getvar "dwgprefix")
	      "txt"
	      2
    )
fid (open fn "r")

 )
 (while (setq strht (read-line fid))
   (setq strht (strcat strht "\t\t\t"))
   (if	(/= strht "   ")
     (progn
(setq
  vt	(pos "\t" strht)
  x	(atof (substr strht 1 (1- vt)))
  strht	(substr strht (1+ vt))
  vt	(pos "\t" strht)
  y	(atof (substr strht 1 (1- vt)))
  strht	(substr strht (1+ vt))
  vt	(pos "\t" strht)
  z	(atof (substr strht 1 (1- vt)))
)
(entmake (list
	   (cons 0 "POINT")
	   (list 10 x y z)
	 )
)
     )
   )
 )
 (close fid)
)
(princ "\neiPoint da duoc nap. su dung 2 lenh: ExpPnt va ImpPnt de xuat va nhap Point")

 

Bản chất của quá trình trao đổi dữ liệu giữa AutoCAD và Excel trong ví dụ trên là tạo ra một tệp có đuôi .txt làm trung gian.

 

 

Trước hết mình xin chân thành cám ơn bạn "nguyen hoanh" vì sự nhiệt tình và sẳn sàng chia sẽ. Nhưng vấn đề là mình muốn làm việc trực tiếp vào các file Excel, không muố nhờ vào tep trung gian (*.txt). Xin bạn vui lòng hương dẫn.


<<

Filename: 1262_exppnt_imppnt.lsp
Tác giả: thanhduan2407
Bài viết gốc: 116286
Tên lệnh: colorx colorxref colorxl colorxrefl
Đổi màu tất cả các đối tượng trên bản vẽ thành một màu duy nhất
Cái lisp này mình sưu tầm được trên mạng đã lâu. Nay thấy bạn có nhu cầu mình port lên bạn xem có vư ý không nhé.

;;; Posted Vladimir...
>>
Cái lisp này mình sưu tầm được trên mạng đã lâu. Nay thấy bạn có nhu cầu mình port lên bạn xem có vư ý không nhé.

;;; Posted Vladimir Azarko (VVA)
;;; 
;;;;http://www.cadtutor.net/forum/showthread.p...=533&page=2
(defun C:COLORX	(/ doc col)
 (vl-load-com)
 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark doc)
 (mip:layer-status-save)
 (if (setq col (acad_colordlg 7 t))
   (ChangeAllObjectsColor doc col) ;_ col — color number
 ) ;_ end of if
 (mip:layer-status-restore)
 (vla-endundomark doc)
 (princ)
) ;_ end of defun
(defun C:COLORXREF (/ doc col)
 (vl-load-com)
 (alert
   "\This lisp change color xref\nONLY ON A CURRENT SESSION"
 ) ;_ end of alert
 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark doc)
 (mip:layer-status-save)
 (if (setq col (acad_colordlg 7 t))
   (ChangeXrefAllObjectsColor doc col) ;_ col — color number
 ) ;_ end of if
 (mip:layer-status-restore)
 (vla-endundomark doc)
 (princ)
) ;_ end of defun
(defun C:COLORXL (/ doc col)
 (vl-load-com)
 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark doc)
 (if (setq col (acad_colordlg 7 t))
   (ChangeAllObjectsColor doc col) ;_ col — color number
 ) ;_ end of if
 (vla-endundomark doc)
 (princ)
) ;_ end of defun
(defun C:COLORXREFL (/ doc col)
 (vl-load-com)
 (alert
   "\This lisp change color xref\nONLY ON A CURRENT SESSION"
 ) ;_ end of alert
 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark doc)
 (if (setq col (acad_colordlg 7 t))
   (ChangeXrefAllObjectsColor doc col) ;_ col — color number
 ) ;_ end of if
 (vla-endundomark doc)
 (princ)
) ;_ end of defun
(defun mip:layer-status-restore	()
 (foreach item	*MIP_LAYER_LST*
   (if	(not (vlax-erased-p (car item)))
     (vl-catch-all-apply
'(lambda ()
   (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
   (vla-put-freeze
     (car item)
     (cdr (assoc "freeze" (cdr item)))
   ) ;_ end of vla-put-freeze
 ) ;_ end of lambda
     ) ;_ end of vl-catch-all-apply
   ) ;_ end of if
 ) ;_ end of foreach
 (setq *MIP_LAYER_LST* nil)
) ;_ end of defun

(defun mip:layer-status-save ()
 (setq *MIP_LAYER_LST* nil)
 (vlax-for item (vla-get-layers
	   (vla-get-activedocument (vlax-get-acad-object))
	 ) ;_ end of vla-get-layers
   (setq *MIP_LAYER_LST*
   (cons (list item
	       (cons "freeze" (vla-get-freeze item))
	       (cons "lock" (vla-get-lock item))
	 ) ;_ end of cons
	 *MIP_LAYER_LST*
   ) ;_ end of cons
   ) ;_ end of setq
   (vla-put-lock item :vlax-false)
   (if	(= (vla-get-freeze item) :vlax-true)
     (vl-catch-all-apply
'(lambda () (vla-put-freeze item :vlax-false))
     ) ;_ end of vl-catch-all-apply
   ) ;_ end of if
 ) ;_ end of vlax-for
) ;_ end of defun
(defun ChangeXrefAllObjectsColor (Doc Color / tmp txtstr)
 (vlax-for Blk	(vla-get-Blocks Doc)
   (cond
     ((or (= (vla-get-IsXref Blk) :vlax-true)
   (and	(= (vla-get-IsXref Blk) :vlax-false)
	(wcmatch (vla-get-name Blk) "*|*")
   ) ;_ end of and
      ) ;_ end of or
      (vlax-for Obj Blk
 (if (and (vlax-write-enabled-p Obj)
	  (vlax-property-available-p Obj 'Color)
     ) ;_ end of and
   (vla-put-Color Obj Color)
 ) ;_ end of if
 (if (and (vlax-write-enabled-p Obj)
	 (vlax-property-available-p Obj 'TextString)
    ) ;_ end of and
  (progn
    (setq txtstr
	   (if (vlax-method-applicable-p Obj 'FieldCode)
	       (vla-FieldCode Obj)
	       (vlax-get-property Obj 'TextString))
	  )
    (setq tmp 0)
     (while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))
      (setq txtstr
      (vl-string-subst
	(strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")
	(substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))
	txtstr
	tmp)
	    )
      (setq tmp (+ tmp 3))
      )
    (vla-put-Textstring Obj txtstr)
    )
) ;_ end of if
 (if (and (vlax-write-enabled-p Obj)
	  (= (vla-get-ObjectName obj) "AcDbBlockReference")
	  (= (vla-get-HasAttributes obj) :vlax-true)
     ) ;_ end of and
   (foreach att	(vlax-safearray->list
		  (vlax-variant-value (vla-GetAttributes obj))
		) ;_ end of vlax-safearray->list
     (if (and (vlax-write-enabled-p att)
	      (vlax-property-available-p att 'Color)
	 ) ;_ end of and
       (vla-put-Color att Color)
     ) ;_ end of if
   ) ;_ end of foreach
 ) ;_ end of if
 (if (and (vlax-write-enabled-p Obj)
	  (wcmatch (vla-get-Objectname Obj) "*Dimension*,AcDb*Leader")
     ) ;_ end of and
   (progn
     (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))
     (vl-catch-all-apply 'vla-put-TextColor (list Obj Color))
     (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))
     (if (vlax-property-available-p Obj 'LeaderLineColor)
       (progn
	 (setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."
	(substr (getvar "ACADVER") 1 2))))
	 (vla-put-colorindex  tmp  Color)
	 (vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))
	 )
       )
   ) ;_ end of progn
 ) ;_ end of if
      ) ;_ end of vlax-for
     )
     ((= (vla-get-IsLayout Blk) :vlax-true)
      (vlax-for Obj Blk
 (if
   (and	(vlax-write-enabled-p Obj)
	(vlax-property-available-p Obj 'Color)
	(vlax-property-available-p Obj 'Path)
	(wcmatch (strcase (vla-get-ObjectName Obj)) "*BLOCK*")
   ) ;_ end of and
    (vla-put-Color Obj Color)
 ) ;_ end of if
      ) ;_ end of vlax-for
     )
     (t nil)
   ) ;_cond
 ) ;_ end of vlax-for
 (vl-cmdf "_redrawall")
) ;_ end of defun
(defun ChangeAllObjectsColor (Doc Color / txtstr tmp txt count)
 (vlax-for Blk	(vla-get-Blocks Doc)
   (if	(= (vla-get-IsXref Blk) :vlax-false)
     (progn
(setq count 0 txt (strcat "Changed " (vla-get-name Blk)))
(grtext -1 txt)
     (vlax-for	Obj Blk
(setq count (1+ count))
(if (zerop(rem count 10))(grtext -1 (strcat txt " : " (itoa count))))
(if (and (vlax-write-enabled-p Obj)
	 (vlax-property-available-p Obj 'Color)
    ) ;_ end of and
  (vla-put-Color Obj Color)
) ;_ end of if
(if (and (vlax-write-enabled-p Obj)
	 (vlax-property-available-p Obj 'TextString)
    ) ;_ end of and
  (progn
    (setq txtstr
	   (if (vlax-method-applicable-p Obj 'FieldCode)
	       (vla-FieldCode Obj)
	       (vlax-get-property Obj 'TextString))
	  )
    (setq tmp 0)
    (while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))
      (setq txtstr
      (vl-string-subst
	(strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")
	(substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))
	txtstr
	tmp)
	    )
      (setq tmp (+ tmp 3))
      )
    (vla-put-Textstring Obj txtstr)
    )
) ;_ end of if
(if (and (vlax-write-enabled-p Obj)
	 (= (vla-get-ObjectName obj) "AcDbBlockReference")
	 (= (vla-get-HasAttributes obj) :vlax-true)
    ) ;_ end of and
  (foreach att (vlax-safearray->list
		 (vlax-variant-value (vla-GetAttributes obj))
	       ) ;_ end of vlax-safearray->list
    (if	(and (vlax-write-enabled-p att)
	     (vlax-property-available-p att 'Color)
	) ;_ end of and
      (vla-put-Color att Color)
    ) ;_ end of if
  ) ;_ end of foreach
) ;_ end of if
       (if (and (vlax-write-enabled-p Obj)
	  (wcmatch (vla-get-Objectname Obj)  "*Dimension*,AcDb*Leader")
     ) ;_ end of and
   (progn
     (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))
     (vl-catch-all-apply 'vla-put-TextColor (list Obj Color))
     (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))
     (if (vlax-property-available-p Obj 'LeaderLineColor)
       (progn
	 (setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."
	(substr (getvar "ACADVER") 1 2))))
	 (vla-put-colorindex  tmp  Color)
	 (vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))
	 )
       )
   ) ;_ end of progn
 ) ;_ end of if
     ) ;_ end of vlax-for
     )
   ) ;_ end of if
 ) ;_ end of vlax-for
(vl-cmdf "_redrawall")
) ;_ end of defun
(princ
 "\nType ColorX, COLORXREF, ColorXL, COLORXREFL  in command line"
) ;_ end of princ

Vâng. Cảm ơn bác phamngoctukts

Không ngờ lisp đổi màu phức tạp đến vậy. Chân thành cảm ơn bác


<<

Filename: 116286_colorx_colorxref_colorxl_colorxrefl.lsp
Tác giả: ketxu
Bài viết gốc: 109847
Tên lệnh: vetuong vt vc
Viết lisp theo yêu cầu [phần 2]
Phù cuối cùng thì cũng hoàn thành cái mớ bòng bong này. Từ lisp ve tường ban đầu mình đã phát triển được như thế này rôi.

>>
Phù cuối cùng thì cũng hoàn thành cái mớ bòng bong này. Từ lisp ve tường ban đầu mình đã phát triển được như thế này rôi.

chot.jpg

Xin lỗi bạn ketxu vì chưa sét thêm phần chọn tỉ lệ vào được. Mình đang kiểm tra xem không biết nó sai chỗ nào mà nhập số nhỏ vào thì nó lại không chạy.

Còn phần dim cho các trường hợp các đường tim chéo thì quá phức tạp có lẽ mình chỉ nên dừng ở trường hợp các đường tim song song với ox oy thôi.

Các bạn test thử xem có bổ xung thêm gì không. Trong khả năng của mình sẽ hết sức để vừa lòng các bạn. Chúc diễn đàn luôn luôn phát triển.

;; free lisp from cadviet.com
(defun c:vetuong ()
(initvetuong)
(command "trim" "" "e" "e" "p" "n" "")
(command "undo" "be")
(setvar "cmdecho" 0)
(setq old_layer (getvar "clayer"))
(setq snap (getvar "osmode"))
(setq hl (getvar "highlight"))
(setq tbl (tblsearch "layer" "tuong"))
(if (= tbl nil) (command "-layer" "n" "tuong" "c" "4" "tuong" ""))
(setq tbl (tblsearch "layer" "_tim"))
(if (= tbl nil) (command "-layer" "n" "_tim" "c" "8" "_tim" "l" "center" "_tim" ""))
(setq tbl (tblsearch "layer" "template"))
(if (= tbl nil) (command "-layer" "n" "template" ""))
(setvar "clayer" "template")
(setvar "osmode" 0)
(setq ss (ssget '((0 . "line"))))
(setq day (cond (day) (220)))
(setq oldday day)
(setq day (getint (strcat "\nnhap chieu day tuong  : ")))
(if (null day)
(setq day oldday)
)
(setq day1 (/ (* day 7) 15))
(command "change" ss "" "p" "la" "_tim" "")
(setq i 0)
(setq lp nil)
(setq ssml nil)
(setq ssml (ssadd))
(while ((setq name (ssname ss i)
ent (entget name)
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent))
lp (append (list (append (list p1) (list p2))) lp)
)
(command "mline" "j" "z" "s" day p1 p2 "")
(command "explode" "l")
(setq ssline (ssget "p"))
(setq line1 (ssname ssline 0))
(setq line2 (ssname ssline 1))
(setq ssml (ssadd line1 (ssadd line2 ssml)))
(setq i (1+ i))
)
(command "-layer" "off" "_tim" "")
(setq j 0)
(setvar "highlight" 0)
(while ((setq nhom (nth j lp)
pt1 (car nhom)
pt2 (last nhom)
angf (+ (angle pt1 pt2) (/ pi 2))
t1 (polar pt1 angf day1)
t2 (polar pt1 (+ angf pi) day1)
t3 (polar pt2 (+ angf pi) day1)
t4 (polar pt2 angf day1)
)
(command "trim" ssml "" "f" t1 t2 t3 t4 t1 "" "")
(setq j (1+ j))
)
(setq q 0)
(setq ssml (ssget "x" '((0 . "line") (8 . "template"))))
(while ((setq l1 (ssname ssml q)
pf1 (cdr (assoc 10 (entget l1)))
pf2 (cdr (assoc 11 (entget l1)))
)
(setq k 0)
(while ((setq l2 (ssname ssml k)
pf3 (cdr (assoc 10 (entget l2)))
pf4 (cdr (assoc 11 (entget l2)))
d1 (distance pf1 pf3)
d2 (distance pf1 pf4)
d3 (distance pf2 pf3)
d4 (distance pf2 pf4)
)
(if (or (and ( d1 0)) (and ( d2 0)) 
        (and ( d3 0)) (and ( d4 0)))
(command "fillet" l1 l2)
)
(setq k (1+ k))
)
(setq q (1+ q))
)
(command "change" ssml "" "p" "la" "tuong" "")
(dimtuong)
(setvar "clayer" old_layer)
(command "-layer" "on" "_tim" "")
(setvar "osmode" snap)
(setvar "highlight" hl)
(setvar "cmdecho" 1)
(command "undo" "e")
(command "trim" "" "e" "n" "")
)
;******************************************
(defun c:vt ()
(command "trim" "" "e" "e" "p" "n" "")
(command "undo" "be")
(setvar "cmdecho" 0)
(setq old_layer (getvar "clayer"))
(setq snap (getvar "osmode"))
(setvar "clayer" "tuong")
(setq dt (cond (dt) (220)))
(setq olddt dt)
(setq dt (getint (strcat "\nrong tuong  : ")))
(if (null dt)
(setq dt olddt)
)
(setq pt1 (getpoint "\ndiem thu nhat:")
pt2 (getpoint "\ndiem thu hai:" pt1)
)
(setvar "osmode" 0)
(command "-layer" "off" "_tim" "")
(command "mline" "j" "z" "s" dt pt1 pt2 "")
(setq mll (entlast))
(command "trim" mll "" "f" pt1 pt2 "" "")
(command "explode" mll)
(setvar "osmode" snap)
(setvar "clayer" old_layer)
(command "-layer" "on" "_tim" "")
(setvar "cmdecho" 1)
(command "trim" "" "e" "n" "")
)
;*****************************************
(defun c:vc ()
(setvar "cmdecho" 0)
(setq old_layer (getvar "clayer"))
(setq snap (getvar "osmode"))
(setvar "clayer" "tuong")
(setq cua (cond (cua) (900)))
(setq oldcua cua)
(setq cua (getint (strcat "\nrong cua  : ")))
(if (null cua)
(setq cua oldcua)
)
(setq pc1 (getpoint "\ndiem thu nhat:")
pc2 (getpoint "\ndiem thu hai:" pc1)
ang (+ (angle pc1 pc2) (/ (* 90 pi) 180))
pc3 (polar pc1 ang (+ 110 (/ cua 2)))
pc4 (polar pc2 ang (+ 110 (/ cua 2)))
)
(setvar "osmode" 0)
(command "-layer" "off" "_tim" "")
(command "mline" "j" "z" "s" cua pc3 pc4 "")
(setq mll (entlast))
(command "trim" mll "" "f" pc3 pc4 "" "")
(command "explode" mll)
(setvar "osmode" snap)
(setvar "clayer" old_layer)
(command "-layer" "on" "_tim" "")
(setvar "cmdecho" 1)
)
;*****************************************
(defun dimtuong ()
(setq e nil c nil)
(setq tbl (tblsearch "layer" "_dim"))
(if (= tbl nil) (command "-layer" "n" "_dim" "c" "8" "_dim" ""))
(setvar "clayer" "_dim")
(setq tldim (getvar "dimscale"))
(setq th (getvar "dimtxt"))
(setq a 0)
(setq lpx nil)
(setq lpy nil)
(while ((setq px1 (car (car (nth a lp)))
py1 (cadr (car (nth a lp)))
px2 (car (cadr (nth a lp)))
py2 (cadr (cadr (nth a lp)))
)
(if (/= py1 py2)
(setq lpx (append (list px1) lpx))
)
(if (= py1 py2)
(setq lpy (append (list py1) lpy))
)
(setq a (1+ a))
)
(setq lpx (vl-sort lpx '(setq lpy (vl-sort lpy '(setq dc (- (last lpx) (car lpx)))
(setq pdi (list (car lpx) (- (car lpy) (/ dc 40)) 0))
(setq pdi2 (list (- (car lpx) (/ dc 40)) (car lpy)  0))
(setq pdim (polar pdi pi  (/ day 2)))
(setq pdim2 (polar pdi2 (/ (* pi 3) 2)  (/ day 2)))
(setq pdim1 (polar pdi (/ (* pi 3) 2) (/ dc 25)))
(setq pdim12 (polar pdi2 pi (/ dc 25)))
(command "_dimlinear" pdi pdim pdim1)
(command "_dimlinear" pdi2 pdim2 pdim12)
(setq c 0)
(while ((setq y (cadr pdim)
x1 (nth c lpx)
x2 (nth (1+ c) lpx)
dd1 (list x1 y 0)
dd2 (list x2 y 0)
tam (list x1 (- (cadr pdim1) (* (* tldim th) 6)) 0)
)
(command "_dimlinear" dd1 dd2 pdim1)
(vetruc)
(setq c (1+ c))
)
(setq tam (list x2 (- (cadr pdim1) (* (* tldim th) 6)) 0))
(vetruc)
(setq c nil)
(setq e 0)
(while ((setq x (car pdim2)
y1 (nth e lpy)
y2 (nth (1+ e) lpy)
ddy1 (list x y1 0)
ddy2 (list x y2 0)
tam (list (- (car pdim12) (* (* tldim th) 7)) y1 0)
)
(command "_dimlinear" ddy1 ddy2 pdim12)
(vetruc)
(setq e (1+ e))
)
(setq tam (list (- (car pdim12) (* (* tldim th) 7)) y2 0))
(vetruc)
(setq e nil)
(setq pcc (polar dd2 0 (/ day 2)))
(setq pcc2 (polar ddy2 (/ pi 2) (/ day 2)))
(command "_dimlinear" dd2 pcc pdim1)
(command "_dimlinear" ddy2 pcc2 pdim12)
(command "_dimlinear" pdim pcc (polar pdim1 (/ (* pi 3) 2) (* (* tldim th) 3)))
(command "_dimlinear" pdim2 pcc2 (polar pdim12 pi (* (* tldim th) 3)))
)
;*************************
(defun vetruc ()
(if (= (tblsearch "style" "chutruc") nil)
(command "style" "chutruc" ".VnAvantH" "" "0.8" "" "" ""))
(setq r (* (* th tldim) 2)
r2 (/ r 1.2)
dline1 (polar tam 0 r2)
dline2 (polar dline1 0 (/ (* r2 2) 3))
listtrucx '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)
listtrucy '("A" "B" "C" "D" "E" "F" "G" "H" "I" "K" "L" "N" "M" "O" 
             "P" "Q" "R" "S" "T" "U" "V" "X" "Y" "Z")
)
(command "circle" tam r)
(command "change" "l" "" "p" "la" "tuong" "")
(command "circle" tam r2)
(command "change" "l" "" "p" "la" "_dim" "")
(command "line" dline1 dline2 "")
(command "change" "l" "" "p" "la" "tuong" "")
(command "-array" "p" "" "p" tam "4" "360" "y")
(if (= e nil)
(command "-text" "j" "m" tam r "0" (rtos (nth c listtrucx)))
)
(if (= c nil)
(command "-text" "j" "m" tam r "0" (nth e listtrucy))
)
)
;********************************
(defun initvetuong ()
(setq 
    vetuong_old_er *error*
    *error* vetuongerror
 )
)
;**************************
(defun vetuongerror (errmsg)
(loivetuong)
)
;**************************
(defun loivetuong ()
(setq *error* vetuong_old_er)
(command "undo" "end")
(command "undo" "")
(princ "xay ra loi trong qua trinh ve")
)
;**************************

BS: Cái lệnh VT với VC là mình viết thêm để chổ cửa và vẽ tường cho nhanh thôi các bạn tự nghiên cứu.

Cám ơn bác,code đã khá đẹp và công phu ^^.Nhưng em vẫn chờ ngày Tỉ lệ được đặt vào ^^.Hihi(tham)

Hiện tại thì trục vẽ rất đẹp,nhưng vì không có lựa chọn cho user là đánh số từ trái qua phải sẽ bắt đầu từ đâu,tăng hay giảm,từ trên xuống dưới cũng vậy.Nên vô hình chung,chẳng may trục có sẵn của bên Ktrúc (giả sử bọn e là dân KCấu vẽ lại) lại đặt là 7-6-5-4...,C-D-E... thì lại phải ngồi sửa lại bác ạ.Nhưng nói chung phần này chưa quan trọng lắm ^^.E tiếp tục test nữa,có gì bác đừng phật ý nhé


<<

Filename: 109847_vetuong_vt_vc.lsp
Tác giả: truongthanh
Bài viết gốc: 109829
Tên lệnh: tktxt
Viết lisp theo yêu cầu [phần 2]
Chào bạn Truongthanh,

Có phải bạn cần như thế này không????

(defun c:tktxt ( / ss n i tnlst cnlst tn cn)
(setq ss (ssget (list (cons 0 "text")))
   ...
>>
Chào bạn Truongthanh,

Có phải bạn cần như thế này không????

(defun c:tktxt ( / ss n i tnlst cnlst tn cn)
(setq ss (ssget (list (cons 0 "text")))
        n  (sslength ss)
        i 0
       tnlst (list)
       cnlst (list)
)
(while (< i n)
       (setq en (ssname ss i)
               els (entget en)
               txt (cdr (assoc 1 els))
       )
       (if  (= (substr txt 1 1) (chr 216))
            (if (> (strlen txt) 12)
               (setq tnlst (append tnlst (list txt)))
               (setq cnlst (append cnlst (list txt)))
            )
        )
        (setq i (1+ i))
)
(setq tn (strcase 
           (getstring "\n Ban muon thong ke duong ong cap nuoc (y or n): ")))
(if (= tn "Y")
(seplst cnlst)
)
(setq cn (strcase 
            (getstring "\n Ban muon thong ke duong ong thoat nuoc (y or n): ")))
(if (= cn "Y")
(seplst tnlst)
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun seplst ( lst / lst1 lst2 lst3 tdd lo )
(while (/= lst nil)
       (setq a (substr (nth 0 lst) 1 4)
                lst1 (cdr lst)
                lst2 nil
                tdd 0
                lst2 (append lst2 (list (nth 0 lst)))
       )
       (foreach b lst1
                (if (= (substr b 1 4) a)
                    (setq lst2 (append lst2 (list b )))
                    (setq lst3 (append lst3 (list b )))
                )
       )
       (foreach c lst2
               (setq tdd (+  tdd (atof (substr c 9 3)))
                       lo (substr c 1 4)
               )
       )
      (alert (strcat "\n Tong do dai ong " lo " la " (rtos tdd 2  ) ))
       (setq lst lst3
               lst3 nil 
       )
)
)

 

Bạn lưu ý như sau:

1/- Lisp này viết dựa trên cái file bạn gửi. Do vậy nếu bạn dùng các định dạng khác của text thì nó sẽ không chịu trách nhiệm đâu nhé. (ví dụ bạn sử dụng mtext thì nó sẽ không lọc được đối tượng, bạn sử dụng cách nhập ký tự "phi" khác nó cũng sẽ không biết để nhận dạng, bạn sử dụng số ký tự trong chuỗi text của bạn không đúng như bạn đã post thì nó sẽ cắt chuỗi sai và chạy sai .....)

2/- Do bạn chỉ yêu cầu thông báo kết quả nên mình chỉ trả kết quả bằng các thông báo alert, nếu bạn muốn tạo thành text trên bản vẽ thì cần cải tạo thêm một chút. Nếu bạn muốn lập bảng trên bản vẽ thì lại phải bổ xung thêm kha khá, và nếu bạn muốn xuất thành file text hay file xls sẽ lại phải phức tạp thêm bạn ạ.

 

Chúc bạn vui.

Chào bác Bình!Tối giờ em ngồi test em mới phát hiện ra khi em thống kê tới đường kính D1000 và L=1000 thì lisp ko hiểu bác ơi!Có fai lisp chỉ hiểu chỗ đường kính tối đa có 3 chữ số và chiều dài cũng tối đa 3 chữ số ko bác?Nhờ bác sữa lại dùm em với!

Thanks bác nhiều!


<<

Filename: 109829_tktxt.lsp
Tác giả: Bee
Bài viết gốc: 422515
Tên lệnh: pts
Lisp xuất tọa độ của Polyline trong CAD theo ý mong muốn

Search là đầy file mà. Sau đó Open trong excel phân column bằng comma.

(defun vert (/		 filterlist  vla-obj-list
	     lwlist	 2dlist	     ptlist	 vlist1
	     vlist2	 vlist3
	    )
  (vl-load-com)
  (setq	filterlist   (make-filter)
	vla-obj-list (get-objects filterlist)
	lwlist	     (nth 0 vla-obj-list)
	2dlist	     (nth 1 vla-obj-list)
	ptlist	     (nth 2 vla-obj-list)
	vlist1	     nil
	vlist2	  ...
>>

Search là đầy file mà. Sau đó Open trong excel phân column bằng comma.

(defun vert (/		 filterlist  vla-obj-list
	     lwlist	 2dlist	     ptlist	 vlist1
	     vlist2	 vlist3
	    )
  (vl-load-com)
  (setq	filterlist   (make-filter)
	vla-obj-list (get-objects filterlist)
	lwlist	     (nth 0 vla-obj-list)
	2dlist	     (nth 1 vla-obj-list)
	ptlist	     (nth 2 vla-obj-list)
	vlist1	     nil
	vlist2	     nil
	vlist3	     nil
  ) ;_ end-of setq
  (if lwlist
    (setq vlist1 (make-list lwlist 2))
  ) ;_ end of if
  (if 2dlist
    (setq vlist2 (make-list 2dlist 3))
  ) ;_ end of if
  (if ptlist
    (setq vlist3 (make-list ptlist 3))
  ) ;_ end of if
  (write-text vlist1 vlist2 vlist3)
  (princ)
) ;_ end of vert

(defun make-list (p-list n / i vlist obj coords ca j x y z xy)
  (setq	i (- 1)
	vlist nil
  ) ;_ end of setq
  (repeat (length p-list)
    (setq obj	 (nth (setq i (1+ i)) p-list)
	  coords (vlax-get-property obj "coordinates")
	  ca	 (vlax-variant-value coords)
	  j	 (- 1)
    ) ;_ end-of setq
    (repeat (/ (length (vlax-safearray->list ca)) n)
      (setq x (vlax-safearray-get-element ca (setq j (1+ j))))
      (setq y (vlax-safearray-get-element ca (setq j (1+ j))))
      (if (= n 2)
	(setq xy (list x y))
	(progn
	  (setq z (vlax-safearray-get-element ca (setq j (1+ j))))
	  (setq xy (list x y z))
	) ;_ end of progn
      ) ;_ end of if
      (setq vlist (append vlist (list xy)))
    ) ;_ end-of repeat
  ) ;_ end-of repeat
) ;_ end-of make-list

(defun make-filter (/ filter)
  (setq	filter '((-4 . "<OR")
		 (0 . "LWPOLYLINE")
		 (0 . "POLYLINE")
		 (0 . "POINT")
		 (-4 . "OR>")
		)
  ) ;_ end of setq
) ;_ end of make-filter

(defun get-objects (filter  /	    ss	    k	    lwp-list
		    2dp-list	    pt-list no-ent  obj	    pl
		    2d	    pt
		   )
  (setq no-ent 1)
  (while no-ent
    (setq ss	   (ssget filter)
	  k	   (- 1)
	  lwp-list nil
	  2dp-list nil
	  pt-list  nil
	  obj	   nil
	  pl	   "AcDbPolyline"
	  2d	   "AcDb2dPolyline"
	  pt	   "AcDbPoint"
    ) ;_ end-of setq
    (if	ss
      (progn
	(setq no-ent nil)
	(repeat	(sslength ss)
	  (setq	ent (ssname ss (setq k (1+ k)))
		obj (vlax-ename->vla-object ent)
	  ) ;_ end-of setq
	  (cond
	    ((= (vlax-get-property obj "ObjectName") pl)
	     (setq lwp-list (append lwp-list (list obj)))
	    )
	    ((= (vlax-get-property obj "ObjectName") 2d)
	     (setq 2dp-list (append 2dp-list (list obj)))
	    )
	    ((= (vlax-get-property obj "ObjectName") pt)
	     (setq pt-list (append pt-list (list obj)))
	    )
	  ) ;_ end-of cond
	) ;_ end-of repeat
      ) ;_ end-of progn
      (prompt "\nNo polylines or points selected, try again.")
    ) ;_ end-of if
  ) ;_ end-of while
  (list lwp-list 2dp-list pt-list)
) ;_ end-of get-objects

(defun write-text (vl1 vl2 vl3)
  (setq	fn (getfiled "Text File" "" "txt" 1)) 
  (setq f (close (open fn "w")))
  (setq msg "Points from LW-Polylines")
  (do-points fn vl1 msg 2)
  (setq msg "Points from 2d-Polylines")
  (do-points fn vl2 msg 3)
  (setq msg "Points from Point entities")
  (do-points fn vl3 msg 3)
  (princ)
) ;_ end of write-text

(defun do-points (fn vl msg n)
  (setq f (open fn "a"))
  (write-line msg f)
  (write-line "  x,  y,  z" f)
  (write-line "" f)
  (foreach point vl
    (setq x (nth 0 point)
	  y (nth 1 point)
    ) ;_ end of setq
    (if	(= n 2)
      (setq str (strcat (rtos x) "," (rtos y)))
      (progn
	(setq z (nth 2 point))
	(setq str (strcat (rtos x) "," (rtos y) "," (rtos z)))
      ) ;_ end of progn
    ) ;_ end of if
    (write-line str f)
  ) ;_ end of foreach
  (setq f (close f))
  (princ)
) ;_ end of defun

(defun c:pts ()
  (vert)
  (princ)
) ;_ end-of defun

(prompt "PLIST.LSP by Tony Hotchkiss - enter PTS to start ")

image.png.8ed4dd591033547a719327b677e23fc3.png


<<

Filename: 422515_pts.lsp
Tác giả: ptd1987
Bài viết gốc: 337540
Tên lệnh: rtd
Nhờ các bác viết lisp rải thép đai cho dầm

 

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

(defun c:rtd(/ ANG B1 B2 DIS DT LI OS P1 P2 TONG)
(defun chan(x n) (* n  (fix (/ x n 1.))...
>>

 

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

(defun c:rtd(/ ANG B1 B2 DIS DT LI OS P1 P2 TONG)
(defun chan(x n) (* n  (fix (/ x n 1.)) ))
(defun chia (a d1 d2 / D150 D200)
(setq d200 (chan (* 0.5 a) d2)
d150 (chan (* 0.5 (- a d200 100)) d1)
)
(list d150 d200)
)
  (setvar 'cmdecho 0) 
(setq os (getvar 'osmode )
dt (car (entsel "\n Chon line de rai:"))
p1 (getpoint "\n Rai tu diem dau:")
p2 (getpoint p1 "\n Den diem cuoi:") 
)
(setq b1 (getint (strcat "\n Buoc cua doan bien <" (if gl_b1 (itoa gl_b1) (itoa (setq gl_b1 150))) ">: ")))
(if b1 (setq gl_b1 b1))
(setq b2 (getint (strcat "\n Buoc cua doan giua <" (if gl_b2 (itoa gl_b2) (itoa (setq gl_b2 200))) ">: ")))
(if b2 (setq gl_b2 b2))
(setq dis (distance p1 p2)
ang (angle p1 p2)
li (chia dis gl_b1 gl_b2))
(setvar 'osmode 0)
(command "copy" dt "" p1 (polar p1 ang (setq tong 50))) 
(repeat (/ (car li) gl_b1)
(command "copy" dt "" p1 (polar p1 ang (setq tong (+ tong gl_b1)))))
(repeat (/ (last li) gl_b2)
(command "copy" dt "" p1 (polar p1 ang (setq tong (+ tong gl_b2)))))
(repeat (/ (car li) gl_b1)
(command "copy" dt "" p1 (polar p1 ang (setq tong (+ tong gl_b1))))) 
(entdel dt)
(setvar 'cmdecho 1) (setvar 'osmode os) (princ)
)

em đã thử lisp bác mới fix, dầm 3m 4m 5m ko sao nhưng 6m 6.5m lại bị khoảng cách cuối cùng là 250 ko rải thêm 1 đai cuối nữa, như hình e đính kèm112169_screenhunter_001.jpg


<<

Filename: 337540_rtd.lsp
Tác giả: Updatelisp
Bài viết gốc: 17543
Tên lệnh: dn
Cần lisp đo khoảng cách và góc nghiêng đoạn thẳng
lệnh dn (đo nghiêng) dưới đây sẽ giúp bạn.

(defun c:dn ()
 (defun str (n)
   (vl-string-right-trim "." (vl-string-right-trim "0" (rtos n)))
 )
 (setq	sel (entsel...
>>
lệnh dn (đo nghiêng) dưới đây sẽ giúp bạn.

(defun c:dn ()
 (defun str (n)
   (vl-string-right-trim "." (vl-string-right-trim "0" (rtos n)))
 )
 (setq	sel (entsel "\nPick vao 1 line:")
ent (car sel)
tt  (entget ent)
p1  (cdr (assoc 10 tt))
p2  (cdr (assoc 11 tt))
goc (str (/ (* (angle p1 p2) 180) pi))
dai (str (distance p1 p2))
 )
 (wtxt (strcat "l=" dai "; g=" goc "%%d") (cadr sel))

)

(defun wtxt (txt p / sty d h)
 (setq
   sty	(getvar "textstyle")
   d	(tblsearch "style" sty)
   h	(cdr (assoc 40 d))
 )
 (entmake (list (cons 0 "TEXT")
	 (cons 7 sty)
	 (cons 1 txt)
	 (cons 10 p)
	 (if (> h 0)
	   (cons 40 h)
	   (assoc 40 d)
	 )
	 (assoc 41 d)
   )
 )
)

Thanks Bác Hoành nhiều !Nhưng lisp này thì text ghi lại không theo phương của đường thẳng mà mình vẽ ra .Làm cách nào để khắc phục lỗi đố vậy Bác !


<<

Filename: 17543_dn.lsp
Tác giả: nhatx2
Bài viết gốc: 413753
Tên lệnh: feq
Lisp Tìm Và Thay Thế Text Theo Mẫu Có Sẵn

 

Bạn sử dụng lệnh FIND của CAD cũng được, tuy nhiên nhược điểm là gọi lệnh này sẽ hiện Dialog và mất thời gian...

>>

 

Bạn sử dụng lệnh FIND của CAD cũng được, tuy nhiên nhược điểm là gọi lệnh này sẽ hiện Dialog và mất thời gian load. Góp vui cho bạn một LISP tìm và thay thế tự động!

;superstr.lsp l. gabriel 11-11-1996  22:04:42
;
;object: string search and replace. Works for both text and attributes. Program
;        will globally search and replace every text/attribute within the selection set.
;
;Rev 1.0 Added Dimension string search and replace l. gabriel 06.12.08
;
(defun atext (num)
   (cdr (assoc num d))
)
;
(defun echooff ()
  (setq oldecho (getvar "CMDECHO"))
  (setq oldblip (getvar "BLIPMODE"))
  (setq oldosm (getvar "OSMODE"))
  (setvar "CMDECHO" 0)
  (setvar "BLIPMODE" 0)
  (setvar "OSMODE" 0)
  (setq olderror_echo *ERROR*)
  (terpri)
  (defun *ERROR* (msg)
    (princ " \n")
    (princ msg)
    (echoon)
  )
)
;
(defun echoon ()
  (setvar "CMDECHO" oldecho)
  (setvar "BLIPMODE" oldblip)
  (setvar "OSMODE" oldosm)
  (setq *ERROR* olderror_echo)
  (princ)
)
;super search and replace routine
(defun c:FEQ()
    (echooff)
    (setq olsosmode (getvar "OSMODE"))
    (setvar "OSMODE" 0)
    (setq p (ssget))   
    (if p 
	(progn 
            (setq osl (strlen (setq os (getstring "\nOld string: " t))))
            (setq nsl (strlen (setq ns (getstring "\nNew string: " t))))
	    (setq l 0 chm 0 n (sslength p))
	    (setq adj 
		(cond 
		    ((/= osl nsl) (- nsl osl))
		    (T nsl)
		)
	    )
	(while (< l n)                   
	    (setq d (entget (setq e (ssname p l))))
	    (if (and (= (atext 0) "INSERT")(= (atext 66) 1))
		(progn
		    (setq e (entnext e))
		    (while e
			(setq d (entget e))
			(cond 
			    ((= (atext 0) "ATTRIB")
				(setq chf nil si 1)
				(setq s (cdr (setq as (assoc 1 d))))
				(while (= osl (setq sl (strlen
				    (setq st (substr s si osl)))))
				    (cond
					((= st os)
					    (setq s (strcat (substr s 1 (1- si)) ns
					    (substr s (+ si osl))))
					    (setq chf t)
					    (setq si (+ si adj))
					)
				    )
				(setq si (1+ si))
			    )
			    (if chf 
				(progn        
				    (setq d (subst (cons 1 s) as d))
				    (entmod d)	       
				    (entupd e)	       
				    (setq chm (1+ chm))
				)
			    )
			    (setq e (entnext e))
			    )
			    ((= (atext 0) "SEQEND")
				(setq e nil)) 
			    (T (setq e (entnext e)))
                        )
		    )
		)
	    )
            (if (= "MTEXT"            ; Look for MTEXT entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
	    (if (= "DIMENSION"            ; Look for DIMENSION entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
	    (if (= "TEXT"            ; Look for TEXT entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
         (setq l (1+ l))
	)
	)
    )
    (if (> chm 1)
       (princ (strcat "\nUpdated " (itoa chm) " text strings"))
       (princ (strcat "\nUpdated " (itoa chm) " text string"))
    )
    (setvar "OSMODE" oldosmode)
    (terpri)
    (echoon)
)

cảm ơn nhé!


<<

Filename: 413753_feq.lsp
Tác giả: quickandfine
Bài viết gốc: 205202
Tên lệnh: ctd
Lisp điều chỉnh vị trí text ghi kích thước trên đường dim

Của bạn đây. Bạn thử xem nhé :

(defun c:ctd(/ ss ename i dxf11 dxf13 vt)
 (if (setq ss (ssget '((0 . "DIMENSION"))))
   (progn
...
>>

Của bạn đây. Bạn thử xem nhé :

(defun c:ctd(/ ss ename i dxf11 dxf13 vt)
 (if (setq ss (ssget '((0 . "DIMENSION"))))
   (progn
     (setq i -1 vt (getreal "\n Text cua dim cach mep trai 1 doan :"))
     (while (setq ename (ssname ss (setq i (1+ i))))
(command "dimtedit" ename "L")
(setq dxf11 (cdr(assoc 11 (entget ename)))
     dxf13 (cdr(assoc 13 (entget ename)))  )
(command "dimtedit" ename (list (+ (car dxf13) vt) (cadr dxf11) 0.0) )
     )
   )
 )
)

Em thấy đoạn lisp này cũng tiện lợi. Nhưng bác có thể sửa thành click chuột vào một điểm mới nằm trên đường dim đó thì text sẽ chuyển tương ứng về vị trí mới đó thì tiện hơn ạ.


<<

Filename: 205202_ctd.lsp
Tác giả: vantran
Bài viết gốc: 92720
Tên lệnh: hkh
chuyển tọa độ từ file excel sang cad
Chào vantran, Lisp này chạy khi trong bản vẽ của bạn đã có block "HOKHOAN" và trong file dữ liệu thêm 1 dòng tiêu đề như trong file Thiep gửi cho bạn sau:

>>
Chào vantran, Lisp này chạy khi trong bản vẽ của bạn đã có block "HOKHOAN" và trong file dữ liệu thêm 1 dòng tiêu đề như trong file Thiep gửi cho bạn sau:

http://www.cadviet.com/upfiles/2/dulieudavoi.zip

Còn đây là lisp:

;| Lisp nhap cac blockref LOKHOAN tu file du lieu *.txt
  copyright by TRAN THIEP V1 03/2010
  Yeu cau: ACAD da co cai dat Express Tools
=====================================================|;
(vl-load-com)
(defun c:hkh (/ ActDoc  *Model* *layer*	f       Lh      posX    posY
      name    Z	  Se	p       objblk  n	    taglst
     )
 (setq ActDoc   (vla-get-ActiveDocument (vlax-get-acad-object))
       *Model*  (vla-get-ModelSpace ActDoc)
       *layer*  (vla-get-Layers ActDoc)
       *sumary* (vla-get-SummaryInfo ActDoc)
 )
 (vla-StartUndoMark ActDoc)
 (or fn (setq fn (getfiled "chon file du lieu"
	     "d:/"
	     "txt"
	     0
     )
     )
 )
 (or (tblobjname "layer" "LOKHOAN")(vla-add *layer* "LOKHOAN"))
 (acet-sysvar-set
   (list "cmdecho" 0 "osmode" 0 "clayer" "LOKHOAN")
 )
 (setq f (open fn "r"))
 (setq	Lh   (ACET-STR-TO-LIST "\t" (read-line f))
posX (vl-position "Y" Lh)
posY (vl-position "X" Lh)
name (vl-position "TEN" Lh)
Z    (vl-position "H" Lh)
 )
 (setq	tyle (cond	(tyle)
	(1)
  )
 )
 (setq oldtyle tyle)
 (setq tyle (getreal (strcat "\nChon ty le chen khoi <"
		   (rtos oldtyle 2 0)
		   "> : "
	   )
  )
 )
 (if (null tyle)
   (setq tyle oldtyle)
 )
 (while (setq Lh (read-line f))
   (setq Se (ACET-STR-TO-LIST "\t" Lh)
  p  (list (distof (nth posX Se) 2)
	   (distof (nth posY Se) 2)
	   (distof (nth Z Se) 2)
     )
   )
   (setq	objblk (vla-InsertBlock
         *Model*
         (vlax-3d-point p)
         "HOKHOAN"
         tyle
         tyle
         1
         0
       )
n      0
   )
   (setq taglst (vlax-safearray->list
	   (vlax-variant-value
	     (vla-getattributes objblk)
	   )
	 )
   )
   (foreach att taglst
     (cond ((eq (vla-get-tagstring att) "TENHK")
     (vla-put-textstring att (nth name Se))
    )
    ((eq (vla-get-tagstring att) "Z")
     (vla-put-textstring att (nth Z Se))
    )

     )
   )
 )
 (close f)
 (acet-sysvar-restore)
 (vla-EndUndoMark ActDoc)
 (vla-put-Author *sumary* "TRAN-THIEP 0918841230")
 (vla-put-Comments
   *sumary*
   (strcat
     "This drawing used to use hokhoan.lsp"
     " "
     " Copyright by Tran Thiep"
     " "
     " Thank you very much"
    )
 )
 (princ "\nThiep chuc ban thanh cong")
 (princ)
)

cảm ơn Thiep. đây đúng là cái lisp mình cần.


<<

Filename: 92720_hkh.lsp

Trang 232/330

232