Bạn thử xem được không nhé!

Yêu cầu cài Cad full (có tool express)

(defun C:00	(/ LTSG LTSLINE PNTMAX PNTMIN SSLINE)
	(defun *error* (msg)
		(if	Olmode
			(setvar 'osmode Olmode)
		)
		(if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
			(princ (strcat "\nError: " msg))
		)
		(princ)
	)
	(setq Olmode (getvar "OSMODE"))
	(setvar "OSMODE" 0)
	(setvar "CMDECHO" 0)
	(setq ssLine...
>>

Bạn thử xem được không nhé!

Yêu cầu cài Cad full (có tool express)

(defun C:00	(/ LTSG LTSLINE PNTMAX PNTMIN SSLINE)
	(defun *error* (msg)
		(if	Olmode
			(setvar 'osmode Olmode)
		)
		(if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
			(princ (strcat "\nError: " msg))
		)
		(princ)
	)
	(setq Olmode (getvar "OSMODE"))
	(setvar "OSMODE" 0)
	(setvar "CMDECHO" 0)
	(setq ssLine (ssget (list (cons 0 "LINE,LWPOLYLINE,POLYLINE"))))
	(if	ssLine
		(progn
			(setq LtsLine (acet-ss-to-list ssLine))
			(setq LtsG (LM:IntersectionsinList LtsLine))
			(if	(= (length LtsG) 4)
				(progn
					(setq PntMin (list (apply 'min (mapcar 'car LtsG)) (apply 'min (mapcar 'cadr LtsG))))
					(setq PntMax (list (apply 'max (mapcar 'car LtsG)) (apply 'max (mapcar 'cadr LtsG))))
					(command "rectang" PntMin PntMax)
					(vla-put-color (vlax-ename->vla-object (entlast)) 1)
				)
			)
		)
	)
	(setvar "OSMODE" Olmode)
	(princ)
)



(defun LM:Intersections	(obj1 obj2 mode / l r)
	(setq l (vlax-invoke obj1 'intersectwith obj2 mode))
	(repeat	(/ (length l) 3)
		(setq	r	(cons (list (car l) (cadr l) (caddr l)) r)
					l	(cdddr l)
		)
	)
	(reverse r)
)

(defun LM:IntersectionsinList	(lst / a l)
	(while (setq a (car lst))
		(foreach b (setq lst (cdr lst))
			(setq	l	(cons	(LM:Intersections
											(vlax-ename->vla-object a)
											(vlax-ename->vla-object b)
											acextendnone
										)
										l
							)
			)
		)
	)
	(apply 'append (reverse l))
)

 

Chào các bạn, mình đang cần làm 1 cái lisp có tính năng là chọn 1 đối tượng, sau đó lisp sẽ chọn tất cả các...

>>

Chào các bạn, mình đang cần làm 1 cái lisp có tính năng là chọn 1 đối tượng, sau đó lisp sẽ chọn tất cả các đối tượng mà có cùng layer như đối tượng được chọn, sau đó tự động chuyển thành 1 layer mới mà mình định sẵn và đã có sẵn ở trong bản vẽ. Mình có mày mò, xem các bài viết trên diễn đàn nhưng không tìm thấy. Mình cũng biết lệnh LAYMRG, nhưng vì 1 vài lý do nên các bạn có thể giúp mình làm lisp như mình trình bày ở trên không ạ.

Mình có xem qua các bài viết, xong viết 1 cái như thế này nhưng không chạy được ạ :)

(defun c:qqq1 (/ targent)
  (setq TargEnt (car (entsel "\nSelect object on layer to select: ")))
  (Setq chuyen (sssetfirst nil (ssget "_X" (list (assoc 8 (entget TargEnt)))))
  (command "chprop" chuyen "" "la" "Hidden"  "")
  (princ)

Mong các bạn giúp đỡ :)

Hề hề hề,

1/- Lisp của bạn không chạy vì có lỗi cơ bản như sau:

- Hàm (sssetfirst .....) chỉ trả về hiển thị trên màn hình chứ không trả về biến trong lisp.

- code thiếu hai ngoặc đóng

2/ Để sửa lại bạn có thể làm như sau:

- Xóa các ký tự sau :  (sssetfirst nil 

- Thêm một dấu ngoặc đóng vào cuối code , dưới dòng (princ)

3/- Bạn có thể test chức năng của hàm (sssetfirst ... ) bằng cách :

- Thêm dòng code sau

(sssetfirst nil chuyen)

vào dươi dòng code

(setq chuyen (ssget "_x" (list (assoc 8 (entget targent)))))

- Thêm vái dấu ;;; vào trước dòng code (command ......)

 

Sau đó load lại lisp và chạy lệnh qqq1 để thấy kết quả. Từ đó sẽ ngộ ra cái chưa đúng của bạn.

<<

Download lisp

Filename: 419496_qqq1.lsp

Mình cũng làm thử 1 cái,

cái này chọn circle nào thì no' insert lên circle đó

 

(defun BatDauVe() (setq OldOs (getvar "osmode")) (setvar...
>>

Mình cũng làm thử 1 cái,

cái này chọn circle nào thì no' insert lên circle đó

 

(defun BatDauVe() (setq OldOs (getvar "osmode")) (setvar "osmode" 0))
(defun KetThucVe() (setvar "osmode" OldOs) (princ))
(defun c:isb (/ cir i OldOs tam)
(BatDauVe)
(setq i 0)
(setq ss (ssget '((0 . "*CIRCLE"))))
     (while (< i (sslength ss))
  (setq cir (ssname ss i))
  (setq tam (cdr (assoc 10 (entget cir))))
 (command "-INSERT" "hk" tam "" "" "")
 (setq i (1+ i))
);_ end while
(KetThucVe)
);_ end defun

mình đã thử ctob.lsp và isb.lsp và cho kết quả đúng như mình mong muổn. mình có ý kiến là nếu như lisp không cố định block mà có thể chọn bất cứ block nào thì hay quá. Ngoài ra mình thấy trong ctob.lsp khi thay đường tròn bằng block thì nó sẽ thay thế tất cả các đường tròn, nhưng điều này đã được khắc phục trong isb.lsp. nếu có thể kết hợp thêm tính năng chọn block thì tuyệt quá. một lần nữa xin cảm ơn hai bạn đã giúp đỡ

<<

Việc đặt Text Style bằng Dialoge là đã rõ ràng.

Tuy nhiên, việc đặt Text Style bằng lisp, dùng hàm (command "style"...), thường...

>>

Việc đặt Text Style bằng Dialoge là đã rõ ràng.

Tuy nhiên, việc đặt Text Style bằng lisp, dùng hàm (command "style"...), thường gặp trở ngại vì cần phải biết chính xác FontFile.

Chẳng hạn, Font Name là .VnArial NarrowH thì FontFile là gì? Trả lời: nó là Vharialn_0.ttf

Hoặc, Font Name là Times New Roman thì FontFile là gì? Trả lời: nó là times.ttf

Làm sao để biết được? Lisp này giúp chúng ta lấy được FontFile chính xác ứng với từng Font Name.

Cách dùng:

1). Dùng lệnh Style để đặt 1 kiểu nào đó ứng với Font Name mà ta muốn biết FontFile.

2). Viết 1 Text ứng với kiểu đó ra screen.

3). Dùng lisp này để xác định FontFile của nó.

;----- Lay FontFile cua Text duoc chon
(defun C:HA( / sty ff)
(setq sty (cdr (assoc 7 (entget (car (entsel "\nChon 1 Text de lay FontFile: "))))))
(foreach ass (VxGetTextStyles)
 (if (= (car ass) sty) (setq ff (cdr ass))))
(alert ff)
ff)
(defun VxGetTextStyles ( / StyLst)
(vlax-for Sty (vla-get-TextStyles (vla-get-ActiveDocument (vlax-get-acad-object)))
 (setq StyLst (cons (cons (vla-get-Name Sty) (vla-get-FontFile Sty)) StyLst)))
(reverse StyLst))

Vì hàm con VxGetTextStyles đã trả về 1 dotted pair rồi nên trong hàm chính ta cũng không cần phải dùng vòng lặp Foreach để duyệt qua từng phần tử mà lúc này ta chỉ cần dùng hàm assoc . Code sẽ ngắn gọn hơn.

 

Ta có thể viết :

(setq sty (cdr (assoc 7 (entget (car (entsel "\nChon 1 Text de lay FontFile: "))))))

(cdr(assoc sty (VxGetTextStyles))) -> Đây là kết quả cần tìm

<<

em có lisp ghi cao độ ZZ, giờ em muốn nó thành thế này, nhờ các cao nhân chỉnh sửa giúp ạ 

đây là lisp 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=15836
(defun DXFcn (code elist)
  (cdr (assoc code elist))
)
;============================================================
(prompt"\n - GHI CAO DO DIEM TREN TRAC NGANG Edit by Hoang Dinh Duc 0922.27.97.33 \n")
;============================================================
(defun c:zz (); / DZ pt y ptside ang OT sc1 scale tx ty tx1 ty1 p0 p1 p2 p3 p4 p5 p6 p7 fn f)
(command "Undo" "BEGIN")
(if (not h) (setq h 0.02))
(if (= tx nil) (setq tx 1))
(if (= ty nil) (setq ty 1))
;===============================
(setq h1 (getreal (strcat "\n Cao text < " (rtos h 2 2) " >: "))
         tx1 (getreal (strcat "\nTy le theo phuong X <1/"(rtos tx 2 2)">: 1/")) 
         ty1 (getreal (strcat "\nTy le theo phuong Y <1/"(rtos ty 2 2)">: 1/")))
(if h1 (setq h h1))
(if tx1 (setq tx tx1))
(if ty1 (setq ty ty1))
(setq ATLAST (getvar "Attreq"))
(setq CMLAST (getvar "cmdecho"))
(setq OSLAST (getvar "OSMODE"))
(setq DZ (getvar "DIMZIN"))
(setq OT (getvar "ORTHOMODE"))
(setvar "ORTHOMODE" 0)
(setvar "cmdecho" 0)
(command "osmode" 99)

;========================================================
(setq p0 (getpoint "\n Chon diem dat bang tong hop"))
(styleset)
(command "osmode" 0) 
(command "text" "j" "mc" (list (+ (car p0) (* 25 h)) (+ (cadr p0) (* 2 h))) (* 2 h) 0 "BANG TONG HOP")
(command "text" "j" "mc" (list (+ (car p0) (* 5 h)) (- (cadr p0) (* 1.5 h))) h 0 "STT diem")
(command "text" "j" "mc" (list (+ (car p0) (* 20 h)) (- (cadr p0) (* 1.5 h))) h 0 "K.cach toi tim (m)")
(command "text" "j" "mc" (list (+ (car p0) (* 40 h)) (- (cadr p0) (* 1.5 h))) h 0 "Cao đo (m)")
(setq p1 (list (+ (car p0) (* 10 h)) (cadr p0))
          p2 (polar p0 0 (* 30 h))
          p3 (polar p0 0 (* 50 h))
          p4 (polar p3 (* 1.5 pi) (* 3 h))
          p5 (polar p2 (* 1.5 pi) (* 3 h))
          p6 (polar p1 (* 1.5 pi) (* 3 h))
          p7 (polar p0 (* 1.5 pi) (* 3 h))
)
(command "pline" p0 p3 p4 p7 "c")
(command "pline" p1 p6 "")
(command "pline" p2 p5 "")
(setq p0 p7)
(command "osmode" 15359) 
(setq fn (getfiled "Select a File" "" "csv" 1))
(setq f (open fn "w"))
(write-line " STT diem, K.cach toi tim (m), Cao đo (m)" f)
(setq i 1)

;================================================================================================


(setq pt0 (osnap (getpoint "Diem tim TN tu nhien") "end")) (print)
(setq x0 (car pt0) y0 (cadr pt0))
(setq ed (entget (car (entsel "\nChon cao do tim: "))))
(setq H0 (read (DXFcn 1 ed)))    
(command "osmode" 15359) 


(setq pt (getpoint "\nDiem chen: "))
(While (/= pt nil)
(command "osmode" 0)
(Progn
(setq ptside (getpoint "\nPhia chen:" pt)
ang (angle pt ptside))
(setq y (- (cadr pt) y0 (- H0)))
(setq x (- (car pt) x0))
(setvar "DIMZIN" 0)         
(cond ((> x 0) (setq x (strcat "" (rtos (* x tx) 2 2))))
         ((< x 0) (setq x (rtos (* x tx) 2 2)))
         ((= x 0) (setq x "0.00"))         )
(cond ((> y 0) (setq y (strcat "+" (rtos (* y ty) 2 2))))
         ((< y 0) (setq y (rtos (* y ty) 2 2)))
         ((= y 0) (setq y "%%p0.00")))
;;;;(setq x (ustr 0 "Khoang cach: " x T))
;;;;(setq y (ustr 0 "Cao do: " y T))
(progn
(if (AND (>= ang 0) (< ang (/ pi 2)))
(setq 	pt3 (list (car pt) (+ (cadr pt) (* 1.15 h)))
	pt4 (list (car pt) (+ (cadr pt) (* 2.5 h)))
	pt5 (list (+ (car pt4) (* 5 h)) (cadr pt4))
	pt6 (list (+ (car pt4) (* 2.5 h)) (+ (cadr pt4) (* 0.8 h)))
	pt7 (list (+ (car pt4) (* 2.5 h)) (- (cadr pt4) (* 0.8 h)))))
(if (AND (>= ang (/ pi 2)) (< ang pi))
(setq 	pt3 (list (car pt) (+ (cadr pt) (* 1.15 h)))
	pt4 (list (car pt) (+ (cadr pt) (* 2.5 h)))
	pt5 (list (- (car pt4) (* 5 h)) (cadr pt4))
	pt6 (list (- (car pt4) (* 2.5 h)) (+ (cadr pt4) (* 0.8 h)))
	pt7 (list (- (car pt4) (* 2.5 h)) (- (cadr pt4) (* 0.8 h)))))
(if (AND (>= ang pi) (< ang (+ pi (/ pi 2))))
(setq 	pt3 (list (car pt) (- (cadr pt) (* 1.15 h)))
	pt4 (list (car pt) (- (cadr pt) (* 2.5 h)))
	pt5 (list (- (car pt4) (* 5 h)) (cadr pt4))
	pt6 (list (- (car pt4) (* 2.6 h)) (+ (cadr pt4) (* 0.8 h)))
	pt7 (list (- (car pt4) (* 2.5 h)) (- (cadr pt4) (* 0.8 h)))))
(if (AND (>= ang (+ pi (/ pi 2))) (< ang (* 2 pi)))
(setq 	pt3 (list (car pt) (- (cadr pt) (* 1.15 h)))
	pt4 (list (car pt) (- (cadr pt) (* 2.5 h)))
	pt5 (list (+ (car pt4) (* 5 h)) (cadr pt4))
	pt6 (list (+ (car pt4) (* 2.5 h)) (+ (cadr pt4) (* 0.8 h)))
	pt7 (list (+ (car pt4) (* 2.5 h)) (- (cadr pt4) (* 0.8 h)))))
);progn
(command "pline" pt "w" 0 (* 0.45 h) pt3 "w" 0 0 pt4 pt5 ""
	 "text" "m" pt6 h 0 y
	 "text" "m" pt7 h 0 x)
(setvar "DIMZIN" DZ)
(command "osmode" 15359)

);progn

(command "osmode" 0)
(command "text" "j" "mc" (list (+ (car p0) (* 5 h)) (- (cadr p0) (* 1.5 h))) h 0 (rtos i 2 0))
(command "text" "j" "mc" (list (+ (car p0) (* 20 h)) (- (cadr p0) (* 1.5 h))) h 0 x)
(command "text" "j" "mc" (list (+ (car p0) (* 40 h)) (- (cadr p0) (* 1.5 h))) h 0 y)
(setq p1 (list (+ (car p0) (* 10 h)) (cadr p0))
          p2 (polar p0 0 (* 30 h))
          p3 (polar p0 0 (* 50 h))
          p4 (polar p3 (* 1.5 pi) (* 3 h))
          p5 (polar p2 (* 1.5 pi) (* 3 h))
          p6 (polar p1 (* 1.5 pi) (* 3 h))
          p7 (polar p0 (* 1.5 pi) (* 3 h))
)
(command "pline" p0 p3 p4 p7 "c")
(command "pline" p1 p6 "")
(command "pline" p2 p5 "")
(setq p0 p7)
(write-line (strcat (rtos i 2 0) (chr 44) x (chr 44) y) f)
(setq i (1+ i))
(command "osmode" 15359)
(setq pt (getpoint "\nDiem chen: "))

);while 
(close f)
(setvar "OSMODE" OSLAST)
(setvar "ORTHOMODE" OT)
(setvar "cmdecho" CMLAST)
(prompt"\n Edit by Hoang Dinh Duc 0922.27.97.33\n")
(command "Undo" "End")
(princ)
);end

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun styleset (/ h0 stl)
(setq stl (getvar "textstyle")
         h0 (getvar "textsize"))
(if (/= h0 0) (command "style" stl "" 0 "" "" "" "" ""))
) 

2 giờ trước, niceEyes đã nói:

Chào anh Gia_bach,

Em có...

>>

2 giờ trước, niceEyes đã nói:

Chào anh Gia_bach,

Em có tìm lại được chủ để này  và lisp anh đã viết về chuyển đổi thống kê diện tích, khoảng lùi đối tượng ra file Ecxel, em có nhắn riêng cho anh nhưng không được. Vậy e có thể nhờ anh chỉnh sửa lisp dừng lại ở bước thứ 2 là đo diện tích đối tượng mà không cần bước 3 là đo khoảng lùi (chuvi).

Em cám ơn anh

chủ đề hơn 10 năm rồi, tạm sửa thế này nhé.

(defun c:2Csv (/ chdai dtich ent1 ent2 ent3 lst solo tmp ent21 enttype len pt)
 (vl-load-com)  
 (while (setq ent1 (car (entsel "\nchon Text de lay So lo :")))
   (and
     (= (cdr (assoc 0 (entget ent1))) "TEXT")
     (setq solo (vlax-get(vlax-Ename->Vla-Object ent1)'TextString))
     (or
(and
  (setq ent2 (car (entsel "\nchon doi tuong (lo dat) de lay Dien tich :")))
  (setq ent2 (vlax-Ename->Vla-Object ent2))
  (vlax-property-available-p ent2 'area)
  (setq dtich (vlax-get ent2 'Area)   ) )
(and
  (setq pt (getpoint "\nPick diem (lo dat) de lay Dien tich :"))
  (vl-cmdf "-bhatch" "Advanced" "Island" "No" "Nearest" "" pt "")
  (setq ent2 (entlast))
  (setq ent21 (vlax-Ename->Vla-Object ent2))
  (vlax-property-available-p ent21 'area)
  (setq dtich (vlax-get ent21 'Area)   )
  (entdel ent2)) )
     (setq chdai "")
;;;     (while (setq ent3 (car (entsel "\nchon doi tuong de lay Khoang lui :")))
;;;(setq enttype (cdr (assoc 0 (entget ent3))))
;;;(cond
;;;  ((eq enttype "TEXT") (setq len (vla-get-TextString (vlax-ename->vla-object ent3))) )
;;;  ((eq enttype "DIMENSION") (setq len (rtos(vla-get-Measurement (vlax-ename->vla-object ent3)))) )
;;;  (T (setq len (rtos (vlax-curve-getDistAtParam ent3 (vlax-curve-getEndParam ent3)))) ) )
;;;(setq chdai (strcat chdai "," len))	 )
     (princ "\n")
     (princ (setq tmp (strcat solo "," (rtos dtich) chdai)))
     (setq lst (append lst (list tmp)))  ) ) 
 (if (setq tmp (getfiled "Ten file " (getvar "dwgprefix") "csv" 1))
   (progn
     (setq tmp (open tmp "a"))
     (write-line "So lo,Dien tich,Khoang lui" tmp)      
     (foreach txt lst
(write-line txt tmp)   )
     (close tmp)))
 (princ))

 

<<

Chào bạn thanhduan, anh Duy

Tue_NV viết 1 đoạn code trên thuật toán mà bạn thanhduan đưa ra :

(defun c:aic(/ ms pl minp maxp minpp name kc ssa ans line minp2)
...
>>

Chào bạn thanhduan, anh Duy

Tue_NV viết 1 đoạn code trên thuật toán mà bạn thanhduan đưa ra :

(defun c:aic(/ ms pl minp maxp minpp name kc ssa ans line minp2)
 (vl-load-com)
 (command "undo" "be")
 (setvar "attreq" 0)
 (setq oldos (getvar "osmode"))
 (setvar "osmode" 0)
 (setq ms (vla-get-modelspace (vla-get-activedocument(vlax-get-acad-object))))
 (setq pl (vlax-ename->vla-object (car(entsel "\n Chon Polyline kin :"))))
 (vla-getboundingbox pl 'minp 'maxp)
 (setq minp (safearray-value minp))
 (setq maxp (safearray-value maxp))
 (setq name (getstring "\n Nhap ten Block / enter de chon doi tuong : ") ssa '())
 (if (= name "") (setq name (cdr(assoc 2 (entget (car(entsel "\n Chon Block :")))))))
 (setq kc (getdist "\n Khoang cach hang :"))
 (setq minpp (mapcar '- minp (list (distance maxp minp) (distance maxp minp) 0)))

 (vl-cmdf "insert" name minp 1 1 0.0)
       (setq dtd (vlax-ename->vla-object (entlast)))
 (setq minp2 (mapcar '+ minp (list (/ kc 2) (/ kc 2) 0.0)))
   (vl-cmdf "insert" name minp2 1 1 0.0)
       (setq dts (vlax-ename->vla-object (entlast)))
     (setq ssa
(append (list dtd)
        (vlax-invoke dtd 'ArrayRectangular
	  	(1+ (fix (/ (- (cadr maxp) (cadr minp)) kc)))
		(1+ (fix (/ (- (car maxp) (car minp)) kc)))
	  	1 kc kc 0
  	)
	(list dts)
	(vlax-invoke dts 'ArrayRectangular
	  	(1+ (fix (/ (- (cadr maxp) (cadr minp)) kc)))
		(1+ (fix (/ (- (car maxp) (car minp)) kc)))
	  	1 kc kc 0
  	)
)
    );setq
   ;;;;;;;;;  )
  ;;;;;;;;;;;;  )
 (initget "N T")
 (setq ans (getkword "\n Ban muon xoa cac doi tuong ngoai hay trong Polyline < N / T > :"))
 (foreach x ssa
   (setq line (vla-addline ms (vlax-3d-point minpp)
	 	       (vla-get-insertionpoint x)
       )
   )
   (if (= (strcase ans) "N")
     (progn
   	(if (= (rem (length (vlax-invoke pl 'intersectwith line 0)) 2) 0)
     		(vla-erase x)
       )	
     )
   )
   (if (= (strcase ans) "T")
     (progn
   	(if (= (rem (length (vlax-invoke pl 'intersectwith line 0)) 2) 1)
     		(vla-erase x)
       )	
     )
   )    

   (vla-erase line)
)
 (setvar "osmode" 0)
 (command "undo" "end")
)

Bạn thanhduan, anhDuy thử nhé

Chúc các bác 1 ngày cuối tuần vui vẻ :(

Bác Tue_NV ơi! Nếu em muốn tiếp tục dựa trên mảng bài toán này mà đi tiếp tục việc nghiên cứu xoá đối tượng trong vùng kín được chọn theo thuộc tính đã được lọc trong fillter (theo layer, theo block, theo màu sắc, kích thước .....)(thao tác "Fi" đã được lọc trước và được ứng dụng "p" trong yêu cầu này).

Thao tác như sau:

- Chọn vùng kín (chọn polyline)

- Chọn đối tượng cần xoá (nhấn "p")

- Chọn xóa đối tượng trong hay ngoài polyline

Em nghĩ là nó đơn giản hơn so với mảng array trong vùng

Bác Tue_NV giúp em chỉnh sửa luôn lisp này bác nhé.

Em cảm ơn bác rất nhiều.

<<

Bạn dùng thử LISP này :

Không biết bạn có gõ nhầm không? thực tế tui thấy bản vẽ ít dùng text có Width factor = 3

>>

Bạn dùng thử LISP này :

Không biết bạn có gõ nhầm không? thực tế tui thấy bản vẽ ít dùng text có Width factor = 3

(defun C:ChangeText( / ss e d )
 (setq ss (ssget '((0 . "TEXT")))
)
 (while (setq e (ssname ss 0))
   (setq d (entget e)
  d (subst (cons 40 0.2) (assoc 40 d) d) ; Height=0.2
  d (subst (cons 41 3) (assoc 41 d) d) ; Width factor = 3
  )
   (entmod d)
   (ssdel e ss)
   )
 (princ)
 )

Ok ! Lisp của bác Gia_Bach chạy ngon lắm. Thực tế Text ban đầu có Width Factor = 1. Đó lá chương trình Nova nó chạy ra là như thế và mặc định cũng là 1 mà. Cảm ơn bác nhiều nhé !

<<

Khi muốn chỉnh sửa textstyle của 1 đối tượng text nào đó trên bản vẽ, ta phải biết tên textstyle áp dụng vào text đó. Theo cách...

>>

Khi muốn chỉnh sửa textstyle của 1 đối tượng text nào đó trên bản vẽ, ta phải biết tên textstyle áp dụng vào text đó. Theo cách thông thường thì phải làm theo trình tự sau: Chọn text -> kiểm tra textstyle -> gõ lệnh st -> tìm kiếm style muốn đổi trong danh sách. mất tương đối nhiều thời gian.

Lisp này cho phép bạn pick vào đối tượng TEXT để gọi hộp thoại sửa textstyle tương ứng của nó luôn.

(defun c:st (/ style c-style)
(and
 (setq style (car (entsel)))
 (setq style (cdr (assoc 7 (entget style))))
 (setq c-style (getvar "textstyle"))
 (setvar "textstyle" style)
 (or
  (initdia)
  (command "style")
  (if (= (getvar "textstyle") style)
(setvar "textstyle" c-style))))
(princ))

Tương tự như vậy với lệnh DST (dimstyle). code tương tự nên mình không viết lại nữa

Khi muốn chỉnh sửa textstyle của 1 đối tượng text nào đó trên bản vẽ, ta phải biết tên textstyle áp dụng vào text đó. Theo cách thông thường thì phải làm theo trình tự sau: Chọn text -> kiểm tra textstyle -> gõ lệnh st -> tìm kiếm style muốn đổi trong danh sách. mất tương đối nhiều thời gian.

Chị Thùy Linh đang sử dụng AutoCAD2000 à???

hay quá, mót về xài thui :D,

Anh nhóc cũng đang sử dụng AutoCAD 2000 à???

Anh hãy phân tích cái hay của lisp xem nào???????

<<

 

Thêm STT đây!

(defun c:pt (/ p lst fn pw n)
 (while (setq p (getpoint "\nPick Point: "))
  (setq lst...
>>

 

Thêm STT đây!

(defun c:pt (/ p lst fn pw n)
 (while (setq p (getpoint "\nPick Point: "))
  (setq lst (cons p lst)))
 (setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
 (setq pw (open fn "w"))
 (setq n 1)
 (write-line "STT,Y,X" pw)
 (foreach p (reverse lst)
  (write-line (strcat (itoa n) "," (rtos (cadr p) 2 2) "," (rtos (car p) 2 2)) pw)
  (setq n (1+ n)))
 (close pw)
 (princ))

nhờ anh giúp sửa để sau khi pick xong các điểm cần xuất xong là pick vị trí cần đặt bảng tọa độ trong bản vẽ được không ạ!

<<

Download lisp

Filename: 333601_pt.lsp

;GHI TOA DO CAC DIEM VA THONG KE THANH BANG
----------------------------------------------
(defun C:td (/ diem PT1 PT2 PT3 tapx tapy
    ...
>>

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

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

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

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

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

 

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

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

Command:

TD

nhap chieu cao chu:1

 

Nhap ten diem:q1

 

chon cac vi tri co toa do can ghi:Unknown command "441692.7207". Press F1 for

help.

Unknown command "1120084.7534". Press F1 for help.

Unknown command "Q11". Press F1 for help.

 

chon cac vi tri co toa do can ghi:Unknown command "441911.3076". Press F1 for

help.

Unknown command "1120071.2679". Press F1 for help.

Unknown command "Q12". Press F1 for help.

 

chon cac vi tri co toa do can ghi:

 

vi tri dat bang :Unknown command "STT". Press F1 for help.

Unknown command "TäA ®é X". Press F1 for help.

Unknown command "TäA ®é Y". Press F1 for help.

Unknown command "Q11". Press F1 for help.

Unknown command "441692.7207". Press F1 for help.

Unknown command "1120084.7534". Press F1 for help.

Unknown command "Q12". Press F1 for help.

Unknown command "441911.3076". Press F1 for help.

Unknown command "1120071.2679". Press F1 for help.

 

xong

Undo Current settings: Auto = On, Control = All, Combine = Yes, Layer = Yes

Enter the number of operations to undo or

<1>: End

 

 

 

 

xem giúp tôi với sao không ghi ra số liệu mà toàn là giá trị 0. Tôi đang dùng AutoCad2010

<<

Chủ yếu lấy thể tích thôi mà. 

(defun c:khoiluong ( / DENSITATE KL MAT RO SS1 STR VOL X)
>>

Chủ yếu lấy thể tích thôi mà. 

(defun c:khoiluong ( / DENSITATE KL MAT RO SS1 STR VOL X)
(initget "S A C B Z T L N")
  (initget
    "Steel Aluminium Copper Brass Zinc Tin Lead Nickel"
  )
  (setq    densitate
     (getkword
       "\nChoose material Aluminium/Copper/Brass/Zinc/Tin/Lead/Nickel/<Steel>:"
     )
  )
  (cond
    ((or (= densitate "Aluminium") (= densitate "A"))
     (setq ro 2.70)
     (setq mat "Aluminium")
    )
    ((or (= densitate "Copper") (= densitate "C"))
     (setq ro 8.93)
     (setq mat "Copper")
    )
    ((or (= densitate "Brass") (= densitate "B"))
     (setq ro 8.80)
     (setq mat "Brass")
    )
    ((or (= densitate "Zinc") (= densitate "Z"))
     (setq ro 7.14)
     (setq mat "Zinc")
    )
    ((or (= densitate "Tin") (= densitate "T"))
     (setq ro 7.29)
     (setq mat "Tin")
    )
    ((or (= densitate "Lead") (= densitate "L"))
     (setq ro 11.34)
     (setq mat "Lead")
    )
    ((or (= densitate "Nickel") (= densitate "N"))
     (setq ro 8.86)
     (setq mat "Nickel")
    )
    (T
     (setq ro 7.85)
     (setq mat "Steel")
    )
  )
(setq ss1 (ACET-SS-TO-LIST(ssget)))
  (if (= ss1 nil)
    (exit)
  )
 (setq ss1 (mapcar '(lambda (x) ( vlax-ename->vla-object x)) ss1)  )
(setq vol 0)
(foreach n ss1
  
       (if (= (vla-get-Objectname n) "AcDb3dSolid")
         (setq vol (+ vol (vla-get-Volume n)))
      )
  )
  ;;;he so chuyen mm3 sang m3
  (setq vol (* vol 0.0000001))
(setq kl (* vol ro))
(setq str (strcat "Vat lieu: \t" mat
          "\nKhoi luong rieng: \t" (rtos ro 2 2) " t/m3"
          "\nThe tich: \t" (rtos vol 2 3) " m3"
          "\nKhoi luong: \t" (rtos kl 2 3) " tan"
          )
      )
          
  (alert str)
)

Block có màu thì mới có tác dụng nhé:

(defun c:test (/ A LS OBJ)
  (setq	obj   (vlax-
>>

Block có màu thì mới có tác dụng nhé:

(defun c:test (/ A LS OBJ)
  (setq	obj   (vlax-ename->vla-object (car (entsel)) )
	color (vla-get-color obj))
  (setq	ls (vlax-safearray->list (vlax-variant-value (vla-Explode obj))))
  (foreach n ls
    ; by block = 0
    (if	(= (vla-get-color n) 0) (vla-put-color n color))
  )
)

Một bài toán hay, lâu rùi mới có hứng thú lại với Lisp ^^. Đây là giải pháp của mình dựa trên thuật toán của các bác đưa ra, nếu...

>>

Một bài toán hay, lâu rùi mới có hứng thú lại với Lisp ^^. Đây là giải pháp của mình dựa trên thuật toán của các bác đưa ra, nếu viết có luộm thuộm các bác thông cảm :D . Chưa có thời gian test kỹ, các bác dùng thử nhé ^_^ .

* Lưu ý kích thước MN quá nhỏ so với PQ có thể gây ra lỗi xác định diện tích, nếu PQ có nhiều điểm cực tiểu, chương trình chỉ tính toán cho điểm điểm cực tiểu thấp nhất.

(vl-load-com)
(defun c:t1 (/	       AREALST	 ENDPNT	   ENDPNTMN  FROMPNT
	     FUZZ      I0	 I1	   I2	     I3
	     INTPNTS   IX	 IY	   LWP0	     LWP1
	     LWPENT    LWPOBJ	 MN	   MNDIST    MSPACE
	     PNT0      PNT1	 PQ	   S0	     S1
	     S2	       S3	 STARTPNT  STARTPNTMN
	     STARTPNTPQ		 SUB01	   SUB01NEW  SUB32
	     SUB32NEW  THISDRAWING	   TMPLWP    TOPNTX
	     TOPNTY    MAXPOINT	 MINPOINT  ISFLIPED  TMPLWPOBJ
	     BOTPNT    MINMAXPNTS	   TOPPNT
	    )
  ;; Thiet lap
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (setq mspace (vla-get-modelspace thisdrawing))
  (vla-startundomark thisdrawing)
  (setvar "CMDECHO" 0)
  (if (null MNdistSv)
    (setq MNdistSv 5)
  )
  ;; Du lieu dau vao
  (initget (+ 2 4))
  (setq	MNdist (getreal	(strcat	"\nXac dinh chieu dai MN: <"
				(rtos MNdistSv 2 2)
				">"
			)
	       )
  )
  (if (null MNdist)
    (setq MNdist MNdistSv)
    (setq MNdistSv MNdist)
  )
  (while (null
	   (setq lwpEnt (car (entsel "\nChon duong cong tich luy: ")))
	 )
    (setq lwpEnt (car (entsel "\nChon duong cong tich luy: ")))
  )
  (setq lwpObj (vlax-ename->vla-object lwpEnt))
  (setq	startPnt (vlax-curve-getStartPoint lwpObj)
	endPnt	 (vlax-curve-getEndPoint lwpObj)
  )
  ;; Kiem tra diem cuc tieu
  (setq MinMaxPnts (LM:CurveMinMax lwpObj 1e-8))
  (setq	TopPnt (cadr MinMaxPnts)
	BotPnt (car MinMaxPnts)
  )
  (if (or (equal (distance BotPnt startPnt) 0.0 1e-8)
	  (equal (distance BotPnt endPnt) 0.0 1e-8)
      )
    (progn
      (setq tmpLwpObj (vla-mirror
			lwpObj
			(vlax-3d-point startPnt)
			(vlax-3d-point (polar startPnt 0 0.1))
		      )
		      ;; lat bung
      )
      (vla-delete lwpObj)
      (setq lwpObj   tmpLwpObj
	    isFliped 1
      )
      (setq startPnt (vlax-curve-getStartPoint lwpObj)
	    endPnt   (vlax-curve-getEndPoint lwpObj)
      )
    )
  )
  (vla-GetBoundingBox lwpObj 'minpoint 'maxpoint)
  (vla-ZoomWindow (vlax-get-acad-object) minpoint maxpoint)
  ;; Xac dinh duong PQ
  (if (< (cadr startPnt) (cadr endPnt))
    (setq startPntPQ startPnt)
    (setq startPntPQ endPnt)
  )
  (setq	tmpLwp (AddLwpolyline
		 (list startPntPQ (polar startPntPQ 0 1))
		 0
		 mspace
	       )
  )
  (setq intPnts (LM:Intersections tmpLwp lwpObj acExtendThisEntity))
  (if (> (length intPnts) 1)
    (setq PQ (AddLwpolyline intPnts 0 mspace))
    (progn
      (vla-delete tmpLwp)
      (reset)
      (exit)
    )
  )
  (vla-delete tmpLwp)
  ;; Chieu dai doan MN
  (if (= isFliped 1)
    (setq BotPnt (car (LM:CurveMinMax lwpObj 1e-8)))
  )
  (setq	startPntMN (polar BotPnt pi (/ MNdist 2))
	endPntMN   (polar BotPnt 0 (/ MNdist 2))
  )
  (setq MN (AddLwpolyline (list startPntMN endPntMN) 0 mspace))
  ;; Xac dinh 2 duong giong tu MN den PQ
  (setq	pnt0 (vlax-curve-getClosestPointTo PQ startPntMN)
	pnt1 (vlax-curve-getClosestPointTo PQ endPntMN)
  )
  (setq	lwp0 (AddLwpolyline (list startPntMN pnt0) 0 mspace)
	lwp1 (AddLwpolyline (list endPntMN pnt1) 0 mspace)
  )
  ;; Kiem tra dien tich
  (setq AreaLst (CalArea pnt0 startPntMN endPntMN pnt1))
  (setq	s0 (nth 0 AreaLst)
	s1 (nth 1 AreaLst)
	s2 (nth 2 AreaLst)
	s3 (nth 3 AreaLst)
  )
  (if (and (< s0 s1)
	   (< s3 s2)
      )
    (progn
      (alert "Khong the dieu chinh!")
      (reset)
      (exit)
    )
  )
  ;; Can bang so bo 1 cap dien tich
  (textscr)
  (setq iY (- 0 (/ (distance startPntMN pnt0) 20)))
					; buoc nhay phuong doc
  (setq fuzz 0.01)			; do chinh xac dien tich
  (setq	FromPnt	(vlax-3d-point pnt0)
	ToPntY	(vlax-3d-point (polar pnt0 (/ pi 2) iY))
  )
  (while (and (>= (nth 0 AreaLst) (nth 1 AreaLst))
	      (>= (nth 3 AreaLst) (nth 2 AreaLst))
	 )
    (vla-move PQ FromPnt ToPntY)
    (setq pnt0 (polar pnt0 (/ pi 2) iY)
	  pnt1 (polar pnt1 (/ pi 2) iY)
    )
    (setq AreaLst (reverse (CalArea pnt0 startPntMN endPntMN pnt1)))
  )
  (if (> (- (nth 0 AreaLst) (nth 1 AreaLst))
	 (- (nth 3 AreaLst) (nth 2 AreaLst))
      )
    (setq i0 3
	  i1 2
	  i2 1
	  i3 0
    )
    (setq i0 0
	  i1 1
	  i2 2
	  i3 3
    )
  )
  (setq sub32 (- (nth i3 AreaLst) (nth i2 AreaLst)))
  ;; Can bang dien tich dua tren dich chuyen PQ
  (while (not (equal (- (nth i3 AreaLst) (nth i2 AreaLst)) 0.0 fuzz))
    (vla-move PQ
	      (vlax-3d-point pnt0)
	      (vlax-3d-point (polar pnt0 (/ pi 2) iY))
    )
    (setq pnt0 (polar pnt0 (/ pi 2) iY)
	  pnt1 (polar pnt1 (/ pi 2) iY)
    )
    (setq iX 0.1)			; buoc nhay phuong ngang
    (setq AreaLst (reverse (CalArea pnt0 startPntMN endPntMN pnt1)))
    (setq sub01 (- (nth i0 AreaLst) (nth i1 AreaLst)))
    (setq FromPnt (vlax-3d-point pnt0)
	  ToPntX  (vlax-3d-point (polar pnt0 0 iX))
    )
    ;; Can bang dien tich dua tren dich chuyen MN
    (while (not (equal (- (nth i0 AreaLst) (nth i1 AreaLst)) 0.0 fuzz))
      (vla-move MN FromPnt ToPntX)
      (vla-move lwp0 FromPnt ToPntX)
      (vla-move lwp1 FromPnt ToPntX)
      (setq pnt0       (polar pnt0 0 iX)
	    pnt1       (polar pnt1 0 iX)
	    startPntMN (polar startPntMN 0 iX)
	    endPntMN   (polar endPntMN 0 iX)
      )
      (setq AreaLst (reverse (CalArea pnt0 startPntMN endPntMN pnt1)))
      (setq sub01new (- (nth i0 AreaLst) (nth i1 AreaLst)))
      (if (> (abs sub01new) (abs sub01))
	(setq iX (/ (- 0 iX) 2))
      )
      (setq sub01 sub01new)
      (setq FromPnt (vlax-3d-point pnt0)
	    ToPntX  (vlax-3d-point (polar pnt0 0 iX))
      )
    )
    (setq sub32new (- (nth i3 AreaLst) (nth i2 AreaLst)))
    (if	(> (abs sub32new) (abs sub32))
      (setq iY (/ (- 0 iY) 2))
    )
    (setq sub32 sub32new)
    (print AreaLst)
  )
  (vla-zoomprevious (vlax-get-acad-object))
  (reset)
  (princ)
)
(defun reset ()
  (if (= isFliped 1)
    (progn
      (foreach obj (list lwpObj MN PQ lwp0 lwp1)
	(vla-mirror
	  obj
	  (vlax-3d-point startPnt)
	  (vlax-3d-point (polar startPnt 0 0.1))
	)
	(vla-delete obj)
      )
    )
  )
  (vla-endundomark thisdrawing)
  (graphscr)
)
(defun CalArea (p0 p1 p2 p3 / AreaLst tmpLwp)
  (setq	p0 (polar p0 (* pi 1.25) 0.1)
	p1 (polar p1 (* pi 0.25) 0.1)
	p2 (polar p2 (* pi 0.75) 0.1)
	p3 (polar p3 (* pi 1.75) 0.1)
  )
  (foreach pt (list p0 p1 p2 p3)
    (command ".boundary" pt "")
    (setq tmpLwp (vlax-ename->vla-object (entlast)))
    (setq AreaLst (cons (vlax-get-property tmpLwp 'AREA) AreaLst))
    (vla-delete tmpLwp)
  )
  AreaLst
)
(defun LM:Intersections	(obj1 obj2 mode / l r)
  (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
  (repeat (/ (length l) 3)
    (setq r (cons (list (car l) (cadr l) (caddr l)) r)
	  l (cdddr l)
    )
  )
  (reverse r)
)

(defun AddLwpolyline (lst-pnt layer *model-space* / array-pt myPline)
  (setq	array-pt (list->variantArray
		   (apply 'append (mapcar '3dPnt->2dPnt lst-pnt))
		 )
	myPline	 (vla-AddLightWeightPolyline *model-space* array-pt)
  )
  (vla-put-layer myPline layer)
  myPline
)

(defun list->variantArray (ptsList / arraySpace sArray)
  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length ptsList) 1)
	   )
	 )
  )
  (setq sArray (vlax-safearray-fill arraySpace ptsList))
  (vlax-make-variant sArray)
)

(defun 3dPnt->2dPnt (3dpt)
  (list (float (car 3dpt)) (float (cadr 3dpt)))
)

(defun LM:CurveMinMax
		      (obj	     fuzz	   /
		       _GetBoundingBoxWithOffset   _GroupByNum
		       _FlattenPoint a		   acdoc
		       acspc	     lst	   obj
		       tmp
		      )

  (defun _GetBoundingBoxWithOffset (obj o / ll ur)
    (
     (lambda (a)
       (mapcar
	 (function
	   (lambda (b)
	     (mapcar
	       (function
		 (lambda (c) ((eval c) a))
	       )
	       b
	     )
	   )
	 )
	 '(
	   (
	    (lambda (x) (- (caar x) o))
	    (lambda (x) (- (cadar x) o))
	   )
	   (
	    (lambda (x) (+ (caadr x) o))
	    (lambda (x) (- (cadar x) o))
	   )
	   (
	    (lambda (x) (+ (caadr x) o))
	    (lambda (x) (+ (cadadr x) o))
	   )
	   (
	    (lambda (x) (- (caar x) o))
	    (lambda (x) (+ (cadadr x) o))
	   )
	  )
       )
     )
      (mapcar 'vlax-safearray->list
	      (progn (vla-getboundingbox obj 'll 'ur) (list ll ur))
      )
    )
  )

  (defun _GroupByNum (l n / r)
    (if	l
      (cons
	(reverse (repeat n
		   (setq r (cons (car l) r)
			 l (cdr l)
		   )
		   r
		 )
	)
	(_GroupByNum l n)
      )
    )
  )

  (defun _FlattenPoint (p)
    (list (car p) (cadr p) 0.0)
  )

  (setq	acdoc (vla-get-activedocument (vlax-get-acad-object))
	acspc (vlax-get-property
		acdoc
		(if (= 1 (getvar 'CVPORT))
		  'Paperspace
		  'Modelspace
		)
	      )
  )
  (cond
    ((not (vlax-method-applicable-p obj 'GetBoundingBox))
    )
    (t
     (setq tmp
	    (mapcar
	      (function
		(lambda	(x)
		  (apply 'vla-addline (cons acspc (mapcar 'vlax-3D-point x)))
		)
	      )
	      (_GroupByNum
		(mapcar	'_FlattenPoint
			(_GetBoundingBoxWithOffset obj (- fuzz))
		)
		2
	      )
	    )
     )
     (setq lst
	    (mapcar
	      (function
		(lambda	(x)
		  (car
		    (_GroupByNum
		      (vlax-invoke obj 'Intersectwith x acExtendOtherEntity)
		      3
		    )
		  )
		)
	      )
	      tmp
	    )
     )
     (mapcar 'vla-delete tmp)
     lst
    )
  )
)

File bản vẽ test

http://www.cadviet.com/upfiles/3/86115_test.dwg

 

Cảm ơn bạn. Chạy được rùi. Nhưng bạn có thể giúp mình sửa nó để có thể áp dụng vào bài sau được không .

Yêu cầu: Đó là, cái đường điều phối ta vẽ trước đó, từ đó ta xác định nó cắt tại bao nhiêu điểm, như hình trên thì ta có 5 khối .Sau đó vẫn như yêu cầu trên là tìm vị trí đường điều phối mà cả 5 khối đó đều thỏa mãn các điều kiện như trước (đoạn MN của các khối không bằng nhau nhưng phải <= L cố định ). Sau khi tính xong thì ta phải được một hình hoàn chỉnh như khối 1 ( Có hatch, ghi kích thước ) .

<<

(defun c:test (/ A LS OBJ ss )
  (setq ss (mapcar '(lambda 
>>

(defun c:test (/ A LS OBJ ss )
  (setq ss (mapcar '(lambda (x) (vlax-ename->vla-object x))
		   (ACET-SS-TO-LIST (ssget '((0 . "INSERT"))))
		   ))
  (foreach obj ss
    (progn
      (setq   color (vla-get-color obj)
	    ls (vlax-safearray->list (vlax-variant-value (vla-Explode obj)))
	     )
    (foreach n ls (if (= (vla-get-color n) 0) (vla-put-color n color))  )
      (vla-Erase obj)
      )
    )
)

3 giờ trước, ngohung104 đã nói:

Cảm ơn bạn đã...

>>

 

3 giờ trước, ngohung104 đã nói:

Cảm ơn bạn đã quan tâm. Mình xin gửi lại bạn file đầy đủ hơn.

Vidu_Noitext_2.dwg

Mình xét khoảng cách min đến tâm vòng tròn nên sẽ có 1 số trường hợp text điểm này nhưng gần vòng tròn điểm kia

với lại với tập điểm lớn như file bạn gửi sẽ chạy mất nhiều thời gian (Do trình chỉ xử lý được đến này thôi)

Giải pháp chọn từng vùng để chạy

Bạn dùng tạm cái này nhé!

(defun timtext (point lsttext /)
(setq lstcaodo (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lsttext))
(setq kcminpoint (vl-sort lstcaodo '(lambda(x y / tmx tmy) (setq tmx (distance (list (car (car x)) (cadr (car x)) 0) point)  tmy (distance (list (car (car y)) (cadr (car y)) 0) point))
                 (< tmx tmy))))
(setq pointtim (list point (car kcminpoint) (cadr kcminpoint)))
)
(defun c:GTEXT (/ luubatdiem spc tapchon tapdiem lstss text gtricaodo phannguyen p1
				phapphan gtridien diemtam)
(command "undo" "BE")
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setvar "CMDECHO" 0)
;;;;;;;;;;;;;;;;;;;;;;;
(setq spc (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-Acad-Object))))

(command "-layer" "n" "Caodo" "c" 4 "Caodo" "")
(setq h (getreal "\nNhap cao chu:"))
(prompt "\nchon tap diem Point Text")
(setq tapchon (acet-ss-to-list (ssget (list (cons 0 "CIRCLE,TEXT")))))
(setq tapdiem (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "CIRCLE")) tapchon))
(setq lstss (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "TEXT")) tapchon))
(foreach ent tapdiem
(setq p1 (cdr (assoc 10 (entget ent))))
(setq text (timtext p1 lstss))
(setq gtricaodo (vl-sort (list (cadr text) (caddr text)) '(lambda(x y) (< (car (car x)) (car (car y))))))
(setq phannguyen (cdr (car gtricaodo)))
(setq phapphan (cdr (cadr gtricaodo)))
(setq gtridien (strcat phannguyen "." phapphan))
(setq diemtam (car text))
(vla-put-Layer (vla-addtext spc gtridien (vlax-3d-point diemtam) h) "Caodo")
)
(setvar "osmode" luubatdiem)
(setvar "CMDECHO" 1)
(command "undo" "End")
)

 

<<

1 giờ} trướ}c, ngohung104 đã nói:

Thank bạn đã giúp đở nhé....

>>

1 giờ} trướ}c, ngohung104 đã nói:

Thank bạn đã giúp đở nhé. Nhưng đối với những tập dử liệu lớn thì lâu quá, m bị treo máy luôn. Và thêm nửa là vẫn có kha khá tọa độ bị sai bạn à.

Sửa lại cho bạn nhưng kết quả nó phụ vẫn phụ thuộc vào khoảng cách text và tâm vòng tròn nhé

(defun c:GTEXT (/ luubatdiem spc tapchon tapdiem lstss text gtricaodo phannguyen p1
				phapphan gtridien diemtam)
(command "undo" "BE")
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setvar "CMDECHO" 0)
;;;;;;;;;;;;;;;;;;;;;;;
(setq spc (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-Acad-Object))))

(command "-layer" "n" "Caodo" "c" 4 "Caodo" "")
(setq h (getreal "\nNhap cao chu:"))
(prompt "\nchon tap diem Point Text")
(setq tapchon (acet-ss-to-list (ssget (list (cons 0 "CIRCLE")))))
(setq tapdiem (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "CIRCLE")) tapchon))
;(setq lstss (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "TEXT")) tapchon))
(foreach ent tapdiem
(setq p1 (cdr (assoc 10 (entget ent))))
(setq p2 (polar p1 (* 3 (/ pi 4)) 3))
(setq p3 (polar p1 (* 1 (/ pi -4)) 3))
(vla-ZoomCenter (vlax-get-acad-object) (vlax-3D-point p1) 200)
(setq lstss (acet-ss-to-list (ssget  "C" p2 p3 (list (cons 0 "TEXT")))))
(setq text (timtext p1 lstss))
(if text
(progn
(setq gtricaodo (vl-sort (list (cadr text) (caddr text)) '(lambda(x y) (< (car (car x)) (car (car y))))))
(setq phannguyen (cdr (car gtricaodo)))
(setq phapphan (cdr (cadr gtricaodo)))
(setq gtridien (strcat phannguyen "." phapphan))
(setq diemtam (car text))
(vla-put-Layer (vla-addtext spc gtridien (vlax-3d-point diemtam) h) "Caodo")
)
)
)
(setvar "osmode" luubatdiem)
(setvar "CMDECHO" 1)
(command "undo" "End")
)

 

<<

Với line nằm ngang thì dùng cái này

(defun c:noiline ( / I KEY LS LS2 N P SS SS1 )
>>

Với line nằm ngang thì dùng cái này

(defun c:noiline ( / I KEY LS LS2 N P SS SS1 )

(defun pointmininline (ent / ENTG LS LS1 PE PS)
  (setq entg (entget ent)
	ps (acet-dxf 10 entg)
	pe (acet-dxf 11 entg)
	ls (list ps pe))
  (setq ls1 (vl-sort ls '(lambda (p1 p2) (< (car p1) (car p2))
			   )
		     )
	)
  ls1
  )
(DEFUN make_lwpolyline  (list_dinh dong_lai do_day layer / dlist elist1 e_list n i)
  (SETQ n (LENGTH list_dinh))
  (SETQ dlist nil)
  (SETQ i 0)
  (WHILE (< i n)
    (SETQ dlist (APPEND dlist
                        (list_point_pline (NTH i list_dinh) do_day)
                        )
          )
    (SETQ i (1+ i))
    )

  (SETQ elist1 (LIST (CONS 0 "LWPOLYLINE")
                     (CONS 100 "AcDbEntity")
                     (CONS 410 "Model")
                     (CONS 8 layer)
                     (CONS 100 "AcDbPolyline")
                     (CONS 90 n)
                     (CONS 70 dong_lai)
 ;(cons 43 0.0)
                     (CONS 38 0.0)
                     (CONS 39 0.0)))
  (SETQ e_list nil)
  (SETQ e_list (APPEND elist1 dlist))
  (SETQ e_list (APPEND e_list (LIST '(210 0.0 0.0 1.0))))
  (ENTMAKE e_list)
  )



(setq ss (ssget '((0 . "LINE")))
      ss (acet-ss-to-list ss))
(setq ss1 (vl-sort ss '(lambda (e1 e2) (< (cadr (car (pointmininline e1)))
					 (cadr (car (pointmininline e2)))
					 )
			)
		  )
      )
(setq n (length ss1)
      i 0
      ls (list))
(initget 1 "T P")
(setq key (GETKWORD "Bat dau tu duoi Trai / Phai"))
(if (= key "T")
  (while (< i n)
    (progn
      (setq ls2 (pointmininline (nth i ss1)))
      (if ( = (rem i 2) 0)
	(setq ls (append ls (list (car ls2) (cadr ls2))))
	(setq ls (append ls (list (cadr ls2) (car ls2))))
	)
      )
    (setq i (1+ i))
    )
  (while (< i n)
    (progn
      (setq ls2 (pointmininline (nth i ss1)))
      (if ( = (rem i 2) 0)
	(setq ls (append ls (list (cadr ls2) (car ls2))))
	(setq ls (append ls (list (car ls2) (cadr ls2))))
	)
      )
    (setq i (1+ i))
    )
  )
(setq ls (mapcar '(lambda (p) (list (car p) (cadr p))) ls))
(MAKE_LWPOLYLINE ls 0 0 "ketqua")
	
(initget 1 "Y N")
(setq key (GETKWORD "Xoa line cu khong Yes / No"))
(if (= key "Y")
  (foreach n ss1 (entdel n))
  )

)
    

Mình viết cho bạn đây vì nó không dài lắm.

(defun c:demc()
 (setq ra (cdr (assoc 40 (entget (car (entsel "Chon...
>>

Mình viết cho bạn đây vì nó không dài lắm.

(defun c:demc()
 (setq ra (cdr (assoc 40 (entget (car (entsel "Chon duong chon can thong ke:")))))
ci (ssget "x" (list (cons 40 ra)))
kq (sslength ci)
)
 (princ (strcat "\nTong so duong tron co duong kinh: " (rtos ra 2 2) " la " (rtos kq 2 0) " cai"))
 )

Chào bác phamngoctukts,

1/- Bác nên cho (cons 0 "CIRCLE") vào trong bộ lọc của hàm SSGET để tránh chọn nhầm các đối tượng khác cũng có mã DXF 40 bằng ra bác ạ.

2/- Bác nên cho chọn trước một tập hợp các đường tròn có bán kính khác nhau để có thể chạy lisp một lần mà có được nhiều kết quả hơn. Có thể việc chọn này do người dùng tự nhập danh sách các bán kính hay nhập các đường tròn từ bản vẽ theo ý của họ.

Chúc bác luôn vui....

<<

Mình ðã sửa lại cho bạn ðây. Về các kiểu bắt dính thì bạn có thể chỉnh lại theo ý mình bằng cách. Ðánh lệnh ds, sau ðó chọn các kiểu thích hợp. chọn OK. Sau ðó tại...

>>

Mình ðã sửa lại cho bạn ðây. Về các kiểu bắt dính thì bạn có thể chỉnh lại theo ý mình bằng cách. Ðánh lệnh ds, sau ðó chọn các kiểu thích hợp. chọn OK. Sau ðó tại dòng command: ðánh osmode. Ví dụ

Command: osmode

Enter new value for OSMODE <2600>:

dùng giá trị 2600 ở trên nhập vào vị trí của dòng (setvar "osmode" 2600) trong lisp.

(defun C:WBR( / name p p1 p2 a ss l old nl)
 (princ "\nLenh chia  thanh tung doan")
 (setvar "pdmode" 33)
 (setvar "pdsize" 0.25)
 (setvar "osmode" 2600);Day la tong cua mot so kieu bat dinh
 (while (setq p (getpoint "Vi tri va doi tuong"))
(setq old (getvar "osmode"))
(setq a (/ (* (getvar "aperture") (getvar "viewsize")) 400)
p1 (list (- (car p) a) (+ (cadr p) a) 0.0)
p2 (list (+ (car p) a) (- (cadr p) a) 0.0) name nil)
(setq ss (ssget "c" p1 p2 '((0 . "LINE,XLINE,RAY,SPLINE,POLYLINE,LWPOLYLINE,ARC"))))
(if ss (progn
  (setq l (sslength ss))
  (if (= l 1) (setq name (ssname ss 0)) (progn
	(setq name (entsel "\nDiem chon co nhieu doi tuong, chon doi tuong can chia"))
	(if name (setq name (car name)))
  ))
))
(if name (progn
  (setvar "osmode" 0)
			  (setq nl (entlast))
  (command "_.break" name p p)
			  (if (null (equal nl (entlast))) (command "_.point" p))
))
(setvar "osmode" old)
 )
)

 

 

thank bác nhiều lắm, nhưng vẫn chọn đối tượng rồi kick điểm chia liên tục thôi. nhưng thôi vậy cũng được rồi, em gửi cho bác bản vẽ bình đồ, đg màu xanh là sông, các đường còn lại là đường đồng mức. cho em hỏi sông được vẽ bằng lệnh gì vậy, tại sao bề dày của nó lại lớn thế, dù em đã tắt lineweight rồi. em dùng lisp của bác sao lại không chia được con sông ra thành nhiều đoạn tại những điểm giao với đường đồng mức. bác rảnh thì xem hộ em nhé. thank bác

 

link file : http://www.mediafire.com/?sharekey=e0519e8...04e75f6e8ebb871

<<